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 * ChEop : chaining equality-testing operator
200 * NCEop : non-chaining comparison operator at equality precedence
201 * ChRop : chaining relational operator <= != gt
202 * NCRop : non-chaining relational operator isa
204 * Also see LOP and lop() below.
207 #ifdef DEBUGGING /* Serve -DT. */
208 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
210 # define REPORT(retval) (retval)
213 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
214 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
215 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
216 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
217 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
218 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
219 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
220 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
221 #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
223 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
225 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
226 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
227 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
228 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
229 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
230 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
231 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
233 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
234 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
235 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
236 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
237 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
238 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
239 #define ChEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHEQOP))
240 #define NCEop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCEQOP))
241 #define ChRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)CHRELOP))
242 #define NCRop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)NCRELOP))
244 /* This bit of chicanery makes a unary function followed by
245 * a parenthesis into a function with one argument, highest precedence.
246 * The UNIDOR macro is for unary functions that can be followed by the //
247 * operator (such as C<shift // 0>).
249 #define UNI3(f,x,have_x) { \
250 pl_yylval.ival = f; \
251 if (have_x) PL_expect = x; \
253 PL_last_uni = PL_oldbufptr; \
254 PL_last_lop_op = (f) < 0 ? -(f) : (f); \
256 return REPORT( (int)FUNC1 ); \
258 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
260 #define UNI(f) UNI3(f,XTERM,1)
261 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
262 #define UNIPROTO(f,optional) { \
263 if (optional) PL_last_uni = PL_oldbufptr; \
267 #define UNIBRACK(f) UNI3(f,0,0)
269 /* grandfather return to old style */
272 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
273 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
274 pl_yylval.ival = (f); \
280 #define COPLINE_INC_WITH_HERELINES \
282 CopLINE_inc(PL_curcop); \
283 if (PL_parser->herelines) \
284 CopLINE(PL_curcop) += PL_parser->herelines, \
285 PL_parser->herelines = 0; \
287 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
288 * is no sublex_push to follow. */
289 #define COPLINE_SET_FROM_MULTI_END \
291 CopLINE_set(PL_curcop, PL_multi_end); \
292 if (PL_multi_end != PL_multi_start) \
293 PL_parser->herelines = 0; \
297 /* A file-local structure for passing around information about subroutines and
298 * related definable words */
308 static const struct code no_code = { NULL, NULL, NULL, NULL, NULL, 0, FALSE };
313 /* how to interpret the pl_yylval associated with the token */
317 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
322 static struct debug_tokens {
324 enum token_type type;
326 } const debug_tokens[] =
328 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
329 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
330 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
331 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
332 { ANON_SIGSUB, TOKENTYPE_IVAL, "ANON_SIGSUB" },
333 { ARROW, TOKENTYPE_NONE, "ARROW" },
334 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
335 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
336 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
337 { CHEQOP, TOKENTYPE_OPNUM, "CHEQOP" },
338 { CHRELOP, TOKENTYPE_OPNUM, "CHRELOP" },
339 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
340 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
341 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
342 { DO, TOKENTYPE_NONE, "DO" },
343 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
344 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
345 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
346 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
347 { ELSE, TOKENTYPE_NONE, "ELSE" },
348 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
349 { FOR, TOKENTYPE_IVAL, "FOR" },
350 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
351 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
352 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
353 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
354 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
355 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
356 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
357 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
358 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
359 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
360 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
361 { IF, TOKENTYPE_IVAL, "IF" },
362 { LABEL, TOKENTYPE_OPVAL, "LABEL" },
363 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
364 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
365 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
366 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
367 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
368 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
369 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
370 { MY, TOKENTYPE_IVAL, "MY" },
371 { NCEQOP, TOKENTYPE_OPNUM, "NCEQOP" },
372 { NCRELOP, TOKENTYPE_OPNUM, "NCRELOP" },
373 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
374 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
375 { OROP, TOKENTYPE_IVAL, "OROP" },
376 { OROR, TOKENTYPE_NONE, "OROR" },
377 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
378 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
379 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
380 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
381 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
382 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
383 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
384 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
385 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
386 { PREINC, TOKENTYPE_NONE, "PREINC" },
387 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
388 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
389 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
390 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
391 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
392 { SIGSUB, TOKENTYPE_NONE, "SIGSUB" },
393 { SUB, TOKENTYPE_NONE, "SUB" },
394 { SUBLEXEND, TOKENTYPE_NONE, "SUBLEXEND" },
395 { SUBLEXSTART, TOKENTYPE_NONE, "SUBLEXSTART" },
396 { THING, TOKENTYPE_OPVAL, "THING" },
397 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
398 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
399 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
400 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
401 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
402 { USE, TOKENTYPE_IVAL, "USE" },
403 { WHEN, TOKENTYPE_IVAL, "WHEN" },
404 { WHILE, TOKENTYPE_IVAL, "WHILE" },
405 { BAREWORD, TOKENTYPE_OPVAL, "BAREWORD" },
406 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
407 { 0, TOKENTYPE_NONE, NULL }
410 /* dump the returned token in rv, plus any optional arg in pl_yylval */
413 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
415 PERL_ARGS_ASSERT_TOKEREPORT;
418 const char *name = NULL;
419 enum token_type type = TOKENTYPE_NONE;
420 const struct debug_tokens *p;
421 SV* const report = newSVpvs("<== ");
423 for (p = debug_tokens; p->token; p++) {
424 if (p->token == (int)rv) {
431 Perl_sv_catpv(aTHX_ report, name);
432 else if (isGRAPH(rv))
434 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
436 sv_catpvs(report, " (pending identifier)");
439 sv_catpvs(report, "EOF");
441 Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv);
446 Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival);
448 case TOKENTYPE_OPNUM:
449 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
450 PL_op_name[lvalp->ival]);
453 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
455 case TOKENTYPE_OPVAL:
457 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
458 PL_op_name[lvalp->opval->op_type]);
459 if (lvalp->opval->op_type == OP_CONST) {
460 Perl_sv_catpvf(aTHX_ report, " %s",
461 SvPEEK(cSVOPx_sv(lvalp->opval)));
466 sv_catpvs(report, "(opval=null)");
469 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
475 /* print the buffer with suitable escapes */
478 S_printbuf(pTHX_ const char *const fmt, const char *const s)
480 SV* const tmp = newSVpvs("");
482 PERL_ARGS_ASSERT_PRINTBUF;
484 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
485 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
486 GCC_DIAG_RESTORE_STMT;
495 * This subroutine looks for an '=' next to the operator that has just been
496 * parsed and turns it into an ASSIGNOP if it finds one.
500 S_ao(pTHX_ int toketype)
502 if (*PL_bufptr == '=') {
504 if (toketype == ANDAND)
505 pl_yylval.ival = OP_ANDASSIGN;
506 else if (toketype == OROR)
507 pl_yylval.ival = OP_ORASSIGN;
508 else if (toketype == DORDOR)
509 pl_yylval.ival = OP_DORASSIGN;
512 return REPORT(toketype);
517 * When Perl expects an operator and finds something else, no_op
518 * prints the warning. It always prints "<something> found where
519 * operator expected. It prints "Missing semicolon on previous line?"
520 * if the surprise occurs at the start of the line. "do you need to
521 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
522 * where the compiler doesn't know if foo is a method call or a function.
523 * It prints "Missing operator before end of line" if there's nothing
524 * after the missing operator, or "... before <...>" if there is something
525 * after the missing operator.
527 * PL_bufptr is expected to point to the start of the thing that was found,
528 * and s after the next token or partial token.
532 S_no_op(pTHX_ const char *const what, char *s)
534 char * const oldbp = PL_bufptr;
535 const bool is_first = (PL_oldbufptr == PL_linestart);
537 PERL_ARGS_ASSERT_NO_OP;
543 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
544 if (ckWARN_d(WARN_SYNTAX)) {
546 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
547 "\t(Missing semicolon on previous line?)\n");
548 else if (PL_oldoldbufptr && isIDFIRST_lazy_if_safe(PL_oldoldbufptr,
553 for (t = PL_oldoldbufptr;
554 (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) || *t == ':');
555 t += UTF ? UTF8SKIP(t) : 1)
559 if (t < PL_bufptr && isSPACE(*t))
560 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
561 "\t(Do you need to predeclare %" UTF8f "?)\n",
562 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
566 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
567 "\t(Missing operator before %" UTF8f "?)\n",
568 UTF8fARG(UTF, s - oldbp, oldbp));
576 * Complain about missing quote/regexp/heredoc terminator.
577 * If it's called with NULL then it cauterizes the line buffer.
578 * If we're in a delimited string and the delimiter is a control
579 * character, it's reformatted into a two-char sequence like ^C.
584 S_missingterm(pTHX_ char *s, STRLEN len)
586 char tmpbuf[UTF8_MAXBYTES + 1];
591 char * const nl = (char *) my_memrchr(s, '\n', len);
598 else if (PL_multi_close < 32) {
600 tmpbuf[1] = (char)toCTRL(PL_multi_close);
606 if (LIKELY(PL_multi_close < 256)) {
607 *tmpbuf = (char)PL_multi_close;
612 char *end = (char *)uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close);
619 q = memchr(s, '"', len) ? '\'' : '"';
620 sv = sv_2mortal(newSVpvn(s, len));
623 Perl_croak(aTHX_ "Can't find string terminator %c%" SVf "%c"
624 " anywhere before EOF", q, SVfARG(sv), q);
630 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
631 * utf16-to-utf8-reversed.
634 #ifdef PERL_CR_FILTER
638 const char *s = SvPVX_const(sv);
639 const char * const e = s + SvCUR(sv);
641 PERL_ARGS_ASSERT_STRIP_RETURN;
643 /* outer loop optimized to do nothing if there are no CR-LFs */
645 if (*s++ == '\r' && *s == '\n') {
646 /* hit a CR-LF, need to copy the rest */
650 if (*s == '\r' && s[1] == '\n')
661 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
663 const I32 count = FILTER_READ(idx+1, sv, maxlen);
664 if (count > 0 && !maxlen)
671 =for apidoc lex_start
673 Creates and initialises a new lexer/parser state object, supplying
674 a context in which to lex and parse from a new source of Perl code.
675 A pointer to the new state object is placed in L</PL_parser>. An entry
676 is made on the save stack so that upon unwinding, the new state object
677 will be destroyed and the former value of L</PL_parser> will be restored.
678 Nothing else need be done to clean up the parsing context.
680 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
681 non-null, provides a string (in SV form) containing code to be parsed.
682 A copy of the string is made, so subsequent modification of C<line>
683 does not affect parsing. C<rsfp>, if non-null, provides an input stream
684 from which code will be read to be parsed. If both are non-null, the
685 code in C<line> comes first and must consist of complete lines of input,
686 and C<rsfp> supplies the remainder of the source.
688 The C<flags> parameter is reserved for future use. Currently it is only
689 used by perl internally, so extensions should always pass zero.
694 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
695 can share filters with the current parser.
696 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
697 caller, hence isn't owned by the parser, so shouldn't be closed on parser
698 destruction. This is used to handle the case of defaulting to reading the
699 script from the standard input because no filename was given on the command
700 line (without getting confused by situation where STDIN has been closed, so
701 the script handle is opened on fd 0) */
704 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
706 const char *s = NULL;
707 yy_parser *parser, *oparser;
709 if (flags && flags & ~LEX_START_FLAGS)
710 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
712 /* create and initialise a parser */
714 Newxz(parser, 1, yy_parser);
715 parser->old_parser = oparser = PL_parser;
718 parser->stack = NULL;
719 parser->stack_max1 = NULL;
722 /* on scope exit, free this parser and restore any outer one */
724 parser->saved_curcop = PL_curcop;
726 /* initialise lexer state */
728 parser->nexttoke = 0;
729 parser->error_count = oparser ? oparser->error_count : 0;
730 parser->copline = parser->preambling = NOLINE;
731 parser->lex_state = LEX_NORMAL;
732 parser->expect = XSTATE;
734 parser->recheck_utf8_validity = TRUE;
735 parser->rsfp_filters =
736 !(flags & LEX_START_SAME_FILTER) || !oparser
738 : MUTABLE_AV(SvREFCNT_inc(
739 oparser->rsfp_filters
740 ? oparser->rsfp_filters
741 : (oparser->rsfp_filters = newAV())
744 Newx(parser->lex_brackstack, 120, char);
745 Newx(parser->lex_casestack, 12, char);
746 *parser->lex_casestack = '\0';
747 Newxz(parser->lex_shared, 1, LEXSHARED);
751 const U8* first_bad_char_loc;
753 s = SvPV_const(line, len);
756 && UNLIKELY(! is_utf8_string_loc((U8 *) s,
758 &first_bad_char_loc)))
760 _force_out_malformed_utf8_message(first_bad_char_loc,
761 (U8 *) s + SvCUR(line),
763 1 /* 1 means die */ );
764 NOT_REACHED; /* NOTREACHED */
767 parser->linestr = flags & LEX_START_COPIED
768 ? SvREFCNT_inc_simple_NN(line)
769 : newSVpvn_flags(s, len, SvUTF8(line));
771 sv_catpvs(parser->linestr, "\n;");
773 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
776 parser->oldoldbufptr =
779 parser->linestart = SvPVX(parser->linestr);
780 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
781 parser->last_lop = parser->last_uni = NULL;
783 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
784 |LEX_DONT_CLOSE_RSFP));
785 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
786 |LEX_DONT_CLOSE_RSFP));
788 parser->in_pod = parser->filtered = 0;
792 /* delete a parser object */
795 Perl_parser_free(pTHX_ const yy_parser *parser)
797 PERL_ARGS_ASSERT_PARSER_FREE;
799 PL_curcop = parser->saved_curcop;
800 SvREFCNT_dec(parser->linestr);
802 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
803 PerlIO_clearerr(parser->rsfp);
804 else if (parser->rsfp && (!parser->old_parser
805 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
806 PerlIO_close(parser->rsfp);
807 SvREFCNT_dec(parser->rsfp_filters);
808 SvREFCNT_dec(parser->lex_stuff);
809 SvREFCNT_dec(parser->lex_sub_repl);
811 Safefree(parser->lex_brackstack);
812 Safefree(parser->lex_casestack);
813 Safefree(parser->lex_shared);
814 PL_parser = parser->old_parser;
819 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
821 I32 nexttoke = parser->nexttoke;
822 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
824 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
825 && parser->nextval[nexttoke].opval
826 && parser->nextval[nexttoke].opval->op_slabbed
827 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
828 op_free(parser->nextval[nexttoke].opval);
829 parser->nextval[nexttoke].opval = NULL;
836 =for apidoc AmnxUN|SV *|PL_parser-E<gt>linestr
838 Buffer scalar containing the chunk currently under consideration of the
839 text currently being lexed. This is always a plain string scalar (for
840 which C<SvPOK> is true). It is not intended to be used as a scalar by
841 normal scalar means; instead refer to the buffer directly by the pointer
842 variables described below.
844 The lexer maintains various C<char*> pointers to things in the
845 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
846 reallocated, all of these pointers must be updated. Don't attempt to
847 do this manually, but rather use L</lex_grow_linestr> if you need to
848 reallocate the buffer.
850 The content of the text chunk in the buffer is commonly exactly one
851 complete line of input, up to and including a newline terminator,
852 but there are situations where it is otherwise. The octets of the
853 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
854 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
855 flag on this scalar, which may disagree with it.
857 For direct examination of the buffer, the variable
858 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
859 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
860 of these pointers is usually preferable to examination of the scalar
861 through normal scalar means.
863 =for apidoc AmnxUN|char *|PL_parser-E<gt>bufend
865 Direct pointer to the end of the chunk of text currently being lexed, the
866 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
867 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
868 always located at the end of the buffer, and does not count as part of
869 the buffer's contents.
871 =for apidoc AmnxUN|char *|PL_parser-E<gt>bufptr
873 Points to the current position of lexing inside the lexer buffer.
874 Characters around this point may be freely examined, within
875 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
876 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
877 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
879 Lexing code (whether in the Perl core or not) moves this pointer past
880 the characters that it consumes. It is also expected to perform some
881 bookkeeping whenever a newline character is consumed. This movement
882 can be more conveniently performed by the function L</lex_read_to>,
883 which handles newlines appropriately.
885 Interpretation of the buffer's octets can be abstracted out by
886 using the slightly higher-level functions L</lex_peek_unichar> and
887 L</lex_read_unichar>.
889 =for apidoc AmnxUN|char *|PL_parser-E<gt>linestart
891 Points to the start of the current line inside the lexer buffer.
892 This is useful for indicating at which column an error occurred, and
893 not much else. This must be updated by any lexing code that consumes
894 a newline; the function L</lex_read_to> handles this detail.
900 =for apidoc lex_bufutf8
902 Indicates whether the octets in the lexer buffer
903 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
904 of Unicode characters. If not, they should be interpreted as Latin-1
905 characters. This is analogous to the C<SvUTF8> flag for scalars.
907 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
908 contains valid UTF-8. Lexing code must be robust in the face of invalid
911 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
912 is significant, but not the whole story regarding the input character
913 encoding. Normally, when a file is being read, the scalar contains octets
914 and its C<SvUTF8> flag is off, but the octets should be interpreted as
915 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
916 however, the scalar may have the C<SvUTF8> flag on, and in this case its
917 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
918 is in effect. This logic may change in the future; use this function
919 instead of implementing the logic yourself.
925 Perl_lex_bufutf8(pTHX)
931 =for apidoc lex_grow_linestr
933 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
934 at least C<len> octets (including terminating C<NUL>). Returns a
935 pointer to the reallocated buffer. This is necessary before making
936 any direct modification of the buffer that would increase its length.
937 L</lex_stuff_pvn> provides a more convenient way to insert text into
940 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
941 this function updates all of the lexer's variables that point directly
948 Perl_lex_grow_linestr(pTHX_ STRLEN len)
952 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
953 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
956 linestr = PL_parser->linestr;
957 buf = SvPVX(linestr);
958 if (len <= SvLEN(linestr))
961 /* Is the lex_shared linestr SV the same as the current linestr SV?
962 * Only in this case does re_eval_start need adjusting, since it
963 * points within lex_shared->ls_linestr's buffer */
964 current = ( !PL_parser->lex_shared->ls_linestr
965 || linestr == PL_parser->lex_shared->ls_linestr);
967 bufend_pos = PL_parser->bufend - buf;
968 bufptr_pos = PL_parser->bufptr - buf;
969 oldbufptr_pos = PL_parser->oldbufptr - buf;
970 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
971 linestart_pos = PL_parser->linestart - buf;
972 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
973 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
974 re_eval_start_pos = (current && PL_parser->lex_shared->re_eval_start) ?
975 PL_parser->lex_shared->re_eval_start - buf : 0;
977 buf = sv_grow(linestr, len);
979 PL_parser->bufend = buf + bufend_pos;
980 PL_parser->bufptr = buf + bufptr_pos;
981 PL_parser->oldbufptr = buf + oldbufptr_pos;
982 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
983 PL_parser->linestart = buf + linestart_pos;
984 if (PL_parser->last_uni)
985 PL_parser->last_uni = buf + last_uni_pos;
986 if (PL_parser->last_lop)
987 PL_parser->last_lop = buf + last_lop_pos;
988 if (current && PL_parser->lex_shared->re_eval_start)
989 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
994 =for apidoc lex_stuff_pvn
996 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
997 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
998 reallocating the buffer if necessary. This means that lexing code that
999 runs later will see the characters as if they had appeared in the input.
1000 It is not recommended to do this as part of normal parsing, and most
1001 uses of this facility run the risk of the inserted characters being
1002 interpreted in an unintended manner.
1004 The string to be inserted is represented by C<len> octets starting
1005 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
1006 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
1007 The characters are recoded for the lexer buffer, according to how the
1008 buffer is currently being interpreted (L</lex_bufutf8>). If a string
1009 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
1010 function is more convenient.
1012 =for apidoc Amnh||LEX_STUFF_UTF8
1018 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1022 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1023 if (flags & ~(LEX_STUFF_UTF8))
1024 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1026 if (flags & LEX_STUFF_UTF8) {
1029 STRLEN highhalf = variant_under_utf8_count((U8 *) pv,
1031 const char *p, *e = pv+len;;
1034 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1035 bufptr = PL_parser->bufptr;
1036 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1037 SvCUR_set(PL_parser->linestr,
1038 SvCUR(PL_parser->linestr) + len+highhalf);
1039 PL_parser->bufend += len+highhalf;
1040 for (p = pv; p != e; p++) {
1041 append_utf8_from_native_byte(*p, (U8 **) &bufptr);
1045 if (flags & LEX_STUFF_UTF8) {
1046 STRLEN highhalf = 0;
1047 const char *p, *e = pv+len;
1048 for (p = pv; p != e; p++) {
1050 if (UTF8_IS_ABOVE_LATIN1(c)) {
1051 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1052 "non-Latin-1 character into Latin-1 input");
1053 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1056 } else assert(UTF8_IS_INVARIANT(c));
1060 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1061 bufptr = PL_parser->bufptr;
1062 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1063 SvCUR_set(PL_parser->linestr,
1064 SvCUR(PL_parser->linestr) + len-highhalf);
1065 PL_parser->bufend += len-highhalf;
1068 if (UTF8_IS_INVARIANT(*p)) {
1074 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1080 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1081 bufptr = PL_parser->bufptr;
1082 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1083 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1084 PL_parser->bufend += len;
1085 Copy(pv, bufptr, len, char);
1091 =for apidoc lex_stuff_pv
1093 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1094 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1095 reallocating the buffer if necessary. This means that lexing code that
1096 runs later will see the characters as if they had appeared in the input.
1097 It is not recommended to do this as part of normal parsing, and most
1098 uses of this facility run the risk of the inserted characters being
1099 interpreted in an unintended manner.
1101 The string to be inserted is represented by octets starting at C<pv>
1102 and continuing to the first nul. These octets are interpreted as either
1103 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1104 in C<flags>. The characters are recoded for the lexer buffer, according
1105 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1106 If it is not convenient to nul-terminate a string to be inserted, the
1107 L</lex_stuff_pvn> function is more appropriate.
1113 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1115 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1116 lex_stuff_pvn(pv, strlen(pv), flags);
1120 =for apidoc lex_stuff_sv
1122 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1123 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1124 reallocating the buffer if necessary. This means that lexing code that
1125 runs later will see the characters as if they had appeared in the input.
1126 It is not recommended to do this as part of normal parsing, and most
1127 uses of this facility run the risk of the inserted characters being
1128 interpreted in an unintended manner.
1130 The string to be inserted is the string value of C<sv>. The characters
1131 are recoded for the lexer buffer, according to how the buffer is currently
1132 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1133 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1134 need to construct a scalar.
1140 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1144 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1146 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1148 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1152 =for apidoc lex_unstuff
1154 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1155 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1156 This hides the discarded text from any lexing code that runs later,
1157 as if the text had never appeared.
1159 This is not the normal way to consume lexed text. For that, use
1166 Perl_lex_unstuff(pTHX_ char *ptr)
1170 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1171 buf = PL_parser->bufptr;
1173 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1176 bufend = PL_parser->bufend;
1178 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1179 unstuff_len = ptr - buf;
1180 Move(ptr, buf, bufend+1-ptr, char);
1181 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1182 PL_parser->bufend = bufend - unstuff_len;
1186 =for apidoc lex_read_to
1188 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1189 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1190 performing the correct bookkeeping whenever a newline character is passed.
1191 This is the normal way to consume lexed text.
1193 Interpretation of the buffer's octets can be abstracted out by
1194 using the slightly higher-level functions L</lex_peek_unichar> and
1195 L</lex_read_unichar>.
1201 Perl_lex_read_to(pTHX_ char *ptr)
1204 PERL_ARGS_ASSERT_LEX_READ_TO;
1205 s = PL_parser->bufptr;
1206 if (ptr < s || ptr > PL_parser->bufend)
1207 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1208 for (; s != ptr; s++)
1210 COPLINE_INC_WITH_HERELINES;
1211 PL_parser->linestart = s+1;
1213 PL_parser->bufptr = ptr;
1217 =for apidoc lex_discard_to
1219 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1220 up to C<ptr>. The remaining content of the buffer will be moved, and
1221 all pointers into the buffer updated appropriately. C<ptr> must not
1222 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1223 it is not permitted to discard text that has yet to be lexed.
1225 Normally it is not necessarily to do this directly, because it suffices to
1226 use the implicit discarding behaviour of L</lex_next_chunk> and things
1227 based on it. However, if a token stretches across multiple lines,
1228 and the lexing code has kept multiple lines of text in the buffer for
1229 that purpose, then after completion of the token it would be wise to
1230 explicitly discard the now-unneeded earlier lines, to avoid future
1231 multi-line tokens growing the buffer without bound.
1237 Perl_lex_discard_to(pTHX_ char *ptr)
1241 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1242 buf = SvPVX(PL_parser->linestr);
1244 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1247 if (ptr > PL_parser->bufptr)
1248 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1249 discard_len = ptr - buf;
1250 if (PL_parser->oldbufptr < ptr)
1251 PL_parser->oldbufptr = ptr;
1252 if (PL_parser->oldoldbufptr < ptr)
1253 PL_parser->oldoldbufptr = ptr;
1254 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1255 PL_parser->last_uni = NULL;
1256 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1257 PL_parser->last_lop = NULL;
1258 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1259 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1260 PL_parser->bufend -= discard_len;
1261 PL_parser->bufptr -= discard_len;
1262 PL_parser->oldbufptr -= discard_len;
1263 PL_parser->oldoldbufptr -= discard_len;
1264 if (PL_parser->last_uni)
1265 PL_parser->last_uni -= discard_len;
1266 if (PL_parser->last_lop)
1267 PL_parser->last_lop -= discard_len;
1271 Perl_notify_parser_that_changed_to_utf8(pTHX)
1273 /* Called when $^H is changed to indicate that HINT_UTF8 has changed from
1274 * off to on. At compile time, this has the effect of entering a 'use
1275 * utf8' section. This means that any input was not previously checked for
1276 * UTF-8 (because it was off), but now we do need to check it, or our
1277 * assumptions about the input being sane could be wrong, and we could
1278 * segfault. This routine just sets a flag so that the next time we look
1279 * at the input we do the well-formed UTF-8 check. If we aren't in the
1280 * proper phase, there may not be a parser object, but if there is, setting
1281 * the flag is harmless */
1284 PL_parser->recheck_utf8_validity = TRUE;
1289 =for apidoc lex_next_chunk
1291 Reads in the next chunk of text to be lexed, appending it to
1292 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1293 looked to the end of the current chunk and wants to know more. It is
1294 usual, but not necessary, for lexing to have consumed the entirety of
1295 the current chunk at this time.
1297 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1298 chunk (i.e., the current chunk has been entirely consumed), normally the
1299 current chunk will be discarded at the same time that the new chunk is
1300 read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1301 will not be discarded. If the current chunk has not been entirely
1302 consumed, then it will not be discarded regardless of the flag.
1304 Returns true if some new text was added to the buffer, or false if the
1305 buffer has reached the end of the input text.
1307 =for apidoc Amnh||LEX_KEEP_PREVIOUS
1312 #define LEX_FAKE_EOF 0x80000000
1313 #define LEX_NO_TERM 0x40000000 /* here-doc */
1316 Perl_lex_next_chunk(pTHX_ U32 flags)
1320 STRLEN old_bufend_pos, new_bufend_pos;
1321 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1322 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1323 bool got_some_for_debugger = 0;
1326 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1327 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1328 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1330 linestr = PL_parser->linestr;
1331 buf = SvPVX(linestr);
1332 if (!(flags & LEX_KEEP_PREVIOUS)
1333 && PL_parser->bufptr == PL_parser->bufend)
1335 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1337 if (PL_parser->last_uni != PL_parser->bufend)
1338 PL_parser->last_uni = NULL;
1339 if (PL_parser->last_lop != PL_parser->bufend)
1340 PL_parser->last_lop = NULL;
1341 last_uni_pos = last_lop_pos = 0;
1343 SvCUR_set(linestr, 0);
1345 old_bufend_pos = PL_parser->bufend - buf;
1346 bufptr_pos = PL_parser->bufptr - buf;
1347 oldbufptr_pos = PL_parser->oldbufptr - buf;
1348 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1349 linestart_pos = PL_parser->linestart - buf;
1350 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1351 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1353 if (flags & LEX_FAKE_EOF) {
1355 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1357 } else if (filter_gets(linestr, old_bufend_pos)) {
1359 got_some_for_debugger = 1;
1360 } else if (flags & LEX_NO_TERM) {
1363 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1366 /* End of real input. Close filehandle (unless it was STDIN),
1367 * then add implicit termination.
1369 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1370 PerlIO_clearerr(PL_parser->rsfp);
1371 else if (PL_parser->rsfp)
1372 (void)PerlIO_close(PL_parser->rsfp);
1373 PL_parser->rsfp = NULL;
1374 PL_parser->in_pod = PL_parser->filtered = 0;
1375 if (!PL_in_eval && PL_minus_p) {
1377 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1378 PL_minus_n = PL_minus_p = 0;
1379 } else if (!PL_in_eval && PL_minus_n) {
1380 sv_catpvs(linestr, /*{*/";}");
1383 sv_catpvs(linestr, ";");
1386 buf = SvPVX(linestr);
1387 new_bufend_pos = SvCUR(linestr);
1388 PL_parser->bufend = buf + new_bufend_pos;
1389 PL_parser->bufptr = buf + bufptr_pos;
1392 const U8* first_bad_char_loc;
1393 if (UNLIKELY(! is_utf8_string_loc(
1394 (U8 *) PL_parser->bufptr,
1395 PL_parser->bufend - PL_parser->bufptr,
1396 &first_bad_char_loc)))
1398 _force_out_malformed_utf8_message(first_bad_char_loc,
1399 (U8 *) PL_parser->bufend,
1401 1 /* 1 means die */ );
1402 NOT_REACHED; /* NOTREACHED */
1406 PL_parser->oldbufptr = buf + oldbufptr_pos;
1407 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1408 PL_parser->linestart = buf + linestart_pos;
1409 if (PL_parser->last_uni)
1410 PL_parser->last_uni = buf + last_uni_pos;
1411 if (PL_parser->last_lop)
1412 PL_parser->last_lop = buf + last_lop_pos;
1413 if (PL_parser->preambling != NOLINE) {
1414 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1415 PL_parser->preambling = NOLINE;
1417 if ( got_some_for_debugger
1418 && PERLDB_LINE_OR_SAVESRC
1419 && PL_curstash != PL_debstash)
1421 /* debugger active and we're not compiling the debugger code,
1422 * so store the line into the debugger's array of lines
1424 update_debugger_info(NULL, buf+old_bufend_pos,
1425 new_bufend_pos-old_bufend_pos);
1431 =for apidoc lex_peek_unichar
1433 Looks ahead one (Unicode) character in the text currently being lexed.
1434 Returns the codepoint (unsigned integer value) of the next character,
1435 or -1 if lexing has reached the end of the input text. To consume the
1436 peeked character, use L</lex_read_unichar>.
1438 If the next character is in (or extends into) the next chunk of input
1439 text, the next chunk will be read in. Normally the current chunk will be
1440 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1441 bit set, then the current chunk will not be discarded.
1443 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1444 is encountered, an exception is generated.
1450 Perl_lex_peek_unichar(pTHX_ U32 flags)
1454 if (flags & ~(LEX_KEEP_PREVIOUS))
1455 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1456 s = PL_parser->bufptr;
1457 bufend = PL_parser->bufend;
1463 if (!lex_next_chunk(flags))
1465 s = PL_parser->bufptr;
1466 bufend = PL_parser->bufend;
1469 if (UTF8_IS_INVARIANT(head))
1471 if (UTF8_IS_START(head)) {
1472 len = UTF8SKIP(&head);
1473 while ((STRLEN)(bufend-s) < len) {
1474 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1476 s = PL_parser->bufptr;
1477 bufend = PL_parser->bufend;
1480 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1481 if (retlen == (STRLEN)-1) {
1482 _force_out_malformed_utf8_message((U8 *) s,
1485 1 /* 1 means die */ );
1486 NOT_REACHED; /* NOTREACHED */
1491 if (!lex_next_chunk(flags))
1493 s = PL_parser->bufptr;
1500 =for apidoc lex_read_unichar
1502 Reads the next (Unicode) character in the text currently being lexed.
1503 Returns the codepoint (unsigned integer value) of the character read,
1504 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1505 if lexing has reached the end of the input text. To non-destructively
1506 examine the next character, use L</lex_peek_unichar> instead.
1508 If the next character is in (or extends into) the next chunk of input
1509 text, the next chunk will be read in. Normally the current chunk will be
1510 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1511 bit set, then the current chunk will not be discarded.
1513 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1514 is encountered, an exception is generated.
1520 Perl_lex_read_unichar(pTHX_ U32 flags)
1523 if (flags & ~(LEX_KEEP_PREVIOUS))
1524 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1525 c = lex_peek_unichar(flags);
1528 COPLINE_INC_WITH_HERELINES;
1530 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1532 ++(PL_parser->bufptr);
1538 =for apidoc lex_read_space
1540 Reads optional spaces, in Perl style, in the text currently being
1541 lexed. The spaces may include ordinary whitespace characters and
1542 Perl-style comments. C<#line> directives are processed if encountered.
1543 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1544 at a non-space character (or the end of the input text).
1546 If spaces extend into the next chunk of input text, the next chunk will
1547 be read in. Normally the current chunk will be discarded at the same
1548 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1549 chunk will not be discarded.
1554 #define LEX_NO_INCLINE 0x40000000
1555 #define LEX_NO_NEXT_CHUNK 0x80000000
1558 Perl_lex_read_space(pTHX_ U32 flags)
1561 const bool can_incline = !(flags & LEX_NO_INCLINE);
1562 bool need_incline = 0;
1563 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1564 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1565 s = PL_parser->bufptr;
1566 bufend = PL_parser->bufend;
1572 } while (!(c == '\n' || (c == 0 && s == bufend)));
1573 } else if (c == '\n') {
1576 PL_parser->linestart = s;
1582 } else if (isSPACE(c)) {
1584 } else if (c == 0 && s == bufend) {
1587 if (flags & LEX_NO_NEXT_CHUNK)
1589 PL_parser->bufptr = s;
1590 l = CopLINE(PL_curcop);
1591 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1592 got_more = lex_next_chunk(flags);
1593 CopLINE_set(PL_curcop, l);
1594 s = PL_parser->bufptr;
1595 bufend = PL_parser->bufend;
1598 if (can_incline && need_incline && PL_parser->rsfp) {
1608 PL_parser->bufptr = s;
1613 =for apidoc validate_proto
1615 This function performs syntax checking on a prototype, C<proto>.
1616 If C<warn> is true, any illegal characters or mismatched brackets
1617 will trigger illegalproto warnings, declaring that they were
1618 detected in the prototype for C<name>.
1620 The return value is C<true> if this is a valid prototype, and
1621 C<false> if it is not, regardless of whether C<warn> was C<true> or
1624 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1631 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn, bool curstash)
1633 STRLEN len, origlen;
1635 bool bad_proto = FALSE;
1636 bool in_brackets = FALSE;
1637 bool after_slash = FALSE;
1638 char greedy_proto = ' ';
1639 bool proto_after_greedy_proto = FALSE;
1640 bool must_be_last = FALSE;
1641 bool underscore = FALSE;
1642 bool bad_proto_after_underscore = FALSE;
1644 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1649 p = SvPV(proto, len);
1651 for (; len--; p++) {
1654 proto_after_greedy_proto = TRUE;
1656 if (!memCHRs(";@%", *p))
1657 bad_proto_after_underscore = TRUE;
1660 if (!memCHRs("$@%*;[]&\\_+", *p) || *p == '\0') {
1667 in_brackets = FALSE;
1668 else if ((*p == '@' || *p == '%')
1672 must_be_last = TRUE;
1681 after_slash = FALSE;
1686 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1689 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1690 origlen, UNI_DISPLAY_ISPRINT)
1691 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1693 if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) {
1694 SV *name2 = sv_2mortal(newSVsv(PL_curstname));
1695 sv_catpvs(name2, "::");
1696 sv_catsv(name2, (SV *)name);
1700 if (proto_after_greedy_proto)
1701 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1702 "Prototype after '%c' for %" SVf " : %s",
1703 greedy_proto, SVfARG(name), p);
1705 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1706 "Missing ']' in prototype for %" SVf " : %s",
1709 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1710 "Illegal character in prototype for %" SVf " : %s",
1712 if (bad_proto_after_underscore)
1713 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1714 "Illegal character after '_' in prototype for %" SVf " : %s",
1718 return (! (proto_after_greedy_proto || bad_proto) );
1723 * This subroutine has nothing to do with tilting, whether at windmills
1724 * or pinball tables. Its name is short for "increment line". It
1725 * increments the current line number in CopLINE(PL_curcop) and checks
1726 * to see whether the line starts with a comment of the form
1727 * # line 500 "foo.pm"
1728 * If so, it sets the current line number and file to the values in the comment.
1732 S_incline(pTHX_ const char *s, const char *end)
1740 PERL_ARGS_ASSERT_INCLINE;
1744 COPLINE_INC_WITH_HERELINES;
1745 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1746 && s+1 == PL_bufend && *s == ';') {
1747 /* fake newline in string eval */
1748 CopLINE_dec(PL_curcop);
1753 while (SPACE_OR_TAB(*s))
1755 if (memBEGINs(s, (STRLEN) (end - s), "line"))
1756 s += sizeof("line") - 1;
1759 if (SPACE_OR_TAB(*s))
1763 while (SPACE_OR_TAB(*s))
1771 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1773 while (SPACE_OR_TAB(*s))
1775 if (*s == '"' && (t = (char *) memchr(s+1, '"', end - s))) {
1781 while (*t && !isSPACE(*t))
1785 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1787 if (*e != '\n' && *e != '\0')
1788 return; /* false alarm */
1790 if (!grok_atoUV(n, &uv, &e))
1792 line_num = ((line_t)uv) - 1;
1795 const STRLEN len = t - s;
1797 if (!PL_rsfp && !PL_parser->filtered) {
1798 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1799 * to *{"::_<newfilename"} */
1800 /* However, the long form of evals is only turned on by the
1801 debugger - usually they're "(eval %lu)" */
1802 GV * const cfgv = CopFILEGV(PL_curcop);
1805 STRLEN tmplen2 = len;
1809 if (tmplen2 + 2 <= sizeof smallbuf)
1812 Newx(tmpbuf2, tmplen2 + 2, char);
1817 memcpy(tmpbuf2 + 2, s, tmplen2);
1820 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1822 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1823 /* adjust ${"::_<newfilename"} to store the new file name */
1824 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1825 /* The line number may differ. If that is the case,
1826 alias the saved lines that are in the array.
1827 Otherwise alias the whole array. */
1828 if (CopLINE(PL_curcop) == line_num) {
1829 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1830 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1832 else if (GvAV(cfgv)) {
1833 AV * const av = GvAV(cfgv);
1834 const line_t start = CopLINE(PL_curcop)+1;
1835 SSize_t items = AvFILLp(av) - start;
1837 AV * const av2 = GvAVn(gv2);
1838 SV **svp = AvARRAY(av) + start;
1839 Size_t l = line_num+1;
1840 while (items-- && l < SSize_t_MAX && l == (line_t)l)
1841 av_store(av2, (SSize_t)l++, SvREFCNT_inc(*svp++));
1846 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1849 CopFILE_free(PL_curcop);
1850 CopFILE_setn(PL_curcop, s, len);
1852 CopLINE_set(PL_curcop, line_num);
1856 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1858 AV *av = CopFILEAVx(PL_curcop);
1861 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1863 sv = *av_fetch(av, 0, 1);
1864 SvUPGRADE(sv, SVt_PVMG);
1866 if (!SvPOK(sv)) SvPVCLEAR(sv);
1868 sv_catsv(sv, orig_sv);
1870 sv_catpvn(sv, buf, len);
1875 if (PL_parser->preambling == NOLINE)
1876 av_store(av, CopLINE(PL_curcop), sv);
1882 * Called to gobble the appropriate amount and type of whitespace.
1883 * Skips comments as well.
1884 * Returns the next character after the whitespace that is skipped.
1887 * Same thing, but look ahead without incrementing line numbers or
1888 * adjusting PL_linestart.
1891 #define skipspace(s) skipspace_flags(s, 0)
1892 #define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
1895 Perl_skipspace_flags(pTHX_ char *s, U32 flags)
1897 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1898 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1899 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1902 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1904 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1905 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1906 LEX_NO_NEXT_CHUNK : 0));
1908 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1909 if (PL_linestart > PL_bufptr)
1910 PL_bufptr = PL_linestart;
1918 * Check the unary operators to ensure there's no ambiguity in how they're
1919 * used. An ambiguous piece of code would be:
1921 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1922 * the +5 is its argument.
1930 if (PL_oldoldbufptr != PL_last_uni)
1932 while (isSPACE(*PL_last_uni))
1935 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-')
1936 s += UTF ? UTF8SKIP(s) : 1;
1937 if (s < PL_bufptr && memchr(s, '(', PL_bufptr - s))
1940 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1941 "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous",
1942 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1946 * LOP : macro to build a list operator. Its behaviour has been replaced
1947 * with a subroutine, S_lop() for which LOP is just another name.
1950 #define LOP(f,x) return lop(f,x,s)
1954 * Build a list operator (or something that might be one). The rules:
1955 * - if we have a next token, then it's a list operator (no parens) for
1956 * which the next token has already been parsed; e.g.,
1959 * - if the next thing is an opening paren, then it's a function
1960 * - else it's a list operator
1964 S_lop(pTHX_ I32 f, U8 x, char *s)
1966 PERL_ARGS_ASSERT_LOP;
1971 PL_last_lop = PL_oldbufptr;
1972 PL_last_lop_op = (OPCODE)f;
1977 return REPORT(FUNC);
1980 return REPORT(FUNC);
1983 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1984 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1985 return REPORT(LSTOP);
1991 * When the lexer realizes it knows the next token (for instance,
1992 * it is reordering tokens for the parser) then it can call S_force_next
1993 * to know what token to return the next time the lexer is called. Caller
1994 * will need to set PL_nextval[] and possibly PL_expect to ensure
1995 * the lexer handles the token correctly.
1999 S_force_next(pTHX_ I32 type)
2003 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2004 tokereport(type, &NEXTVAL_NEXTTOKE);
2007 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
2008 PL_nexttype[PL_nexttoke] = type;
2015 * This subroutine handles postfix deref syntax after the arrow has already
2016 * been emitted. @* $* etc. are emitted as two separate tokens right here.
2017 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
2018 * only the first, leaving yylex to find the next.
2022 S_postderef(pTHX_ int const funny, char const next)
2024 assert(funny == DOLSHARP || memCHRs("$@%&*", funny));
2026 PL_expect = XOPERATOR;
2027 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
2028 assert('@' == funny || '$' == funny || DOLSHARP == funny);
2029 PL_lex_state = LEX_INTERPEND;
2031 force_next(POSTJOIN);
2037 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
2038 && !PL_lex_brackets)
2040 PL_expect = XOPERATOR;
2049 int yyc = PL_parser->yychar;
2050 if (yyc != YYEMPTY) {
2052 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2053 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2054 PL_lex_allbrackets--;
2056 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2057 } else if (yyc == '('/*)*/) {
2058 PL_lex_allbrackets--;
2063 PL_parser->yychar = YYEMPTY;
2068 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2070 SV * const sv = newSVpvn_utf8(start, len,
2074 && is_utf8_non_invariant_string((const U8*)start, len));
2080 * When the lexer knows the next thing is a word (for instance, it has
2081 * just seen -> and it knows that the next char is a word char, then
2082 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2086 * char *start : buffer position (must be within PL_linestr)
2087 * int token : PL_next* will be this type of bare word
2088 * (e.g., METHOD,BAREWORD)
2089 * int check_keyword : if true, Perl checks to make sure the word isn't
2090 * a keyword (do this if the word is a label, e.g. goto FOO)
2091 * int allow_pack : if true, : characters will also be allowed (require,
2092 * use, etc. do this)
2096 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2101 PERL_ARGS_ASSERT_FORCE_WORD;
2103 start = skipspace(start);
2105 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
2106 || (allow_pack && *s == ':' && s[1] == ':') )
2108 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2109 if (check_keyword) {
2110 char *s2 = PL_tokenbuf;
2112 if (allow_pack && memBEGINPs(s2, len, "CORE::")) {
2113 s2 += sizeof("CORE::") - 1;
2114 len2 -= sizeof("CORE::") - 1;
2116 if (keyword(s2, len2, 0))
2119 if (token == METHOD) {
2124 PL_expect = XOPERATOR;
2127 NEXTVAL_NEXTTOKE.opval
2128 = newSVOP(OP_CONST,0,
2129 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2130 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2138 * Called when the lexer wants $foo *foo &foo etc, but the program
2139 * text only contains the "foo" portion. The first argument is a pointer
2140 * to the "foo", and the second argument is the type symbol to prefix.
2141 * Forces the next token to be a "BAREWORD".
2142 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2146 S_force_ident(pTHX_ const char *s, int kind)
2148 PERL_ARGS_ASSERT_FORCE_IDENT;
2151 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2152 OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2153 UTF ? SVf_UTF8 : 0));
2154 NEXTVAL_NEXTTOKE.opval = o;
2155 force_next(BAREWORD);
2157 o->op_private = OPpCONST_ENTERED;
2158 /* XXX see note in pp_entereval() for why we forgo typo
2159 warnings if the symbol must be introduced in an eval.
2161 gv_fetchpvn_flags(s, len,
2162 (PL_in_eval ? GV_ADDMULTI
2163 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2164 kind == '$' ? SVt_PV :
2165 kind == '@' ? SVt_PVAV :
2166 kind == '%' ? SVt_PVHV :
2174 S_force_ident_maybe_lex(pTHX_ char pit)
2176 NEXTVAL_NEXTTOKE.ival = pit;
2181 Perl_str_to_version(pTHX_ SV *sv)
2186 const char *start = SvPV_const(sv,len);
2187 const char * const end = start + len;
2188 const bool utf = cBOOL(SvUTF8(sv));
2190 PERL_ARGS_ASSERT_STR_TO_VERSION;
2192 while (start < end) {
2196 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2201 retval += ((NV)n)/nshift;
2210 * Forces the next token to be a version number.
2211 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2212 * and if "guessing" is TRUE, then no new token is created (and the caller
2213 * must use an alternative parsing method).
2217 S_force_version(pTHX_ char *s, int guessing)
2222 PERL_ARGS_ASSERT_FORCE_VERSION;
2230 while (isDIGIT(*d) || *d == '_' || *d == '.')
2232 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2234 s = scan_num(s, &pl_yylval);
2235 version = pl_yylval.opval;
2236 ver = cSVOPx(version)->op_sv;
2237 if (SvPOK(ver) && !SvNIOK(ver)) {
2238 SvUPGRADE(ver, SVt_PVNV);
2239 SvNV_set(ver, str_to_version(ver));
2240 SvNOK_on(ver); /* hint that it is a version */
2243 else if (guessing) {
2248 /* NOTE: The parser sees the package name and the VERSION swapped */
2249 NEXTVAL_NEXTTOKE.opval = version;
2250 force_next(BAREWORD);
2256 * S_force_strict_version
2257 * Forces the next token to be a version number using strict syntax rules.
2261 S_force_strict_version(pTHX_ char *s)
2264 const char *errstr = NULL;
2266 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2268 while (isSPACE(*s)) /* leading whitespace */
2271 if (is_STRICT_VERSION(s,&errstr)) {
2273 s = (char *)scan_version(s, ver, 0);
2274 version = newSVOP(OP_CONST, 0, ver);
2276 else if ((*s != ';' && *s != '{' && *s != '}' )
2277 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2281 yyerror(errstr); /* version required */
2285 /* NOTE: The parser sees the package name and the VERSION swapped */
2286 NEXTVAL_NEXTTOKE.opval = version;
2287 force_next(BAREWORD);
2294 * Turns any \\ into \ in a quoted string passed in in 'sv', returning 'sv',
2295 * modified as necessary. However, if HINT_NEW_STRING is on, 'sv' is
2296 * unchanged, and a new SV containing the modified input is returned.
2300 S_tokeq(pTHX_ SV *sv)
2307 PERL_ARGS_ASSERT_TOKEQ;
2311 assert (!SvIsCOW(sv));
2312 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2316 /* This is relying on the SV being "well formed" with a trailing '\0' */
2317 while (s < send && !(*s == '\\' && s[1] == '\\'))
2322 if ( PL_hints & HINT_NEW_STRING ) {
2323 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2324 SVs_TEMP | SvUTF8(sv));
2328 if (s + 1 < send && (s[1] == '\\'))
2329 s++; /* all that, just for this */
2334 SvCUR_set(sv, d - SvPVX_const(sv));
2336 if ( PL_hints & HINT_NEW_STRING )
2337 return new_constant(NULL, 0, "q", sv, pv, "q", 1, NULL);
2342 * Now come three functions related to double-quote context,
2343 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2344 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2345 * interact with PL_lex_state, and create fake ( ... ) argument lists
2346 * to handle functions and concatenation.
2350 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2355 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2357 * Pattern matching will set PL_lex_op to the pattern-matching op to
2358 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2360 * OP_CONST is easy--just make the new op and return.
2362 * Everything else becomes a FUNC.
2364 * Sets PL_lex_state to LEX_INTERPPUSH unless ival was OP_NULL or we
2365 * had an OP_CONST. This just sets us up for a
2366 * call to S_sublex_push().
2370 S_sublex_start(pTHX)
2372 const I32 op_type = pl_yylval.ival;
2374 if (op_type == OP_NULL) {
2375 pl_yylval.opval = PL_lex_op;
2379 if (op_type == OP_CONST) {
2380 SV *sv = PL_lex_stuff;
2381 PL_lex_stuff = NULL;
2384 if (SvTYPE(sv) == SVt_PVIV) {
2385 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2387 const char * const p = SvPV_const(sv, len);
2388 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2392 pl_yylval.opval = newSVOP(op_type, 0, sv);
2396 PL_parser->lex_super_state = PL_lex_state;
2397 PL_parser->lex_sub_inwhat = (U16)op_type;
2398 PL_parser->lex_sub_op = PL_lex_op;
2399 PL_parser->sub_no_recover = FALSE;
2400 PL_parser->sub_error_count = PL_error_count;
2401 PL_lex_state = LEX_INTERPPUSH;
2405 pl_yylval.opval = PL_lex_op;
2415 * Create a new scope to save the lexing state. The scope will be
2416 * ended in S_sublex_done. Returns a '(', starting the function arguments
2417 * to the uc, lc, etc. found before.
2418 * Sets PL_lex_state to LEX_INTERPCONCAT.
2425 const bool is_heredoc = PL_multi_close == '<';
2428 PL_lex_state = PL_parser->lex_super_state;
2429 SAVEI8(PL_lex_dojoin);
2430 SAVEI32(PL_lex_brackets);
2431 SAVEI32(PL_lex_allbrackets);
2432 SAVEI32(PL_lex_formbrack);
2433 SAVEI8(PL_lex_fakeeof);
2434 SAVEI32(PL_lex_casemods);
2435 SAVEI32(PL_lex_starts);
2436 SAVEI8(PL_lex_state);
2437 SAVESPTR(PL_lex_repl);
2438 SAVEVPTR(PL_lex_inpat);
2439 SAVEI16(PL_lex_inwhat);
2442 SAVECOPLINE(PL_curcop);
2443 SAVEI32(PL_multi_end);
2444 SAVEI32(PL_parser->herelines);
2445 PL_parser->herelines = 0;
2447 SAVEIV(PL_multi_close);
2448 SAVEPPTR(PL_bufptr);
2449 SAVEPPTR(PL_bufend);
2450 SAVEPPTR(PL_oldbufptr);
2451 SAVEPPTR(PL_oldoldbufptr);
2452 SAVEPPTR(PL_last_lop);
2453 SAVEPPTR(PL_last_uni);
2454 SAVEPPTR(PL_linestart);
2455 SAVESPTR(PL_linestr);
2456 SAVEGENERICPV(PL_lex_brackstack);
2457 SAVEGENERICPV(PL_lex_casestack);
2458 SAVEGENERICPV(PL_parser->lex_shared);
2459 SAVEBOOL(PL_parser->lex_re_reparsing);
2460 SAVEI32(PL_copline);
2462 /* The here-doc parser needs to be able to peek into outer lexing
2463 scopes to find the body of the here-doc. So we put PL_linestr and
2464 PL_bufptr into lex_shared, to ‘share’ those values.
2466 PL_parser->lex_shared->ls_linestr = PL_linestr;
2467 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2469 PL_linestr = PL_lex_stuff;
2470 PL_lex_repl = PL_parser->lex_sub_repl;
2471 PL_lex_stuff = NULL;
2472 PL_parser->lex_sub_repl = NULL;
2474 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2475 set for an inner quote-like operator and then an error causes scope-
2476 popping. We must not have a PL_lex_stuff value left dangling, as
2477 that breaks assumptions elsewhere. See bug #123617. */
2478 SAVEGENERICSV(PL_lex_stuff);
2479 SAVEGENERICSV(PL_parser->lex_sub_repl);
2481 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2482 = SvPVX(PL_linestr);
2483 PL_bufend += SvCUR(PL_linestr);
2484 PL_last_lop = PL_last_uni = NULL;
2485 SAVEFREESV(PL_linestr);
2486 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2488 PL_lex_dojoin = FALSE;
2489 PL_lex_brackets = PL_lex_formbrack = 0;
2490 PL_lex_allbrackets = 0;
2491 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2492 Newx(PL_lex_brackstack, 120, char);
2493 Newx(PL_lex_casestack, 12, char);
2494 PL_lex_casemods = 0;
2495 *PL_lex_casestack = '\0';
2497 PL_lex_state = LEX_INTERPCONCAT;
2499 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2500 PL_copline = NOLINE;
2502 Newxz(shared, 1, LEXSHARED);
2503 shared->ls_prev = PL_parser->lex_shared;
2504 PL_parser->lex_shared = shared;
2506 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
2507 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2508 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2509 PL_lex_inpat = PL_parser->lex_sub_op;
2511 PL_lex_inpat = NULL;
2513 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2514 PL_in_eval &= ~EVAL_RE_REPARSING;
2521 * Restores lexer state after a S_sublex_push.
2527 if (!PL_lex_starts++) {
2528 SV * const sv = newSVpvs("");
2529 if (SvUTF8(PL_linestr))
2531 PL_expect = XOPERATOR;
2532 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
2536 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2537 PL_lex_state = LEX_INTERPCASEMOD;
2541 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2542 assert(PL_lex_inwhat != OP_TRANSR);
2544 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2545 PL_linestr = PL_lex_repl;
2547 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2548 PL_bufend += SvCUR(PL_linestr);
2549 PL_last_lop = PL_last_uni = NULL;
2550 PL_lex_dojoin = FALSE;
2551 PL_lex_brackets = 0;
2552 PL_lex_allbrackets = 0;
2553 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2554 PL_lex_casemods = 0;
2555 *PL_lex_casestack = '\0';
2557 if (SvEVALED(PL_lex_repl)) {
2558 PL_lex_state = LEX_INTERPNORMAL;
2560 /* we don't clear PL_lex_repl here, so that we can check later
2561 whether this is an evalled subst; that means we rely on the
2562 logic to ensure sublex_done() is called again only via the
2563 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2566 PL_lex_state = LEX_INTERPCONCAT;
2569 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2570 CopLINE(PL_curcop) +=
2571 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
2572 + PL_parser->herelines;
2573 PL_parser->herelines = 0;
2578 const line_t l = CopLINE(PL_curcop);
2580 if (PL_parser->sub_error_count != PL_error_count) {
2581 if (PL_parser->sub_no_recover) {
2586 if (PL_multi_close == '<')
2587 PL_parser->herelines += l - PL_multi_end;
2588 PL_bufend = SvPVX(PL_linestr);
2589 PL_bufend += SvCUR(PL_linestr);
2590 PL_expect = XOPERATOR;
2596 Perl_load_charnames(pTHX_ SV * char_name, const char * context,
2597 const STRLEN context_len, const char ** error_msg)
2599 /* Load the official _charnames module if not already there. The
2600 * parameters are just to give info for any error messages generated:
2601 * char_name a name to look up which is the reason for loading this
2602 * context 'char_name' in the context in the input in which it appears
2603 * context_len how many bytes 'context' occupies
2604 * error_msg *error_msg will be set to any error
2606 * Returns the ^H table if success; otherwise NULL */
2613 PERL_ARGS_ASSERT_LOAD_CHARNAMES;
2615 /* This loop is executed 1 1/2 times. On the first time through, if it
2616 * isn't already loaded, try loading it, and iterate just once to see if it
2618 for (i = 0; i < 2; i++) {
2619 table = GvHV(PL_hintgv); /* ^H */
2622 && (PL_hints & HINT_LOCALIZE_HH)
2623 && (cvp = hv_fetchs(table, "charnames", FALSE))
2626 return table; /* Quit if already loaded */
2630 Perl_load_module(aTHX_
2632 newSVpvs("_charnames"),
2634 /* version parameter; no need to specify it, as if we get too early
2635 * a version, will fail anyway, not being able to find 'charnames'
2644 /* Here, it failed; new_constant will give appropriate error messages */
2646 res = new_constant( NULL, 0, "charnames", char_name, NULL,
2647 context, context_len, error_msg);
2654 S_get_and_check_backslash_N_name_wrapper(pTHX_ const char* s, const char* const e)
2656 /* This justs wraps get_and_check_backslash_N_name() to output any error
2657 * message it returns. */
2659 const char * error_msg = NULL;
2662 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME_WRAPPER;
2664 /* charnames doesn't work well if there have been errors found */
2665 if (PL_error_count > 0) {
2669 result = get_and_check_backslash_N_name(s, e, cBOOL(UTF), &error_msg);
2672 yyerror_pv(error_msg, UTF ? SVf_UTF8 : 0);
2679 Perl_get_and_check_backslash_N_name(pTHX_ const char* s,
2680 const char* const e,
2682 const char ** error_msg)
2684 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2685 * interior, hence to the "}". Finds what the name resolves to, returning
2686 * an SV* containing it; NULL if no valid one found.
2688 * 'is_utf8' is TRUE if we know we want the result to be UTF-8 even if it
2689 * doesn't have to be. */
2699 /* Points to the beginning of the \N{... so that any messages include the
2700 * context of what's failing*/
2701 const char* context = s - 3;
2702 STRLEN context_len = e - context + 1; /* include all of \N{...} */
2706 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2709 assert(s > (char *) 3);
2711 char_name = newSVpvn_flags(s, e - s, (is_utf8) ? SVf_UTF8 : 0);
2713 if (!SvCUR(char_name)) {
2714 SvREFCNT_dec_NN(char_name);
2715 /* diag_listed_as: Unknown charname '%s' */
2716 *error_msg = Perl_form(aTHX_ "Unknown charname ''");
2720 /* Autoload the charnames module */
2722 table = load_charnames(char_name, context, context_len, error_msg);
2723 if (table == NULL) {
2728 res = new_constant( NULL, 0, "charnames", char_name, NULL,
2729 context, context_len, error_msg);
2731 *error_msg = Perl_form(aTHX_ "Unknown charname '%s'", SvPVX(char_name));
2737 /* See if the charnames handler is the Perl core's, and if so, we can skip
2738 * the validation needed for a user-supplied one, as Perl's does its own
2740 cvp = hv_fetchs(table, "charnames", FALSE);
2741 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2742 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2744 const char * const name = HvNAME(stash);
2745 if (memEQs(name, HvNAMELEN(stash), "_charnames")) {
2750 /* Here, it isn't Perl's charname handler. We can't rely on a
2751 * user-supplied handler to validate the input name. For non-ut8 input,
2752 * look to see that the first character is legal. Then loop through the
2753 * rest checking that each is a continuation */
2755 /* This code makes the reasonable assumption that the only Latin1-range
2756 * characters that begin a character name alias are alphabetic, otherwise
2757 * would have to create a isCHARNAME_BEGIN macro */
2760 if (! isALPHAU(*s)) {
2765 if (! isCHARNAME_CONT(*s)) {
2768 if (*s == ' ' && *(s-1) == ' ') {
2775 /* Similarly for utf8. For invariants can check directly; for other
2776 * Latin1, can calculate their code point and check; otherwise use an
2778 if (UTF8_IS_INVARIANT(*s)) {
2779 if (! isALPHAU(*s)) {
2783 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2784 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2790 if (! _invlist_contains_cp(PL_utf8_charname_begin,
2791 utf8_to_uvchr_buf((U8 *) s,
2801 if (UTF8_IS_INVARIANT(*s)) {
2802 if (! isCHARNAME_CONT(*s)) {
2805 if (*s == ' ' && *(s-1) == ' ') {
2810 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2811 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2818 if (! _invlist_contains_cp(PL_utf8_charname_continue,
2819 utf8_to_uvchr_buf((U8 *) s,
2829 if (*(s-1) == ' ') {
2830 /* diag_listed_as: charnames alias definitions may not contain
2831 trailing white-space; marked by <-- HERE in %s
2833 *error_msg = Perl_form(aTHX_
2834 "charnames alias definitions may not contain trailing "
2835 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2836 (int)(s - context + 1), context,
2837 (int)(e - s + 1), s + 1);
2841 if (SvUTF8(res)) { /* Don't accept malformed charname value */
2842 const U8* first_bad_char_loc;
2844 const char* const str = SvPV_const(res, len);
2845 if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len,
2846 &first_bad_char_loc)))
2848 _force_out_malformed_utf8_message(first_bad_char_loc,
2849 (U8 *) PL_parser->bufend,
2851 0 /* 0 means don't die */ );
2852 /* diag_listed_as: Malformed UTF-8 returned by \N{%s}
2853 immediately after '%s' */
2854 *error_msg = Perl_form(aTHX_
2855 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2856 (int) context_len, context,
2857 (int) ((char *) first_bad_char_loc - str), str);
2866 /* The final %.*s makes sure that should the trailing NUL be missing
2867 * that this print won't run off the end of the string */
2868 /* diag_listed_as: Invalid character in \N{...}; marked by <-- HERE
2870 *error_msg = Perl_form(aTHX_
2871 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2872 (int)(s - context + 1), context,
2873 (int)(e - s + 1), s + 1);
2878 /* diag_listed_as: charnames alias definitions may not contain a
2879 sequence of multiple spaces; marked by <-- HERE
2881 *error_msg = Perl_form(aTHX_
2882 "charnames alias definitions may not contain a sequence of "
2883 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2884 (int)(s - context + 1), context,
2885 (int)(e - s + 1), s + 1);
2892 Extracts the next constant part of a pattern, double-quoted string,
2893 or transliteration. This is terrifying code.
2895 For example, in parsing the double-quoted string "ab\x63$d", it would
2896 stop at the '$' and return an OP_CONST containing 'abc'.
2898 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2899 processing a pattern (PL_lex_inpat is true), a transliteration
2900 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2902 Returns a pointer to the character scanned up to. If this is
2903 advanced from the start pointer supplied (i.e. if anything was
2904 successfully parsed), will leave an OP_CONST for the substring scanned
2905 in pl_yylval. Caller must intuit reason for not parsing further
2906 by looking at the next characters herself.
2910 \N{FOO} => \N{U+hex_for_character_FOO}
2911 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2914 all other \-char, including \N and \N{ apart from \N{ABC}
2917 @ and $ where it appears to be a var, but not for $ as tail anchor
2921 In transliterations:
2922 characters are VERY literal, except for - not at the start or end
2923 of the string, which indicates a range. However some backslash sequences
2924 are recognized: \r, \n, and the like
2925 \007 \o{}, \x{}, \N{}
2926 If all elements in the transliteration are below 256,
2927 scan_const expands the range to the full set of intermediate
2928 characters. If the range is in utf8, the hyphen is replaced with
2929 a certain range mark which will be handled by pmtrans() in op.c.
2931 In double-quoted strings:
2933 all those recognized in transliterations
2934 deprecated backrefs: \1 (in substitution replacements)
2935 case and quoting: \U \Q \E
2938 scan_const does *not* construct ops to handle interpolated strings.
2939 It stops processing as soon as it finds an embedded $ or @ variable
2940 and leaves it to the caller to work out what's going on.
2942 embedded arrays (whether in pattern or not) could be:
2943 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2945 $ in double-quoted strings must be the symbol of an embedded scalar.
2947 $ in pattern could be $foo or could be tail anchor. Assumption:
2948 it's a tail anchor if $ is the last thing in the string, or if it's
2949 followed by one of "()| \r\n\t"
2951 \1 (backreferences) are turned into $1 in substitutions
2953 The structure of the code is
2954 while (there's a character to process) {
2955 handle transliteration ranges
2956 skip regexp comments /(?#comment)/ and codes /(?{code})/
2957 skip #-initiated comments in //x patterns
2958 check for embedded arrays
2959 check for embedded scalars
2961 deprecate \1 in substitution replacements
2962 handle string-changing backslashes \l \U \Q \E, etc.
2963 switch (what was escaped) {
2964 handle \- in a transliteration (becomes a literal -)
2965 if a pattern and not \N{, go treat as regular character
2966 handle \132 (octal characters)
2967 handle \x15 and \x{1234} (hex characters)
2968 handle \N{name} (named characters, also \N{3,5} in a pattern)
2969 handle \cV (control characters)
2970 handle printf-style backslashes (\f, \r, \n, etc)
2973 } (end if backslash)
2974 handle regular character
2975 } (end while character to read)
2980 S_scan_const(pTHX_ char *start)
2982 char *send = PL_bufend; /* end of the constant */
2983 SV *sv = newSV(send - start); /* sv for the constant. See note below
2985 char *s = start; /* start of the constant */
2986 char *d = SvPVX(sv); /* destination for copies */
2987 bool dorange = FALSE; /* are we in a translit range? */
2988 bool didrange = FALSE; /* did we just finish a range? */
2989 bool in_charclass = FALSE; /* within /[...]/ */
2990 bool s_is_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2991 UTF8? But, this can show as true
2992 when the source isn't utf8, as for
2993 example when it is entirely composed
2995 bool d_is_utf8 = FALSE; /* Output constant is UTF8 */
2996 STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
2997 number of characters found so far
2998 that will expand (into 2 bytes)
2999 should we have to convert to
3001 SV *res; /* result from charnames */
3002 STRLEN offset_to_max = 0; /* The offset in the output to where the range
3003 high-end character is temporarily placed */
3005 /* Does something require special handling in tr/// ? This avoids extra
3006 * work in a less likely case. As such, khw didn't feel it was worth
3007 * adding any branches to the more mainline code to handle this, which
3008 * means that this doesn't get set in some circumstances when things like
3009 * \x{100} get expanded out. As a result there needs to be extra testing
3010 * done in the tr code */
3011 bool has_above_latin1 = FALSE;
3013 /* Note on sizing: The scanned constant is placed into sv, which is
3014 * initialized by newSV() assuming one byte of output for every byte of
3015 * input. This routine expects newSV() to allocate an extra byte for a
3016 * trailing NUL, which this routine will append if it gets to the end of
3017 * the input. There may be more bytes of input than output (eg., \N{LATIN
3018 * CAPITAL LETTER A}), or more output than input if the constant ends up
3019 * recoded to utf8, but each time a construct is found that might increase
3020 * the needed size, SvGROW() is called. Its size parameter each time is
3021 * based on the best guess estimate at the time, namely the length used so
3022 * far, plus the length the current construct will occupy, plus room for
3023 * the trailing NUL, plus one byte for every input byte still unscanned */
3025 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
3028 int backslash_N = 0; /* ? was the character from \N{} */
3029 int non_portable_endpoint = 0; /* ? In a range is an endpoint
3030 platform-specific like \x65 */
3033 PERL_ARGS_ASSERT_SCAN_CONST;
3035 assert(PL_lex_inwhat != OP_TRANSR);
3037 /* Protect sv from errors and fatal warnings. */
3038 ENTER_with_name("scan_const");
3041 /* A bunch of code in the loop below assumes that if s[n] exists and is not
3042 * NUL, then s[n+1] exists. This assertion makes sure that assumption is
3044 assert(*send == '\0');
3047 || dorange /* Handle tr/// range at right edge of input */
3050 /* get transliterations out of the way (they're most literal) */
3051 if (PL_lex_inwhat == OP_TRANS) {
3053 /* But there isn't any special handling necessary unless there is a
3054 * range, so for most cases we just drop down and handle the value
3055 * as any other. There are two exceptions.
3057 * 1. A hyphen indicates that we are actually going to have a
3058 * range. In this case, skip the '-', set a flag, then drop
3059 * down to handle what should be the end range value.
3060 * 2. After we've handled that value, the next time through, that
3061 * flag is set and we fix up the range.
3063 * Ranges entirely within Latin1 are expanded out entirely, in
3064 * order to make the transliteration a simple table look-up.
3065 * Ranges that extend above Latin1 have to be done differently, so
3066 * there is no advantage to expanding them here, so they are
3067 * stored here as Min, RANGE_INDICATOR, Max. 'RANGE_INDICATOR' is
3068 * a byte that can't occur in legal UTF-8, and hence can signify a
3069 * hyphen without any possible ambiguity. On EBCDIC machines, if
3070 * the range is expressed as Unicode, the Latin1 portion is
3071 * expanded out even if the range extends above Latin1. This is
3072 * because each code point in it has to be processed here
3073 * individually to get its native translation */
3077 /* Here, we don't think we're in a range. If the new character
3078 * is not a hyphen; or if it is a hyphen, but it's too close to
3079 * either edge to indicate a range, or if we haven't output any
3080 * characters yet then it's a regular character. */
3081 if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv))
3084 /* A regular character. Process like any other, but first
3085 * clear any flags */
3089 non_portable_endpoint = 0;
3092 /* The tests here for being above Latin1 and similar ones
3093 * in the following 'else' suffice to find all such
3094 * occurences in the constant, except those added by a
3095 * backslash escape sequence, like \x{100}. Mostly, those
3096 * set 'has_above_latin1' as appropriate */
3097 if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3098 has_above_latin1 = TRUE;
3101 /* Drops down to generic code to process current byte */
3103 else { /* Is a '-' in the context where it means a range */
3104 if (didrange) { /* Something like y/A-C-Z// */
3105 Perl_croak(aTHX_ "Ambiguous range in transliteration"
3111 s++; /* Skip past the hyphen */
3113 /* d now points to where the end-range character will be
3114 * placed. Drop down to get that character. We'll finish
3115 * processing the range the next time through the loop */
3117 if (s_is_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3118 has_above_latin1 = TRUE;
3121 /* Drops down to generic code to process current byte */
3123 } /* End of not a range */
3125 /* Here we have parsed a range. Now must handle it. At this
3127 * 'sv' is a SV* that contains the output string we are
3128 * constructing. The final two characters in that string
3129 * are the range start and range end, in order.
3130 * 'd' points to just beyond the range end in the 'sv' string,
3131 * where we would next place something
3136 IV range_max; /* last character in range */
3138 Size_t offset_to_min = 0;
3141 bool convert_unicode;
3142 IV real_range_max = 0;
3144 /* Get the code point values of the range ends. */
3145 max_ptr = (d_is_utf8) ? (char *) utf8_hop( (U8*) d, -1) : d - 1;
3146 offset_to_max = max_ptr - SvPVX_const(sv);
3148 /* We know the utf8 is valid, because we just constructed
3149 * it ourselves in previous loop iterations */
3150 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
3151 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
3152 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
3154 /* This compensates for not all code setting
3155 * 'has_above_latin1', so that we don't skip stuff that
3156 * should be executed */
3157 if (range_max > 255) {
3158 has_above_latin1 = TRUE;
3162 min_ptr = max_ptr - 1;
3163 range_min = * (U8*) min_ptr;
3164 range_max = * (U8*) max_ptr;
3167 /* If the range is just a single code point, like tr/a-a/.../,
3168 * that code point is already in the output, twice. We can
3169 * just back up over the second instance and avoid all the rest
3170 * of the work. But if it is a variant character, it's been
3171 * counted twice, so decrement. (This unlikely scenario is
3172 * special cased, like the one for a range of 2 code points
3173 * below, only because the main-line code below needs a range
3174 * of 3 or more to work without special casing. Might as well
3175 * get it out of the way now.) */
3176 if (UNLIKELY(range_max == range_min)) {
3178 if (! d_is_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
3179 utf8_variant_count--;
3185 /* On EBCDIC platforms, we may have to deal with portable
3186 * ranges. These happen if at least one range endpoint is a
3187 * Unicode value (\N{...}), or if the range is a subset of
3188 * [A-Z] or [a-z], and both ends are literal characters,
3189 * like 'A', and not like \x{C1} */
3191 cBOOL(backslash_N) /* \N{} forces Unicode,
3192 hence portable range */
3193 || ( ! non_portable_endpoint
3194 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3195 || (isUPPER_A(range_min) && isUPPER_A(range_max))));
3196 if (convert_unicode) {
3198 /* Special handling is needed for these portable ranges.
3199 * They are defined to be in Unicode terms, which includes
3200 * all the Unicode code points between the end points.
3201 * Convert to Unicode to get the Unicode range. Later we
3202 * will convert each code point in the range back to
3204 range_min = NATIVE_TO_UNI(range_min);
3205 range_max = NATIVE_TO_UNI(range_max);
3209 if (range_min > range_max) {
3211 if (convert_unicode) {
3212 /* Need to convert back to native for meaningful
3213 * messages for this platform */
3214 range_min = UNI_TO_NATIVE(range_min);
3215 range_max = UNI_TO_NATIVE(range_max);
3218 /* Use the characters themselves for the error message if
3219 * ASCII printables; otherwise some visible representation
3221 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3223 "Invalid range \"%c-%c\" in transliteration operator",
3224 (char)range_min, (char)range_max);
3227 else if (convert_unicode) {
3228 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3230 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04"
3231 UVXf "}\" in transliteration operator",
3232 range_min, range_max);
3236 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3238 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
3239 " in transliteration operator",
3240 range_min, range_max);
3244 /* If the range is exactly two code points long, they are
3245 * already both in the output */
3246 if (UNLIKELY(range_min + 1 == range_max)) {
3250 /* Here the range contains at least 3 code points */
3254 /* If everything in the transliteration is below 256, we
3255 * can avoid special handling later. A translation table
3256 * for each of those bytes is created by op.c. So we
3257 * expand out all ranges to their constituent code points.
3258 * But if we've encountered something above 255, the
3259 * expanding won't help, so skip doing that. But if it's
3260 * EBCDIC, we may have to look at each character below 256
3261 * if we have to convert to/from Unicode values */
3262 if ( has_above_latin1
3264 && (range_min > 255 || ! convert_unicode)
3267 const STRLEN off = d - SvPVX(sv);
3268 const STRLEN extra = 1 + (send - s) + 1;
3271 /* Move the high character one byte to the right; then
3272 * insert between it and the range begin, an illegal
3273 * byte which serves to indicate this is a range (using
3274 * a '-' would be ambiguous). */
3276 if (off + extra > SvLEN(sv)) {
3277 d = off + SvGROW(sv, off + extra);
3278 max_ptr = d - off + offset_to_max;
3282 while (e-- > max_ptr) {
3285 *(e + 1) = (char) RANGE_INDICATOR;
3289 /* Here, we're going to expand out the range. For EBCDIC
3290 * the range can extend above 255 (not so in ASCII), so
3291 * for EBCDIC, split it into the parts above and below
3294 if (range_max > 255) {
3295 real_range_max = range_max;
3301 /* Here we need to expand out the string to contain each
3302 * character in the range. Grow the output to handle this.
3303 * For non-UTF8, we need a byte for each code point in the
3304 * range, minus the three that we've already allocated for: the
3305 * hyphen, the min, and the max. For UTF-8, we need this
3306 * plus an extra byte for each code point that occupies two
3307 * bytes (is variant) when in UTF-8 (except we've already
3308 * allocated for the end points, including if they are
3309 * variants). For ASCII platforms and Unicode ranges on EBCDIC
3310 * platforms, it's easy to calculate a precise number. To
3311 * start, we count the variants in the range, which we need
3312 * elsewhere in this function anyway. (For the case where it
3313 * isn't easy to calculate, 'extras' has been initialized to 0,
3314 * and the calculation is done in a loop further down.) */
3316 if (convert_unicode)
3319 /* This is executed unconditionally on ASCII, and for
3320 * Unicode ranges on EBCDIC. Under these conditions, all
3321 * code points above a certain value are variant; and none
3322 * under that value are. We just need to find out how much
3323 * of the range is above that value. We don't count the
3324 * end points here, as they will already have been counted
3325 * as they were parsed. */
3326 if (range_min >= UTF_CONTINUATION_MARK) {
3328 /* The whole range is made up of variants */
3329 extras = (range_max - 1) - (range_min + 1) + 1;
3331 else if (range_max >= UTF_CONTINUATION_MARK) {
3333 /* Only the higher portion of the range is variants */
3334 extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1;
3337 utf8_variant_count += extras;
3340 /* The base growth is the number of code points in the range,
3341 * not including the endpoints, which have already been sized
3342 * for (and output). We don't subtract for the hyphen, as it
3343 * has been parsed but not output, and the SvGROW below is
3344 * based only on what's been output plus what's left to parse.
3346 grow = (range_max - 1) - (range_min + 1) + 1;
3350 /* In some cases in EBCDIC, we haven't yet calculated a
3351 * precise amount needed for the UTF-8 variants. Just
3352 * assume the worst case, that everything will expand by a
3354 if (! convert_unicode) {
3360 /* Otherwise we know exactly how many variants there
3361 * are in the range. */
3366 /* Grow, but position the output to overwrite the range min end
3367 * point, because in some cases we overwrite that */
3368 SvCUR_set(sv, d - SvPVX_const(sv));
3369 offset_to_min = min_ptr - SvPVX_const(sv);
3371 /* See Note on sizing above. */
3372 d = offset_to_min + SvGROW(sv, SvCUR(sv)
3375 + 1 /* Trailing NUL */ );
3377 /* Now, we can expand out the range. */
3379 if (convert_unicode) {
3382 /* Recall that the min and max are now in Unicode terms, so
3383 * we have to convert each character to its native
3386 for (i = range_min; i <= range_max; i++) {
3387 append_utf8_from_native_byte(
3388 LATIN1_TO_NATIVE((U8) i),
3393 for (i = range_min; i <= range_max; i++) {
3394 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3400 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3402 /* Here, no conversions are necessary, which means that the
3403 * first character in the range is already in 'd' and
3404 * valid, so we can skip overwriting it */
3408 for (i = range_min + 1; i <= range_max; i++) {
3409 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3415 assert(range_min + 1 <= range_max);
3416 for (i = range_min + 1; i < range_max; i++) {
3418 /* In this case on EBCDIC, we haven't calculated
3419 * the variants. Do it here, as we go along */
3420 if (! UVCHR_IS_INVARIANT(i)) {
3421 utf8_variant_count++;
3427 /* The range_max is done outside the loop so as to
3428 * avoid having to special case not incrementing
3429 * 'utf8_variant_count' on EBCDIC (it's already been
3430 * counted when originally parsed) */
3431 *d++ = (char) range_max;
3436 /* If the original range extended above 255, add in that
3438 if (real_range_max) {
3439 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3440 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3441 if (real_range_max > 0x100) {
3442 if (real_range_max > 0x101) {
3443 *d++ = (char) RANGE_INDICATOR;
3445 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3451 /* mark the range as done, and continue */
3455 non_portable_endpoint = 0;
3459 } /* End of is a range */
3460 } /* End of transliteration. Joins main code after these else's */
3461 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3464 while (s1 >= start && *s1-- == '\\')
3467 in_charclass = TRUE;
3469 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3472 while (s1 >= start && *s1-- == '\\')
3475 in_charclass = FALSE;
3477 /* skip for regexp comments /(?#comment)/, except for the last
3478 * char, which will be done separately. Stop on (?{..}) and
3480 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3483 PERL_UINT_FAST8_T len = UTF8SKIP(s);
3485 while (s + len < send && *s != ')') {
3486 Copy(s, d, len, U8);
3489 len = UTF8_SAFE_SKIP(s, send);
3492 else while (s+1 < send && *s != ')') {
3496 else if (!PL_lex_casemods
3497 && ( s[2] == '{' /* This should match regcomp.c */
3498 || (s[2] == '?' && s[3] == '{')))
3503 /* likewise skip #-initiated comments in //x patterns */
3507 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3509 while (s < send && *s != '\n')
3512 /* no further processing of single-quoted regex */
3513 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3514 goto default_action;
3516 /* check for embedded arrays
3517 * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3519 else if (*s == '@' && s[1]) {
3521 ? isIDFIRST_utf8_safe(s+1, send)
3522 : isWORDCHAR_A(s[1]))
3526 if (memCHRs(":'{$", s[1]))
3528 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3529 break; /* in regexp, neither @+ nor @- are interpolated */
3531 /* check for embedded scalars. only stop if we're sure it's a
3533 else if (*s == '$') {
3534 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3536 if (s + 1 < send && !memCHRs("()| \r\n\t", s[1])) {
3538 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3539 "Possible unintended interpolation of $\\ in regex");
3541 break; /* in regexp, $ might be tail anchor */
3545 /* End of else if chain - OP_TRANS rejoin rest */
3547 if (UNLIKELY(s >= send)) {
3553 if (*s == '\\' && s+1 < send) {
3554 char* e; /* Can be used for ending '}', etc. */
3558 /* warn on \1 - \9 in substitution replacements, but note that \11
3559 * is an octal; and \19 is \1 followed by '9' */
3560 if (PL_lex_inwhat == OP_SUBST
3566 /* diag_listed_as: \%d better written as $%d */
3567 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3572 /* string-change backslash escapes */
3573 if (PL_lex_inwhat != OP_TRANS && *s && memCHRs("lLuUEQF", *s)) {
3577 /* In a pattern, process \N, but skip any other backslash escapes.
3578 * This is because we don't want to translate an escape sequence
3579 * into a meta symbol and have the regex compiler use the meta
3580 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3581 * in spite of this, we do have to process \N here while the proper
3582 * charnames handler is in scope. See bugs #56444 and #62056.
3584 * There is a complication because \N in a pattern may also stand
3585 * for 'match a non-nl', and not mean a charname, in which case its
3586 * processing should be deferred to the regex compiler. To be a
3587 * charname it must be followed immediately by a '{', and not look
3588 * like \N followed by a curly quantifier, i.e., not something like
3589 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3591 else if (PL_lex_inpat
3594 || regcurly(s + 1)))
3597 goto default_action;
3603 if ((isALPHANUMERIC(*s)))
3604 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3605 "Unrecognized escape \\%c passed through",
3607 /* default action is to copy the quoted character */
3608 goto default_action;
3611 /* eg. \132 indicates the octal constant 0132 */
3612 case '0': case '1': case '2': case '3':
3613 case '4': case '5': case '6': case '7':
3615 I32 flags = PERL_SCAN_SILENT_ILLDIGIT
3616 | PERL_SCAN_NOTIFY_ILLDIGIT;
3618 uv = grok_oct(s, &len, &flags, NULL);
3620 if ( (flags & PERL_SCAN_NOTIFY_ILLDIGIT)
3622 && isDIGIT(*s) /* like \08, \178 */
3623 && ckWARN(WARN_MISC))
3625 Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
3626 form_alien_digit_msg(8, len, s, send, UTF, FALSE));
3629 goto NUM_ESCAPE_INSERT;
3631 /* eg. \o{24} indicates the octal constant \024 */
3636 if (! grok_bslash_o(&s, send,
3639 FALSE, /* Not strict */
3640 FALSE, /* No illegal cp's */
3644 uv = 0; /* drop through to ensure range ends are set */
3646 goto NUM_ESCAPE_INSERT;
3649 /* eg. \x24 indicates the hex constant 0x24 */
3654 if (! grok_bslash_x(&s, send,
3657 FALSE, /* Not strict */
3658 FALSE, /* No illegal cp's */
3662 uv = 0; /* drop through to ensure range ends are set */
3667 /* Insert oct or hex escaped character. */
3669 /* Here uv is the ordinal of the next character being added */
3670 if (UVCHR_IS_INVARIANT(uv)) {
3674 if (!d_is_utf8 && uv > 255) {
3676 /* Here, 'uv' won't fit unless we convert to UTF-8.
3677 * If we've only seen invariants so far, all we have to
3678 * do is turn on the flag */
3679 if (utf8_variant_count == 0) {
3683 SvCUR_set(sv, d - SvPVX_const(sv));
3687 sv_utf8_upgrade_flags_grow(
3689 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3691 /* Since we're having to grow here,
3692 * make sure we have enough room for
3693 * this escape and a NUL, so the
3694 * code immediately below won't have
3695 * to actually grow again */
3697 + (STRLEN)(send - s) + 1);
3698 d = SvPVX(sv) + SvCUR(sv);
3701 has_above_latin1 = TRUE;
3707 utf8_variant_count++;
3710 /* Usually, there will already be enough room in 'sv'
3711 * since such escapes are likely longer than any UTF-8
3712 * sequence they can end up as. This isn't the case on
3713 * EBCDIC where \x{40000000} contains 12 bytes, and the
3714 * UTF-8 for it contains 14. And, we have to allow for
3715 * a trailing NUL. It probably can't happen on ASCII
3716 * platforms, but be safe. See Note on sizing above. */
3717 const STRLEN needed = d - SvPVX(sv)
3721 if (UNLIKELY(needed > SvLEN(sv))) {
3722 SvCUR_set(sv, d - SvPVX_const(sv));
3723 d = SvCUR(sv) + SvGROW(sv, needed);
3726 d = (char*) uvchr_to_utf8_flags((U8*)d, uv,
3727 (ckWARN(WARN_PORTABLE))
3728 ? UNICODE_WARN_PERL_EXTENDED
3733 non_portable_endpoint++;
3738 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3739 * named character, like \N{LATIN SMALL LETTER A}, or a named
3740 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3741 * GRAVE} (except y/// can't handle the latter, croaking). For
3742 * convenience all three forms are referred to as "named
3743 * characters" below.
3745 * For patterns, \N also can mean to match a non-newline. Code
3746 * before this 'switch' statement should already have handled
3747 * this situation, and hence this code only has to deal with
3748 * the named character cases.
3750 * For non-patterns, the named characters are converted to
3751 * their string equivalents. In patterns, named characters are
3752 * not converted to their ultimate forms for the same reasons
3753 * that other escapes aren't (mainly that the ultimate
3754 * character could be considered a meta-symbol by the regex
3755 * compiler). Instead, they are converted to the \N{U+...}
3756 * form to get the value from the charnames that is in effect
3757 * right now, while preserving the fact that it was a named
3758 * character, so that the regex compiler knows this.
3760 * The structure of this section of code (besides checking for
3761 * errors and upgrading to utf8) is:
3762 * If the named character is of the form \N{U+...}, pass it
3763 * through if a pattern; otherwise convert the code point
3765 * Otherwise must be some \N{NAME}: convert to
3766 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3768 * Transliteration is an exception. The conversion to utf8 is
3769 * only done if the code point requires it to be representable.
3771 * Here, 's' points to the 'N'; the test below is guaranteed to
3772 * succeed if we are being called on a pattern, as we already
3773 * know from a test above that the next character is a '{'. A
3774 * non-pattern \N must mean 'named character', which requires
3778 yyerror("Missing braces on \\N{}");
3784 /* If there is no matching '}', it is an error. */
3785 if (! (e = (char *) memchr(s, '}', send - s))) {
3786 if (! PL_lex_inpat) {
3787 yyerror("Missing right brace on \\N{}");
3789 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3791 yyquit(); /* Have exhausted the input. */
3794 /* Here it looks like a named character */
3796 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3797 s += 2; /* Skip to next char after the 'U+' */
3800 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3801 /* Check the syntax. */
3804 if (!isXDIGIT(*s)) {
3807 "Invalid hexadecimal number in \\N{U+...}"
3816 else if ((*s == '.' || *s == '_')
3822 /* Pass everything through unchanged.
3823 * +1 is for the '}' */
3824 Copy(orig_s, d, e - orig_s + 1, char);
3825 d += e - orig_s + 1;
3827 else { /* Not a pattern: convert the hex to string */
3828 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3829 | PERL_SCAN_SILENT_ILLDIGIT
3830 | PERL_SCAN_SILENT_OVERFLOW
3831 | PERL_SCAN_DISALLOW_PREFIX;
3834 uv = grok_hex(s, &len, &flags, NULL);
3835 if (len == 0 || (len != (STRLEN)(e - s)))
3838 if ( uv > MAX_LEGAL_CP
3839 || (flags & PERL_SCAN_GREATER_THAN_UV_MAX))
3841 yyerror(form_cp_too_large_msg(16, s, len, 0));
3842 uv = 0; /* drop through to ensure range ends are
3846 /* For non-tr///, if the destination is not in utf8,
3847 * unconditionally recode it to be so. This is
3848 * because \N{} implies Unicode semantics, and scalars
3849 * have to be in utf8 to guarantee those semantics.
3850 * tr/// doesn't care about Unicode rules, so no need
3851 * there to upgrade to UTF-8 for small enough code
3853 if (! d_is_utf8 && ( uv > 0xFF
3854 || PL_lex_inwhat != OP_TRANS))
3856 /* See Note on sizing above. */
3857 const STRLEN extra = OFFUNISKIP(uv) + (send - e) + 1;
3859 SvCUR_set(sv, d - SvPVX_const(sv));
3863 if (utf8_variant_count == 0) {
3865 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3868 sv_utf8_upgrade_flags_grow(
3870 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3872 d = SvPVX(sv) + SvCUR(sv);
3876 has_above_latin1 = TRUE;
3879 /* Add the (Unicode) code point to the output. */
3880 if (! d_is_utf8 || OFFUNI_IS_INVARIANT(uv)) {
3881 *d++ = (char) LATIN1_TO_NATIVE(uv);
3884 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv,
3885 (ckWARN(WARN_PORTABLE))
3886 ? UNICODE_WARN_PERL_EXTENDED
3891 else /* Here is \N{NAME} but not \N{U+...}. */
3892 if (! (res = get_and_check_backslash_N_name_wrapper(s, e)))
3893 { /* Failed. We should die eventually, but for now use a NUL
3897 else { /* Successfully evaluated the name */
3899 const char *str = SvPV_const(res, len);
3902 if (! len) { /* The name resolved to an empty string */
3903 const char empty_N[] = "\\N{_}";
3904 Copy(empty_N, d, sizeof(empty_N) - 1, char);
3905 d += sizeof(empty_N) - 1;
3908 /* In order to not lose information for the regex
3909 * compiler, pass the result in the specially made
3910 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3911 * the code points in hex of each character
3912 * returned by charnames */
3914 const char *str_end = str + len;
3915 const STRLEN off = d - SvPVX_const(sv);
3917 if (! SvUTF8(res)) {
3918 /* For the non-UTF-8 case, we can determine the
3919 * exact length needed without having to parse
3920 * through the string. Each character takes up
3921 * 2 hex digits plus either a trailing dot or
3923 const char initial_text[] = "\\N{U+";
3924 const STRLEN initial_len = sizeof(initial_text)
3926 d = off + SvGROW(sv, off
3929 /* +1 for trailing NUL */
3932 + (STRLEN)(send - e));
3933 Copy(initial_text, d, initial_len, char);
3935 while (str < str_end) {
3938 my_snprintf(hex_string,
3942 /* The regex compiler is
3943 * expecting Unicode, not
3945 NATIVE_TO_LATIN1(*str));
3946 PERL_MY_SNPRINTF_POST_GUARD(len,
3947 sizeof(hex_string));
3948 Copy(hex_string, d, 3, char);
3952 d--; /* Below, we will overwrite the final
3953 dot with a right brace */
3956 STRLEN char_length; /* cur char's byte length */
3958 /* and the number of bytes after this is
3959 * translated into hex digits */
3960 STRLEN output_length;
3962 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3963 * for max('U+', '.'); and 1 for NUL */
3964 char hex_string[2 * UTF8_MAXBYTES + 5];
3966 /* Get the first character of the result. */
3967 U32 uv = utf8n_to_uvchr((U8 *) str,
3971 /* Convert first code point to Unicode hex,
3972 * including the boiler plate before it. */
3974 my_snprintf(hex_string, sizeof(hex_string),
3976 (unsigned int) NATIVE_TO_UNI(uv));
3978 /* Make sure there is enough space to hold it */
3979 d = off + SvGROW(sv, off
3981 + (STRLEN)(send - e)
3982 + 2); /* '}' + NUL */
3984 Copy(hex_string, d, output_length, char);
3987 /* For each subsequent character, append dot and
3988 * its Unicode code point in hex */
3989 while ((str += char_length) < str_end) {
3990 const STRLEN off = d - SvPVX_const(sv);
3991 U32 uv = utf8n_to_uvchr((U8 *) str,
3996 my_snprintf(hex_string,
3999 (unsigned int) NATIVE_TO_UNI(uv));
4001 d = off + SvGROW(sv, off
4003 + (STRLEN)(send - e)
4004 + 2); /* '}' + NUL */
4005 Copy(hex_string, d, output_length, char);
4010 *d++ = '}'; /* Done. Add the trailing brace */
4013 else { /* Here, not in a pattern. Convert the name to a
4016 if (PL_lex_inwhat == OP_TRANS) {
4017 str = SvPV_const(res, len);
4018 if (len > ((SvUTF8(res))
4022 yyerror(Perl_form(aTHX_
4023 "%.*s must not be a named sequence"
4024 " in transliteration operator",
4025 /* +1 to include the "}" */
4026 (int) (e + 1 - start), start));
4028 goto end_backslash_N;
4031 if (SvUTF8(res) && UTF8_IS_ABOVE_LATIN1(*str)) {
4032 has_above_latin1 = TRUE;
4036 else if (! SvUTF8(res)) {
4037 /* Make sure \N{} return is UTF-8. This is because
4038 * \N{} implies Unicode semantics, and scalars have
4039 * to be in utf8 to guarantee those semantics; but
4040 * not needed in tr/// */
4041 sv_utf8_upgrade_flags(res, 0);
4042 str = SvPV_const(res, len);
4045 /* Upgrade destination to be utf8 if this new
4047 if (! d_is_utf8 && SvUTF8(res)) {
4048 /* See Note on sizing above. */
4049 const STRLEN extra = len + (send - s) + 1;
4051 SvCUR_set(sv, d - SvPVX_const(sv));
4055 if (utf8_variant_count == 0) {
4057 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
4060 sv_utf8_upgrade_flags_grow(sv,
4061 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4063 d = SvPVX(sv) + SvCUR(sv);
4066 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
4068 /* See Note on sizing above. (NOTE: SvCUR() is not
4069 * set correctly here). */
4070 const STRLEN extra = len + (send - e) + 1;
4071 const STRLEN off = d - SvPVX_const(sv);
4072 d = off + SvGROW(sv, off + extra);
4074 Copy(str, d, len, char);
4080 } /* End \N{NAME} */
4084 backslash_N++; /* \N{} is defined to be Unicode */
4086 s = e + 1; /* Point to just after the '}' */
4089 /* \c is a control character */
4093 const char * message;
4095 if (! grok_bslash_c(*s, (U8 *) d, &message, NULL)) {
4097 yyquit(); /* Have always immediately croaked on
4103 yyerror("Missing control char name in \\c");
4104 yyquit(); /* Are at end of input, no sense continuing */
4107 non_portable_endpoint++;
4111 /* printf-style backslashes, formfeeds, newlines, etc */
4137 } /* end if (backslash) */
4140 /* Just copy the input to the output, though we may have to convert
4143 * If the input has the same representation in UTF-8 as not, it will be
4144 * a single byte, and we don't care about UTF8ness; just copy the byte */
4145 if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) {
4148 else if (! s_is_utf8 && ! d_is_utf8) {
4149 /* If neither source nor output is UTF-8, is also a single byte,
4150 * just copy it; but this byte counts should we later have to
4151 * convert to UTF-8 */
4153 utf8_variant_count++;
4155 else if (s_is_utf8 && d_is_utf8) { /* Both UTF-8, can just copy */
4156 const STRLEN len = UTF8SKIP(s);
4158 /* We expect the source to have already been checked for
4160 assert(isUTF8_CHAR((U8 *) s, (U8 *) send));
4162 Copy(s, d, len, U8);
4166 else if (s_is_utf8) { /* UTF8ness matters: convert output to utf8 */
4167 STRLEN need = send - s + 1; /* See Note on sizing above. */
4169 SvCUR_set(sv, d - SvPVX_const(sv));
4173 if (utf8_variant_count == 0) {
4175 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
4178 sv_utf8_upgrade_flags_grow(sv,
4179 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4181 d = SvPVX(sv) + SvCUR(sv);
4184 goto default_action; /* Redo, having upgraded so both are UTF-8 */
4186 else { /* UTF8ness matters: convert this non-UTF8 source char to
4187 UTF-8 for output. It will occupy 2 bytes, but don't include
4188 the input byte since we haven't incremented 's' yet. See
4189 Note on sizing above. */
4190 const STRLEN off = d - SvPVX(sv);
4191 const STRLEN extra = 2 + (send - s - 1) + 1;
4192 if (off + extra > SvLEN(sv)) {
4193 d = off + SvGROW(sv, off + extra);
4195 *d++ = UTF8_EIGHT_BIT_HI(*s);
4196 *d++ = UTF8_EIGHT_BIT_LO(*s);
4199 } /* while loop to process each character */
4202 const STRLEN off = d - SvPVX(sv);
4204 /* See if room for the terminating NUL */
4205 if (UNLIKELY(off >= SvLEN(sv))) {
4209 if (off > SvLEN(sv))
4211 Perl_croak(aTHX_ "panic: constant overflowed allocated space,"
4212 " %" UVuf " >= %" UVuf, (UV)off, (UV)SvLEN(sv));
4214 /* Whew! Here we don't have room for the terminating NUL, but
4215 * everything else so far has fit. It's not too late to grow
4216 * to fit the NUL and continue on. But it is a bug, as the code
4217 * above was supposed to have made room for this, so under
4218 * DEBUGGING builds, we panic anyway. */
4219 d = off + SvGROW(sv, off + 1);
4223 /* terminate the string and set up the sv */
4225 SvCUR_set(sv, d - SvPVX_const(sv));
4232 /* shrink the sv if we allocated more than we used */
4233 if (SvCUR(sv) + 5 < SvLEN(sv)) {
4234 SvPV_shrink_to_cur(sv);
4237 /* return the substring (via pl_yylval) only if we parsed anything */
4240 for (; s2 < s; s2++) {
4242 COPLINE_INC_WITH_HERELINES;
4244 SvREFCNT_inc_simple_void_NN(sv);
4245 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
4246 && ! PL_parser->lex_re_reparsing)
4248 const char *const key = PL_lex_inpat ? "qr" : "q";
4249 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
4253 if (PL_lex_inwhat == OP_TRANS) {
4256 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
4259 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
4267 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
4268 type, typelen, NULL);
4270 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
4272 LEAVE_with_name("scan_const");
4277 * Returns TRUE if there's more to the expression (e.g., a subscript),
4280 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
4282 * ->[ and ->{ return TRUE
4283 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
4284 * { and [ outside a pattern are always subscripts, so return TRUE
4285 * if we're outside a pattern and it's not { or [, then return FALSE
4286 * if we're in a pattern and the first char is a {
4287 * {4,5} (any digits around the comma) returns FALSE
4288 * if we're in a pattern and the first char is a [
4290 * [SOMETHING] has a funky algorithm to decide whether it's a
4291 * character class or not. It has to deal with things like
4292 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
4293 * anything else returns TRUE
4296 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
4299 S_intuit_more(pTHX_ char *s, char *e)
4301 PERL_ARGS_ASSERT_INTUIT_MORE;
4303 if (PL_lex_brackets)
4305 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
4307 if (*s == '-' && s[1] == '>'
4308 && FEATURE_POSTDEREF_QQ_IS_ENABLED
4309 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
4310 ||(s[2] == '@' && memCHRs("*[{",s[3])) ))
4312 if (*s != '{' && *s != '[')
4314 PL_parser->sub_no_recover = TRUE;
4318 /* In a pattern, so maybe we have {n,m}. */
4326 /* On the other hand, maybe we have a character class */
4329 if (*s == ']' || *s == '^')
4332 /* this is terrifying, and it works */
4335 const char * const send = (char *) memchr(s, ']', e - s);
4336 unsigned char un_char, last_un_char;
4337 char tmpbuf[sizeof PL_tokenbuf * 4];
4339 if (!send) /* has to be an expression */
4341 weight = 2; /* let's weigh the evidence */
4345 else if (isDIGIT(*s)) {
4347 if (isDIGIT(s[1]) && s[2] == ']')
4353 Zero(seen,256,char);
4355 for (; s < send; s++) {
4356 last_un_char = un_char;
4357 un_char = (unsigned char)*s;
4362 weight -= seen[un_char] * 10;
4363 if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) {
4365 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
4366 len = (int)strlen(tmpbuf);
4367 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
4368 UTF ? SVf_UTF8 : 0, SVt_PV))
4375 && memCHRs("[#!%*<>()-=",s[1]))
4377 if (/*{*/ memCHRs("])} =",s[2]))
4386 if (memCHRs("wds]",s[1]))
4388 else if (seen[(U8)'\''] || seen[(U8)'"'])
4390 else if (memCHRs("rnftbxcav",s[1]))
4392 else if (isDIGIT(s[1])) {
4394 while (s[1] && isDIGIT(s[1]))
4404 if (memCHRs("aA01! ",last_un_char))
4406 if (memCHRs("zZ79~",s[1]))
4408 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4409 weight -= 5; /* cope with negative subscript */
4412 if (!isWORDCHAR(last_un_char)
4413 && !(last_un_char == '$' || last_un_char == '@'
4414 || last_un_char == '&')
4415 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4419 if (keyword(d, s - d, 0))
4422 if (un_char == last_un_char + 1)
4424 weight -= seen[un_char];
4429 if (weight >= 0) /* probably a character class */
4439 * Does all the checking to disambiguate
4441 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4442 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4444 * First argument is the stuff after the first token, e.g. "bar".
4446 * Not a method if foo is a filehandle.
4447 * Not a method if foo is a subroutine prototyped to take a filehandle.
4448 * Not a method if it's really "Foo $bar"
4449 * Method if it's "foo $bar"
4450 * Not a method if it's really "print foo $bar"
4451 * Method if it's really "foo package::" (interpreted as package->foo)
4452 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4453 * Not a method if bar is a filehandle or package, but is quoted with
4458 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4460 char *s = start + (*start == '$');
4461 char tmpbuf[sizeof PL_tokenbuf];
4464 /* Mustn't actually add anything to a symbol table.
4465 But also don't want to "initialise" any placeholder
4466 constants that might already be there into full
4467 blown PVGVs with attached PVCV. */
4469 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4471 PERL_ARGS_ASSERT_INTUIT_METHOD;
4473 if (!FEATURE_INDIRECT_IS_ENABLED)
4476 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4478 if (cv && SvPOK(cv)) {
4479 const char *proto = CvPROTO(cv);
4481 while (*proto && (isSPACE(*proto) || *proto == ';'))
4488 if (*start == '$') {
4489 SSize_t start_off = start - SvPVX(PL_linestr);
4490 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4491 || isUPPER(*PL_tokenbuf))
4493 /* this could be $# */
4496 PL_bufptr = SvPVX(PL_linestr) + start_off;
4498 return *s == '(' ? FUNCMETH : METHOD;
4501 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4502 /* start is the beginning of the possible filehandle/object,
4503 * and s is the end of it
4504 * tmpbuf is a copy of it (but with single quotes as double colons)
4507 if (!keyword(tmpbuf, len, 0)) {
4508 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4513 indirgv = gv_fetchpvn_flags(tmpbuf, len,
4514 GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
4516 if (indirgv && SvTYPE(indirgv) != SVt_NULL
4517 && (!isGV(indirgv) || GvCVu(indirgv)))
4519 /* filehandle or package name makes it a method */
4520 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4522 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4523 return 0; /* no assumptions -- "=>" quotes bareword */
4525 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0,
4526 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4527 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4529 force_next(BAREWORD);
4531 return *s == '(' ? FUNCMETH : METHOD;
4537 /* Encoded script support. filter_add() effectively inserts a
4538 * 'pre-processing' function into the current source input stream.
4539 * Note that the filter function only applies to the current source file
4540 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4542 * The datasv parameter (which may be NULL) can be used to pass
4543 * private data to this instance of the filter. The filter function
4544 * can recover the SV using the FILTER_DATA macro and use it to
4545 * store private buffers and state information.
4547 * The supplied datasv parameter is upgraded to a PVIO type
4548 * and the IoDIRP/IoANY field is used to store the function pointer,
4549 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4550 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4551 * private use must be set using malloc'd pointers.
4555 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4563 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4564 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4566 if (!PL_rsfp_filters)
4567 PL_rsfp_filters = newAV();
4570 SvUPGRADE(datasv, SVt_PVIO);
4571 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4572 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4573 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4574 FPTR2DPTR(void *, IoANY(datasv)),
4575 SvPV_nolen(datasv)));
4576 av_unshift(PL_rsfp_filters, 1);
4577 av_store(PL_rsfp_filters, 0, datasv) ;
4579 !PL_parser->filtered
4580 && PL_parser->lex_flags & LEX_EVALBYTES
4581 && PL_bufptr < PL_bufend
4583 const char *s = PL_bufptr;
4584 while (s < PL_bufend) {
4586 SV *linestr = PL_parser->linestr;
4587 char *buf = SvPVX(linestr);
4588 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4589 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4590 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4591 STRLEN const linestart_pos = PL_parser->linestart - buf;
4592 STRLEN const last_uni_pos =
4593 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4594 STRLEN const last_lop_pos =
4595 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4596 av_push(PL_rsfp_filters, linestr);
4597 PL_parser->linestr =
4598 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4599 buf = SvPVX(PL_parser->linestr);
4600 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4601 PL_parser->bufptr = buf + bufptr_pos;
4602 PL_parser->oldbufptr = buf + oldbufptr_pos;
4603 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4604 PL_parser->linestart = buf + linestart_pos;
4605 if (PL_parser->last_uni)
4606 PL_parser->last_uni = buf + last_uni_pos;
4607 if (PL_parser->last_lop)
4608 PL_parser->last_lop = buf + last_lop_pos;
4609 SvLEN_set(linestr, SvCUR(linestr));
4610 SvCUR_set(linestr, s - SvPVX(linestr));
4611 PL_parser->filtered = 1;
4621 /* Delete most recently added instance of this filter function. */
4623 Perl_filter_del(pTHX_ filter_t funcp)
4627 PERL_ARGS_ASSERT_FILTER_DEL;
4630 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4631 FPTR2DPTR(void*, funcp)));
4633 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4635 /* if filter is on top of stack (usual case) just pop it off */
4636 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4637 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4638 sv_free(av_pop(PL_rsfp_filters));
4642 /* we need to search for the correct entry and clear it */
4643 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4647 /* Invoke the idxth filter function for the current rsfp. */
4648 /* maxlen 0 = read one text line */
4650 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4655 /* This API is bad. It should have been using unsigned int for maxlen.
4656 Not sure if we want to change the API, but if not we should sanity
4657 check the value here. */
4658 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4660 PERL_ARGS_ASSERT_FILTER_READ;
4662 if (!PL_parser || !PL_rsfp_filters)
4664 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4665 /* Provide a default input filter to make life easy. */
4666 /* Note that we append to the line. This is handy. */
4667 DEBUG_P(PerlIO_printf(Perl_debug_log,
4668 "filter_read %d: from rsfp\n", idx));
4669 if (correct_length) {
4672 const int old_len = SvCUR(buf_sv);
4674 /* ensure buf_sv is large enough */
4675 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4676 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4677 correct_length)) <= 0) {
4678 if (PerlIO_error(PL_rsfp))
4679 return -1; /* error */
4681 return 0 ; /* end of file */
4683 SvCUR_set(buf_sv, old_len + len) ;
4684 SvPVX(buf_sv)[old_len + len] = '\0';
4687 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4688 if (PerlIO_error(PL_rsfp))
4689 return -1; /* error */
4691 return 0 ; /* end of file */
4694 return SvCUR(buf_sv);
4696 /* Skip this filter slot if filter has been deleted */
4697 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4698 DEBUG_P(PerlIO_printf(Perl_debug_log,
4699 "filter_read %d: skipped (filter deleted)\n",
4701 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4703 if (SvTYPE(datasv) != SVt_PVIO) {
4704 if (correct_length) {
4706 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4707 if (!remainder) return 0; /* eof */
4708 if (correct_length > remainder) correct_length = remainder;
4709 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4710 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4713 const char *s = SvEND(datasv);
4714 const char *send = SvPVX(datasv) + SvLEN(datasv);
4722 if (s == send) return 0; /* eof */
4723 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4724 SvCUR_set(datasv, s-SvPVX(datasv));
4726 return SvCUR(buf_sv);
4728 /* Get function pointer hidden within datasv */
4729 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4730 DEBUG_P(PerlIO_printf(Perl_debug_log,
4731 "filter_read %d: via function %p (%s)\n",
4732 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4733 /* Call function. The function is expected to */
4734 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4735 /* Return: <0:error, =0:eof, >0:not eof */
4737 save_scalar(PL_errgv);
4738 ret = (*funcp)(aTHX_ idx, buf_sv, correct_length);
4744 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4746 PERL_ARGS_ASSERT_FILTER_GETS;
4748 #ifdef PERL_CR_FILTER
4749 if (!PL_rsfp_filters) {
4750 filter_add(S_cr_textfilter,NULL);
4753 if (PL_rsfp_filters) {
4755 SvCUR_set(sv, 0); /* start with empty line */
4756 if (FILTER_READ(0, sv, 0) > 0)
4757 return ( SvPVX(sv) ) ;
4762 return (sv_gets(sv, PL_rsfp, append));
4766 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4770 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4772 if (memEQs(pkgname, len, "__PACKAGE__"))
4776 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4777 && (gv = gv_fetchpvn_flags(pkgname,
4779 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4781 return GvHV(gv); /* Foo:: */
4784 /* use constant CLASS => 'MyClass' */
4785 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4786 if (gv && GvCV(gv)) {
4787 SV * const sv = cv_const_sv(GvCV(gv));
4789 return gv_stashsv(sv, 0);
4792 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4797 S_tokenize_use(pTHX_ int is_use, char *s) {
4798 PERL_ARGS_ASSERT_TOKENIZE_USE;
4800 if (PL_expect != XSTATE)
4801 /* diag_listed_as: "use" not allowed in expression */
4802 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4803 is_use ? "use" : "no"));
4806 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4807 s = force_version(s, TRUE);
4808 if (*s == ';' || *s == '}'
4809 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4810 NEXTVAL_NEXTTOKE.opval = NULL;
4811 force_next(BAREWORD);
4813 else if (*s == 'v') {
4814 s = force_word(s,BAREWORD,FALSE,TRUE);
4815 s = force_version(s, FALSE);
4819 s = force_word(s,BAREWORD,FALSE,TRUE);
4820 s = force_version(s, FALSE);
4822 pl_yylval.ival = is_use;
4826 static const char* const exp_name[] =
4827 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4828 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4829 "SIGVAR", "TERMORDORDOR"
4833 #define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l)
4835 S_word_takes_any_delimiter(char *p, STRLEN len)
4837 return (len == 1 && memCHRs("msyq", p[0]))
4839 && ((p[0] == 't' && p[1] == 'r')
4840 || (p[0] == 'q' && memCHRs("qwxr", p[1]))));
4844 S_check_scalar_slice(pTHX_ char *s)
4847 while (SPACE_OR_TAB(*s)) s++;
4848 if (*s == 'q' && s[1] == 'w' && !isWORDCHAR_lazy_if_safe(s+2,
4854 while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)
4855 || (*s && memCHRs(" \t$#+-'\"", *s)))
4857 s += UTF ? UTF8SKIP(s) : 1;
4859 if (*s == '}' || *s == ']')
4860 pl_yylval.ival = OPpSLICEWARNING;
4863 #define lex_token_boundary() S_lex_token_boundary(aTHX)
4865 S_lex_token_boundary(pTHX)
4867 PL_oldoldbufptr = PL_oldbufptr;
4868 PL_oldbufptr = PL_bufptr;
4871 #define vcs_conflict_marker(s) S_vcs_conflict_marker(aTHX_ s)
4873 S_vcs_conflict_marker(pTHX_ char *s)
4875 lex_token_boundary();
4877 yyerror("Version control conflict marker");
4878 while (s < PL_bufend && *s != '\n')
4884 yyl_sigvar(pTHX_ char *s)
4886 /* we expect the sigil and optional var name part of a
4887 * signature element here. Since a '$' is not necessarily
4888 * followed by a var name, handle it specially here; the general
4889 * yylex code would otherwise try to interpret whatever follows
4890 * as a var; e.g. ($, ...) would be seen as the var '$,'
4897 PL_bufptr = s; /* for error reporting */
4902 /* spot stuff that looks like an prototype */
4903 if (memCHRs("$:@%&*;\\[]", *s)) {
4904 yyerror("Illegal character following sigil in a subroutine signature");
4907 /* '$#' is banned, while '$ # comment' isn't */
4909 yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
4913 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
4914 char *dest = PL_tokenbuf + 1;
4915 /* read var name, including sigil, into PL_tokenbuf */
4916 PL_tokenbuf[0] = sigil;
4917 parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
4918 0, cBOOL(UTF), FALSE, FALSE);
4920 assert(PL_tokenbuf[1]); /* we have a variable name */
4928 /* parse the = for the default ourselves to avoid '+=' etc being accepted here
4929 * as the ASSIGNOP, and exclude other tokens that start with =
4931 if (*s == '=' && (!s[1] || memCHRs("=~>", s[1]) == 0)) {
4932 /* save now to report with the same context as we did when
4933 * all ASSIGNOPS were accepted */
4937 NEXTVAL_NEXTTOKE.ival = 0;
4938 force_next(ASSIGNOP);
4941 else if (*s == ',' || *s == ')') {
4942 PL_expect = XOPERATOR;
4945 /* make sure the context shows the unexpected character and
4946 * hopefully a bit more */
4948 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
4950 PL_bufptr = s; /* for error reporting */
4951 yyerror("Illegal operator following parameter in a subroutine signature");
4955 NEXTVAL_NEXTTOKE.ival = sigil;
4956 force_next('p'); /* force a signature pending identifier */
4963 case ',': /* handle ($a,,$b) */
4968 yyerror("A signature parameter must start with '$', '@' or '%'");
4969 /* very crude error recovery: skip to likely next signature
4971 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
4980 yyl_dollar(pTHX_ char *s)
4984 if (PL_expect == XPOSTDEREF) {
4987 POSTDEREF(DOLSHARP);
4993 && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
4994 || memCHRs("{$:+-@", s[2])))
4996 PL_tokenbuf[0] = '@';
4997 s = scan_ident(s + 1, PL_tokenbuf + 1,
4998 sizeof PL_tokenbuf - 1, FALSE);
4999 if (PL_expect == XOPERATOR) {
5001 if (PL_bufptr > s) {
5003 PL_bufptr = PL_oldbufptr;
5005 no_op("Array length", d);
5007 if (!PL_tokenbuf[1])
5009 PL_expect = XOPERATOR;
5010 force_ident_maybe_lex('#');
5014 PL_tokenbuf[0] = '$';
5015 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5016 if (PL_expect == XOPERATOR) {
5018 if (PL_bufptr > s) {
5020 PL_bufptr = PL_oldbufptr;
5024 if (!PL_tokenbuf[1]) {
5026 yyerror("Final $ should be \\$ or $name");
5031 const char tmp = *s;
5032 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
5035 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5036 && intuit_more(s, PL_bufend)) {
5038 PL_tokenbuf[0] = '@';
5039 if (ckWARN(WARN_SYNTAX)) {
5042 while ( t < PL_bufend ) {
5044 do { t += UTF ? UTF8SKIP(t) : 1; } while (t < PL_bufend && isSPACE(*t));
5045 /* consumed one or more space chars */
5046 } else if (*t == '$' || *t == '@') {
5047 /* could be more than one '$' like $$ref or @$ref */
5048 do { t++; } while (t < PL_bufend && *t == '$');
5050 /* could be an abigail style identifier like $ foo */
5051 while (t < PL_bufend && *t == ' ') t++;
5053 /* strip off the name of the var */
5054 while (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
5055 t += UTF ? UTF8SKIP(t) : 1;
5056 /* consumed a varname */
5057 } else if (isDIGIT(*t)) {
5058 /* deal with hex constants like 0x11 */
5059 if (t[0] == '0' && t[1] == 'x') {
5061 while (t < PL_bufend && isXDIGIT(*t)) t++;
5063 /* deal with decimal/octal constants like 1 and 0123 */
5064 do { t++; } while (isDIGIT(*t));
5065 if (t<PL_bufend && *t == '.') {
5066 do { t++; } while (isDIGIT(*t));
5069 /* consumed a number */
5071 /* not a var nor a space nor a number */
5075 if (t < PL_bufend && *t++ == ',') {
5076 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
5077 while (t < PL_bufend && *t != ']')
5079 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5080 "Multidimensional syntax %" UTF8f " not supported",
5081 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
5085 else if (*s == '{') {
5087 PL_tokenbuf[0] = '%';
5088 if ( strEQ(PL_tokenbuf+1, "SIG")
5089 && ckWARN(WARN_SYNTAX)
5090 && (t = (char *) memchr(s, '}', PL_bufend - s))
5091 && (t = (char *) memchr(t, '=', PL_bufend - t)))
5093 char tmpbuf[sizeof PL_tokenbuf];
5096 } while (isSPACE(*t));
5097 if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
5099 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
5104 && get_cvn_flags(tmpbuf, len, UTF
5108 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5109 "You need to quote \"%" UTF8f "\"",
5110 UTF8fARG(UTF, len, tmpbuf));
5117 PL_expect = XOPERATOR;
5118 if ((PL_lex_state == LEX_NORMAL || PL_lex_brackets) && isSPACE((char)tmp)) {
5119 const bool islop = (PL_last_lop == PL_oldoldbufptr);
5120 if (!islop || PL_last_lop_op == OP_GREPSTART)
5121 PL_expect = XOPERATOR;
5122 else if (memCHRs("$@\"'`q", *s))
5123 PL_expect = XTERM; /* e.g. print $fh "foo" */
5124 else if ( memCHRs("&*<%", *s)
5125 && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
5127 PL_expect = XTERM; /* e.g. print $fh &sub */
5129 else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5130 char tmpbuf[sizeof PL_tokenbuf];
5133 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5134 if ((t2 = keyword(tmpbuf, len, 0))) {
5135 /* binary operators exclude handle interpretations */
5147 PL_expect = XTERM; /* e.g. print $fh length() */
5152 PL_expect = XTERM; /* e.g. print $fh subr() */
5155 else if (isDIGIT(*s))
5156 PL_expect = XTERM; /* e.g. print $fh 3 */
5157 else if (*s == '.' && isDIGIT(s[1]))
5158 PL_expect = XTERM; /* e.g. print $fh .3 */
5159 else if ((*s == '?' || *s == '-' || *s == '+')
5160 && !isSPACE(s[1]) && s[1] != '=')
5161 PL_expect = XTERM; /* e.g. print $fh -1 */
5162 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
5164 PL_expect = XTERM; /* e.g. print $fh /.../
5165 XXX except DORDOR operator
5167 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
5169 PL_expect = XTERM; /* print $fh <<"EOF" */
5172 force_ident_maybe_lex('$');
5177 yyl_sub(pTHX_ char *s, const int key)
5179 char * const tmpbuf = PL_tokenbuf + 1;
5180 bool have_name, have_proto;
5182 SV *format_name = NULL;
5183 bool is_sigsub = FEATURE_SIGNATURES_IS_ENABLED;
5185 SSize_t off = s-SvPVX(PL_linestr);
5188 s = skipspace(s); /* can move PL_linestr */
5190 d = SvPVX(PL_linestr)+off;
5192 SAVEBOOL(PL_parser->sig_seen);
5193 PL_parser->sig_seen = FALSE;
5195 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
5197 || (*s == ':' && s[1] == ':'))
5200 PL_expect = XATTRBLOCK;
5201 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
5203 if (key == KEY_format)
5204 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
5206 if (memchr(tmpbuf, ':', len) || key != KEY_sub
5208 PL_tokenbuf, len + 1, 0
5210 sv_setpvn(PL_subname, tmpbuf, len);
5212 sv_setsv(PL_subname,PL_curstname);
5213 sv_catpvs(PL_subname,"::");
5214 sv_catpvn(PL_subname,tmpbuf,len);
5216 if (SvUTF8(PL_linestr))
5217 SvUTF8_on(PL_subname);
5223 if (key == KEY_my || key == KEY_our || key==KEY_state) {
5225 /* diag_listed_as: Missing name in "%s sub" */
5227 "Missing name in \"%s\"", PL_bufptr);
5229 PL_expect = XATTRTERM;
5230 sv_setpvs(PL_subname,"?");
5234 if (key == KEY_format) {
5236 NEXTVAL_NEXTTOKE.opval
5237 = newSVOP(OP_CONST,0, format_name);
5238 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
5239 force_next(BAREWORD);
5244 /* Look for a prototype */
5245 if (*s == '(' && !is_sigsub) {
5246 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
5248 Perl_croak(aTHX_ "Prototype not terminated");
5249 COPLINE_SET_FROM_MULTI_END;
5250 (void)validate_proto(PL_subname, PL_lex_stuff,
5251 ckWARN(WARN_ILLEGALPROTO), 0);
5259 if ( !(*s == ':' && s[1] != ':')
5260 && (*s != '{' && *s != '(') && key != KEY_format)
5262 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
5263 key == KEY_DESTROY || key == KEY_BEGIN ||
5264 key == KEY_UNITCHECK || key == KEY_CHECK ||
5265 key == KEY_INIT || key == KEY_END ||
5266 key == KEY_my || key == KEY_state ||
5269 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5270 else if (*s != ';' && *s != '}')
5271 Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
5275 NEXTVAL_NEXTTOKE.opval =
5276 newSVOP(OP_CONST, 0, PL_lex_stuff);
5277 PL_lex_stuff = NULL;
5282 sv_setpvs(PL_subname, "__ANON__");
5284 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5290 force_ident_maybe_lex('&');
5298 yyl_interpcasemod(pTHX_ char *s)
5301 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
5303 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
5304 PL_bufptr, PL_bufend, *PL_bufptr);
5307 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
5309 if (PL_lex_casemods) {
5310 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
5311 PL_lex_casestack[PL_lex_casemods] = '\0';
5313 if (PL_bufptr != PL_bufend
5314 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
5315 || oldmod == 'F')) {
5317 PL_lex_state = LEX_INTERPCONCAT;
5319 PL_lex_allbrackets--;
5322 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
5323 /* Got an unpaired \E */
5324 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
5325 "Useless use of \\E");
5327 if (PL_bufptr != PL_bufend)
5329 PL_lex_state = LEX_INTERPCONCAT;
5334 PerlIO_printf(Perl_debug_log, "### Saw case modifier\n");
5337 if (s[1] == '\\' && s[2] == 'E') {
5339 PL_lex_state = LEX_INTERPCONCAT;
5344 if ( memBEGINs(s, (STRLEN) (PL_bufend - s), "L\\u")
5345 || memBEGINs(s, (STRLEN) (PL_bufend - s), "U\\l"))
5347 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
5349 if ((*s == 'L' || *s == 'U' || *s == 'F')
5350 && (strpbrk(PL_lex_casestack, "LUF")))
5352 PL_lex_casestack[--PL_lex_casemods] = '\0';
5353 PL_lex_allbrackets--;
5356 if (PL_lex_casemods > 10)
5357 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
5358 PL_lex_casestack[PL_lex_casemods++] = *s;
5359 PL_lex_casestack[PL_lex_casemods] = '\0';
5360 PL_lex_state = LEX_INTERPCONCAT;
5361 NEXTVAL_NEXTTOKE.ival = 0;
5362 force_next((2<<24)|'(');
5364 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
5366 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
5368 NEXTVAL_NEXTTOKE.ival = OP_LC;
5370 NEXTVAL_NEXTTOKE.ival = OP_UC;
5372 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
5374 NEXTVAL_NEXTTOKE.ival = OP_FC;
5376 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
5380 if (PL_lex_starts) {
5383 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5384 if (PL_lex_casemods == 1 && PL_lex_inpat)
5387 AopNOASSIGN(OP_CONCAT);
5395 yyl_secondclass_keyword(pTHX_ char *s, STRLEN len, int key, I32 *orig_keyword,
5396 GV **pgv, GV ***pgvp)
5398 GV *ogv = NULL; /* override (winner) */
5399 GV *hgv = NULL; /* hidden (loser) */
5402 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5404 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5405 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
5407 && (cv = GvCVu(gv)))
5409 if (GvIMPORTED_CV(gv))
5411 else if (! CvMETHOD(cv))
5415 && (*pgvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf, len, FALSE))
5417 && (isGV_with_GP(gv)
5418 ? GvCVu(gv) && GvIMPORTED_CV(gv)
5419 : SvPCS_IMPORTED(gv)
5420 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
5430 *orig_keyword = key;
5431 return 0; /* overridden by import or by GLOBAL */
5433 else if (gv && !*pgvp
5434 && -key==KEY_lock /* XXX generalizable kludge */
5437 return 0; /* any sub overrides "weak" keyword */
5439 else { /* no override */
5441 if (key == KEY_dump) {
5442 Perl_croak(aTHX_ "dump() must be written as CORE::dump() as of Perl 5.30");
5446 if (hgv && key != KEY_x) /* never ambiguous */
5447 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5448 "Ambiguous call resolved as CORE::%s(), "
5449 "qualify as such or use &",
5456 yyl_qw(pTHX_ char *s, STRLEN len)
5460 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
5462 missingterm(NULL, 0);
5464 COPLINE_SET_FROM_MULTI_END;
5465 PL_expect = XOPERATOR;
5466 if (SvCUR(PL_lex_stuff)) {
5467 int warned_comma = !ckWARN(WARN_QW);
5468 int warned_comment = warned_comma;
5469 char *d = SvPV_force(PL_lex_stuff, len);
5471 for (; isSPACE(*d) && len; --len, ++d)
5476 if (!warned_comma || !warned_comment) {
5477 for (; !isSPACE(*d) && len; --len, ++d) {
5478 if (!warned_comma && *d == ',') {
5479 Perl_warner(aTHX_ packWARN(WARN_QW),
5480 "Possible attempt to separate words with commas");
5483 else if (!warned_comment && *d == '#') {
5484 Perl_warner(aTHX_ packWARN(WARN_QW),
5485 "Possible attempt to put comments in qw() list");
5491 for (; !isSPACE(*d) && len; --len, ++d)
5494 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
5495 words = op_append_elem(OP_LIST, words,
5496 newSVOP(OP_CONST, 0, tokeq(sv)));
5501 words = newNULLLIST();
5502 SvREFCNT_dec_NN(PL_lex_stuff);
5503 PL_lex_stuff = NULL;
5504 PL_expect = XOPERATOR;
5505 pl_yylval.opval = sawparens(words);
5510 yyl_hyphen(pTHX_ char *s)
5512 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5520 while (s < PL_bufend && SPACE_OR_TAB(*s))
5523 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) {
5524 s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
5525 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5526 OPERATOR('-'); /* unary minus */
5529 case 'r': ftst = OP_FTEREAD; break;
5530 case 'w': ftst = OP_FTEWRITE; break;
5531 case 'x': ftst = OP_FTEEXEC; break;
5532 case 'o': ftst = OP_FTEOWNED; break;
5533 case 'R': ftst = OP_FTRREAD; break;
5534 case 'W': ftst = OP_FTRWRITE; break;
5535 case 'X': ftst = OP_FTREXEC; break;
5536 case 'O': ftst = OP_FTROWNED; break;
5537 case 'e': ftst = OP_FTIS; break;
5538 case 'z': ftst = OP_FTZERO; break;
5539 case 's': ftst = OP_FTSIZE; break;
5540 case 'f': ftst = OP_FTFILE; break;
5541 case 'd': ftst = OP_FTDIR; break;
5542 case 'l': ftst = OP_FTLINK; break;
5543 case 'p': ftst = OP_FTPIPE; break;
5544 case 'S': ftst = OP_FTSOCK; break;
5545 case 'u': ftst = OP_FTSUID; break;
5546 case 'g': ftst = OP_FTSGID; break;
5547 case 'k': ftst = OP_FTSVTX; break;
5548 case 'b': ftst = OP_FTBLK; break;
5549 case 'c': ftst = OP_FTCHR; break;
5550 case 't': ftst = OP_FTTTY; break;
5551 case 'T': ftst = OP_FTTEXT; break;
5552 case 'B': ftst = OP_FTBINARY; break;
5553 case 'M': case 'A': case 'C':
5554 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5556 case 'M': ftst = OP_FTMTIME; break;
5557 case 'A': ftst = OP_FTATIME; break;
5558 case 'C': ftst = OP_FTCTIME; break;
5566 PL_last_uni = PL_oldbufptr;
5567 PL_last_lop_op = (OPCODE)ftst;
5569 PerlIO_printf(Perl_debug_log, "### Saw file test %c\n", (int)tmp);
5574 /* Assume it was a minus followed by a one-letter named
5575 * subroutine call (or a -bareword), then. */
5577 PerlIO_printf(Perl_debug_log,
5578 "### '-%c' looked like a file test but was not\n",
5585 const char tmp = *s++;
5588 if (PL_expect == XOPERATOR)
5593 else if (*s == '>') {
5596 if (((*s == '$' || *s == '&') && s[1] == '*')
5597 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5598 ||((*s == '@' || *s == '%') && memCHRs("*[{", s[1]))
5599 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5602 PL_expect = XPOSTDEREF;
5605 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5606 s = force_word(s,METHOD,FALSE,TRUE);
5614 if (PL_expect == XOPERATOR) {
5616 && !PL_lex_allbrackets
5617 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5625 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5627 OPERATOR('-'); /* unary minus */
5633 yyl_plus(pTHX_ char *s)
5635 const char tmp = *s++;
5638 if (PL_expect == XOPERATOR)
5643 if (PL_expect == XOPERATOR) {
5645 && !PL_lex_allbrackets
5646 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5654 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5661 yyl_star(pTHX_ char *s)
5663 if (PL_expect == XPOSTDEREF)
5666 if (PL_expect != XOPERATOR) {
5667 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5668 PL_expect = XOPERATOR;
5669 force_ident(PL_tokenbuf, '*');
5678 if (*s == '=' && !PL_lex_allbrackets
5679 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5688 && !PL_lex_allbrackets
5689 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5699 yyl_percent(pTHX_ char *s)
5701 if (PL_expect == XOPERATOR) {
5703 && !PL_lex_allbrackets
5704 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5711 else if (PL_expect == XPOSTDEREF)
5714 PL_tokenbuf[0] = '%';
5715 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5717 if (!PL_tokenbuf[1]) {
5720 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5721 && intuit_more(s, PL_bufend)) {
5723 PL_tokenbuf[0] = '@';
5725 PL_expect = XOPERATOR;
5726 force_ident_maybe_lex('%');
5731 yyl_caret(pTHX_ char *s)
5734 const bool bof = cBOOL(FEATURE_BITWISE_IS_ENABLED);
5735 if (bof && s[1] == '.')
5737 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5738 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5744 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5748 yyl_colon(pTHX_ char *s)
5752 switch (PL_expect) {
5754 if (!PL_in_my || (PL_lex_state != LEX_NORMAL && !PL_lex_brackets))
5756 PL_bufptr = s; /* update in case we back off */
5759 "Use of := for an empty attribute list is not allowed");
5766 PL_expect = XTERMBLOCK;
5768 /* NB: as well as parsing normal attributes, we also end up
5769 * here if there is something looking like attributes
5770 * following a signature (which is illegal, but used to be
5771 * legal in 5.20..5.26). If the latter, we still parse the
5772 * attributes so that error messages(s) are less confusing,
5773 * but ignore them (parser->sig_seen).
5777 while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5778 bool sig = PL_parser->sig_seen;
5782 char *d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5783 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5784 if (tmp < 0) tmp = -tmp;
5799 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5801 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5806 Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
5808 COPLINE_SET_FROM_MULTI_END;
5811 sv_catsv(sv, PL_lex_stuff);
5812 attrs = op_append_elem(OP_LIST, attrs,
5813 newSVOP(OP_CONST, 0, sv));
5814 SvREFCNT_dec_NN(PL_lex_stuff);
5815 PL_lex_stuff = NULL;
5818 /* NOTE: any CV attrs applied here need to be part of
5819 the CVf_BUILTIN_ATTRS define in cv.h! */
5820 if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
5823 CvLVALUE_on(PL_compcv);
5825 else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
5828 CvMETHOD_on(PL_compcv);
5830 else if (!PL_in_my && memEQs(SvPVX(sv), len, "const")) {
5833 Perl_ck_warner_d(aTHX_
5834 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5835 ":const is experimental"
5837 CvANONCONST_on(PL_compcv);
5838 if (!CvANON(PL_compcv))
5839 yyerror(":const is not permitted on named "
5843 /* After we've set the flags, it could be argued that
5844 we don't need to do the attributes.pm-based setting
5845 process, and shouldn't bother appending recognized
5846 flags. To experiment with that, uncomment the
5847 following "else". (Note that's already been
5848 uncommented. That keeps the above-applied built-in
5849 attributes from being intercepted (and possibly
5850 rejected) by a package's attribute routines, but is
5851 justified by the performance win for the common case
5852 of applying only built-in attributes.) */
5854 attrs = op_append_elem(OP_LIST, attrs,
5855 newSVOP(OP_CONST, 0,
5859 if (*s == ':' && s[1] != ':')
5862 break; /* require real whitespace or :'s */
5863 /* XXX losing whitespace on sequential attributes here */
5868 && !(PL_expect == XOPERATOR
5869 ? (*s == '=' || *s == ')')
5870 : (*s == '{' || *s == '(')))
5872 const char q = ((*s == '\'') ? '"' : '\'');
5873 /* If here for an expression, and parsed no attrs, back off. */
5874 if (PL_expect == XOPERATOR && !attrs) {
5878 /* MUST advance bufptr here to avoid bogus "at end of line"
5879 context messages from yyerror().
5882 yyerror( (const char *)
5884 ? Perl_form(aTHX_ "Invalid separator character "
5885 "%c%c%c in attribute list", q, *s, q)
5886 : "Unterminated attribute list" ) );
5893 if (PL_parser->sig_seen) {
5894 /* see comment about about sig_seen and parser error
5898 Perl_croak(aTHX_ "Subroutine attributes must come "
5899 "before the signature");
5902 NEXTVAL_NEXTTOKE.opval = attrs;
5908 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5913 PL_lex_allbrackets--;
5918 yyl_subproto(pTHX_ char *s, CV *cv)
5920 STRLEN protolen = CvPROTOLEN(cv);
5921 const char *proto = CvPROTO(cv);
5924 proto = S_strip_spaces(aTHX_ proto, &protolen);
5927 if ((optional = *proto == ';')) {
5930 } while (*proto == ';');
5936 *proto == '$' || *proto == '_'
5937 || *proto == '*' || *proto == '+'
5942 *proto == '\\' && proto[1] && proto[2] == '\0'
5945 UNIPROTO(UNIOPSUB,optional);
5948 if (*proto == '\\' && proto[1] == '[') {
5949 const char *p = proto + 2;
5950 while(*p && *p != ']')
5952 if(*p == ']' && !p[1])
5953 UNIPROTO(UNIOPSUB,optional);
5956 if (*proto == '&' && *s == '{') {
5958 sv_setpvs(PL_subname, "__ANON__");
5960 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5961 if (!PL_lex_allbrackets
5962 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
5964 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
5973 yyl_leftcurly(pTHX_ char *s, const U8 formbrack)
5976 if (PL_lex_brackets > 100) {
5977 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5980 switch (PL_expect) {
5983 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5984 PL_lex_allbrackets++;
5985 OPERATOR(HASHBRACK);
5987 while (s < PL_bufend && SPACE_OR_TAB(*s))
5990 PL_tokenbuf[0] = '\0';
5991 if (d < PL_bufend && *d == '-') {
5992 PL_tokenbuf[0] = '-';
5994 while (d < PL_bufend && SPACE_OR_TAB(*d))
5997 if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
5999 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6001 while (d < PL_bufend && SPACE_OR_TAB(*d))
6004 const char minus = (PL_tokenbuf[0] == '-');
6005 s = force_word(s + minus, BAREWORD, FALSE, TRUE);
6013 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6014 PL_lex_allbrackets++;
6019 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6020 PL_lex_allbrackets++;
6024 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6025 PL_lex_allbrackets++;
6030 if (PL_oldoldbufptr == PL_last_lop)
6031 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6033 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6034 PL_lex_allbrackets++;
6037 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6039 /* This hack is to get the ${} in the message. */
6041 yyerror("syntax error");
6044 OPERATOR(HASHBRACK);
6046 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
6047 /* ${...} or @{...} etc., but not print {...}
6048 * Skip the disambiguation and treat this as a block.
6050 goto block_expectation;
6052 /* This hack serves to disambiguate a pair of curlies
6053 * as being a block or an anon hash. Normally, expectation
6054 * determines that, but in cases where we're not in a
6055 * position to expect anything in particular (like inside
6056 * eval"") we have to resolve the ambiguity. This code
6057 * covers the case where the first term in the curlies is a
6058 * quoted string. Most other cases need to be explicitly
6059 * disambiguated by prepending a "+" before the opening
6060 * curly in order to force resolution as an anon hash.
6062 * XXX should probably propagate the outer expectation
6063 * into eval"" to rely less on this hack, but that could
6064 * potentially break current behavior of eval"".
6068 if (*s == '\'' || *s == '"' || *s == '`') {
6069 /* common case: get past first string, handling escapes */
6070 for (t++; t < PL_bufend && *t != *s;)
6075 else if (*s == 'q') {
6078 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6079 && !isWORDCHAR(*t))))
6081 /* skip q//-like construct */
6083 char open, close, term;
6086 while (t < PL_bufend && isSPACE(*t))
6088 /* check for q => */
6089 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6090 OPERATOR(HASHBRACK);
6094 if (term && (tmps = memCHRs("([{< )]}> )]}>",term)))
6098 for (t++; t < PL_bufend; t++) {
6099 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6101 else if (*t == open)
6105 for (t++; t < PL_bufend; t++) {
6106 if (*t == '\\' && t+1 < PL_bufend)
6108 else if (*t == close && --brackets <= 0)
6110 else if (*t == open)
6117 /* skip plain q word */
6118 while ( t < PL_bufend
6119 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6121 t += UTF ? UTF8SKIP(t) : 1;
6124 else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
6125 t += UTF ? UTF8SKIP(t) : 1;
6126 while ( t < PL_bufend
6127 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6129 t += UTF ? UTF8SKIP(t) : 1;
6132 while (t < PL_bufend && isSPACE(*t))
6134 /* if comma follows first term, call it an anon hash */
6135 /* XXX it could be a comma expression with loop modifiers */
6136 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6137 || (*t == '=' && t[1] == '>')))
6138 OPERATOR(HASHBRACK);
6139 if (PL_expect == XREF) {
6141 /* If there is an opening brace or 'sub:', treat it
6142 as a term to make ${{...}}{k} and &{sub:attr...}
6143 dwim. Otherwise, treat it as a statement, so
6144 map {no strict; ...} works.
6151 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
6164 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6171 pl_yylval.ival = CopLINE(PL_curcop);
6172 PL_copline = NOLINE; /* invalidate current command line number */
6173 TOKEN(formbrack ? '=' : '{');
6177 yyl_rightcurly(pTHX_ char *s, const U8 formbrack)
6179 assert(s != PL_bufend);
6182 if (PL_lex_brackets <= 0)
6183 /* diag_listed_as: Unmatched right %s bracket */
6184 yyerror("Unmatched right curly bracket");
6186 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6188 PL_lex_allbrackets--;
6190 if (PL_lex_state == LEX_INTERPNORMAL) {
6191 if (PL_lex_brackets == 0) {
6192 if (PL_expect & XFAKEBRACK) {
6193 PL_expect &= XENUMMASK;
6194 PL_lex_state = LEX_INTERPEND;
6196 return yylex(); /* ignore fake brackets */
6198 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6199 && SvEVALED(PL_lex_repl))
6200 PL_lex_state = LEX_INTERPEND;
6201 else if (*s == '-' && s[1] == '>')
6202 PL_lex_state = LEX_INTERPENDMAYBE;
6203 else if (*s != '[' && *s != '{')
6204 PL_lex_state = LEX_INTERPEND;
6208 if (PL_expect & XFAKEBRACK) {
6209 PL_expect &= XENUMMASK;
6211 return yylex(); /* ignore fake brackets */
6214 force_next(formbrack ? '.' : '}');
6215 if (formbrack) LEAVE_with_name("lex_format");
6216 if (formbrack == 2) { /* means . where arguments were expected */
6225 yyl_ampersand(pTHX_ char *s)
6227 if (PL_expect == XPOSTDEREF)
6232 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6233 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6241 if (PL_expect == XOPERATOR) {
6244 if ( PL_bufptr == PL_linestart
6245 && ckWARN(WARN_SEMICOLON)
6246 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
6248 CopLINE_dec(PL_curcop);
6249 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6250 CopLINE_inc(PL_curcop);
6253 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6255 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6256 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6262 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
6267 PL_tokenbuf[0] = '&';
6268 s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
6269 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6272 force_ident_maybe_lex('&');
6280 yyl_verticalbar(pTHX_ char *s)
6287 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6288 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6297 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6300 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6301 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6306 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6310 yyl_bang(pTHX_ char *s)
6312 const char tmp = *s++;
6314 /* was this !=~ where !~ was meant?
6315 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6317 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6318 const char *t = s+1;
6320 while (t < PL_bufend && isSPACE(*t))
6323 if (*t == '/' || *t == '?'
6324 || ((*t == 'm' || *t == 's' || *t == 'y')
6325 && !isWORDCHAR(t[1]))
6326 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6327 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6328 "!=~ should be !~");
6331 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6347 yyl_snail(pTHX_ char *s)
6349 if (PL_expect == XPOSTDEREF)
6351 PL_tokenbuf[0] = '@';
6352 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6353 if (PL_expect == XOPERATOR) {
6355 if (PL_bufptr > s) {
6357 PL_bufptr = PL_oldbufptr;
6362 if (!PL_tokenbuf[1]) {
6365 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6367 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6368 && intuit_more(s, PL_bufend))
6371 PL_tokenbuf[0] = '%';
6373 /* Warn about @ where they meant $. */
6374 if (*s == '[' || *s == '{') {
6375 if (ckWARN(WARN_SYNTAX)) {
6376 S_check_scalar_slice(aTHX_ s);
6380 PL_expect = XOPERATOR;
6381 force_ident_maybe_lex('@');
6386 yyl_slash(pTHX_ char *s)
6388 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6389 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6390 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6395 else if (PL_expect == XOPERATOR) {
6397 if (*s == '=' && !PL_lex_allbrackets
6398 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6406 /* Disable warning on "study /blah/" */
6407 if ( PL_oldoldbufptr == PL_last_uni
6408 && ( *PL_last_uni != 's' || s - PL_last_uni < 5
6409 || memNE(PL_last_uni, "study", 5)
6410 || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
6413 s = scan_pat(s,OP_MATCH);
6414 TERM(sublex_start());
6419 yyl_leftsquare(pTHX_ char *s)
6423 if (PL_lex_brackets > 100)
6424 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6425 PL_lex_brackstack[PL_lex_brackets++] = 0;
6426 PL_lex_allbrackets++;
6432 yyl_rightsquare(pTHX_ char *s)
6434 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6437 if (PL_lex_brackets <= 0)
6438 /* diag_listed_as: Unmatched right %s bracket */
6439 yyerror("Unmatched right square bracket");
6442 PL_lex_allbrackets--;
6443 if (PL_lex_state == LEX_INTERPNORMAL) {
6444 if (PL_lex_brackets == 0) {
6445 if (*s == '-' && s[1] == '>')
6446 PL_lex_state = LEX_INTERPENDMAYBE;
6447 else if (*s != '[' && *s != '{')
6448 PL_lex_state = LEX_INTERPEND;
6455 yyl_tilde(pTHX_ char *s)
6458 if (s[1] == '~' && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)) {
6459 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6462 Perl_ck_warner_d(aTHX_
6463 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
6464 "Smartmatch is experimental");
6465 NCEop(OP_SMARTMATCH);
6468 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
6470 BCop(OP_SCOMPLEMENT);
6472 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
6476 yyl_leftparen(pTHX_ char *s)
6478 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6479 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6483 PL_lex_allbrackets++;
6488 yyl_rightparen(pTHX_ char *s)
6490 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6493 PL_lex_allbrackets--;
6501 yyl_leftpointy(pTHX_ char *s)
6505 if (PL_expect != XOPERATOR) {
6506 if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
6508 if (s[1] == '<' && s[2] != '>')
6509 s = scan_heredoc(s);
6511 s = scan_inputsymbol(s);
6512 PL_expect = XOPERATOR;
6513 TOKEN(sublex_start());
6520 if (*s == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6524 SHop(OP_LEFT_SHIFT);
6529 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6536 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6544 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6553 yyl_rightpointy(pTHX_ char *s)
6555 const char tmp = *s++;
6558 if (*s == '=' && !PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6562 SHop(OP_RIGHT_SHIFT);
6564 else if (tmp == '=') {
6565 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6573 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6582 yyl_sglquote(pTHX_ char *s)
6584 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6586 missingterm(NULL, 0);
6587 COPLINE_SET_FROM_MULTI_END;
6588 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6589 if (PL_expect == XOPERATOR) {
6592 pl_yylval.ival = OP_CONST;
6593 TERM(sublex_start());
6597 yyl_dblquote(pTHX_ char *s, STRLEN len)
6600 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6603 printbuf("### Saw string before %s\n", s);
6605 PerlIO_printf(Perl_debug_log,
6606 "### Saw unterminated string\n");
6608 if (PL_expect == XOPERATOR) {
6612 missingterm(NULL, 0);
6613 pl_yylval.ival = OP_CONST;
6614 /* FIXME. I think that this can be const if char *d is replaced by
6615 more localised variables. */
6616 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6617 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6618 pl_yylval.ival = OP_STRINGIFY;
6622 if (pl_yylval.ival == OP_CONST)
6623 COPLINE_SET_FROM_MULTI_END;
6624 TERM(sublex_start());
6628 yyl_backtick(pTHX_ char *s)
6630 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6633 printbuf("### Saw backtick string before %s\n", s);
6635 PerlIO_printf(Perl_debug_log,
6636 "### Saw unterminated backtick string\n");
6638 if (PL_expect == XOPERATOR)
6639 no_op("Backticks",s);
6641 missingterm(NULL, 0);
6642 pl_yylval.ival = OP_BACKTICK;
6643 TERM(sublex_start());
6647 yyl_backslash(pTHX_ char *s)
6649 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr && isDIGIT(*s))
6650 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6652 if (PL_expect == XOPERATOR)
6653 no_op("Backslash",s);
6658 yyl_data_handle(pTHX)
6660 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
6663 GV *gv = (GV *)*hv_fetchs(stash, "DATA", 1);
6666 gv_init(gv,stash,"DATA",4,0);
6670 GvIOp(gv) = newIO();
6671 IoIFP(GvIOp(gv)) = PL_rsfp;
6673 /* Mark this internal pseudo-handle as clean */
6674 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6675 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6676 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6678 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6680 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6681 /* if the script was opened in binmode, we need to revert
6682 * it to text mode for compatibility; but only iff it has CRs
6683 * XXX this is a questionable hack at best. */
6684 if (PL_bufend-PL_bufptr > 2
6685 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6688 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6689 loc = PerlIO_tell(PL_rsfp);
6690 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6692 if (PerlLIO_setmode(RSFP_FILENO, O_TEXT) != -1) {
6694 PerlIO_seek(PL_rsfp, loc, 0);
6699 #ifdef PERLIO_LAYERS
6702 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
6709 PERL_STATIC_NO_RET void yyl_croak_unrecognised(pTHX_ char*)
6710 __attribute__noreturn__;
6712 PERL_STATIC_NO_RET void
6713 yyl_croak_unrecognised(pTHX_ char *s)
6715 SV *dsv = newSVpvs_flags("", SVs_TEMP);
6721 STRLEN skiplen = UTF8SKIP(s);
6722 STRLEN stravail = PL_bufend - s;
6723 c = sv_uni_display(dsv, newSVpvn_flags(s,
6724 skiplen > stravail ? stravail : skiplen,
6725 SVs_TEMP | SVf_UTF8),
6726 10, UNI_DISPLAY_ISPRINT);
6729 c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
6732 if (s >= PL_linestart) {
6736 /* somehow (probably due to a parse failure), PL_linestart has advanced
6737 * pass PL_bufptr, get a reasonable beginning of line
6740 while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
6743 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
6744 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
6745 d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
6748 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
6749 UTF8fARG(UTF, (s - d), d),
6754 yyl_require(pTHX_ char *s, I32 orig_keyword)
6758 s = force_version(s, FALSE);
6760 else if (*s != 'v' || !isDIGIT(s[1])
6761 || (s = force_version(s, TRUE), *s == 'v'))
6763 *PL_tokenbuf = '\0';
6764 s = force_word(s,BAREWORD,TRUE,TRUE);
6765 if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
6766 PL_tokenbuf + sizeof(PL_tokenbuf),
6769 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
6770 GV_ADD | (UTF ? SVf_UTF8 : 0));
6773 yyerror("<> at require-statement should be quotes");
6776 if (orig_keyword == KEY_require)
6781 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
6783 PL_last_uni = PL_oldbufptr;
6784 PL_last_lop_op = OP_REQUIRE;
6786 return REPORT( (int)REQUIRE );
6790 yyl_foreach(pTHX_ char *s)
6792 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6794 pl_yylval.ival = CopLINE(PL_curcop);
6796 if (PL_expect == XSTATE && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6798 SSize_t s_off = s - SvPVX(PL_linestr);
6801 if (memBEGINPs(p, (STRLEN) (PL_bufend - p), "my") && isSPACE(p[2])) {
6804 else if (memBEGINPs(p, (STRLEN) (PL_bufend - p), "our") && isSPACE(p[3])) {
6809 /* skip optional package name, as in "for my abc $x (..)" */
6810 if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
6811 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6814 if (*p != '$' && *p != '\\')
6815 Perl_croak(aTHX_ "Missing $ on loop variable");
6817 /* The buffer may have been reallocated, update s */
6818 s = SvPVX(PL_linestr) + s_off;
6824 yyl_do(pTHX_ char *s, I32 orig_keyword)
6833 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6835 if (len && memNEs(PL_tokenbuf+1, len, "CORE")
6836 && !keyword(PL_tokenbuf + 1, len, 0)) {
6837 SSize_t off = s-SvPVX(PL_linestr);
6839 s = SvPVX(PL_linestr)+off;
6841 force_ident_maybe_lex('&');
6846 if (orig_keyword == KEY_do)
6854 yyl_my(pTHX_ char *s, I32 my)
6858 yyerror(Perl_form(aTHX_
6859 "Can't redeclare \"%s\" in \"%s\"",
6860 my == KEY_my ? "my" :
6861 my == KEY_state ? "state" : "our",
6862 PL_in_my == KEY_my ? "my" :
6863 PL_in_my == KEY_state ? "state" : "our"));
6867 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6869 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6870 if (memEQs(PL_tokenbuf, len, "sub"))
6871 return yyl_sub(aTHX_ s, my);
6872 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6873 if (!PL_in_my_stash) {
6877 i = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6878 PERL_MY_SNPRINTF_POST_GUARD(i, sizeof(tmpbuf));
6879 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
6882 else if (*s == '\\') {
6883 if (!FEATURE_MYREF_IS_ENABLED)
6884 Perl_croak(aTHX_ "The experimental declared_refs "
6885 "feature is not enabled");
6886 Perl_ck_warner_d(aTHX_
6887 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
6888 "Declaring references is experimental");
6893 static int yyl_try(pTHX_ char*, STRLEN);
6896 yyl_eol_needs_semicolon(pTHX_ char **ps)
6899 if (PL_lex_state != LEX_NORMAL
6900 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
6902 const bool in_comment = *s == '#';
6904 if (*s == '#' && s == PL_linestart && PL_in_eval
6905 && !PL_rsfp && !PL_parser->filtered) {
6906 /* handle eval qq[#line 1 "foo"\n ...] */
6907 CopLINE_dec(PL_curcop);
6908 incline(s, PL_bufend);
6911 while (d < PL_bufend && *d != '\n')
6916 if (in_comment && d == PL_bufend
6917 && PL_lex_state == LEX_INTERPNORMAL
6918 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6919 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
6921 incline(s, PL_bufend);
6922 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
6923 PL_lex_state = LEX_FORMLINE;
6924 force_next(FORMRBRACK);
6930 while (s < PL_bufend && *s != '\n')
6932 if (s < PL_bufend) {
6935 incline(s, PL_bufend);
6943 yyl_fake_eof(pTHX_ U32 fake_eof, bool bof, char *s, STRLEN len)
6951 bof = cBOOL(PL_rsfp);
6954 PL_bufptr = PL_bufend;
6955 COPLINE_INC_WITH_HERELINES;
6956 if (!lex_next_chunk(fake_eof)) {
6957 CopLINE_dec(PL_curcop);
6959 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
6961 CopLINE_dec(PL_curcop);
6963 /* If it looks like the start of a BOM or raw UTF-16,
6964 * check if it in fact is. */
6967 || *(U8*)s == BOM_UTF8_FIRST_BYTE
6971 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
6972 bof = (offset == (Off_t)SvCUR(PL_linestr));
6973 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
6974 /* offset may include swallowed CR */
6976 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
6979 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6980 s = swallow_bom((U8*)s);
6983 if (PL_parser->in_pod) {
6984 /* Incest with pod. */
6985 if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
6988 SvPVCLEAR(PL_linestr);
6989 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
6990 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6991 PL_last_lop = PL_last_uni = NULL;
6992 PL_parser->in_pod = 0;
6995 if (PL_rsfp || PL_parser->filtered)
6996 incline(s, PL_bufend);
6997 } while (PL_parser->in_pod);
6999 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
7000 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7001 PL_last_lop = PL_last_uni = NULL;
7002 if (CopLINE(PL_curcop) == 1) {
7003 while (s < PL_bufend && isSPACE(*s))
7005 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
7009 if (*s == '#' && *(s+1) == '!')
7011 #ifdef ALTERNATE_SHEBANG
7013 static char const as[] = ALTERNATE_SHEBANG;
7014 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
7015 d = s + (sizeof(as) - 1);
7017 #endif /* ALTERNATE_SHEBANG */
7026 while (*d && !isSPACE(*d))
7030 #ifdef ARG_ZERO_IS_SCRIPT
7031 if (ipathend > ipath) {
7033 * HP-UX (at least) sets argv[0] to the script name,
7034 * which makes $^X incorrect. And Digital UNIX and Linux,
7035 * at least, set argv[0] to the basename of the Perl
7036 * interpreter. So, having found "#!", we'll set it right.
7038 SV* copfilesv = CopFILESV(PL_curcop);
7041 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
7043 assert(SvPOK(x) || SvGMAGICAL(x));
7044 if (sv_eq(x, copfilesv)) {
7045 sv_setpvn(x, ipath, ipathend - ipath);
7051 const char *bstart = SvPV_const(copfilesv, blen);
7052 const char * const lstart = SvPV_const(x, llen);
7054 bstart += blen - llen;
7055 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
7056 sv_setpvn(x, ipath, ipathend - ipath);
7063 /* Anything to do if no copfilesv? */
7065 TAINT_NOT; /* $^X is always tainted, but that's OK */
7067 #endif /* ARG_ZERO_IS_SCRIPT */
7072 d = instr(s,"perl -");
7074 d = instr(s,"perl");
7076 /* avoid getting into infinite loops when shebang
7077 * line contains "Perl" rather than "perl" */
7079 for (d = ipathend-4; d >= ipath; --d) {
7080 if (isALPHA_FOLD_EQ(*d, 'p')
7081 && !ibcmp(d, "perl", 4))
7091 #ifdef ALTERNATE_SHEBANG
7093 * If the ALTERNATE_SHEBANG on this system starts with a
7094 * character that can be part of a Perl expression, then if
7095 * we see it but not "perl", we're probably looking at the
7096 * start of Perl code, not a request to hand off to some
7097 * other interpreter. Similarly, if "perl" is there, but
7098 * not in the first 'word' of the line, we assume the line
7099 * contains the start of the Perl program.
7101 if (d && *s != '#') {
7102 const char *c = ipath;
7103 while (*c && !memCHRs("; \t\r\n\f\v#", *c))
7106 d = NULL; /* "perl" not in first word; ignore */
7108 *s = '#'; /* Don't try to parse shebang line */
7110 #endif /* ALTERNATE_SHEBANG */
7115 && !instr(s,"indir")
7116 && instr(PL_origargv[0],"perl"))
7123 while (s < PL_bufend && isSPACE(*s))
7125 if (s < PL_bufend) {
7126 Newx(newargv,PL_origargc+3,char*);
7128 while (s < PL_bufend && !isSPACE(*s))
7131 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
7134 newargv = PL_origargv;
7137 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
7139 Perl_croak(aTHX_ "Can't exec %s", ipath);
7142 while (*d && !isSPACE(*d))
7144 while (SPACE_OR_TAB(*d))
7148 const bool switches_done = PL_doswitches;
7149 const U32 oldpdb = PL_perldb;
7150 const bool oldn = PL_minus_n;
7151 const bool oldp = PL_minus_p;
7155 bool baduni = FALSE;
7157 const char *d2 = d1 + 1;
7158 if (parse_unicode_opts((const char **)&d2)
7162 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
7163 const char * const m = d1;
7164 while (*d1 && !isSPACE(*d1))
7166 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
7169 d1 = moreswitches(d1);
7171 if (PL_doswitches && !switches_done) {
7172 int argc = PL_origargc;
7173 char **argv = PL_origargv;
7176 } while (argc && argv[0][0] == '-' && argv[0][1]);
7177 init_argv_symbols(argc,argv);
7179 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
7180 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
7181 /* if we have already added "LINE: while (<>) {",
7182 we must not do it again */
7184 SvPVCLEAR(PL_linestr);
7185 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
7186 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7187 PL_last_lop = PL_last_uni = NULL;
7188 PL_preambled = FALSE;
7189 if (PERLDB_LINE_OR_SAVESRC)
7190 (void)gv_fetchfile(PL_origfilename);
7191 return yyl_try(aTHX_ s, len);
7198 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
7199 PL_lex_state = LEX_FORMLINE;
7200 force_next(FORMRBRACK);
7204 return yyl_try(aTHX_ s, len);
7208 yyl_fatcomma(pTHX_ char *s, STRLEN len)
7212 = newSVOP(OP_CONST, 0,
7213 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
7214 pl_yylval.opval->op_private = OPpCONST_BARE;
7219 yyl_safe_bareword(pTHX_ char *s, const char lastchar)
7221 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7222 && PL_parser->saw_infix_sigil)
7224 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7225 "Operator or semicolon missing before %c%" UTF8f,
7227 UTF8fARG(UTF, strlen(PL_tokenbuf),
7229 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7230 "Ambiguous use of %c resolved as operator %c",
7231 lastchar, lastchar);
7237 yyl_constant_op(pTHX_ char *s, SV *sv, CV *cv, OP *rv2cv_op, PADOFFSET off)
7241 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7242 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7243 if (SvTYPE(sv) == SVt_PVAV)
7244 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7247 pl_yylval.opval->op_private = 0;
7248 pl_yylval.opval->op_folded = 1;
7249 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7254 op_free(pl_yylval.opval);
7256 off ? newCVREF(0, rv2cv_op) : rv2cv_op;
7257 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7258 PL_last_lop = PL_oldbufptr;
7259 PL_last_lop_op = OP_ENTERSUB;
7261 /* Is there a prototype? */
7263 int k = yyl_subproto(aTHX_ s, cv);
7268 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7270 force_next(off ? PRIVATEREF : BAREWORD);
7271 if (!PL_lex_allbrackets
7272 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7274 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7280 /* Honour "reserved word" warnings, and enforce strict subs */
7282 yyl_strictwarn_bareword(pTHX_ const char lastchar)
7284 /* after "print" and similar functions (corresponding to
7285 * "F? L" in opcode.pl), whatever wasn't already parsed as
7286 * a filehandle should be subject to "strict subs".
7287 * Likewise for the optional indirect-object argument to system
7288 * or exec, which can't be a bareword */
7289 if ((PL_last_lop_op == OP_PRINT
7290 || PL_last_lop_op == OP_PRTF
7291 || PL_last_lop_op == OP_SAY
7292 || PL_last_lop_op == OP_SYSTEM
7293 || PL_last_lop_op == OP_EXEC)
7294 && (PL_hints & HINT_STRICT_SUBS))
7296 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7299 if (lastchar != '-' && ckWARN(WARN_RESERVED)) {
7300 char *d = PL_tokenbuf;
7303 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0)) {
7304 /* PL_warn_reserved is constant */
7305 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
7306 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7308 GCC_DIAG_RESTORE_STMT;
7314 yyl_just_a_word(pTHX_ char *s, STRLEN len, I32 orig_keyword, struct code c)
7317 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7319 bool no_op_error = FALSE;
7320 /* Use this var to track whether intuit_method has been
7321 called. intuit_method returns 0 or > 255. */
7324 if (PL_expect == XOPERATOR) {
7325 if (PL_bufptr == PL_linestart) {
7326 CopLINE_dec(PL_curcop);
7327 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7328 CopLINE_inc(PL_curcop);
7331 /* We want to call no_op with s pointing after the
7332 bareword, so defer it. But we want it to come
7333 before the Bad name croak. */
7337 /* Get the rest if it looks like a package qualifier */
7339 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7341 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7344 no_op("Bareword",s);
7345 no_op_error = FALSE;
7348 Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
7349 UTF8fARG(UTF, len, PL_tokenbuf),
7350 *s == '\'' ? "'" : "::");
7356 no_op("Bareword",s);
7358 /* See if the name is "Foo::",
7359 in which case Foo is a bareword
7360 (and a package name). */
7362 if (len > 2 && PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') {
7363 if (ckWARN(WARN_BAREWORD)
7364 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7365 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7366 "Bareword \"%" UTF8f
7367 "\" refers to nonexistent package",
7368 UTF8fARG(UTF, len, PL_tokenbuf));
7370 PL_tokenbuf[len] = '\0';
7379 /* if we saw a global override before, get the right name */
7382 c.sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len);
7384 SV *sv = newSVpvs("CORE::GLOBAL::");
7390 /* Presume this is going to be a bareword of some sort. */
7392 pl_yylval.opval = newSVOP(OP_CONST, 0, c.sv);
7393 pl_yylval.opval->op_private = OPpCONST_BARE;
7395 /* And if "Foo::", then that's what it certainly is. */
7397 return yyl_safe_bareword(aTHX_ s, lastchar);
7400 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(c.sv));
7401 const_op->op_private = OPpCONST_BARE;
7402 c.rv2cv_op = newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
7406 : SvROK(c.gv) && SvTYPE(SvRV(c.gv)) == SVt_PVCV
7409 : rv2cv_op_cv(c.rv2cv_op, RV2CVOPCV_RETURN_STUB);
7412 /* See if it's the indirect object for a list operator. */
7415 && PL_oldoldbufptr < PL_bufptr
7416 && (PL_oldoldbufptr == PL_last_lop
7417 || PL_oldoldbufptr == PL_last_uni)
7418 && /* NO SKIPSPACE BEFORE HERE! */
7420 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
7423 bool immediate_paren = *s == '(';
7426 /* (Now we can afford to cross potential line boundary.) */
7429 /* intuit_method() can indirectly call lex_next_chunk(),
7432 s_off = s - SvPVX(PL_linestr);
7433 /* Two barewords in a row may indicate method call. */
7434 if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
7436 && (key = intuit_method(s, c.lex ? NULL : c.sv, c.cv)))
7438 /* the code at method: doesn't use s */
7441 s = SvPVX(PL_linestr) + s_off;
7443 /* If not a declared subroutine, it's an indirect object. */
7444 /* (But it's an indir obj regardless for sort.) */
7445 /* Also, if "_" follows a filetest operator, it's a bareword */
7448 ( !immediate_paren && (PL_last_lop_op == OP_SORT
7450 && (PL_last_lop_op != OP_MAPSTART
7451 && PL_last_lop_op != OP_GREPSTART))))
7452 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7453 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
7457 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7458 yyl_strictwarn_bareword(aTHX_ lastchar);
7459 op_free(c.rv2cv_op);
7460 return yyl_safe_bareword(aTHX_ s, lastchar);
7464 PL_expect = XOPERATOR;
7467 /* Is this a word before a => operator? */
7468 if (*s == '=' && s[1] == '>' && !pkgname) {
7469 op_free(c.rv2cv_op);
7471 if (c.gvp || (c.lex && !c.off)) {
7472 assert (cSVOPx(pl_yylval.opval)->op_sv == c.sv);
7473 /* This is our own scalar, created a few lines
7474 above, so this is safe. */
7475 SvREADONLY_off(c.sv);
7476 sv_setpv(c.sv, PL_tokenbuf);
7477 if (UTF && !IN_BYTES
7478 && is_utf8_string((U8*)PL_tokenbuf, len))
7480 SvREADONLY_on(c.sv);
7485 /* If followed by a paren, it's certainly a subroutine. */
7490 while (SPACE_OR_TAB(*d))
7492 if (*d == ')' && (c.sv = cv_const_sv_or_av(c.cv)))
7493 return yyl_constant_op(aTHX_ d + 1, c.sv, c.cv, c.rv2cv_op, c.off);
7495 NEXTVAL_NEXTTOKE.opval =
7496 c.off ? c.rv2cv_op : pl_yylval.opval;
7498 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7499 else op_free(c.rv2cv_op), force_next(BAREWORD);
7504 /* If followed by var or block, call it a method (unless sub) */
7506 if ((*s == '$' || *s == '{') && !c.cv && FEATURE_INDIRECT_IS_ENABLED) {
7507 op_free(c.rv2cv_op);
7508 PL_last_lop = PL_oldbufptr;
7509 PL_last_lop_op = OP_METHOD;
7510 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7511 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7512 PL_expect = XBLOCKTERM;
7514 return REPORT(METHOD);
7517 /* If followed by a bareword, see if it looks like indir obj. */
7521 && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
7522 && (key = intuit_method(s, c.lex ? NULL : c.sv, c.cv)))
7525 if (c.lex && !c.off) {
7526 assert(cSVOPx(pl_yylval.opval)->op_sv == c.sv);
7527 SvREADONLY_off(c.sv);
7528 sv_setpvn(c.sv, PL_tokenbuf, len);
7529 if (UTF && !IN_BYTES
7530 && is_utf8_string((U8*)PL_tokenbuf, len))
7532 else SvUTF8_off(c.sv);
7534 op_free(c.rv2cv_op);
7535 if (key == METHOD && !PL_lex_allbrackets
7536 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7538 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7543 /* Not a method, so call it a subroutine (if defined) */
7546 /* Check for a constant sub */
7547 c.sv = cv_const_sv_or_av(c.cv);
7548 return yyl_constant_op(aTHX_ s, c.sv, c.cv, c.rv2cv_op, c.off);
7551 /* Call it a bare word */
7553 if (PL_hints & HINT_STRICT_SUBS)
7554 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7556 yyl_strictwarn_bareword(aTHX_ lastchar);
7558 op_free(c.rv2cv_op);
7560 return yyl_safe_bareword(aTHX_ s, lastchar);
7564 yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct code c)
7567 default: /* not a keyword */
7568 return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
7571 FUN0OP( newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0)) );
7575 newSVOP(OP_CONST, 0,
7576 Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
7579 case KEY___PACKAGE__:
7581 newSVOP(OP_CONST, 0, (PL_curstash
7582 ? newSVhek(HvNAME_HEK(PL_curstash))
7588 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D'))
7589 yyl_data_handle(aTHX);
7590 return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s, len);
7593 FUN0OP(CvCLONE(PL_compcv)
7594 ? newOP(OP_RUNCV, 0)
7595 : newPVOP(OP_RUNCV,0,NULL));
7604 if (PL_expect == XSTATE)
7605 return yyl_sub(aTHX_ PL_bufptr, key);
7606 return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
7615 LOP(OP_ACCEPT,XTERM);
7618 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7623 LOP(OP_ATAN2,XTERM);
7629 LOP(OP_BINMODE,XTERM);
7632 LOP(OP_BLESS,XTERM);
7641 /* We have to disambiguate the two senses of
7642 "continue". If the next token is a '{' then
7643 treat it as the start of a continue block;
7644 otherwise treat it as a control operator.
7654 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7664 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7673 if (!PL_cryptseen) {
7674 PL_cryptseen = TRUE;
7678 LOP(OP_CRYPT,XTERM);
7681 LOP(OP_CHMOD,XTERM);
7684 LOP(OP_CHOWN,XTERM);
7687 LOP(OP_CONNECT,XTERM);
7702 return yyl_do(aTHX_ s, orig_keyword);
7705 PL_hints |= HINT_BLOCK_SCOPE;
7715 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7716 STR_WITH_LEN("NDBM_File::"),
7717 STR_WITH_LEN("DB_File::"),
7718 STR_WITH_LEN("GDBM_File::"),
7719 STR_WITH_LEN("SDBM_File::"),
7720 STR_WITH_LEN("ODBM_File::"),
7722 LOP(OP_DBMOPEN,XTERM);
7734 pl_yylval.ival = CopLINE(PL_curcop);
7738 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7750 if (*s == '{') { /* block eval */
7751 PL_expect = XTERMBLOCK;
7752 UNIBRACK(OP_ENTERTRY);
7754 else { /* string eval */
7756 UNIBRACK(OP_ENTEREVAL);
7761 UNIBRACK(-OP_ENTEREVAL);
7775 case KEY_endhostent:
7781 case KEY_endservent:
7784 case KEY_endprotoent:
7795 return yyl_foreach(aTHX_ s);
7798 LOP(OP_FORMLINE,XTERM);
7807 LOP(OP_FCNTL,XTERM);
7813 LOP(OP_FLOCK,XTERM);
7816 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7821 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7826 LOP(OP_GREPSTART, XREF);
7843 case KEY_getpriority:
7844 LOP(OP_GETPRIORITY,XTERM);
7846 case KEY_getprotobyname:
7849 case KEY_getprotobynumber:
7850 LOP(OP_GPBYNUMBER,XTERM);
7852 case KEY_getprotoent:
7864 case KEY_getpeername:
7865 UNI(OP_GETPEERNAME);
7867 case KEY_gethostbyname:
7870 case KEY_gethostbyaddr:
7871 LOP(OP_GHBYADDR,XTERM);
7873 case KEY_gethostent:
7876 case KEY_getnetbyname:
7879 case KEY_getnetbyaddr:
7880 LOP(OP_GNBYADDR,XTERM);
7885 case KEY_getservbyname:
7886 LOP(OP_GSBYNAME,XTERM);
7888 case KEY_getservbyport:
7889 LOP(OP_GSBYPORT,XTERM);
7891 case KEY_getservent:
7894 case KEY_getsockname:
7895 UNI(OP_GETSOCKNAME);
7897 case KEY_getsockopt:
7898 LOP(OP_GSOCKOPT,XTERM);
7913 pl_yylval.ival = CopLINE(PL_curcop);
7914 Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7915 "given is experimental");
7919 LOP( orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB, XTERM );
7925 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7927 pl_yylval.ival = CopLINE(PL_curcop);
7931 LOP(OP_INDEX,XTERM);
7937 LOP(OP_IOCTL,XTERM);
7940 Perl_ck_warner_d(aTHX_
7941 packWARN(WARN_EXPERIMENTAL__ISA), "isa is experimental");
7969 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7974 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7988 LOP(OP_LISTEN,XTERM);
7997 s = scan_pat(s,OP_MATCH);
7998 TERM(sublex_start());
8001 LOP(OP_MAPSTART, XREF);
8004 LOP(OP_MKDIR,XTERM);
8007 LOP(OP_MSGCTL,XTERM);
8010 LOP(OP_MSGGET,XTERM);
8013 LOP(OP_MSGRCV,XTERM);
8016 LOP(OP_MSGSND,XTERM);
8021 return yyl_my(aTHX_ s, key);
8027 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8032 s = tokenize_use(0, s);
8036 if (*s == '(' || (s = skipspace(s), *s == '('))
8039 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8040 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8046 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8048 char *d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8049 for (t=d; isSPACE(*t);)
8051 if ( *t && memCHRs("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8053 && !(t[0] == '=' && t[1] == '>')
8054 && !(t[0] == ':' && t[1] == ':')
8055 && !keyword(s, d-s, 0)
8057 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8058 "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
8059 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8065 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8067 pl_yylval.ival = OP_OR;
8077 LOP(OP_OPEN_DIR,XTERM);
8080 checkcomma(s,PL_tokenbuf,"filehandle");
8084 checkcomma(s,PL_tokenbuf,"filehandle");
8103 s = force_word(s,BAREWORD,FALSE,TRUE);
8105 s = force_strict_version(s);
8109 LOP(OP_PIPE_OP,XTERM);
8112 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8114 missingterm(NULL, 0);
8115 COPLINE_SET_FROM_MULTI_END;
8116 pl_yylval.ival = OP_CONST;
8117 TERM(sublex_start());
8123 return yyl_qw(aTHX_ s, len);
8126 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8128 missingterm(NULL, 0);
8129 pl_yylval.ival = OP_STRINGIFY;
8130 if (SvIVX(PL_lex_stuff) == '\'')
8131 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8132 TERM(sublex_start());
8135 s = scan_pat(s,OP_QR);
8136 TERM(sublex_start());
8139 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8141 missingterm(NULL, 0);
8142 pl_yylval.ival = OP_BACKTICK;
8143 TERM(sublex_start());
8149 return yyl_require(aTHX_ s, orig_keyword);
8158 LOP(OP_RENAME,XTERM);
8167 LOP(OP_RINDEX,XTERM);
8176 UNIDOR(OP_READLINE);
8179 UNIDOR(OP_BACKTICK);
8188 LOP(OP_REVERSE,XTERM);
8191 UNIDOR(OP_READLINK);
8198 if (pl_yylval.opval)
8199 TERM(sublex_start());
8201 TOKEN(1); /* force error */
8204 checkcomma(s,PL_tokenbuf,"filehandle");
8214 LOP(OP_SELECT,XTERM);
8220 LOP(OP_SEMCTL,XTERM);
8223 LOP(OP_SEMGET,XTERM);
8226 LOP(OP_SEMOP,XTERM);
8232 LOP(OP_SETPGRP,XTERM);
8234 case KEY_setpriority:
8235 LOP(OP_SETPRIORITY,XTERM);
8237 case KEY_sethostent:
8243 case KEY_setservent:
8246 case KEY_setprotoent:
8256 LOP(OP_SEEKDIR,XTERM);
8258 case KEY_setsockopt:
8259 LOP(OP_SSOCKOPT,XTERM);
8265 LOP(OP_SHMCTL,XTERM);
8268 LOP(OP_SHMGET,XTERM);
8271 LOP(OP_SHMREAD,XTERM);
8274 LOP(OP_SHMWRITE,XTERM);
8277 LOP(OP_SHUTDOWN,XTERM);
8286 LOP(OP_SOCKET,XTERM);
8288 case KEY_socketpair:
8289 LOP(OP_SOCKPAIR,XTERM);
8292 checkcomma(s,PL_tokenbuf,"subroutine name");
8295 s = force_word(s,BAREWORD,TRUE,TRUE);
8299 LOP(OP_SPLIT,XTERM);
8302 LOP(OP_SPRINTF,XTERM);
8305 LOP(OP_SPLICE,XTERM);
8320 LOP(OP_SUBSTR,XTERM);
8324 return yyl_sub(aTHX_ s, key);
8327 LOP(OP_SYSTEM,XREF);
8330 LOP(OP_SYMLINK,XTERM);
8333 LOP(OP_SYSCALL,XTERM);
8336 LOP(OP_SYSOPEN,XTERM);
8339 LOP(OP_SYSSEEK,XTERM);
8342 LOP(OP_SYSREAD,XTERM);
8345 LOP(OP_SYSWRITE,XTERM);
8350 TERM(sublex_start());
8371 LOP(OP_TRUNCATE,XTERM);
8383 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8385 pl_yylval.ival = CopLINE(PL_curcop);
8389 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8391 pl_yylval.ival = CopLINE(PL_curcop);
8395 LOP(OP_UNLINK,XTERM);
8401 LOP(OP_UNPACK,XTERM);
8404 LOP(OP_UTIME,XTERM);
8410 LOP(OP_UNSHIFT,XTERM);
8413 s = tokenize_use(1, s);
8423 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8425 pl_yylval.ival = CopLINE(PL_curcop);
8426 Perl_ck_warner_d(aTHX_
8427 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8428 "when is experimental");
8432 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8434 pl_yylval.ival = CopLINE(PL_curcop);
8438 PL_hints |= HINT_BLOCK_SCOPE;
8445 LOP(OP_WAITPID,XTERM);
8451 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8452 * we use the same number on EBCDIC */
8453 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8457 if (PL_expect == XOPERATOR) {
8458 if (*s == '=' && !PL_lex_allbrackets
8459 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8466 return yyl_just_a_word(aTHX_ s, len, orig_keyword, c);
8469 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8471 pl_yylval.ival = OP_XOR;
8477 yyl_key_core(pTHX_ char *s, STRLEN len, struct code c)
8480 I32 orig_keyword = 0;
8484 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8485 if ((*s == ':' && s[1] == ':')
8486 || (!(key = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
8488 Copy(PL_bufptr, PL_tokenbuf, olen, char);
8489 return yyl_just_a_word(aTHX_ d, olen, 0, c);
8492 Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
8493 UTF8fARG(UTF, len, PL_tokenbuf));
8496 else if (key == KEY_require || key == KEY_do
8498 /* that's a way to remember we saw "CORE::" */
8501 /* Known to be a reserved word at this point */
8502 return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
8506 yyl_keylookup(pTHX_ char *s, GV *gv)
8512 struct code c = no_code;
8513 I32 orig_keyword = 0;
8519 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
8521 /* Some keywords can be followed by any delimiter, including ':' */
8522 anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
8524 /* x::* is just a word, unless x is "CORE" */
8525 if (!anydelim && *s == ':' && s[1] == ':') {
8526 if (memEQs(PL_tokenbuf, len, "CORE"))
8527 return yyl_key_core(aTHX_ s, len, c);
8528 return yyl_just_a_word(aTHX_ s, len, 0, c);
8532 while (d < PL_bufend && isSPACE(*d))
8533 d++; /* no comments skipped here, or s### is misparsed */
8535 /* Is this a word before a => operator? */
8536 if (*d == '=' && d[1] == '>') {
8537 return yyl_fatcomma(aTHX_ s, len);
8540 /* Check for plugged-in keyword */
8544 char *saved_bufptr = PL_bufptr;
8546 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
8548 if (result == KEYWORD_PLUGIN_DECLINE) {
8549 /* not a plugged-in keyword */
8550 PL_bufptr = saved_bufptr;
8551 } else if (result == KEYWORD_PLUGIN_STMT) {
8552 pl_yylval.opval = o;
8554 if (!PL_nexttoke) PL_expect = XSTATE;
8555 return REPORT(PLUGSTMT);
8556 } else if (result == KEYWORD_PLUGIN_EXPR) {
8557 pl_yylval.opval = o;
8559 if (!PL_nexttoke) PL_expect = XOPERATOR;
8560 return REPORT(PLUGEXPR);
8562 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'", PL_tokenbuf);
8566 /* Is this a label? */
8567 if (!anydelim && PL_expect == XSTATE
8568 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
8571 newSVOP(OP_CONST, 0,
8572 newSVpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0));
8577 /* Check for lexical sub */
8578 if (PL_expect != XOPERATOR) {
8579 char tmpbuf[sizeof PL_tokenbuf + 1];
8581 Copy(PL_tokenbuf, tmpbuf+1, len, char);
8582 c.off = pad_findmy_pvn(tmpbuf, len+1, 0);
8583 if (c.off != NOT_IN_PAD) {
8584 assert(c.off); /* we assume this is boolean-true below */
8585 if (PAD_COMPNAME_FLAGS_isOUR(c.off)) {
8586 HV * const stash = PAD_COMPNAME_OURSTASH(c.off);
8587 HEK * const stashname = HvNAME_HEK(stash);
8588 c.sv = newSVhek(stashname);
8589 sv_catpvs(c.sv, "::");
8590 sv_catpvn_flags(c.sv, PL_tokenbuf, len,
8591 (UTF ? SV_CATUTF8 : SV_CATBYTES));
8592 c.gv = gv_fetchsv(c.sv, GV_NOADD_NOINIT | SvUTF8(c.sv),
8598 return yyl_just_a_word(aTHX_ s, len, 0, c);
8602 c.rv2cv_op = newOP(OP_PADANY, 0);
8603 c.rv2cv_op->op_targ = c.off;
8604 c.cv = find_lexical_cv(c.off);
8607 return yyl_just_a_word(aTHX_ s, len, 0, c);
8612 /* Check for built-in keyword */
8613 key = keyword(PL_tokenbuf, len, 0);
8616 key = yyl_secondclass_keyword(aTHX_ s, len, key, &orig_keyword, &c.gv, &c.gvp);
8618 if (key && key != KEY___DATA__ && key != KEY___END__
8619 && (!anydelim || *s != '#')) {
8620 /* no override, and not s### either; skipspace is safe here
8621 * check for => on following line */
8623 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
8624 STRLEN soff = s - SvPVX(PL_linestr);
8626 arrow = *s == '=' && s[1] == '>';
8627 PL_bufptr = SvPVX(PL_linestr) + bufoff;
8628 s = SvPVX(PL_linestr) + soff;
8630 return yyl_fatcomma(aTHX_ s, len);
8633 return yyl_word_or_keyword(aTHX_ s, len, key, orig_keyword, c);
8637 yyl_try(pTHX_ char *s, STRLEN len)
8645 if (UTF ? isIDFIRST_utf8_safe(s, PL_bufend) : isALNUMC(*s))
8646 return yyl_keylookup(aTHX_ s, gv);
8647 yyl_croak_unrecognised(aTHX_ s);
8651 /* emulate EOF on ^D or ^Z */
8652 return yyl_fake_eof(aTHX_ LEX_FAKE_EOF, FALSE, s, len);
8655 if ((!PL_rsfp || PL_lex_inwhat)
8656 && (!PL_parser->filtered || s+1 < PL_bufend)) {
8660 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
8662 yyerror((const char *)
8664 ? "Format not terminated"
8665 : "Missing right curly or square bracket"));
8668 PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n");
8672 if (s++ < PL_bufend)
8673 goto retry; /* ignore stray nulls */
8676 if (!PL_in_eval && !PL_preambled) {
8677 PL_preambled = TRUE;
8679 /* Generate a string of Perl code to load the debugger.
8680 * If PERL5DB is set, it will return the contents of that,
8681 * otherwise a compile-time require of perl5db.pl. */
8683 const char * const pdb = PerlEnv_getenv("PERL5DB");
8686 sv_setpv(PL_linestr, pdb);
8687 sv_catpvs(PL_linestr,";");
8689 SETERRNO(0,SS_NORMAL);
8690 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
8692 PL_parser->preambling = CopLINE(PL_curcop);
8694 SvPVCLEAR(PL_linestr);
8695 if (PL_preambleav) {
8696 SV **svp = AvARRAY(PL_preambleav);
8697 SV **const end = svp + AvFILLp(PL_preambleav);
8699 sv_catsv(PL_linestr, *svp);
8701 sv_catpvs(PL_linestr, ";");
8703 sv_free(MUTABLE_SV(PL_preambleav));
8704 PL_preambleav = NULL;
8707 sv_catpvs(PL_linestr,
8708 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
8709 if (PL_minus_n || PL_minus_p) {
8710 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
8712 sv_catpvs(PL_linestr,"chomp;");
8715 if ( ( *PL_splitstr == '/'
8716 || *PL_splitstr == '\''
8717 || *PL_splitstr == '"')
8718 && strchr(PL_splitstr + 1, *PL_splitstr))
8720 /* strchr is ok, because -F pattern can't contain
8722 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
8725 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
8726 bytes can be used as quoting characters. :-) */
8727 const char *splits = PL_splitstr;
8728 sv_catpvs(PL_linestr, "our @F=split(q\0");
8731 if (*splits == '\\')
8732 sv_catpvn(PL_linestr, splits, 1);
8733 sv_catpvn(PL_linestr, splits, 1);
8734 } while (*splits++);
8735 /* This loop will embed the trailing NUL of
8736 PL_linestr as the last thing it does before
8738 sv_catpvs(PL_linestr, ");");
8742 sv_catpvs(PL_linestr,"our @F=split(' ');");
8745 sv_catpvs(PL_linestr, "\n");
8746 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
8747 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8748 PL_last_lop = PL_last_uni = NULL;
8749 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
8750 update_debugger_info(PL_linestr, NULL, 0);
8753 return yyl_fake_eof(aTHX_ 0, cBOOL(PL_rsfp), s, len);
8756 #ifdef PERL_STRICT_CR
8757 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
8759 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
8761 case ' ': case '\t': case '\f': case '\v':
8767 const bool needs_semicolon = yyl_eol_needs_semicolon(aTHX_ &s);
8768 if (needs_semicolon)
8775 return yyl_hyphen(aTHX_ s);
8778 return yyl_plus(aTHX_ s);
8781 return yyl_star(aTHX_ s);
8784 return yyl_percent(aTHX_ s);
8787 return yyl_caret(aTHX_ s);
8790 return yyl_leftsquare(aTHX_ s);
8793 return yyl_tilde(aTHX_ s);
8796 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
8802 return yyl_just_a_word(aTHX_ s, 0, 0, no_code);
8803 return yyl_colon(aTHX_ s + 1);
8806 return yyl_leftparen(aTHX_ s + 1);
8809 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8817 return yyl_rightparen(aTHX_ s);
8820 return yyl_rightsquare(aTHX_ s);
8823 return yyl_leftcurly(aTHX_ s + 1, 0);
8826 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
8828 return yyl_rightcurly(aTHX_ s, 0);
8831 return yyl_ampersand(aTHX_ s);
8834 return yyl_verticalbar(aTHX_ s);
8837 if (s[1] == '=' && (s == PL_linestart || s[-1] == '\n')
8838 && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), "====="))
8840 s = vcs_conflict_marker(s + 7);
8846 const char tmp = *s++;
8848 if (!PL_lex_allbrackets
8849 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8857 if (!PL_lex_allbrackets
8858 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
8867 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
8868 && memCHRs("+-*/%.^&|<",tmp))
8869 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8870 "Reversed %c= operator",(int)tmp);
8872 if (PL_expect == XSTATE
8874 && (s == PL_linestart+1 || s[-2] == '\n') )
8876 if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
8877 || PL_lex_state != LEX_NORMAL)
8882 incline(s, PL_bufend);
8883 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
8885 s = (char *) memchr(s,'\n', d - s);
8890 incline(s, PL_bufend);
8898 PL_parser->in_pod = 1;
8902 if (PL_expect == XBLOCK) {
8904 #ifdef PERL_STRICT_CR
8905 while (SPACE_OR_TAB(*t))
8907 while (SPACE_OR_TAB(*t) || *t == '\r')
8910 if (*t == '\n' || *t == '#') {
8911 ENTER_with_name("lex_format");
8912 SAVEI8(PL_parser->form_lex_state);
8913 SAVEI32(PL_lex_formbrack);
8914 PL_parser->form_lex_state = PL_lex_state;
8915 PL_lex_formbrack = PL_lex_brackets + 1;
8916 PL_parser->sub_error_count = PL_error_count;
8917 return yyl_leftcurly(aTHX_ s, 1);
8920 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
8928 return yyl_bang(aTHX_ s + 1);
8931 if (s[1] == '<' && (s == PL_linestart || s[-1] == '\n')
8932 && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), "<<<<<"))
8934 s = vcs_conflict_marker(s + 7);
8937 return yyl_leftpointy(aTHX_ s);
8940 if (s[1] == '>' && (s == PL_linestart || s[-1] == '\n')
8941 && memBEGINs(s + 2, (STRLEN) (PL_bufend - (s + 2)), ">>>>>"))
8943 s = vcs_conflict_marker(s + 7);
8946 return yyl_rightpointy(aTHX_ s + 1);
8949 return yyl_dollar(aTHX_ s);
8952 return yyl_snail(aTHX_ s);
8954 case '/': /* may be division, defined-or, or pattern */
8955 return yyl_slash(aTHX_ s);
8957 case '?': /* conditional */
8959 if (!PL_lex_allbrackets
8960 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
8965 PL_lex_allbrackets++;
8969 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
8970 #ifdef PERL_STRICT_CR
8973 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
8975 && (s == PL_linestart || s[-1] == '\n') )
8978 /* formbrack==2 means dot seen where arguments expected */
8979 return yyl_rightcurly(aTHX_ s, 2);
8981 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
8985 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
8988 if (!PL_lex_allbrackets
8989 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
8997 pl_yylval.ival = OPf_SPECIAL;
9003 if (*s == '=' && !PL_lex_allbrackets
9004 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
9012 case '0': case '1': case '2': case '3': case '4':
9013 case '5': case '6': case '7': case '8': case '9':
9014 s = scan_num(s, &pl_yylval);
9015 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
9016 if (PL_expect == XOPERATOR)
9021 return yyl_sglquote(aTHX_ s);
9024 return yyl_dblquote(aTHX_ s, len);
9027 return yyl_backtick(aTHX_ s);
9030 return yyl_backslash(aTHX_ s + 1);
9033 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
9034 char *start = s + 2;
9035 while (isDIGIT(*start) || *start == '_')
9037 if (*start == '.' && isDIGIT(start[1])) {
9038 s = scan_num(s, &pl_yylval);
9041 else if ((*start == ':' && start[1] == ':')
9042 || (PL_expect == XSTATE && *start == ':'))
9043 return yyl_keylookup(aTHX_ s, gv);
9044 else if (PL_expect == XSTATE) {
9046 while (d < PL_bufend && isSPACE(*d)) d++;
9048 return yyl_keylookup(aTHX_ s, gv);
9050 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
9051 if (!isALPHA(*start) && (PL_expect == XTERM
9052 || PL_expect == XREF || PL_expect == XSTATE
9053 || PL_expect == XTERMORDORDOR)) {
9054 GV *const gv = gv_fetchpvn_flags(s, start - s,
9055 UTF ? SVf_UTF8 : 0, SVt_PVCV);
9057 s = scan_num(s, &pl_yylval);
9062 return yyl_keylookup(aTHX_ s, gv);
9065 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
9069 return yyl_keylookup(aTHX_ s, gv);
9098 return yyl_keylookup(aTHX_ s, gv);
9106 Works out what to call the token just pulled out of the input
9107 stream. The yacc parser takes care of taking the ops we return and
9108 stitching them into a tree.
9111 The type of the next token
9114 Check if we have already built the token; if so, use it.
9115 Switch based on the current state:
9116 - if we have a case modifier in a string, deal with that
9117 - handle other cases of interpolation inside a string
9118 - scan the next line if we are inside a format
9119 In the normal state, switch on the next character:
9121 if alphabetic, go to key lookup
9122 unrecognized character - croak
9123 - 0/4/26: handle end-of-line or EOF
9124 - cases for whitespace
9125 - \n and #: handle comments and line numbers
9126 - various operators, brackets and sigils
9129 - 'v': vstrings (or go to key lookup)
9130 - 'x' repetition operator (or go to key lookup)
9131 - other ASCII alphanumerics (key lookup begins here):
9134 scan built-in keyword (but do nothing with it yet)
9135 check for statement label
9136 check for lexical subs
9137 return yyl_just_a_word if there is one
9138 see whether built-in keyword is overridden
9139 switch on keyword number:
9140 - default: return yyl_just_a_word:
9141 not a built-in keyword; handle bareword lookup
9142 disambiguate between method and sub call
9143 fall back to bareword
9144 - cases for built-in keywords
9148 #define RSFP_FILENO (PL_rsfp)
9150 #define RSFP_FILENO (PerlIO_fileno(PL_rsfp))
9158 char *s = PL_bufptr;
9160 if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
9161 const U8* first_bad_char_loc;
9162 if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
9163 PL_bufend - PL_bufptr,
9164 &first_bad_char_loc)))
9166 _force_out_malformed_utf8_message(first_bad_char_loc,
9169 1 /* 1 means die */ );
9170 NOT_REACHED; /* NOTREACHED */
9172 PL_parser->recheck_utf8_validity = FALSE;
9175 SV* tmp = newSVpvs("");
9176 PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
9177 (IV)CopLINE(PL_curcop),
9178 lex_state_names[PL_lex_state],
9179 exp_name[PL_expect],
9180 pv_display(tmp, s, strlen(s), 0, 60));
9184 /* when we've already built the next token, just pull it out of the queue */
9187 pl_yylval = PL_nextval[PL_nexttoke];
9190 next_type = PL_nexttype[PL_nexttoke];
9191 if (next_type & (7<<24)) {
9192 if (next_type & (1<<24)) {
9193 if (PL_lex_brackets > 100)
9194 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
9195 PL_lex_brackstack[PL_lex_brackets++] =
9196 (char) ((next_type >> 16) & 0xff);
9198 if (next_type & (2<<24))
9199 PL_lex_allbrackets++;
9200 if (next_type & (4<<24))
9201 PL_lex_allbrackets--;
9202 next_type &= 0xffff;
9204 return REPORT(next_type == 'p' ? pending_ident() : next_type);
9208 switch (PL_lex_state) {
9210 case LEX_INTERPNORMAL:
9213 /* interpolated case modifiers like \L \U, including \Q and \E.
9214 when we get here, PL_bufptr is at the \
9216 case LEX_INTERPCASEMOD:
9217 /* handle \E or end of string */
9218 return yyl_interpcasemod(aTHX_ s);
9220 case LEX_INTERPPUSH:
9221 return REPORT(sublex_push());
9223 case LEX_INTERPSTART:
9224 if (PL_bufptr == PL_bufend)
9225 return REPORT(sublex_done());
9227 if(*PL_bufptr != '(')
9228 PerlIO_printf(Perl_debug_log, "### Interpolated variable\n");
9231 /* for /@a/, we leave the joining for the regex engine to do
9232 * (unless we're within \Q etc) */
9233 PL_lex_dojoin = (*PL_bufptr == '@'
9234 && (!PL_lex_inpat || PL_lex_casemods));
9235 PL_lex_state = LEX_INTERPNORMAL;
9236 if (PL_lex_dojoin) {
9237 NEXTVAL_NEXTTOKE.ival = 0;
9239 force_ident("\"", '$');
9240 NEXTVAL_NEXTTOKE.ival = 0;
9242 NEXTVAL_NEXTTOKE.ival = 0;
9243 force_next((2<<24)|'(');
9244 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
9247 /* Convert (?{...}) and friends to 'do {...}' */
9248 if (PL_lex_inpat && *PL_bufptr == '(') {
9249 PL_parser->lex_shared->re_eval_start = PL_bufptr;
9251 if (*PL_bufptr != '{')
9253 PL_expect = XTERMBLOCK;
9257 if (PL_lex_starts++) {
9259 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
9260 if (!PL_lex_casemods && PL_lex_inpat)
9263 AopNOASSIGN(OP_CONCAT);
9267 case LEX_INTERPENDMAYBE:
9268 if (intuit_more(PL_bufptr, PL_bufend)) {
9269 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
9275 if (PL_lex_dojoin) {
9276 const U8 dojoin_was = PL_lex_dojoin;
9277 PL_lex_dojoin = FALSE;
9278 PL_lex_state = LEX_INTERPCONCAT;
9279 PL_lex_allbrackets--;
9280 return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
9282 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
9283 && SvEVALED(PL_lex_repl))
9285 if (PL_bufptr != PL_bufend)
9286 Perl_croak(aTHX_ "Bad evalled substitution pattern");
9289 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
9290 re_eval_str. If the here-doc body’s length equals the previous
9291 value of re_eval_start, re_eval_start will now be null. So
9292 check re_eval_str as well. */
9293 if (PL_parser->lex_shared->re_eval_start
9294 || PL_parser->lex_shared->re_eval_str) {
9296 if (*PL_bufptr != ')')
9297 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
9299 /* having compiled a (?{..}) expression, return the original
9300 * text too, as a const */
9301 if (PL_parser->lex_shared->re_eval_str) {
9302 sv = PL_parser->lex_shared->re_eval_str;
9303 PL_parser->lex_shared->re_eval_str = NULL;
9305 PL_bufptr - PL_parser->lex_shared->re_eval_start);
9306 SvPV_shrink_to_cur(sv);
9308 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
9309 PL_bufptr - PL_parser->lex_shared->re_eval_start);
9310 NEXTVAL_NEXTTOKE.opval =
9311 newSVOP(OP_CONST, 0,
9314 PL_parser->lex_shared->re_eval_start = NULL;
9320 case LEX_INTERPCONCAT:
9322 if (PL_lex_brackets)
9323 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
9324 (long) PL_lex_brackets);
9326 if (PL_bufptr == PL_bufend)
9327 return REPORT(sublex_done());
9329 /* m'foo' still needs to be parsed for possible (?{...}) */
9330 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
9331 SV *sv = newSVsv(PL_linestr);
9333 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
9337 int save_error_count = PL_error_count;
9339 s = scan_const(PL_bufptr);
9341 /* Set flag if this was a pattern and there were errors. op.c will
9342 * refuse to compile a pattern with this flag set. Otherwise, we
9343 * could get segfaults, etc. */
9344 if (PL_lex_inpat && PL_error_count > save_error_count) {
9345 ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
9348 PL_lex_state = LEX_INTERPCASEMOD;
9350 PL_lex_state = LEX_INTERPSTART;
9353 if (s != PL_bufptr) {
9354 NEXTVAL_NEXTTOKE = pl_yylval;
9357 if (PL_lex_starts++) {
9358 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
9359 if (!PL_lex_casemods && PL_lex_inpat)
9362 AopNOASSIGN(OP_CONCAT);
9372 if (PL_parser->sub_error_count != PL_error_count) {
9373 /* There was an error parsing a formline, which tends to
9375 Unlike interpolated sub-parsing, we can't treat any of
9376 these as recoverable, so no need to check sub_no_recover.
9380 assert(PL_lex_formbrack);
9381 s = scan_formline(PL_bufptr);
9382 if (!PL_lex_formbrack)
9383 return yyl_rightcurly(aTHX_ s, 1);
9388 /* We really do *not* want PL_linestr ever becoming a COW. */
9389 assert (!SvIsCOW(PL_linestr));
9391 PL_oldoldbufptr = PL_oldbufptr;
9394 if (PL_in_my == KEY_sigvar) {
9395 PL_parser->saw_infix_sigil = 0;
9396 return yyl_sigvar(aTHX_ s);
9400 /* yyl_try() and its callees might consult PL_parser->saw_infix_sigil.
9401 On its return, we then need to set it to indicate whether the token
9402 we just encountered was an infix operator that (if we hadn't been
9403 expecting an operator) have been a sigil.
9405 bool expected_operator = (PL_expect == XOPERATOR);
9406 int ret = yyl_try(aTHX_ s, 0);
9407 switch (pl_yylval.ival) {
9412 if (expected_operator) {
9413 PL_parser->saw_infix_sigil = 1;
9418 PL_parser->saw_infix_sigil = 0;
9428 Looks up an identifier in the pad or in a package
9430 PL_in_my == KEY_sigvar indicates that this is a subroutine signature variable
9431 rather than a plain pad var.
9434 PRIVATEREF if this is a lexical name.
9435 BAREWORD if this belongs to a package.
9438 if we're in a my declaration
9439 croak if they tried to say my($foo::bar)
9440 build the ops for a my() declaration
9441 if it's an access to a my() variable
9442 build ops for access to a my() variable
9443 if in a dq string, and they've said @foo and we can't find @foo
9445 build ops for a bareword
9449 S_pending_ident(pTHX)
9452 const char pit = (char)pl_yylval.ival;
9453 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
9454 /* All routes through this function want to know if there is a colon. */
9455 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
9457 DEBUG_T({ PerlIO_printf(Perl_debug_log,
9458 "### Pending identifier '%s'\n", PL_tokenbuf); });
9459 assert(tokenbuf_len >= 2);
9461 /* if we're in a my(), we can't allow dynamics here.
9462 $foo'bar has already been turned into $foo::bar, so
9463 just check for colons.
9465 if it's a legal name, the OP is a PADANY.
9468 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
9470 /* diag_listed_as: No package name allowed for variable %s
9472 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
9474 *PL_tokenbuf=='&' ? "subroutine" : "variable",
9475 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
9476 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
9481 /* "my" variable %s can't be in a package */
9482 /* PL_no_myglob is constant */
9483 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
9484 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
9485 PL_in_my == KEY_my ? "my" : "state",
9486 *PL_tokenbuf == '&' ? "subroutine" : "variable",
9488 UTF ? SVf_UTF8 : 0);
9489 GCC_DIAG_RESTORE_STMT;
9492 if (PL_in_my == KEY_sigvar) {
9493 /* A signature 'padop' needs in addition, an op_first to
9494 * point to a child sigdefelem, and an extra field to hold
9495 * the signature index. We can achieve both by using an
9496 * UNOP_AUX and (ab)using the op_aux field to hold the
9497 * index. If we ever need more fields, use a real malloced
9498 * aux strut instead.
9500 o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
9501 INT2PTR(UNOP_AUX_item *,
9502 (PL_parser->sig_elems)));
9503 o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
9504 : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
9508 o = newOP(OP_PADANY, 0);
9509 o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
9510 UTF ? SVf_UTF8 : 0);
9511 if (PL_in_my == KEY_sigvar)
9514 pl_yylval.opval = o;
9520 build the ops for accesses to a my() variable.
9525 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
9527 if (tmp != NOT_IN_PAD) {
9528 /* might be an "our" variable" */
9529 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9530 /* build ops for a bareword */
9531 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9532 HEK * const stashname = HvNAME_HEK(stash);
9533 SV * const sym = newSVhek(stashname);
9534 sv_catpvs(sym, "::");
9535 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9536 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
9537 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9541 ((PL_tokenbuf[0] == '$') ? SVt_PV
9542 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9547 pl_yylval.opval = newOP(OP_PADANY, 0);
9548 pl_yylval.opval->op_targ = tmp;
9554 Whine if they've said @foo or @foo{key} in a doublequoted string,
9555 and @foo (or %foo) isn't a variable we can find in the symbol
9558 if (ckWARN(WARN_AMBIGUOUS)
9560 && PL_lex_state != LEX_NORMAL
9561 && !PL_lex_brackets)
9563 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9564 ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
9566 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9569 /* Downgraded from fatal to warning 20000522 mjd */
9570 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9571 "Possible unintended interpolation of %" UTF8f
9573 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9577 /* build ops for a bareword */
9578 pl_yylval.opval = newSVOP(OP_CONST, 0,
9579 newSVpvn_flags(PL_tokenbuf + 1,
9580 tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9581 UTF ? SVf_UTF8 : 0 ));
9582 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9584 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9585 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
9586 | ( UTF ? SVf_UTF8 : 0 ),
9587 ((PL_tokenbuf[0] == '$') ? SVt_PV
9588 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9594 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9596 PERL_ARGS_ASSERT_CHECKCOMMA;
9598 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9599 if (ckWARN(WARN_SYNTAX)) {
9602 for (w = s+2; *w && level; w++) {
9610 /* the list of chars below is for end of statements or
9611 * block / parens, boolean operators (&&, ||, //) and branch
9612 * constructs (or, and, if, until, unless, while, err, for).
9613 * Not a very solid hack... */
9614 if (!*w || !memCHRs(";&/|})]oaiuwef!=", *w))
9615 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9616 "%s (...) interpreted as function",name);
9619 while (s < PL_bufend && isSPACE(*s))
9623 while (s < PL_bufend && isSPACE(*s))
9625 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
9626 const char * const w = s;
9627 s += UTF ? UTF8SKIP(s) : 1;
9628 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9629 s += UTF ? UTF8SKIP(s) : 1;
9630 while (s < PL_bufend && isSPACE(*s))
9634 if (keyword(w, s - w, 0))
9637 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9638 if (gv && GvCVu(gv))
9643 Copy(w, tmpbuf+1, s - w, char);
9645 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
9646 if (off != NOT_IN_PAD) return;
9648 Perl_croak(aTHX_ "No comma allowed after %s", what);
9653 /* S_new_constant(): do any overload::constant lookup.
9655 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9656 Best used as sv=new_constant(..., sv, ...).
9657 If s, pv are NULL, calls subroutine with one argument,
9658 and <type> is used with error messages only.
9659 <type> is assumed to be well formed UTF-8.
9661 If error_msg is not NULL, *error_msg will be set to any error encountered.
9662 Otherwise yyerror() will be used to output it */
9665 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9666 SV *sv, SV *pv, const char *type, STRLEN typelen,
9667 const char ** error_msg)
9670 HV * table = GvHV(PL_hintgv); /* ^H */
9675 const char *why1 = "", *why2 = "", *why3 = "";
9676 const char * optional_colon = ":"; /* Only some messages have a colon */
9679 PERL_ARGS_ASSERT_NEW_CONSTANT;
9680 /* We assume that this is true: */
9683 sv_2mortal(sv); /* Parent created it permanently */
9686 || ! (PL_hints & HINT_LOCALIZE_HH))
9689 optional_colon = "";
9693 cvp = hv_fetch(table, key, keylen, FALSE);
9694 if (!cvp || !SvOK(*cvp)) {
9697 why3 = "} is not defined";
9703 pv = newSVpvn_flags(s, len, SVs_TEMP);
9705 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9707 typesv = &PL_sv_undef;
9709 PUSHSTACKi(PERLSI_OVERLOAD);
9721 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9725 /* Check the eval first */
9726 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9728 const char * errstr;
9729 sv_catpvs(errsv, "Propagated");
9730 errstr = SvPV_const(errsv, errlen);
9731 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9733 res = SvREFCNT_inc_simple_NN(sv);
9737 SvREFCNT_inc_simple_void_NN(res);
9750 (void)sv_2mortal(sv);
9752 why1 = "Call to &{$^H{";
9754 why3 = "}} did not return a defined value";
9758 msg = Perl_form(aTHX_ "Constant(%.*s)%s %s%s%s",
9759 (int)(type ? typelen : len),
9767 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9769 return SvREFCNT_inc_simple_NN(sv);
9772 PERL_STATIC_INLINE void
9773 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package,
9774 bool is_utf8, bool check_dollar, bool tick_warn)
9777 const char *olds = *s;
9778 PERL_ARGS_ASSERT_PARSE_IDENT;
9780 while (*s < PL_bufend) {
9782 Perl_croak(aTHX_ "%s", ident_too_long);
9783 if (is_utf8 && isIDFIRST_utf8_safe(*s, PL_bufend)) {
9784 /* The UTF-8 case must come first, otherwise things
9785 * like c\N{COMBINING TILDE} would start failing, as the
9786 * isWORDCHAR_A case below would gobble the 'c' up.
9789 char *t = *s + UTF8SKIP(*s);
9790 while (isIDCONT_utf8_safe((const U8*) t, (const U8*) PL_bufend)) {
9793 if (*d + (t - *s) > e)
9794 Perl_croak(aTHX_ "%s", ident_too_long);
9795 Copy(*s, *d, t - *s, char);
9799 else if ( isWORDCHAR_A(**s) ) {
9802 } while (isWORDCHAR_A(**s) && *d < e);
9804 else if ( allow_package
9806 && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8))
9813 else if (allow_package && **s == ':' && (*s)[1] == ':'
9814 /* Disallow things like Foo::$bar. For the curious, this is
9815 * the code path that triggers the "Bad name after" warning
9816 * when looking for barewords.
9818 && !(check_dollar && (*s)[2] == '$')) {
9825 if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL
9826 && !PL_lex_brackets && ckWARN(WARN_SYNTAX))) {
9829 Newx(this_d, *s - olds + saw_tick + 2, char); /* +2 for $# */
9832 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9833 "Old package separator used in string");
9834 if (olds[-1] == '#')
9838 if (*olds == '\'') {
9845 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9846 "\t(Did you mean \"%" UTF8f "\" instead?)\n",
9847 UTF8fARG(is_utf8, d2-this_d, this_d));
9852 /* Returns a NUL terminated string, with the length of the string written to
9856 Perl_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9859 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9860 bool is_utf8 = cBOOL(UTF);
9862 PERL_ARGS_ASSERT_SCAN_WORD;
9864 parse_ident(&s, &d, e, allow_package, is_utf8, TRUE, FALSE);
9870 /* Is the byte 'd' a legal single character identifier name? 'u' is true
9871 * iff Unicode semantics are to be used. The legal ones are any of:
9872 * a) all ASCII characters except:
9873 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
9875 * The final case currently doesn't get this far in the program, so we
9876 * don't test for it. If that were to change, it would be ok to allow it.
9877 * b) When not under Unicode rules, any upper Latin1 character
9878 * c) Otherwise, when unicode rules are used, all XIDS characters.
9880 * Because all ASCII characters have the same representation whether
9881 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
9882 * '{' without knowing if is UTF-8 or not. */
9883 #define VALID_LEN_ONE_IDENT(s, e, is_utf8) \
9884 (isGRAPH_A(*(s)) || ((is_utf8) \
9885 ? isIDFIRST_utf8_safe(s, e) \
9887 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
9890 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
9892 I32 herelines = PL_parser->herelines;
9893 SSize_t bracket = -1;
9896 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9897 bool is_utf8 = cBOOL(UTF);
9898 I32 orig_copline = 0, tmp_copline = 0;
9900 PERL_ARGS_ASSERT_SCAN_IDENT;
9902 if (isSPACE(*s) || !*s)
9904 if (isDIGIT(*s)) { /* handle $0 and $1 $2 and $10 and etc */
9905 bool is_zero= *s == '0' ? TRUE : FALSE;
9906 char *digit_start= d;
9908 while (s < PL_bufend && isDIGIT(*s)) {
9910 Perl_croak(aTHX_ "%s", ident_too_long);
9913 if (is_zero && d - digit_start > 1)
9914 Perl_croak(aTHX_ ident_var_zero_multi_digit);
9916 else { /* See if it is a "normal" identifier */
9917 parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE);
9922 /* Either a digit variable, or parse_ident() found an identifier
9923 (anything valid as a bareword), so job done and return. */
9924 if (PL_lex_state != LEX_NORMAL)
9925 PL_lex_state = LEX_INTERPENDMAYBE;
9929 /* Here, it is not a run-of-the-mill identifier name */
9931 if (*s == '$' && s[1]
9932 && ( isIDFIRST_lazy_if_safe(s+1, PL_bufend, is_utf8)
9933 || isDIGIT_A((U8)s[1])
9936 || memBEGINs(s+1, (STRLEN) (PL_bufend - (s+1)), "::")) )
9938 /* Dereferencing a value in a scalar variable.
9939 The alternatives are different syntaxes for a scalar variable.
9940 Using ' as a leading package separator isn't allowed. :: is. */
9943 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9945 bracket = s - SvPVX(PL_linestr);
9947 orig_copline = CopLINE(PL_curcop);
9948 if (s < PL_bufend && isSPACE(*s)) {
9952 if ((s <= PL_bufend - ((is_utf8)
9955 && VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
9958 const STRLEN skip = UTF8SKIP(s);
9961 for ( i = 0; i < skip; i++ )
9966 /* special case to handle ${10}, ${11} the same way we handle ${1} etc */
9968 bool is_zero= *d == '0' ? TRUE : FALSE;
9969 char *digit_start= d;
9970 while (s < PL_bufend && isDIGIT(*s)) {
9973 Perl_croak(aTHX_ "%s", ident_too_long);
9976 if (is_zero && d - digit_start > 1)
9977 Perl_croak(aTHX_ ident_var_zero_multi_digit);
9982 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9983 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9987 /* Warn about ambiguous code after unary operators if {...} notation isn't
9988 used. There's no difference in ambiguity; it's merely a heuristic
9989 about when not to warn. */
9990 else if (ck_uni && bracket == -1)
9992 if (bracket != -1) {
9995 /* If we were processing {...} notation then... */
9996 if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
9997 || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
10000 /* note we have to check for a normal identifier first,
10001 * as it handles utf8 symbols, and only after that has
10002 * been ruled out can we look at the caret words */
10003 if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
10004 /* if it starts as a valid identifier, assume that it is one.
10005 (the later check for } being at the expected point will trap
10006 cases where this doesn't pan out.) */
10007 d += is_utf8 ? UTF8SKIP(d) : 1;
10008 parse_ident(&s, &d, e, 1, is_utf8, TRUE, TRUE);
10011 else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
10013 while (isWORDCHAR(*s) && d < e) {
10017 Perl_croak(aTHX_ "%s", ident_too_long);
10020 tmp_copline = CopLINE(PL_curcop);
10021 if (s < PL_bufend && isSPACE(*s)) {
10024 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10025 /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
10026 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10027 const char * const brack =
10029 ((*s == '[') ? "[...]" : "{...}");
10030 orig_copline = CopLINE(PL_curcop);
10031 CopLINE_set(PL_curcop, tmp_copline);
10032 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
10033 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10034 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10035 funny, dest, brack, funny, dest, brack);
10036 CopLINE_set(PL_curcop, orig_copline);
10039 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10040 PL_lex_allbrackets++;
10045 if ( !tmp_copline )
10046 tmp_copline = CopLINE(PL_curcop);
10047 if ((skip = s < PL_bufend && isSPACE(*s))) {
10048 /* Avoid incrementing line numbers or resetting PL_linestart,
10049 in case we have to back up. */
10050 STRLEN s_off = s - SvPVX(PL_linestr);
10052 s = SvPVX(PL_linestr) + s_off;
10057 /* Expect to find a closing } after consuming any trailing whitespace.
10060 /* Now increment line numbers if applicable. */
10064 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10065 PL_lex_state = LEX_INTERPEND;
10068 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets) {
10069 if (ckWARN(WARN_AMBIGUOUS)
10070 && (keyword(dest, d - dest, 0)
10071 || get_cvn_flags(dest, d - dest, is_utf8
10075 SV *tmp = newSVpvn_flags( dest, d - dest,
10076 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
10079 orig_copline = CopLINE(PL_curcop);
10080 CopLINE_set(PL_curcop, tmp_copline);
10081 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10082 "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf,
10083 funny, SVfARG(tmp), funny, SVfARG(tmp));
10084 CopLINE_set(PL_curcop, orig_copline);
10089 /* Didn't find the closing } at the point we expected, so restore
10090 state such that the next thing to process is the opening { and */
10091 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
10092 CopLINE_set(PL_curcop, orig_copline);
10093 PL_parser->herelines = herelines;
10095 PL_parser->sub_no_recover = TRUE;
10098 else if ( PL_lex_state == LEX_INTERPNORMAL
10099 && !PL_lex_brackets
10100 && !intuit_more(s, PL_bufend))
10101 PL_lex_state = LEX_INTERPEND;
10106 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
10108 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
10109 * found in the parse starting at 's', based on the subset that are valid
10110 * in this context input to this routine in 'valid_flags'. Advances s.
10111 * Returns TRUE if the input should be treated as a valid flag, so the next
10112 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
10113 * upon first call on the current regex. This routine will set it to any
10114 * charset modifier found. The caller shouldn't change it. This way,
10115 * another charset modifier encountered in the parse can be detected as an
10116 * error, as we have decided to allow only one */
10118 const char c = **s;
10119 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
10121 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
10122 if (isWORDCHAR_lazy_if_safe( *s, PL_bufend, UTF)) {
10123 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
10124 UTF ? SVf_UTF8 : 0);
10126 /* Pretend that it worked, so will continue processing before
10135 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
10136 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
10137 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
10138 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
10139 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
10140 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
10141 case LOCALE_PAT_MOD:
10143 goto multiple_charsets;
10145 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
10148 case UNICODE_PAT_MOD:
10150 goto multiple_charsets;
10152 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
10155 case ASCII_RESTRICT_PAT_MOD:
10157 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
10161 /* Error if previous modifier wasn't an 'a', but if it was, see
10162 * if, and accept, a second occurrence (only) */
10163 if (*charset != 'a'
10164 || get_regex_charset(*pmfl)
10165 != REGEX_ASCII_RESTRICTED_CHARSET)
10167 goto multiple_charsets;
10169 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
10173 case DEPENDS_PAT_MOD:
10175 goto multiple_charsets;
10177 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
10186 if (*charset != c) {
10187 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
10189 else if (c == 'a') {
10190 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
10191 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
10194 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
10197 /* Pretend that it worked, so will continue processing before dieing */
10203 S_scan_pat(pTHX_ char *start, I32 type)
10207 const char * const valid_flags =
10208 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10209 char charset = '\0'; /* character set modifier */
10210 unsigned int x_mod_count = 0;
10212 PERL_ARGS_ASSERT_SCAN_PAT;
10214 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
10216 Perl_croak(aTHX_ "Search pattern not terminated");
10218 pm = (PMOP*)newPMOP(type, 0);
10219 if (PL_multi_open == '?') {
10220 /* This is the only point in the code that sets PMf_ONCE: */
10221 pm->op_pmflags |= PMf_ONCE;
10223 /* Hence it's safe to do this bit of PMOP book-keeping here, which
10224 allows us to restrict the list needed by reset to just the ??
10226 assert(type != OP_TRANS);
10228 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
10231 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
10234 elements = mg->mg_len / sizeof(PMOP**);
10235 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
10236 ((PMOP**)mg->mg_ptr) [elements++] = pm;
10237 mg->mg_len = elements * sizeof(PMOP**);
10238 PmopSTASH_set(pm,PL_curstash);
10242 /* if qr/...(?{..}).../, then need to parse the pattern within a new
10243 * anon CV. False positives like qr/[(?{]/ are harmless */
10245 if (type == OP_QR) {
10247 char *e, *p = SvPV(PL_lex_stuff, len);
10249 for (; p < e; p++) {
10250 if (p[0] == '(' && p[1] == '?'
10251 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
10253 pm->op_pmflags |= PMf_HAS_CV;
10257 pm->op_pmflags |= PMf_IS_QR;
10260 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
10261 &s, &charset, &x_mod_count))
10263 /* issue a warning if /c is specified,but /g is not */
10264 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
10266 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
10267 "Use of /c modifier is meaningless without /g" );
10270 PL_lex_op = (OP*)pm;
10271 pl_yylval.ival = OP_MATCH;
10276 S_scan_subst(pTHX_ char *start)
10282 line_t linediff = 0;
10284 char charset = '\0'; /* character set modifier */
10285 unsigned int x_mod_count = 0;
10288 PERL_ARGS_ASSERT_SCAN_SUBST;
10290 pl_yylval.ival = OP_NULL;
10292 s = scan_str(start, TRUE, FALSE, FALSE, &t);
10295 Perl_croak(aTHX_ "Substitution pattern not terminated");
10299 first_start = PL_multi_start;
10300 first_line = CopLINE(PL_curcop);
10301 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
10303 SvREFCNT_dec_NN(PL_lex_stuff);
10304 PL_lex_stuff = NULL;
10305 Perl_croak(aTHX_ "Substitution replacement not terminated");
10307 PL_multi_start = first_start; /* so whole substitution is taken together */
10309 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10313 if (*s == EXEC_PAT_MOD) {
10317 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
10318 &s, &charset, &x_mod_count))
10324 if ((pm->op_pmflags & PMf_CONTINUE)) {
10325 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10329 SV * const repl = newSVpvs("");
10332 pm->op_pmflags |= PMf_EVAL;
10333 for (; es > 1; es--) {
10334 sv_catpvs(repl, "eval ");
10336 sv_catpvs(repl, "do {");
10337 sv_catsv(repl, PL_parser->lex_sub_repl);
10338 sv_catpvs(repl, "}");
10339 SvREFCNT_dec(PL_parser->lex_sub_repl);
10340 PL_parser->lex_sub_repl = repl;
10344 linediff = CopLINE(PL_curcop) - first_line;
10346 CopLINE_set(PL_curcop, first_line);
10348 if (linediff || es) {
10349 /* the IVX field indicates that the replacement string is a s///e;
10350 * the NVX field indicates how many src code lines the replacement
10352 sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
10353 ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
10354 ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
10358 PL_lex_op = (OP*)pm;
10359 pl_yylval.ival = OP_SUBST;
10364 S_scan_trans(pTHX_ char *start)
10371 bool nondestruct = 0;
10374 PERL_ARGS_ASSERT_SCAN_TRANS;
10376 pl_yylval.ival = OP_NULL;
10378 s = scan_str(start,FALSE,FALSE,FALSE,&t);
10380 Perl_croak(aTHX_ "Transliteration pattern not terminated");
10384 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
10386 SvREFCNT_dec_NN(PL_lex_stuff);
10387 PL_lex_stuff = NULL;
10388 Perl_croak(aTHX_ "Transliteration replacement not terminated");
10391 complement = del = squash = 0;
10395 complement = OPpTRANS_COMPLEMENT;
10398 del = OPpTRANS_DELETE;
10401 squash = OPpTRANS_SQUASH;
10413 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
10414 o->op_private &= ~OPpTRANS_ALL;
10415 o->op_private |= del|squash|complement;
10418 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
10425 Takes a pointer to the first < in <<FOO.
10426 Returns a pointer to the byte following <<FOO.
10428 This function scans a heredoc, which involves different methods
10429 depending on whether we are in a string eval, quoted construct, etc.
10430 This is because PL_linestr could containing a single line of input, or
10431 a whole string being evalled, or the contents of the current quote-
10434 The two basic methods are:
10435 - Steal lines from the input stream
10436 - Scan the heredoc in PL_linestr and remove it therefrom
10438 In a file scope or filtered eval, the first method is used; in a
10439 string eval, the second.
10441 In a quote-like operator, we have to choose between the two,
10442 depending on where we can find a newline. We peek into outer lex-
10443 ing scopes until we find one with a newline in it. If we reach the
10444 outermost lexing scope and it is a file, we use the stream method.
10445 Otherwise it is treated as an eval.
10449 S_scan_heredoc(pTHX_ char *s)
10451 I32 op_type = OP_SCALAR;
10459 I32 indent_len = 0;
10460 bool indented = FALSE;
10461 const bool infile = PL_rsfp || PL_parser->filtered;
10462 const line_t origline = CopLINE(PL_curcop);
10463 LEXSHARED *shared = PL_parser->lex_shared;
10465 PERL_ARGS_ASSERT_SCAN_HEREDOC;
10468 d = PL_tokenbuf + 1;
10469 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
10470 *PL_tokenbuf = '\n';
10473 if (*peek == '~') {
10478 while (SPACE_OR_TAB(*peek))
10481 if (*peek == '`' || *peek == '\'' || *peek =='"') {
10484 s = delimcpy(d, e, s, PL_bufend, term, &len);
10485 if (s == PL_bufend)
10486 Perl_croak(aTHX_ "Unterminated delimiter for here document");
10492 /* <<\FOO is equivalent to <<'FOO' */
10497 if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
10498 Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden");
10502 while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) {
10503 peek += UTF ? UTF8SKIP(peek) : 1;
10506 len = (peek - s >= e - d) ? (e - d) : (peek - s);
10507 Copy(s, d, len, char);
10512 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10513 Perl_croak(aTHX_ "Delimiter for here document is too long");
10517 len = d - PL_tokenbuf;
10519 #ifndef PERL_STRICT_CR
10520 d = (char *) memchr(s, '\r', PL_bufend - s);
10522 char * const olds = s;
10524 while (s < PL_bufend) {
10530 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
10539 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10544 tmpstr = newSV_type(SVt_PVIV);
10545 SvGROW(tmpstr, 80);
10546 if (term == '\'') {
10547 op_type = OP_CONST;
10548 SvIV_set(tmpstr, -1);
10550 else if (term == '`') {
10551 op_type = OP_BACKTICK;
10552 SvIV_set(tmpstr, '\\');
10555 PL_multi_start = origline + 1 + PL_parser->herelines;
10556 PL_multi_open = PL_multi_close = '<';
10558 /* inside a string eval or quote-like operator */
10559 if (!infile || PL_lex_inwhat) {
10562 char * const olds = s;
10563 PERL_CONTEXT * const cx = CX_CUR();
10564 /* These two fields are not set until an inner lexing scope is
10565 entered. But we need them set here. */
10566 shared->ls_bufptr = s;
10567 shared->ls_linestr = PL_linestr;
10569 if (PL_lex_inwhat) {
10570 /* Look for a newline. If the current buffer does not have one,
10571 peek into the line buffer of the parent lexing scope, going
10572 up as many levels as necessary to find one with a newline
10575 while (!(s = (char *)memchr(
10576 (void *)shared->ls_bufptr, '\n',
10577 SvEND(shared->ls_linestr)-shared->ls_bufptr
10580 shared = shared->ls_prev;
10581 /* shared is only null if we have gone beyond the outermost
10582 lexing scope. In a file, we will have broken out of the
10583 loop in the previous iteration. In an eval, the string buf-
10584 fer ends with "\n;", so the while condition above will have
10585 evaluated to false. So shared can never be null. Or so you
10586 might think. Odd syntax errors like s;@{<<; can gobble up
10587 the implicit semicolon at the end of a flie, causing the
10588 file handle to be closed even when we are not in a string
10589 eval. So shared may be null in that case.
10590 (Closing '>>}' here to balance the earlier open brace for
10591 editors that look for matched pairs.) */
10592 if (UNLIKELY(!shared))
10594 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10595 most lexing scope. In a file, shared->ls_linestr at that
10596 level is just one line, so there is no body to steal. */
10597 if (infile && !shared->ls_prev) {
10603 else { /* eval or we've already hit EOF */
10604 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10609 linestr = shared->ls_linestr;
10610 bufend = SvEND(linestr);
10615 while (s < bufend - len + 1) {
10617 ++PL_parser->herelines;
10619 if (memEQ(s, PL_tokenbuf + 1, len - 1)) {
10623 /* Only valid if it's preceded by whitespace only */
10624 while (backup != myolds && --backup >= myolds) {
10625 if (! SPACE_OR_TAB(*backup)) {
10631 /* No whitespace or all! */
10632 if (backup == s || *backup == '\n') {
10633 Newx(indent, indent_len + 1, char);
10634 memcpy(indent, backup + 1, indent_len);
10635 indent[indent_len] = 0;
10636 s--; /* before our delimiter */
10637 PL_parser->herelines--; /* this line doesn't count */
10644 while (s < bufend - len + 1
10645 && memNE(s,PL_tokenbuf,len) )
10648 ++PL_parser->herelines;
10652 if (s >= bufend - len + 1) {
10656 sv_setpvn(tmpstr,d+1,s-d);
10658 /* the preceding stmt passes a newline */
10659 PL_parser->herelines++;
10661 /* s now points to the newline after the heredoc terminator.
10662 d points to the newline before the body of the heredoc.
10665 /* We are going to modify linestr in place here, so set
10666 aside copies of the string if necessary for re-evals or
10668 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10669 check shared->re_eval_str. */
10670 if (shared->re_eval_start || shared->re_eval_str) {
10671 /* Set aside the rest of the regexp */
10672 if (!shared->re_eval_str)
10673 shared->re_eval_str =
10674 newSVpvn(shared->re_eval_start,
10675 bufend - shared->re_eval_start);
10676 shared->re_eval_start -= s-d;
10679 if (cxstack_ix >= 0
10680 && CxTYPE(cx) == CXt_EVAL
10681 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
10682 && cx->blk_eval.cur_text == linestr)
10684 cx->blk_eval.cur_text = newSVsv(linestr);
10685 cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
10688 /* Copy everything from s onwards back to d. */
10689 Move(s,d,bufend-s + 1,char);
10690 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10691 /* Setting PL_bufend only applies when we have not dug deeper
10692 into other scopes, because sublex_done sets PL_bufend to
10693 SvEND(PL_linestr). */
10694 if (shared == PL_parser->lex_shared)
10695 PL_bufend = SvEND(linestr);
10700 char *oldbufptr_save;
10701 char *oldoldbufptr_save;
10703 SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
10704 term = PL_tokenbuf[1];
10706 linestr_save = PL_linestr; /* must restore this afterwards */
10707 d = s; /* and this */
10708 oldbufptr_save = PL_oldbufptr;
10709 oldoldbufptr_save = PL_oldoldbufptr;
10710 PL_linestr = newSVpvs("");
10711 PL_bufend = SvPVX(PL_linestr);
10714 PL_bufptr = PL_bufend;
10715 CopLINE_set(PL_curcop,
10716 origline + 1 + PL_parser->herelines);
10718 if ( !lex_next_chunk(LEX_NO_TERM)
10719 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n'))
10721 /* Simply freeing linestr_save might seem simpler here, as it
10722 does not matter what PL_linestr points to, since we are
10723 about to croak; but in a quote-like op, linestr_save
10724 will have been prospectively freed already, via
10725 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
10726 restore PL_linestr. */
10727 SvREFCNT_dec_NN(PL_linestr);
10728 PL_linestr = linestr_save;
10729 PL_oldbufptr = oldbufptr_save;
10730 PL_oldoldbufptr = oldoldbufptr_save;
10734 CopLINE_set(PL_curcop, origline);
10736 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10737 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10738 /* ^That should be enough to avoid this needing to grow: */
10739 sv_catpvs(PL_linestr, "\n\0");
10740 assert(s == SvPVX(PL_linestr));
10741 PL_bufend = SvEND(PL_linestr);
10745 PL_parser->herelines++;
10746 PL_last_lop = PL_last_uni = NULL;
10748 #ifndef PERL_STRICT_CR
10749 if (PL_bufend - PL_linestart >= 2) {
10750 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
10751 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10753 PL_bufend[-2] = '\n';
10755 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10757 else if (PL_bufend[-1] == '\r')
10758 PL_bufend[-1] = '\n';
10760 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10761 PL_bufend[-1] = '\n';
10764 if (indented && (PL_bufend-s) >= len) {
10765 char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
10768 char *backup = found;
10771 /* Only valid if it's preceded by whitespace only */
10772 while (backup != s && --backup >= s) {
10773 if (! SPACE_OR_TAB(*backup)) {
10779 /* All whitespace or none! */
10780 if (backup == found || SPACE_OR_TAB(*backup)) {
10781 Newx(indent, indent_len + 1, char);
10782 memcpy(indent, backup, indent_len);
10783 indent[indent_len] = 0;
10784 SvREFCNT_dec(PL_linestr);
10785 PL_linestr = linestr_save;
10786 PL_linestart = SvPVX(linestr_save);
10787 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10788 PL_oldbufptr = oldbufptr_save;
10789 PL_oldoldbufptr = oldoldbufptr_save;
10795 /* Didn't find it */
10796 sv_catsv(tmpstr,PL_linestr);
10799 if (*s == term && PL_bufend-s >= len
10800 && memEQ(s,PL_tokenbuf + 1,len))
10802 SvREFCNT_dec(PL_linestr);
10803 PL_linestr = linestr_save;
10804 PL_linestart = SvPVX(linestr_save);
10805 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10806 PL_oldbufptr = oldbufptr_save;
10807 PL_oldoldbufptr = oldoldbufptr_save;
10812 sv_catsv(tmpstr,PL_linestr);
10818 PL_multi_end = origline + PL_parser->herelines;
10820 if (indented && indent) {
10821 STRLEN linecount = 1;
10822 STRLEN herelen = SvCUR(tmpstr);
10823 char *ss = SvPVX(tmpstr);
10824 char *se = ss + herelen;
10825 SV *newstr = newSV(herelen+1);
10828 /* Trim leading whitespace */
10830 /* newline only? Copy and move on */
10832 sv_catpvs(newstr,"\n");
10836 /* Found our indentation? Strip it */
10838 else if (se - ss >= indent_len
10839 && memEQ(ss, indent, indent_len))
10844 while ((ss + le) < se && *(ss + le) != '\n')
10847 sv_catpvn(newstr, ss, le);
10850 /* Line doesn't begin with our indentation? Croak */
10855 "Indentation on line %d of here-doc doesn't match delimiter",
10861 /* avoid sv_setsv() as we dont wan't to COW here */
10862 sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
10864 SvREFCNT_dec_NN(newstr);
10867 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10868 SvPV_shrink_to_cur(tmpstr);
10872 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10876 PL_lex_stuff = tmpstr;
10877 pl_yylval.ival = op_type;
10883 SvREFCNT_dec(tmpstr);
10884 CopLINE_set(PL_curcop, origline);
10885 missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1);
10889 /* scan_inputsymbol
10890 takes: position of first '<' in input buffer
10891 returns: position of first char following the matching '>' in
10893 side-effects: pl_yylval and lex_op are set.
10898 <<>> read from ARGV without magic open
10899 <FH> read from filehandle
10900 <pkg::FH> read from package qualified filehandle
10901 <pkg'FH> read from package qualified filehandle
10902 <$fh> read from filehandle in $fh
10903 <*.h> filename glob
10908 S_scan_inputsymbol(pTHX_ char *start)
10910 char *s = start; /* current position in buffer */
10913 bool nomagicopen = FALSE;
10914 char *d = PL_tokenbuf; /* start of temp holding space */
10915 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10917 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10919 end = (char *) memchr(s, '\n', PL_bufend - s);
10922 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
10923 nomagicopen = TRUE;
10929 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10931 /* die if we didn't have space for the contents of the <>,
10932 or if it didn't end, or if we see a newline
10935 if (len >= (I32)sizeof PL_tokenbuf)
10936 Perl_croak(aTHX_ "Excessively long <> operator");
10938 Perl_croak(aTHX_ "Unterminated <> operator");
10943 Remember, only scalar variables are interpreted as filehandles by
10944 this code. Anything more complex (e.g., <$fh{$num}>) will be
10945 treated as a glob() call.
10946 This code makes use of the fact that except for the $ at the front,
10947 a scalar variable and a filehandle look the same.
10949 if (*d == '$' && d[1]) d++;
10951 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10952 while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') {
10953 d += UTF ? UTF8SKIP(d) : 1;
10956 /* If we've tried to read what we allow filehandles to look like, and
10957 there's still text left, then it must be a glob() and not a getline.
10958 Use scan_str to pull out the stuff between the <> and treat it
10959 as nothing more than a string.
10962 if (d - PL_tokenbuf != len) {
10963 pl_yylval.ival = OP_GLOB;
10964 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
10966 Perl_croak(aTHX_ "Glob not terminated");
10970 bool readline_overriden = FALSE;
10972 /* we're in a filehandle read situation */
10975 /* turn <> into <ARGV> */
10977 Copy("ARGV",d,5,char);
10979 /* Check whether readline() is overriden */
10980 if ((gv_readline = gv_override("readline",8)))
10981 readline_overriden = TRUE;
10983 /* if <$fh>, create the ops to turn the variable into a
10987 /* try to find it in the pad for this block, otherwise find
10988 add symbol table ops
10990 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
10991 if (tmp != NOT_IN_PAD) {
10992 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10993 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10994 HEK * const stashname = HvNAME_HEK(stash);
10995 SV * const sym = sv_2mortal(newSVhek(stashname));
10996 sv_catpvs(sym, "::");
10997 sv_catpv(sym, d+1);
11002 OP * const o = newOP(OP_PADSV, 0);
11004 PL_lex_op = readline_overriden
11005 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
11006 op_append_elem(OP_LIST, o,
11007 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11008 : newUNOP(OP_READLINE, 0, o);
11016 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
11018 PL_lex_op = readline_overriden
11019 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
11020 op_append_elem(OP_LIST,
11021 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11022 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11023 : newUNOP(OP_READLINE, 0,
11024 newUNOP(OP_RV2SV, 0,
11025 newGVOP(OP_GV, 0, gv)));
11027 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
11028 pl_yylval.ival = OP_NULL;
11031 /* If it's none of the above, it must be a literal filehandle
11032 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11034 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
11035 PL_lex_op = readline_overriden
11036 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
11037 op_append_elem(OP_LIST,
11038 newGVOP(OP_GV, 0, gv),
11039 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11040 : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
11041 pl_yylval.ival = OP_NULL;
11051 start position in buffer
11052 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
11053 only if they are of the open/close form
11054 keep_delims preserve the delimiters around the string
11055 re_reparse compiling a run-time /(?{})/:
11056 collapse // to /, and skip encoding src
11057 delimp if non-null, this is set to the position of
11058 the closing delimiter, or just after it if
11059 the closing and opening delimiters differ
11060 (i.e., the opening delimiter of a substitu-
11062 returns: position to continue reading from buffer
11063 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11064 updates the read buffer.
11066 This subroutine pulls a string out of the input. It is called for:
11067 q single quotes q(literal text)
11068 ' single quotes 'literal text'
11069 qq double quotes qq(interpolate $here please)
11070 " double quotes "interpolate $here please"
11071 qx backticks qx(/bin/ls -l)
11072 ` backticks `/bin/ls -l`
11073 qw quote words @EXPORT_OK = qw( func() $spam )
11074 m// regexp match m/this/
11075 s/// regexp substitute s/this/that/
11076 tr/// string transliterate tr/this/that/
11077 y/// string transliterate y/this/that/
11078 ($*@) sub prototypes sub foo ($)
11079 (stuff) sub attr parameters sub foo : attr(stuff)
11080 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11082 In most of these cases (all but <>, patterns and transliterate)
11083 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11084 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11085 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11088 It skips whitespace before the string starts, and treats the first
11089 character as the delimiter. If the delimiter is one of ([{< then
11090 the corresponding "close" character )]}> is used as the closing
11091 delimiter. It allows quoting of delimiters, and if the string has
11092 balanced delimiters ([{<>}]) it allows nesting.
11094 On success, the SV with the resulting string is put into lex_stuff or,
11095 if that is already non-NULL, into lex_repl. The second case occurs only
11096 when parsing the RHS of the special constructs s/// and tr/// (y///).
11097 For convenience, the terminating delimiter character is stuffed into
11102 Perl_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
11106 SV *sv; /* scalar value: string */
11107 const char *tmps; /* temp string, used for delimiter matching */
11108 char *s = start; /* current position in the buffer */
11109 char term; /* terminating character */
11110 char *to; /* current position in the sv's data */
11111 I32 brackets = 1; /* bracket nesting level */
11112 bool d_is_utf8 = FALSE; /* is there any utf8 content? */
11113 IV termcode; /* terminating char. code */
11114 U8 termstr[UTF8_MAXBYTES+1]; /* terminating string */
11115 STRLEN termlen; /* length of terminating string */
11118 /* The delimiters that have a mirror-image closing one */
11119 const char * opening_delims = "([{<";
11120 const char * closing_delims = ")]}>";
11122 /* The only non-UTF character that isn't a stand alone grapheme is
11123 * white-space, hence can't be a delimiter. */
11124 const char * non_grapheme_msg = "Use of unassigned code point or"
11125 " non-standalone grapheme for a delimiter"
11127 PERL_ARGS_ASSERT_SCAN_STR;
11129 /* skip space before the delimiter */
11134 /* mark where we are, in case we need to report errors */
11137 /* after skipping whitespace, the next character is the terminator */
11139 if (!UTF || UTF8_IS_INVARIANT(term)) {
11140 termcode = termstr[0] = term;
11144 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
11145 if (UTF && UNLIKELY(! is_grapheme((U8 *) start,
11150 yyerror(non_grapheme_msg);
11153 Copy(s, termstr, termlen, U8);
11156 /* mark where we are */
11157 PL_multi_start = CopLINE(PL_curcop);
11158 PL_multi_open = termcode;
11159 herelines = PL_parser->herelines;
11161 /* If the delimiter has a mirror-image closing one, get it */
11162 if (term && (tmps = strchr(opening_delims, term))) {
11163 termcode = termstr[0] = term = closing_delims[tmps - opening_delims];
11166 PL_multi_close = termcode;
11168 if (PL_multi_open == PL_multi_close) {
11169 keep_bracketed_quoted = FALSE;
11172 /* create a new SV to hold the contents. 79 is the SV's initial length.
11173 What a random number. */
11174 sv = newSV_type(SVt_PVIV);
11176 SvIV_set(sv, termcode);
11177 (void)SvPOK_only(sv); /* validate pointer */
11179 /* move past delimiter and try to read a complete string */
11181 sv_catpvn(sv, s, termlen);
11184 /* extend sv if need be */
11185 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11186 /* set 'to' to the next character in the sv's string */
11187 to = SvPVX(sv)+SvCUR(sv);
11189 /* if open delimiter is the close delimiter read unbridle */
11190 if (PL_multi_open == PL_multi_close) {
11191 for (; s < PL_bufend; s++,to++) {
11192 /* embedded newlines increment the current line number */
11193 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
11194 COPLINE_INC_WITH_HERELINES;
11195 /* handle quoted delimiters */
11196 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11197 if (!keep_bracketed_quoted
11199 || (re_reparse && s[1] == '\\'))
11202 else /* any other quotes are simply copied straight through */
11205 /* terminate when run out of buffer (the for() condition), or
11206 have found the terminator */
11207 else if (*s == term) { /* First byte of terminator matches */
11208 if (termlen == 1) /* If is the only byte, are done */
11211 /* If the remainder of the terminator matches, also are
11212 * done, after checking that is a separate grapheme */
11213 if ( s + termlen <= PL_bufend
11214 && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
11217 && UNLIKELY(! is_grapheme((U8 *) start,
11222 yyerror(non_grapheme_msg);
11227 else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
11235 /* if the terminator isn't the same as the start character (e.g.,
11236 matched brackets), we have to allow more in the quoting, and
11237 be prepared for nested brackets.
11240 /* read until we run out of string, or we find the terminator */
11241 for (; s < PL_bufend; s++,to++) {
11242 /* embedded newlines increment the line count */
11243 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
11244 COPLINE_INC_WITH_HERELINES;
11245 /* backslashes can escape the open or closing characters */
11246 if (*s == '\\' && s+1 < PL_bufend) {
11247 if (!keep_bracketed_quoted
11248 && ( ((UV)s[1] == PL_multi_open)
11249 || ((UV)s[1] == PL_multi_close) ))
11256 /* allow nested opens and closes */
11257 else if ((UV)*s == PL_multi_close && --brackets <= 0)
11259 else if ((UV)*s == PL_multi_open)
11261 else if (!d_is_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11266 /* terminate the copied string and update the sv's end-of-string */
11268 SvCUR_set(sv, to - SvPVX_const(sv));
11271 * this next chunk reads more into the buffer if we're not done yet
11275 break; /* handle case where we are done yet :-) */
11277 #ifndef PERL_STRICT_CR
11278 if (to - SvPVX_const(sv) >= 2) {
11279 if ( (to[-2] == '\r' && to[-1] == '\n')
11280 || (to[-2] == '\n' && to[-1] == '\r'))
11284 SvCUR_set(sv, to - SvPVX_const(sv));
11286 else if (to[-1] == '\r')
11289 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11293 /* if we're out of file, or a read fails, bail and reset the current
11294 line marker so we can report where the unterminated string began
11296 COPLINE_INC_WITH_HERELINES;
11297 PL_bufptr = PL_bufend;
11298 if (!lex_next_chunk(0)) {
11300 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11303 s = start = PL_bufptr;
11306 /* at this point, we have successfully read the delimited string */
11309 sv_catpvn(sv, s, termlen);
11315 PL_multi_end = CopLINE(PL_curcop);
11316 CopLINE_set(PL_curcop, PL_multi_start);
11317 PL_parser->herelines = herelines;
11319 /* if we allocated too much space, give some back */
11320 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11321 SvLEN_set(sv, SvCUR(sv) + 1);
11322 SvPV_renew(sv, SvLEN(sv));
11325 /* decide whether this is the first or second quoted string we've read
11330 PL_parser->lex_sub_repl = sv;
11333 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
11339 takes: pointer to position in buffer
11340 returns: pointer to new position in buffer
11341 side-effects: builds ops for the constant in pl_yylval.op
11343 Read a number in any of the formats that Perl accepts:
11345 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11346 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11347 0b[01](_?[01])* binary integers
11348 0[0-7](_?[0-7])* octal integers
11349 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
11350 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
11352 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11355 If it reads a number without a decimal point or an exponent, it will
11356 try converting the number to an integer and see if it can do so
11357 without loss of precision.
11361 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11363 const char *s = start; /* current position in buffer */
11364 char *d; /* destination in temp buffer */
11365 char *e; /* end of temp buffer */
11366 NV nv; /* number read, as a double */
11367 SV *sv = NULL; /* place to put the converted number */
11368 bool floatit; /* boolean: int or float? */
11369 const char *lastub = NULL; /* position of last underbar */
11370 static const char* const number_too_long = "Number too long";
11371 bool warned_about_underscore = 0;
11372 I32 shift; /* shift per digit for hex/oct/bin, hoisted here for fp */
11373 #define WARN_ABOUT_UNDERSCORE() \
11375 if (!warned_about_underscore) { \
11376 warned_about_underscore = 1; \
11377 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \
11378 "Misplaced _ in number"); \
11381 /* Hexadecimal floating point.
11383 * In many places (where we have quads and NV is IEEE 754 double)
11384 * we can fit the mantissa bits of a NV into an unsigned quad.
11385 * (Note that UVs might not be quads even when we have quads.)
11386 * This will not work everywhere, though (either no quads, or
11387 * using long doubles), in which case we have to resort to NV,
11388 * which will probably mean horrible loss of precision due to
11389 * multiple fp operations. */
11390 bool hexfp = FALSE;
11391 int total_bits = 0;
11392 int significant_bits = 0;
11393 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
11394 # define HEXFP_UQUAD
11395 Uquad_t hexfp_uquad = 0;
11396 int hexfp_frac_bits = 0;
11401 NV hexfp_mult = 1.0;
11402 UV high_non_zero = 0; /* highest digit */
11403 int non_zero_integer_digits = 0;
11405 PERL_ARGS_ASSERT_SCAN_NUM;
11407 /* We use the first character to decide what type of number this is */
11411 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
11413 /* if it starts with a 0, it could be an octal number, a decimal in
11414 0.13 disguise, or a hexadecimal number, or a binary number. */
11418 u holds the "number so far"
11419 overflowed was the number more than we can hold?
11421 Shift is used when we add a digit. It also serves as an "are
11422 we in octal/hex/binary?" indicator to disallow hex characters
11423 when in octal mode.
11427 bool overflowed = FALSE;
11428 bool just_zero = TRUE; /* just plain 0 or binary number? */
11429 bool has_digs = FALSE;
11430 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11431 static const char* const bases[5] =
11432 { "", "binary", "", "octal", "hexadecimal" };
11433 static const char* const Bases[5] =
11434 { "", "Binary", "", "Octal", "Hexadecimal" };
11435 static const char* const maxima[5] =
11437 "0b11111111111111111111111111111111",
11441 const char *base, *Base, *max;
11443 /* check for hex */
11444 if (isALPHA_FOLD_EQ(s[1], 'x')) {
11448 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
11453 /* check for a decimal in disguise */
11454 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
11456 /* so it must be octal */
11463 WARN_ABOUT_UNDERSCORE();
11467 base = bases[shift];
11468 Base = Bases[shift];
11469 max = maxima[shift];
11471 /* read the rest of the number */
11473 /* x is used in the overflow test,
11474 b is the digit we're adding on. */
11479 /* if we don't mention it, we're done */
11483 /* _ are ignored -- but warned about if consecutive */
11485 if (lastub && s == lastub + 1)
11486 WARN_ABOUT_UNDERSCORE();
11490 /* 8 and 9 are not octal */
11491 case '8': case '9':
11493 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11497 case '2': case '3': case '4':
11498 case '5': case '6': case '7':
11500 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11503 case '0': case '1':
11504 b = *s++ & 15; /* ASCII digit -> value of digit */
11508 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11509 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11510 /* make sure they said 0x */
11513 b = (*s++ & 7) + 9;
11515 /* Prepare to put the digit we have onto the end
11516 of the number so far. We check for overflows.
11523 assert(shift >= 0);
11524 x = u << shift; /* make room for the digit */
11526 total_bits += shift;
11528 if ((x >> shift) != u
11529 && !(PL_hints & HINT_NEW_BINARY)) {
11532 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11533 "Integer overflow in %s number",
11536 u = x | b; /* add the digit to the end */
11539 n *= nvshift[shift];
11540 /* If an NV has not enough bits in its
11541 * mantissa to represent an UV this summing of
11542 * small low-order numbers is a waste of time
11543 * (because the NV cannot preserve the
11544 * low-order bits anyway): we could just
11545 * remember when did we overflow and in the
11546 * end just multiply n by the right
11551 if (high_non_zero == 0 && b > 0)
11555 non_zero_integer_digits++;
11557 /* this could be hexfp, but peek ahead
11558 * to avoid matching ".." */
11559 if (UNLIKELY(HEXFP_PEEK(s))) {
11567 /* if we get here, we had success: make a scalar value from
11572 /* final misplaced underbar check */
11574 WARN_ABOUT_UNDERSCORE();
11576 if (UNLIKELY(HEXFP_PEEK(s))) {
11577 /* Do sloppy (on the underbars) but quick detection
11578 * (and value construction) for hexfp, the decimal
11579 * detection will shortly be more thorough with the
11580 * underbar checks. */
11582 significant_bits = non_zero_integer_digits * shift;
11585 #else /* HEXFP_NV */
11588 /* Ignore the leading zero bits of
11589 * the high (first) non-zero digit. */
11590 if (high_non_zero) {
11591 if (high_non_zero < 0x8)
11592 significant_bits--;
11593 if (high_non_zero < 0x4)
11594 significant_bits--;
11595 if (high_non_zero < 0x2)
11596 significant_bits--;
11603 bool accumulate = TRUE;
11605 int lim = 1 << shift;
11606 for (h++; ((isXDIGIT(*h) && (b = XDIGIT_VALUE(*h)) < lim) ||
11608 if (isXDIGIT(*h)) {
11609 significant_bits += shift;
11612 if (significant_bits < NV_MANT_DIG) {
11613 /* We are in the long "run" of xdigits,
11614 * accumulate the full four bits. */
11615 assert(shift >= 0);
11616 hexfp_uquad <<= shift;
11618 hexfp_frac_bits += shift;
11619 } else if (significant_bits - shift < NV_MANT_DIG) {
11620 /* We are at a hexdigit either at,
11621 * or straddling, the edge of mantissa.
11622 * We will try grabbing as many as
11623 * possible bits. */
11625 significant_bits - NV_MANT_DIG;
11629 hexfp_uquad <<= tail;
11630 assert((shift - tail) >= 0);
11631 hexfp_uquad |= b >> (shift - tail);
11632 hexfp_frac_bits += tail;
11634 /* Ignore the trailing zero bits
11635 * of the last non-zero xdigit.
11637 * The assumption here is that if
11638 * one has input of e.g. the xdigit
11639 * eight (0x8), there is only one
11640 * bit being input, not the full
11641 * four bits. Conversely, if one
11642 * specifies a zero xdigit, the
11643 * assumption is that one really
11644 * wants all those bits to be zero. */
11646 if ((b & 0x1) == 0x0) {
11647 significant_bits--;
11648 if ((b & 0x2) == 0x0) {
11649 significant_bits--;
11650 if ((b & 0x4) == 0x0) {
11651 significant_bits--;
11657 accumulate = FALSE;
11660 /* Keep skipping the xdigits, and
11661 * accumulating the significant bits,
11662 * but do not shift the uquad
11663 * (which would catastrophically drop
11664 * high-order bits) or accumulate the
11665 * xdigits anymore. */
11667 #else /* HEXFP_NV */
11669 nv_mult /= nvshift[shift];
11671 hexfp_nv += b * nv_mult;
11673 accumulate = FALSE;
11677 if (significant_bits >= NV_MANT_DIG)
11678 accumulate = FALSE;
11682 if ((total_bits > 0 || significant_bits > 0) &&
11683 isALPHA_FOLD_EQ(*h, 'p')) {
11684 bool negexp = FALSE;
11688 else if (*h == '-') {
11694 while (isDIGIT(*h) || *h == '_') {
11697 hexfp_exp += *h - '0';
11700 && -hexfp_exp < NV_MIN_EXP - 1) {
11701 /* NOTE: this means that the exponent
11702 * underflow warning happens for
11703 * the IEEE 754 subnormals (denormals),
11704 * because DBL_MIN_EXP etc are the lowest
11705 * possible binary (or, rather, DBL_RADIX-base)
11706 * exponent for normals, not subnormals.
11708 * This may or may not be a good thing. */
11709 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11710 "Hexadecimal float: exponent underflow");
11716 && hexfp_exp > NV_MAX_EXP - 1) {
11717 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11718 "Hexadecimal float: exponent overflow");
11726 hexfp_exp = -hexfp_exp;
11728 hexfp_exp -= hexfp_frac_bits;
11730 hexfp_mult = Perl_pow(2.0, hexfp_exp);
11737 if (shift != 3 && !has_digs) {
11738 /* 0x or 0b with no digits, treat it as an error.
11739 Originally this backed up the parse before the b or
11740 x, but that has the potential for silent changes in
11741 behaviour, like for: "0x.3" and "0x+$foo".
11744 char *oldbp = PL_bufptr;
11745 if (*d) ++d; /* so the user sees the bad non-digit */
11746 PL_bufptr = (char *)d; /* so yyerror reports the context */
11747 yyerror(Perl_form(aTHX_ "No digits found for %s literal",
11748 shift == 4 ? "hexadecimal" : "binary"));
11753 if (n > 4294967295.0)
11754 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11755 "%s number > %s non-portable",
11761 if (u > 0xffffffff)
11762 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11763 "%s number > %s non-portable",
11768 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11769 sv = new_constant(start, s - start, "integer",
11770 sv, NULL, NULL, 0, NULL);
11771 else if (PL_hints & HINT_NEW_BINARY)
11772 sv = new_constant(start, s - start, "binary",
11773 sv, NULL, NULL, 0, NULL);
11778 handle decimal numbers.
11779 we're also sent here when we read a 0 as the first digit
11781 case '1': case '2': case '3': case '4': case '5':
11782 case '6': case '7': case '8': case '9': case '.':
11785 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11803 NOT_REACHED; /* NOTREACHED */
11807 /* read next group of digits and _ and copy into d */
11810 || UNLIKELY(hexfp && isXDIGIT(*s)))
11812 /* skip underscores, checking for misplaced ones
11816 if (lastub && s == lastub + 1)
11817 WARN_ABOUT_UNDERSCORE();
11821 /* check for end of fixed-length buffer */
11823 Perl_croak(aTHX_ "%s", number_too_long);
11824 /* if we're ok, copy the character */
11829 /* final misplaced underbar check */
11830 if (lastub && s == lastub + 1)
11831 WARN_ABOUT_UNDERSCORE();
11833 /* read a decimal portion if there is one. avoid
11834 3..5 being interpreted as the number 3. followed
11837 if (*s == '.' && s[1] != '.') {
11842 WARN_ABOUT_UNDERSCORE();
11846 /* copy, ignoring underbars, until we run out of digits.
11850 || UNLIKELY(hexfp && isXDIGIT(*s));
11853 /* fixed length buffer check */
11855 Perl_croak(aTHX_ "%s", number_too_long);
11857 if (lastub && s == lastub + 1)
11858 WARN_ABOUT_UNDERSCORE();
11864 /* fractional part ending in underbar? */
11866 WARN_ABOUT_UNDERSCORE();
11867 if (*s == '.' && isDIGIT(s[1])) {
11868 /* oops, it's really a v-string, but without the "v" */
11874 /* read exponent part, if present */
11875 if ((isALPHA_FOLD_EQ(*s, 'e')
11876 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
11877 && memCHRs("+-0123456789_", s[1]))
11879 int exp_digits = 0;
11880 const char *save_s = s;
11883 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
11884 ditto for p (hexfloats) */
11885 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
11886 /* At least some Mach atof()s don't grok 'E' */
11889 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
11896 /* stray preinitial _ */
11898 WARN_ABOUT_UNDERSCORE();
11902 /* allow positive or negative exponent */
11903 if (*s == '+' || *s == '-')
11906 /* stray initial _ */
11908 WARN_ABOUT_UNDERSCORE();
11912 /* read digits of exponent */
11913 while (isDIGIT(*s) || *s == '_') {
11917 Perl_croak(aTHX_ "%s", number_too_long);
11921 if (((lastub && s == lastub + 1)
11922 || (!isDIGIT(s[1]) && s[1] != '_')))
11923 WARN_ABOUT_UNDERSCORE();
11929 /* no exponent digits, the [eEpP] could be for something else,
11930 * though in practice we don't get here for p since that's preparsed
11931 * earlier, and results in only the 0xX being consumed, so behave similarly
11932 * for decimal floats and consume only the D.DD, leaving the [eE] to the
11945 We try to do an integer conversion first if no characters
11946 indicating "float" have been found.
11951 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11953 if (flags == IS_NUMBER_IN_UV) {
11955 sv = newSViv(uv); /* Prefer IVs over UVs. */
11958 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11959 if (uv <= (UV) IV_MIN)
11960 sv = newSViv(-(IV)uv);
11967 /* terminate the string */
11969 if (UNLIKELY(hexfp)) {
11970 # ifdef NV_MANT_DIG
11971 if (significant_bits > NV_MANT_DIG)
11972 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11973 "Hexadecimal float: mantissa overflow");
11976 nv = hexfp_uquad * hexfp_mult;
11977 #else /* HEXFP_NV */
11978 nv = hexfp_nv * hexfp_mult;
11981 nv = Atof(PL_tokenbuf);
11987 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11988 const char *const key = floatit ? "float" : "integer";
11989 const STRLEN keylen = floatit ? 5 : 7;
11990 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11991 key, keylen, sv, NULL, NULL, 0, NULL);
11995 /* if it starts with a v, it could be a v-string */
11998 sv = newSV(5); /* preallocate storage space */
11999 ENTER_with_name("scan_vstring");
12001 s = scan_vstring(s, PL_bufend, sv);
12002 SvREFCNT_inc_simple_void_NN(sv);
12003 LEAVE_with_name("scan_vstring");
12007 /* make the op for the constant and return */
12010 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12012 lvalp->opval = NULL;
12018 S_scan_formline(pTHX_ char *s)
12020 SV * const stuff = newSVpvs("");
12021 bool needargs = FALSE;
12022 bool eofmt = FALSE;
12024 PERL_ARGS_ASSERT_SCAN_FORMLINE;
12026 while (!needargs) {
12030 #ifdef PERL_STRICT_CR
12031 while (SPACE_OR_TAB(*t))
12034 while (SPACE_OR_TAB(*t) || *t == '\r')
12037 if (*t == '\n' || t == PL_bufend) {
12042 eol = (char *) memchr(s,'\n',PL_bufend-s);
12047 for (t = s; t < eol; t++) {
12048 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12050 goto enough; /* ~~ must be first line in formline */
12052 if (*t == '@' || *t == '^')
12056 sv_catpvn(stuff, s, eol-s);
12057 #ifndef PERL_STRICT_CR
12058 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12059 char *end = SvPVX(stuff) + SvCUR(stuff);
12062 SvCUR_set(stuff, SvCUR(stuff) - 1);
12070 if ((PL_rsfp || PL_parser->filtered)
12071 && PL_parser->form_lex_state == LEX_NORMAL) {
12073 PL_bufptr = PL_bufend;
12074 COPLINE_INC_WITH_HERELINES;
12075 got_some = lex_next_chunk(0);
12076 CopLINE_dec(PL_curcop);
12081 incline(s, PL_bufend);
12084 if (!SvCUR(stuff) || needargs)
12085 PL_lex_state = PL_parser->form_lex_state;
12086 if (SvCUR(stuff)) {
12087 PL_expect = XSTATE;
12089 const char *s2 = s;
12090 while (isSPACE(*s2) && *s2 != '\n')
12093 PL_expect = XTERMBLOCK;
12094 NEXTVAL_NEXTTOKE.ival = 0;
12097 NEXTVAL_NEXTTOKE.ival = 0;
12098 force_next(FORMLBRACK);
12101 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12104 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
12108 SvREFCNT_dec(stuff);
12110 PL_lex_formbrack = 0;
12116 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12118 const I32 oldsavestack_ix = PL_savestack_ix;
12119 CV* const outsidecv = PL_compcv;
12121 SAVEI32(PL_subline);
12122 save_item(PL_subname);
12123 SAVESPTR(PL_compcv);
12125 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
12126 CvFLAGS(PL_compcv) |= flags;
12128 PL_subline = CopLINE(PL_curcop);
12129 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12130 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
12131 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12132 if (outsidecv && CvPADLIST(outsidecv))
12133 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
12135 return oldsavestack_ix;
12139 /* Do extra initialisation of a CV (typically one just created by
12140 * start_subparse()) if that CV is for a named sub
12144 Perl_init_named_cv(pTHX_ CV *cv, OP *nameop)
12146 PERL_ARGS_ASSERT_INIT_NAMED_CV;
12148 if (nameop->op_type == OP_CONST) {
12149 const char *const name = SvPV_nolen_const(((SVOP*)nameop)->op_sv);
12150 if ( strEQ(name, "BEGIN")
12151 || strEQ(name, "END")
12152 || strEQ(name, "INIT")
12153 || strEQ(name, "CHECK")
12154 || strEQ(name, "UNITCHECK")
12159 /* State subs inside anonymous subs need to be
12160 clonable themselves. */
12161 if ( CvANON(CvOUTSIDE(cv))
12162 || CvCLONE(CvOUTSIDE(cv))
12163 || !PadnameIsSTATE(PadlistNAMESARRAY(CvPADLIST(
12165 ))[nameop->op_targ])
12172 S_yywarn(pTHX_ const char *const s, U32 flags)
12174 PERL_ARGS_ASSERT_YYWARN;
12176 PL_in_eval |= EVAL_WARNONLY;
12177 yyerror_pv(s, flags);
12182 Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
12184 PERL_ARGS_ASSERT_ABORT_EXECUTION;
12187 Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
12190 "%sExecution of %s aborted due to compilation errors.\n", msg, name);
12192 NOT_REACHED; /* NOTREACHED */
12198 /* Called, after at least one error has been found, to abort the parse now,
12199 * instead of trying to forge ahead */
12201 yyerror_pvn(NULL, 0, 0);
12205 Perl_yyerror(pTHX_ const char *const s)
12207 PERL_ARGS_ASSERT_YYERROR;
12208 return yyerror_pvn(s, strlen(s), 0);
12212 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
12214 PERL_ARGS_ASSERT_YYERROR_PV;
12215 return yyerror_pvn(s, strlen(s), flags);
12219 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
12221 const char *context = NULL;
12224 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
12225 int yychar = PL_parser->yychar;
12227 /* Output error message 's' with length 'len'. 'flags' are SV flags that
12228 * apply. If the number of errors found is large enough, it abandons
12229 * parsing. If 's' is NULL, there is no message, and it abandons
12230 * processing unconditionally */
12233 if (!yychar || (yychar == ';' && !PL_rsfp))
12234 sv_catpvs(where_sv, "at EOF");
12235 else if ( PL_oldoldbufptr
12236 && PL_bufptr > PL_oldoldbufptr
12237 && PL_bufptr - PL_oldoldbufptr < 200
12238 && PL_oldoldbufptr != PL_oldbufptr
12239 && PL_oldbufptr != PL_bufptr)
12243 The code below is removed for NetWare because it
12244 abends/crashes on NetWare when the script has error such as
12245 not having the closing quotes like:
12246 if ($var eq "value)
12247 Checking of white spaces is anyway done in NetWare code.
12250 while (isSPACE(*PL_oldoldbufptr))
12253 context = PL_oldoldbufptr;
12254 contlen = PL_bufptr - PL_oldoldbufptr;
12256 else if ( PL_oldbufptr
12257 && PL_bufptr > PL_oldbufptr
12258 && PL_bufptr - PL_oldbufptr < 200
12259 && PL_oldbufptr != PL_bufptr) {
12262 The code below is removed for NetWare because it
12263 abends/crashes on NetWare when the script has error such as
12264 not having the closing quotes like:
12265 if ($var eq "value)
12266 Checking of white spaces is anyway done in NetWare code.
12269 while (isSPACE(*PL_oldbufptr))
12272 context = PL_oldbufptr;
12273 contlen = PL_bufptr - PL_oldbufptr;
12275 else if (yychar > 255)
12276 sv_catpvs(where_sv, "next token ???");
12277 else if (yychar == YYEMPTY) {
12278 if (PL_lex_state == LEX_NORMAL)
12279 sv_catpvs(where_sv, "at end of line");
12280 else if (PL_lex_inpat)
12281 sv_catpvs(where_sv, "within pattern");
12283 sv_catpvs(where_sv, "within string");
12286 sv_catpvs(where_sv, "next char ");
12288 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12289 else if (isPRINT_LC(yychar)) {
12290 const char string = yychar;
12291 sv_catpvn(where_sv, &string, 1);
12294 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12296 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
12297 Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
12298 OutCopFILE(PL_curcop),
12299 (IV)(PL_parser->preambling == NOLINE
12300 ? CopLINE(PL_curcop)
12301 : PL_parser->preambling));
12303 Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
12304 UTF8fARG(UTF, contlen, context));
12306 Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
12307 if ( PL_multi_start < PL_multi_end
12308 && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
12310 Perl_sv_catpvf(aTHX_ msg,
12311 " (Might be a runaway multi-line %c%c string starting on"
12312 " line %" IVdf ")\n",
12313 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12316 if (PL_in_eval & EVAL_WARNONLY) {
12317 PL_in_eval &= ~EVAL_WARNONLY;
12318 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
12324 if (s == NULL || PL_error_count >= 10) {
12325 const char * msg = "";
12326 const char * const name = OutCopFILE(PL_curcop);
12329 SV * errsv = ERRSV;
12330 if (SvCUR(errsv)) {
12331 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
12336 abort_execution(msg, name);
12339 Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
12343 PL_in_my_stash = NULL;
12348 S_swallow_bom(pTHX_ U8 *s)
12350 const STRLEN slen = SvCUR(PL_linestr);
12352 PERL_ARGS_ASSERT_SWALLOW_BOM;
12356 if (s[1] == 0xFE) {
12357 /* UTF-16 little-endian? (or UTF-32LE?) */
12358 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12359 /* diag_listed_as: Unsupported script encoding %s */
12360 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
12361 #ifndef PERL_NO_UTF16_FILTER
12363 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
12366 if (PL_bufend > (char*)s) {
12367 s = add_utf16_textfilter(s, TRUE);
12370 /* diag_listed_as: Unsupported script encoding %s */
12371 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
12376 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12377 #ifndef PERL_NO_UTF16_FILTER
12379 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12382 if (PL_bufend > (char *)s) {
12383 s = add_utf16_textfilter(s, FALSE);
12386 /* diag_listed_as: Unsupported script encoding %s */
12387 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
12391 case BOM_UTF8_FIRST_BYTE: {
12392 if (memBEGINs(s+1, slen - 1, BOM_UTF8_TAIL)) {
12394 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12396 s += sizeof(BOM_UTF8) - 1; /* UTF-8 */
12403 if (s[2] == 0xFE && s[3] == 0xFF) {
12404 /* UTF-32 big-endian */
12405 /* diag_listed_as: Unsupported script encoding %s */
12406 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
12409 else if (s[2] == 0 && s[3] != 0) {
12412 * are a good indicator of UTF-16BE. */
12413 #ifndef PERL_NO_UTF16_FILTER
12415 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12417 s = add_utf16_textfilter(s, FALSE);
12419 /* diag_listed_as: Unsupported script encoding %s */
12420 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
12427 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12430 * are a good indicator of UTF-16LE. */
12431 #ifndef PERL_NO_UTF16_FILTER
12433 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12435 s = add_utf16_textfilter(s, TRUE);
12437 /* diag_listed_as: Unsupported script encoding %s */
12438 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
12446 #ifndef PERL_NO_UTF16_FILTER
12448 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12450 SV *const filter = FILTER_DATA(idx);
12451 /* We re-use this each time round, throwing the contents away before we
12453 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
12454 SV *const utf8_buffer = filter;
12455 IV status = IoPAGE(filter);
12456 const bool reverse = cBOOL(IoLINES(filter));
12459 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
12461 /* As we're automatically added, at the lowest level, and hence only called
12462 from this file, we can be sure that we're not called in block mode. Hence
12463 don't bother writing code to deal with block mode. */
12465 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
12468 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status);
12470 DEBUG_P(PerlIO_printf(Perl_debug_log,
12471 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
12472 FPTR2DPTR(void *, S_utf16_textfilter),
12473 reverse ? 'l' : 'b', idx, maxlen, status,
12474 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12481 /* First, look in our buffer of existing UTF-8 data: */
12482 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
12486 } else if (status == 0) {
12488 IoPAGE(filter) = 0;
12489 nl = SvEND(utf8_buffer);
12492 STRLEN got = nl - SvPVX(utf8_buffer);
12493 /* Did we have anything to append? */
12495 sv_catpvn(sv, SvPVX(utf8_buffer), got);
12496 /* Everything else in this code works just fine if SVp_POK isn't
12497 set. This, however, needs it, and we need it to work, else
12498 we loop infinitely because the buffer is never consumed. */
12499 sv_chop(utf8_buffer, nl);
12503 /* OK, not a complete line there, so need to read some more UTF-16.
12504 Read an extra octect if the buffer currently has an odd number. */
12508 if (SvCUR(utf16_buffer) >= 2) {
12509 /* Location of the high octet of the last complete code point.
12510 Gosh, UTF-16 is a pain. All the benefits of variable length,
12511 *coupled* with all the benefits of partial reads and
12513 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
12514 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
12516 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
12520 /* We have the first half of a surrogate. Read more. */
12521 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
12524 status = FILTER_READ(idx + 1, utf16_buffer,
12525 160 + (SvCUR(utf16_buffer) & 1));
12526 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer)));
12527 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
12530 IoPAGE(filter) = status;
12535 /* 'chars' isn't quite the right name, as code points above 0xFFFF
12536 * require 4 bytes per char */
12537 chars = SvCUR(utf16_buffer) >> 1;
12538 have = SvCUR(utf8_buffer);
12540 /* Assume the worst case size as noted by the functions: twice the
12541 * number of input bytes */
12542 SvGROW(utf8_buffer, have + chars * 4 + 1);
12545 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
12546 (U8*)SvPVX_const(utf8_buffer) + have,
12547 chars * 2, &newlen);
12549 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
12550 (U8*)SvPVX_const(utf8_buffer) + have,
12551 chars * 2, &newlen);
12553 SvCUR_set(utf8_buffer, have + newlen);
12556 /* No need to keep this SV "well-formed" with a '\0' after the end, as
12557 it's private to us, and utf16_to_utf8{,reversed} take a
12558 (pointer,length) pair, rather than a NUL-terminated string. */
12559 if(SvCUR(utf16_buffer) & 1) {
12560 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
12561 SvCUR_set(utf16_buffer, 1);
12563 SvCUR_set(utf16_buffer, 0);
12566 DEBUG_P(PerlIO_printf(Perl_debug_log,
12567 "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
12569 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12570 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
12575 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
12577 SV *filter = filter_add(S_utf16_textfilter, NULL);
12579 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
12581 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
12583 IoLINES(filter) = reversed;
12584 IoPAGE(filter) = 1; /* Not EOF */
12586 /* Sadly, we have to return a valid pointer, come what may, so we have to
12587 ignore any error return from this. */
12588 SvCUR_set(PL_linestr, 0);
12589 if (FILTER_READ(0, PL_linestr, 0)) {
12590 SvUTF8_on(PL_linestr);
12592 SvUTF8_on(PL_linestr);
12594 PL_bufend = SvEND(PL_linestr);
12595 return (U8*)SvPVX(PL_linestr);
12600 Returns a pointer to the next character after the parsed
12601 vstring, as well as updating the passed in sv.
12603 Function must be called like
12605 sv = sv_2mortal(newSV(5));
12606 s = scan_vstring(s,e,sv);
12608 where s and e are the start and end of the string.
12609 The sv should already be large enough to store the vstring
12610 passed in, for performance reasons.
12612 This function may croak if fatal warnings are enabled in the
12613 calling scope, hence the sv_2mortal in the example (to prevent
12614 a leak). Make sure to do SvREFCNT_inc afterwards if you use
12620 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12622 const char *pos = s;
12623 const char *start = s;
12625 PERL_ARGS_ASSERT_SCAN_VSTRING;
12627 if (*pos == 'v') pos++; /* get past 'v' */
12628 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12630 if ( *pos != '.') {
12631 /* this may not be a v-string if followed by => */
12632 const char *next = pos;
12633 while (next < e && isSPACE(*next))
12635 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12636 /* return string not v-string */
12637 sv_setpvn(sv,(char *)s,pos-s);
12638 return (char *)pos;
12642 if (!isALPHA(*pos)) {
12643 U8 tmpbuf[UTF8_MAXBYTES+1];
12646 s++; /* get past 'v' */
12651 /* this is atoi() that tolerates underscores */
12654 const char *end = pos;
12656 while (--end >= s) {
12658 const UV orev = rev;
12659 rev += (*end - '0') * mult;
12662 /* diag_listed_as: Integer overflow in %s number */
12663 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
12664 "Integer overflow in decimal number");
12668 /* Append native character for the rev point */
12669 tmpend = uvchr_to_utf8(tmpbuf, rev);
12670 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12671 if (!UVCHR_IS_INVARIANT(rev))
12673 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12679 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12683 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12690 Perl_keyword_plugin_standard(pTHX_
12691 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
12693 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
12694 PERL_UNUSED_CONTEXT;
12695 PERL_UNUSED_ARG(keyword_ptr);
12696 PERL_UNUSED_ARG(keyword_len);
12697 PERL_UNUSED_ARG(op_ptr);
12698 return KEYWORD_PLUGIN_DECLINE;
12702 =for apidoc wrap_keyword_plugin
12704 Puts a C function into the chain of keyword plugins. This is the
12705 preferred way to manipulate the L</PL_keyword_plugin> variable.
12706 C<new_plugin> is a pointer to the C function that is to be added to the
12707 keyword plugin chain, and C<old_plugin_p> points to the storage location
12708 where a pointer to the next function in the chain will be stored. The
12709 value of C<new_plugin> is written into the L</PL_keyword_plugin> variable,
12710 while the value previously stored there is written to C<*old_plugin_p>.
12712 L</PL_keyword_plugin> is global to an entire process, and a module wishing
12713 to hook keyword parsing may find itself invoked more than once per
12714 process, typically in different threads. To handle that situation, this
12715 function is idempotent. The location C<*old_plugin_p> must initially
12716 (once per process) contain a null pointer. A C variable of static
12717 duration (declared at file scope, typically also marked C<static> to give
12718 it internal linkage) will be implicitly initialised appropriately, if it
12719 does not have an explicit initialiser. This function will only actually
12720 modify the plugin chain if it finds C<*old_plugin_p> to be null. This
12721 function is also thread safe on the small scale. It uses appropriate
12722 locking to avoid race conditions in accessing L</PL_keyword_plugin>.
12724 When this function is called, the function referenced by C<new_plugin>
12725 must be ready to be called, except for C<*old_plugin_p> being unfilled.
12726 In a threading situation, C<new_plugin> may be called immediately, even
12727 before this function has returned. C<*old_plugin_p> will always be
12728 appropriately set before C<new_plugin> is called. If C<new_plugin>
12729 decides not to do anything special with the identifier that it is given
12730 (which is the usual case for most calls to a keyword plugin), it must
12731 chain the plugin function referenced by C<*old_plugin_p>.
12733 Taken all together, XS code to install a keyword plugin should typically
12734 look something like this:
12736 static Perl_keyword_plugin_t next_keyword_plugin;
12737 static OP *my_keyword_plugin(pTHX_
12738 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
12740 if (memEQs(keyword_ptr, keyword_len,
12741 "my_new_keyword")) {
12744 return next_keyword_plugin(aTHX_
12745 keyword_ptr, keyword_len, op_ptr);
12749 wrap_keyword_plugin(my_keyword_plugin,
12750 &next_keyword_plugin);
12752 Direct access to L</PL_keyword_plugin> should be avoided.
12758 Perl_wrap_keyword_plugin(pTHX_
12759 Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
12763 PERL_UNUSED_CONTEXT;
12764 PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;
12765 if (*old_plugin_p) return;
12766 KEYWORD_PLUGIN_MUTEX_LOCK;
12767 if (!*old_plugin_p) {
12768 *old_plugin_p = PL_keyword_plugin;
12769 PL_keyword_plugin = new_plugin;
12771 KEYWORD_PLUGIN_MUTEX_UNLOCK;
12774 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
12776 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
12778 SAVEI32(PL_lex_brackets);
12779 if (PL_lex_brackets > 100)
12780 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
12781 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
12782 SAVEI32(PL_lex_allbrackets);
12783 PL_lex_allbrackets = 0;
12784 SAVEI8(PL_lex_fakeeof);
12785 PL_lex_fakeeof = (U8)fakeeof;
12786 if(yyparse(gramtype) && !PL_parser->error_count)
12787 qerror(Perl_mess(aTHX_ "Parse error"));
12790 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
12792 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
12796 SAVEVPTR(PL_eval_root);
12797 PL_eval_root = NULL;
12798 parse_recdescent(gramtype, fakeeof);
12804 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
12806 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
12809 if (flags & ~PARSE_OPTIONAL)
12810 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
12811 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
12812 if (!exprop && !(flags & PARSE_OPTIONAL)) {
12813 if (!PL_parser->error_count)
12814 qerror(Perl_mess(aTHX_ "Parse error"));
12815 exprop = newOP(OP_NULL, 0);
12821 =for apidoc parse_arithexpr
12823 Parse a Perl arithmetic expression. This may contain operators of precedence
12824 down to the bit shift operators. The expression must be followed (and thus
12825 terminated) either by a comparison or lower-precedence operator or by
12826 something that would normally terminate an expression such as semicolon.
12827 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12828 otherwise it is mandatory. It is up to the caller to ensure that the
12829 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12830 the source of the code to be parsed and the lexical context for the
12833 The op tree representing the expression is returned. If an optional
12834 expression is absent, a null pointer is returned, otherwise the pointer
12837 If an error occurs in parsing or compilation, in most cases a valid op
12838 tree is returned anyway. The error is reflected in the parser state,
12839 normally resulting in a single exception at the top level of parsing
12840 which covers all the compilation errors that occurred. Some compilation
12841 errors, however, will throw an exception immediately.
12843 =for apidoc Amnh||PARSE_OPTIONAL
12850 Perl_parse_arithexpr(pTHX_ U32 flags)
12852 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
12856 =for apidoc parse_termexpr
12858 Parse a Perl term expression. This may contain operators of precedence
12859 down to the assignment operators. The expression must be followed (and thus
12860 terminated) either by a comma or lower-precedence operator or by
12861 something that would normally terminate an expression such as semicolon.
12862 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12863 otherwise it is mandatory. It is up to the caller to ensure that the
12864 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12865 the source of the code to be parsed and the lexical context for the
12868 The op tree representing the expression is returned. If an optional
12869 expression is absent, a null pointer is returned, otherwise the pointer
12872 If an error occurs in parsing or compilation, in most cases a valid op
12873 tree is returned anyway. The error is reflected in the parser state,
12874 normally resulting in a single exception at the top level of parsing
12875 which covers all the compilation errors that occurred. Some compilation
12876 errors, however, will throw an exception immediately.
12882 Perl_parse_termexpr(pTHX_ U32 flags)
12884 return parse_expr(LEX_FAKEEOF_COMMA, flags);
12888 =for apidoc parse_listexpr
12890 Parse a Perl list expression. This may contain operators of precedence
12891 down to the comma operator. The expression must be followed (and thus
12892 terminated) either by a low-precedence logic operator such as C<or> or by
12893 something that would normally terminate an expression such as semicolon.
12894 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12895 otherwise it is mandatory. It is up to the caller to ensure that the
12896 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12897 the source of the code to be parsed and the lexical context for the
12900 The op tree representing the expression is returned. If an optional
12901 expression is absent, a null pointer is returned, otherwise the pointer
12904 If an error occurs in parsing or compilation, in most cases a valid op
12905 tree is returned anyway. The error is reflected in the parser state,
12906 normally resulting in a single exception at the top level of parsing
12907 which covers all the compilation errors that occurred. Some compilation
12908 errors, however, will throw an exception immediately.
12914 Perl_parse_listexpr(pTHX_ U32 flags)
12916 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12920 =for apidoc parse_fullexpr
12922 Parse a single complete Perl expression. This allows the full
12923 expression grammar, including the lowest-precedence operators such
12924 as C<or>. The expression must be followed (and thus terminated) by a
12925 token that an expression would normally be terminated by: end-of-file,
12926 closing bracketing punctuation, semicolon, or one of the keywords that
12927 signals a postfix expression-statement modifier. If C<flags> has the
12928 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
12929 mandatory. It is up to the caller to ensure that the dynamic parser
12930 state (L</PL_parser> et al) is correctly set to reflect the source of
12931 the code to be parsed and the lexical context for the expression.
12933 The op tree representing the expression is returned. If an optional
12934 expression is absent, a null pointer is returned, otherwise the pointer
12937 If an error occurs in parsing or compilation, in most cases a valid op
12938 tree is returned anyway. The error is reflected in the parser state,
12939 normally resulting in a single exception at the top level of parsing
12940 which covers all the compilation errors that occurred. Some compilation
12941 errors, however, will throw an exception immediately.
12947 Perl_parse_fullexpr(pTHX_ U32 flags)
12949 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12953 =for apidoc parse_block
12955 Parse a single complete Perl code block. This consists of an opening
12956 brace, a sequence of statements, and a closing brace. The block
12957 constitutes a lexical scope, so C<my> variables and various compile-time
12958 effects can be contained within it. It is up to the caller to ensure
12959 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12960 reflect the source of the code to be parsed and the lexical context for
12963 The op tree representing the code block is returned. This is always a
12964 real op, never a null pointer. It will normally be a C<lineseq> list,
12965 including C<nextstate> or equivalent ops. No ops to construct any kind
12966 of runtime scope are included by virtue of it being a block.
12968 If an error occurs in parsing or compilation, in most cases a valid op
12969 tree (most likely null) is returned anyway. The error is reflected in
12970 the parser state, normally resulting in a single exception at the top
12971 level of parsing which covers all the compilation errors that occurred.
12972 Some compilation errors, however, will throw an exception immediately.
12974 The C<flags> parameter is reserved for future use, and must always
12981 Perl_parse_block(pTHX_ U32 flags)
12984 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12985 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12989 =for apidoc parse_barestmt
12991 Parse a single unadorned Perl statement. This may be a normal imperative
12992 statement or a declaration that has compile-time effect. It does not
12993 include any label or other affixture. It is up to the caller to ensure
12994 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12995 reflect the source of the code to be parsed and the lexical context for
12998 The op tree representing the statement is returned. This may be a
12999 null pointer if the statement is null, for example if it was actually
13000 a subroutine definition (which has compile-time side effects). If not
13001 null, it will be ops directly implementing the statement, suitable to
13002 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
13003 equivalent op (except for those embedded in a scope contained entirely
13004 within the statement).
13006 If an error occurs in parsing or compilation, in most cases a valid op
13007 tree (most likely null) is returned anyway. The error is reflected in
13008 the parser state, normally resulting in a single exception at the top
13009 level of parsing which covers all the compilation errors that occurred.
13010 Some compilation errors, however, will throw an exception immediately.
13012 The C<flags> parameter is reserved for future use, and must always
13019 Perl_parse_barestmt(pTHX_ U32 flags)
13022 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
13023 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
13027 =for apidoc parse_label
13029 Parse a single label, possibly optional, of the type that may prefix a
13030 Perl statement. It is up to the caller to ensure that the dynamic parser
13031 state (L</PL_parser> et al) is correctly set to reflect the source of
13032 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
13033 label is optional, otherwise it is mandatory.
13035 The name of the label is returned in the form of a fresh scalar. If an
13036 optional label is absent, a null pointer is returned.
13038 If an error occurs in parsing, which can only occur if the label is
13039 mandatory, a valid label is returned anyway. The error is reflected in
13040 the parser state, normally resulting in a single exception at the top
13041 level of parsing which covers all the compilation errors that occurred.
13047 Perl_parse_label(pTHX_ U32 flags)
13049 if (flags & ~PARSE_OPTIONAL)
13050 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
13052 PL_parser->yychar = yylex();
13053 if (PL_parser->yychar == LABEL) {
13054 SV * const labelsv = cSVOPx(pl_yylval.opval)->op_sv;
13055 PL_parser->yychar = YYEMPTY;
13056 cSVOPx(pl_yylval.opval)->op_sv = NULL;
13057 op_free(pl_yylval.opval);
13065 STRLEN wlen, bufptr_pos;
13068 if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
13070 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
13071 if (word_takes_any_delimiter(s, wlen))
13073 bufptr_pos = s - SvPVX(PL_linestr);
13075 lex_read_space(LEX_KEEP_PREVIOUS);
13077 s = SvPVX(PL_linestr) + bufptr_pos;
13078 if (t[0] == ':' && t[1] != ':') {
13079 PL_oldoldbufptr = PL_oldbufptr;
13082 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
13086 if (flags & PARSE_OPTIONAL) {
13089 qerror(Perl_mess(aTHX_ "Parse error"));
13090 return newSVpvs("x");
13097 =for apidoc parse_fullstmt
13099 Parse a single complete Perl statement. This may be a normal imperative
13100 statement or a declaration that has compile-time effect, and may include
13101 optional labels. It is up to the caller to ensure that the dynamic
13102 parser state (L</PL_parser> et al) is correctly set to reflect the source
13103 of the code to be parsed and the lexical context for the statement.
13105 The op tree representing the statement is returned. This may be a
13106 null pointer if the statement is null, for example if it was actually
13107 a subroutine definition (which has compile-time side effects). If not
13108 null, it will be the result of a L</newSTATEOP> call, normally including
13109 a C<nextstate> or equivalent op.
13111 If an error occurs in parsing or compilation, in most cases a valid op
13112 tree (most likely null) is returned anyway. The error is reflected in
13113 the parser state, normally resulting in a single exception at the top
13114 level of parsing which covers all the compilation errors that occurred.
13115 Some compilation errors, however, will throw an exception immediately.
13117 The C<flags> parameter is reserved for future use, and must always
13124 Perl_parse_fullstmt(pTHX_ U32 flags)
13127 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
13128 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
13132 =for apidoc parse_stmtseq
13134 Parse a sequence of zero or more Perl statements. These may be normal
13135 imperative statements, including optional labels, or declarations
13136 that have compile-time effect, or any mixture thereof. The statement
13137 sequence ends when a closing brace or end-of-file is encountered in a
13138 place where a new statement could have validly started. It is up to
13139 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
13140 is correctly set to reflect the source of the code to be parsed and the
13141 lexical context for the statements.
13143 The op tree representing the statement sequence is returned. This may
13144 be a null pointer if the statements were all null, for example if there
13145 were no statements or if there were only subroutine definitions (which
13146 have compile-time side effects). If not null, it will be a C<lineseq>
13147 list, normally including C<nextstate> or equivalent ops.
13149 If an error occurs in parsing or compilation, in most cases a valid op
13150 tree is returned anyway. The error is reflected in the parser state,
13151 normally resulting in a single exception at the top level of parsing
13152 which covers all the compilation errors that occurred. Some compilation
13153 errors, however, will throw an exception immediately.
13155 The C<flags> parameter is reserved for future use, and must always
13162 Perl_parse_stmtseq(pTHX_ U32 flags)
13167 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
13168 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
13169 c = lex_peek_unichar(0);
13170 if (c != -1 && c != /*{*/'}')
13171 qerror(Perl_mess(aTHX_ "Parse error"));
13176 =for apidoc parse_subsignature
13178 Parse a subroutine signature declaration. This is the contents of the
13179 parentheses following a named or anonymous subroutine declaration when the
13180 C<signatures> feature is enabled. Note that this function neither expects
13181 nor consumes the opening and closing parentheses around the signature; it
13182 is the caller's job to handle these.
13184 This function must only be called during parsing of a subroutine; after
13185 L</start_subparse> has been called. It might allocate lexical variables on
13186 the pad for the current subroutine.
13188 The op tree to unpack the arguments from the stack at runtime is returned.
13189 This op tree should appear at the beginning of the compiled function. The
13190 caller may wish to use L</op_append_list> to build their function body
13191 after it, or splice it together with the body before calling L</newATTRSUB>.
13193 The C<flags> parameter is reserved for future use, and must always
13200 Perl_parse_subsignature(pTHX_ U32 flags)
13203 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_subsignature");
13204 return parse_recdescent_for_op(GRAMSUBSIGNATURE, LEX_FAKEEOF_NONEXPR);
13208 * ex: set ts=8 sts=4 sw=4 et: