3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
26 This is the lower layer of the Perl parser, managing characters and tokens.
28 =for apidoc AmU|yy_parser *|PL_parser
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress. The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
39 #define PERL_IN_TOKE_C
41 #include "dquote_inline.h"
43 #define new_constant(a,b,c,d,e,f,g) \
44 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
46 #define pl_yylval (PL_parser->yylval)
48 /* XXX temporary backwards compatibility */
49 #define PL_lex_brackets (PL_parser->lex_brackets)
50 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
51 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
52 #define PL_lex_brackstack (PL_parser->lex_brackstack)
53 #define PL_lex_casemods (PL_parser->lex_casemods)
54 #define PL_lex_casestack (PL_parser->lex_casestack)
55 #define PL_lex_dojoin (PL_parser->lex_dojoin)
56 #define PL_lex_formbrack (PL_parser->lex_formbrack)
57 #define PL_lex_inpat (PL_parser->lex_inpat)
58 #define PL_lex_inwhat (PL_parser->lex_inwhat)
59 #define PL_lex_op (PL_parser->lex_op)
60 #define PL_lex_repl (PL_parser->lex_repl)
61 #define PL_lex_starts (PL_parser->lex_starts)
62 #define PL_lex_stuff (PL_parser->lex_stuff)
63 #define PL_multi_start (PL_parser->multi_start)
64 #define PL_multi_open (PL_parser->multi_open)
65 #define PL_multi_close (PL_parser->multi_close)
66 #define PL_preambled (PL_parser->preambled)
67 #define PL_linestr (PL_parser->linestr)
68 #define PL_expect (PL_parser->expect)
69 #define PL_copline (PL_parser->copline)
70 #define PL_bufptr (PL_parser->bufptr)
71 #define PL_oldbufptr (PL_parser->oldbufptr)
72 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
73 #define PL_linestart (PL_parser->linestart)
74 #define PL_bufend (PL_parser->bufend)
75 #define PL_last_uni (PL_parser->last_uni)
76 #define PL_last_lop (PL_parser->last_lop)
77 #define PL_last_lop_op (PL_parser->last_lop_op)
78 #define PL_lex_state (PL_parser->lex_state)
79 #define PL_rsfp (PL_parser->rsfp)
80 #define PL_rsfp_filters (PL_parser->rsfp_filters)
81 #define PL_in_my (PL_parser->in_my)
82 #define PL_in_my_stash (PL_parser->in_my_stash)
83 #define PL_tokenbuf (PL_parser->tokenbuf)
84 #define PL_multi_end (PL_parser->multi_end)
85 #define PL_error_count (PL_parser->error_count)
87 # define PL_nexttoke (PL_parser->nexttoke)
88 # define PL_nexttype (PL_parser->nexttype)
89 # define PL_nextval (PL_parser->nextval)
92 #define SvEVALED(sv) \
93 (SvTYPE(sv) >= SVt_PVNV \
94 && ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen)
96 static const char* const ident_too_long = "Identifier too long";
98 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
100 #define XENUMMASK 0x3f
101 #define XFAKEEOF 0x40
102 #define XFAKEBRACK 0x80
104 #ifdef USE_UTF8_SCRIPTS
105 # define UTF cBOOL(!IN_BYTES)
107 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
110 /* The maximum number of characters preceding the unrecognized one to display */
111 #define UNRECOGNIZED_PRECEDE_COUNT 10
113 /* In variables named $^X, these are the legal values for X.
114 * 1999-02-27 mjd-perl-patch@plover.com */
115 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
117 #define SPACE_OR_TAB(c) isBLANK_A(c)
119 #define HEXFP_PEEK(s) \
121 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
122 isALPHA_FOLD_EQ(s[0], 'p'))
124 /* LEX_* are values for PL_lex_state, the state of the lexer.
125 * They are arranged oddly so that the guard on the switch statement
126 * can get by with a single comparison (if the compiler is smart enough).
128 * These values refer to the various states within a sublex parse,
129 * i.e. within a double quotish string
132 /* #define LEX_NOTPARSING 11 is done in perl.h. */
134 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
135 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
136 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
137 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
138 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
140 /* at end of code, eg "$x" followed by: */
141 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
142 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
144 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
145 string or after \E, $foo, etc */
146 #define LEX_INTERPCONST 2 /* NOT USED */
147 #define LEX_FORMLINE 1 /* expecting a format line */
151 static const char* const lex_state_names[] = {
166 #include "keywords.h"
168 /* CLINE is a macro that ensures PL_copline has a sane value */
170 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
173 * Convenience functions to return different tokens and prime the
174 * lexer for the next token. They all take an argument.
176 * TOKEN : generic token (used for '(', DOLSHARP, etc)
177 * OPERATOR : generic operator
178 * AOPERATOR : assignment operator
179 * PREBLOCK : beginning the block after an if, while, foreach, ...
180 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
181 * PREREF : *EXPR where EXPR is not a simple identifier
182 * TERM : expression term
183 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
184 * LOOPX : loop exiting command (goto, last, dump, etc)
185 * FTST : file test operator
186 * FUN0 : zero-argument function
187 * FUN0OP : zero-argument function, with its op created in this file
188 * FUN1 : not used, except for not, which isn't a UNIOP
189 * BOop : bitwise or or xor
191 * BCop : bitwise complement
192 * SHop : shift operator
193 * PWop : power operator
194 * PMop : pattern-matching operator
195 * Aop : addition-level operator
196 * AopNOASSIGN : addition-level operator that is never part of .=
197 * Mop : multiplication-level operator
198 * Eop : equality-testing operator
199 * Rop : relational operator <= != gt
201 * Also see LOP and lop() below.
204 #ifdef DEBUGGING /* Serve -DT. */
205 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
207 # define REPORT(retval) (retval)
210 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
211 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
212 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
213 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
214 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
215 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
216 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
217 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
218 #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
220 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
222 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
223 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
224 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
225 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
226 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
227 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
228 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
230 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
231 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
232 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
233 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
234 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
235 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
236 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
237 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
239 /* This bit of chicanery makes a unary function followed by
240 * a parenthesis into a function with one argument, highest precedence.
241 * The UNIDOR macro is for unary functions that can be followed by the //
242 * operator (such as C<shift // 0>).
244 #define UNI3(f,x,have_x) { \
245 pl_yylval.ival = f; \
246 if (have_x) PL_expect = x; \
248 PL_last_uni = PL_oldbufptr; \
249 PL_last_lop_op = (f) < 0 ? -(f) : (f); \
251 return REPORT( (int)FUNC1 ); \
253 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
255 #define UNI(f) UNI3(f,XTERM,1)
256 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
257 #define UNIPROTO(f,optional) { \
258 if (optional) PL_last_uni = PL_oldbufptr; \
262 #define UNIBRACK(f) UNI3(f,0,0)
264 /* grandfather return to old style */
267 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
268 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
269 pl_yylval.ival = (f); \
275 #define COPLINE_INC_WITH_HERELINES \
277 CopLINE_inc(PL_curcop); \
278 if (PL_parser->herelines) \
279 CopLINE(PL_curcop) += PL_parser->herelines, \
280 PL_parser->herelines = 0; \
282 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
283 * is no sublex_push to follow. */
284 #define COPLINE_SET_FROM_MULTI_END \
286 CopLINE_set(PL_curcop, PL_multi_end); \
287 if (PL_multi_end != PL_multi_start) \
288 PL_parser->herelines = 0; \
294 /* how to interpret the pl_yylval associated with the token */
298 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
303 static struct debug_tokens {
305 enum token_type type;
307 } const debug_tokens[] =
309 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
310 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
311 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
312 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
313 { ARROW, TOKENTYPE_NONE, "ARROW" },
314 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
315 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
316 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
317 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
318 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
319 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
320 { DO, TOKENTYPE_NONE, "DO" },
321 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
322 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
323 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
324 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
325 { ELSE, TOKENTYPE_NONE, "ELSE" },
326 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
327 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
328 { FOR, TOKENTYPE_IVAL, "FOR" },
329 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
330 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
331 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
332 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
333 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
334 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
335 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
336 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
337 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
338 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
339 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
340 { IF, TOKENTYPE_IVAL, "IF" },
341 { LABEL, TOKENTYPE_PVAL, "LABEL" },
342 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
343 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
344 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
345 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
346 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
347 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
348 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
349 { MY, TOKENTYPE_IVAL, "MY" },
350 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
351 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
352 { OROP, TOKENTYPE_IVAL, "OROP" },
353 { OROR, TOKENTYPE_NONE, "OROR" },
354 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
355 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
356 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
357 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
358 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
359 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
360 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
361 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
362 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
363 { PREINC, TOKENTYPE_NONE, "PREINC" },
364 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
365 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
366 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
367 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
368 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
369 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
370 { SUB, TOKENTYPE_NONE, "SUB" },
371 { THING, TOKENTYPE_OPVAL, "THING" },
372 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
373 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
374 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
375 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
376 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
377 { USE, TOKENTYPE_IVAL, "USE" },
378 { WHEN, TOKENTYPE_IVAL, "WHEN" },
379 { WHILE, TOKENTYPE_IVAL, "WHILE" },
380 { BAREWORD, TOKENTYPE_OPVAL, "BAREWORD" },
381 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
382 { 0, TOKENTYPE_NONE, NULL }
385 /* dump the returned token in rv, plus any optional arg in pl_yylval */
388 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
390 PERL_ARGS_ASSERT_TOKEREPORT;
393 const char *name = NULL;
394 enum token_type type = TOKENTYPE_NONE;
395 const struct debug_tokens *p;
396 SV* const report = newSVpvs("<== ");
398 for (p = debug_tokens; p->token; p++) {
399 if (p->token == (int)rv) {
406 Perl_sv_catpv(aTHX_ report, name);
407 else if (isGRAPH(rv))
409 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
411 sv_catpvs(report, " (pending identifier)");
414 sv_catpvs(report, "EOF");
416 Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv);
421 Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival);
423 case TOKENTYPE_OPNUM:
424 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
425 PL_op_name[lvalp->ival]);
428 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
430 case TOKENTYPE_OPVAL:
432 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
433 PL_op_name[lvalp->opval->op_type]);
434 if (lvalp->opval->op_type == OP_CONST) {
435 Perl_sv_catpvf(aTHX_ report, " %s",
436 SvPEEK(cSVOPx_sv(lvalp->opval)));
441 sv_catpvs(report, "(opval=null)");
444 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
450 /* print the buffer with suitable escapes */
453 S_printbuf(pTHX_ const char *const fmt, const char *const s)
455 SV* const tmp = newSVpvs("");
457 PERL_ARGS_ASSERT_PRINTBUF;
459 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
460 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
468 S_deprecate_commaless_var_list(pTHX) {
470 deprecate_fatal_in("5.28", "Use of comma-less variable list is deprecated");
471 return REPORT(','); /* grandfather non-comma-format format */
477 * This subroutine looks for an '=' next to the operator that has just been
478 * parsed and turns it into an ASSIGNOP if it finds one.
482 S_ao(pTHX_ int toketype)
484 if (*PL_bufptr == '=') {
486 if (toketype == ANDAND)
487 pl_yylval.ival = OP_ANDASSIGN;
488 else if (toketype == OROR)
489 pl_yylval.ival = OP_ORASSIGN;
490 else if (toketype == DORDOR)
491 pl_yylval.ival = OP_DORASSIGN;
494 return REPORT(toketype);
499 * When Perl expects an operator and finds something else, no_op
500 * prints the warning. It always prints "<something> found where
501 * operator expected. It prints "Missing semicolon on previous line?"
502 * if the surprise occurs at the start of the line. "do you need to
503 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
504 * where the compiler doesn't know if foo is a method call or a function.
505 * It prints "Missing operator before end of line" if there's nothing
506 * after the missing operator, or "... before <...>" if there is something
507 * after the missing operator.
509 * PL_bufptr is expected to point to the start of the thing that was found,
510 * and s after the next token or partial token.
514 S_no_op(pTHX_ const char *const what, char *s)
516 char * const oldbp = PL_bufptr;
517 const bool is_first = (PL_oldbufptr == PL_linestart);
519 PERL_ARGS_ASSERT_NO_OP;
525 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
526 if (ckWARN_d(WARN_SYNTAX)) {
528 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
529 "\t(Missing semicolon on previous line?)\n");
530 else if (PL_oldoldbufptr && isIDFIRST_lazy_if_safe(PL_oldoldbufptr,
535 for (t = PL_oldoldbufptr;
536 (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) || *t == ':');
537 t += UTF ? UTF8SKIP(t) : 1)
541 if (t < PL_bufptr && isSPACE(*t))
542 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
543 "\t(Do you need to predeclare %" UTF8f "?)\n",
544 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
548 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
549 "\t(Missing operator before %" UTF8f "?)\n",
550 UTF8fARG(UTF, s - oldbp, oldbp));
558 * Complain about missing quote/regexp/heredoc terminator.
559 * If it's called with NULL then it cauterizes the line buffer.
560 * If we're in a delimited string and the delimiter is a control
561 * character, it's reformatted into a two-char sequence like ^C.
566 S_missingterm(pTHX_ char *s)
568 char tmpbuf[UTF8_MAXBYTES + 1];
573 char * const nl = strrchr(s,'\n');
578 else if (PL_multi_close < 32) {
580 tmpbuf[1] = (char)toCTRL(PL_multi_close);
585 if (LIKELY(PL_multi_close < 256)) {
586 *tmpbuf = (char)PL_multi_close;
591 *uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close) = 0;
595 q = strchr(s,'"') ? '\'' : '"';
596 sv = sv_2mortal(newSVpv(s,0));
599 Perl_croak(aTHX_ "Can't find string terminator %c%" SVf
600 "%c anywhere before EOF",q,SVfARG(sv),q);
606 * Check whether the named feature is enabled.
609 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
611 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
613 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
615 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
617 if (namelen > MAX_FEATURE_LEN)
619 memcpy(&he_name[8], name, namelen);
621 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
622 REFCOUNTED_HE_EXISTS));
626 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
627 * utf16-to-utf8-reversed.
630 #ifdef PERL_CR_FILTER
634 const char *s = SvPVX_const(sv);
635 const char * const e = s + SvCUR(sv);
637 PERL_ARGS_ASSERT_STRIP_RETURN;
639 /* outer loop optimized to do nothing if there are no CR-LFs */
641 if (*s++ == '\r' && *s == '\n') {
642 /* hit a CR-LF, need to copy the rest */
646 if (*s == '\r' && s[1] == '\n')
657 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
659 const I32 count = FILTER_READ(idx+1, sv, maxlen);
660 if (count > 0 && !maxlen)
667 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
669 Creates and initialises a new lexer/parser state object, supplying
670 a context in which to lex and parse from a new source of Perl code.
671 A pointer to the new state object is placed in L</PL_parser>. An entry
672 is made on the save stack so that upon unwinding, the new state object
673 will be destroyed and the former value of L</PL_parser> will be restored.
674 Nothing else need be done to clean up the parsing context.
676 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
677 non-null, provides a string (in SV form) containing code to be parsed.
678 A copy of the string is made, so subsequent modification of C<line>
679 does not affect parsing. C<rsfp>, if non-null, provides an input stream
680 from which code will be read to be parsed. If both are non-null, the
681 code in C<line> comes first and must consist of complete lines of input,
682 and C<rsfp> supplies the remainder of the source.
684 The C<flags> parameter is reserved for future use. Currently it is only
685 used by perl internally, so extensions should always pass zero.
690 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
691 can share filters with the current parser.
692 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
693 caller, hence isn't owned by the parser, so shouldn't be closed on parser
694 destruction. This is used to handle the case of defaulting to reading the
695 script from the standard input because no filename was given on the command
696 line (without getting confused by situation where STDIN has been closed, so
697 the script handle is opened on fd 0) */
700 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
702 const char *s = NULL;
703 yy_parser *parser, *oparser;
705 if (flags && flags & ~LEX_START_FLAGS)
706 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
708 /* create and initialise a parser */
710 Newxz(parser, 1, yy_parser);
711 parser->old_parser = oparser = PL_parser;
714 parser->stack = NULL;
715 parser->stack_max1 = NULL;
718 /* on scope exit, free this parser and restore any outer one */
720 parser->saved_curcop = PL_curcop;
722 /* initialise lexer state */
724 parser->nexttoke = 0;
725 parser->error_count = oparser ? oparser->error_count : 0;
726 parser->copline = parser->preambling = NOLINE;
727 parser->lex_state = LEX_NORMAL;
728 parser->expect = XSTATE;
730 parser->recheck_utf8_validity = FALSE;
731 parser->rsfp_filters =
732 !(flags & LEX_START_SAME_FILTER) || !oparser
734 : MUTABLE_AV(SvREFCNT_inc(
735 oparser->rsfp_filters
736 ? oparser->rsfp_filters
737 : (oparser->rsfp_filters = newAV())
740 Newx(parser->lex_brackstack, 120, char);
741 Newx(parser->lex_casestack, 12, char);
742 *parser->lex_casestack = '\0';
743 Newxz(parser->lex_shared, 1, LEXSHARED);
747 const U8* first_bad_char_loc;
749 s = SvPV_const(line, len);
752 && UNLIKELY(! is_utf8_string_loc((U8 *) s,
754 &first_bad_char_loc)))
756 _force_out_malformed_utf8_message(first_bad_char_loc,
757 (U8 *) s + SvCUR(line),
759 1 /* 1 means die */ );
760 NOT_REACHED; /* NOTREACHED */
763 parser->linestr = flags & LEX_START_COPIED
764 ? SvREFCNT_inc_simple_NN(line)
765 : newSVpvn_flags(s, len, SvUTF8(line));
767 sv_catpvs(parser->linestr, "\n;");
769 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
772 parser->oldoldbufptr =
775 parser->linestart = SvPVX(parser->linestr);
776 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
777 parser->last_lop = parser->last_uni = NULL;
779 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
780 |LEX_DONT_CLOSE_RSFP));
781 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
782 |LEX_DONT_CLOSE_RSFP));
784 parser->in_pod = parser->filtered = 0;
788 /* delete a parser object */
791 Perl_parser_free(pTHX_ const yy_parser *parser)
793 PERL_ARGS_ASSERT_PARSER_FREE;
795 PL_curcop = parser->saved_curcop;
796 SvREFCNT_dec(parser->linestr);
798 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
799 PerlIO_clearerr(parser->rsfp);
800 else if (parser->rsfp && (!parser->old_parser
801 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
802 PerlIO_close(parser->rsfp);
803 SvREFCNT_dec(parser->rsfp_filters);
804 SvREFCNT_dec(parser->lex_stuff);
805 SvREFCNT_dec(parser->lex_sub_repl);
807 Safefree(parser->lex_brackstack);
808 Safefree(parser->lex_casestack);
809 Safefree(parser->lex_shared);
810 PL_parser = parser->old_parser;
815 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
817 I32 nexttoke = parser->nexttoke;
818 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
820 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
821 && parser->nextval[nexttoke].opval
822 && parser->nextval[nexttoke].opval->op_slabbed
823 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
824 op_free(parser->nextval[nexttoke].opval);
825 parser->nextval[nexttoke].opval = NULL;
832 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
834 Buffer scalar containing the chunk currently under consideration of the
835 text currently being lexed. This is always a plain string scalar (for
836 which C<SvPOK> is true). It is not intended to be used as a scalar by
837 normal scalar means; instead refer to the buffer directly by the pointer
838 variables described below.
840 The lexer maintains various C<char*> pointers to things in the
841 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
842 reallocated, all of these pointers must be updated. Don't attempt to
843 do this manually, but rather use L</lex_grow_linestr> if you need to
844 reallocate the buffer.
846 The content of the text chunk in the buffer is commonly exactly one
847 complete line of input, up to and including a newline terminator,
848 but there are situations where it is otherwise. The octets of the
849 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
850 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
851 flag on this scalar, which may disagree with it.
853 For direct examination of the buffer, the variable
854 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
855 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
856 of these pointers is usually preferable to examination of the scalar
857 through normal scalar means.
859 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
861 Direct pointer to the end of the chunk of text currently being lexed, the
862 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
863 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
864 always located at the end of the buffer, and does not count as part of
865 the buffer's contents.
867 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
869 Points to the current position of lexing inside the lexer buffer.
870 Characters around this point may be freely examined, within
871 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
872 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
873 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
875 Lexing code (whether in the Perl core or not) moves this pointer past
876 the characters that it consumes. It is also expected to perform some
877 bookkeeping whenever a newline character is consumed. This movement
878 can be more conveniently performed by the function L</lex_read_to>,
879 which handles newlines appropriately.
881 Interpretation of the buffer's octets can be abstracted out by
882 using the slightly higher-level functions L</lex_peek_unichar> and
883 L</lex_read_unichar>.
885 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
887 Points to the start of the current line inside the lexer buffer.
888 This is useful for indicating at which column an error occurred, and
889 not much else. This must be updated by any lexing code that consumes
890 a newline; the function L</lex_read_to> handles this detail.
896 =for apidoc Amx|bool|lex_bufutf8
898 Indicates whether the octets in the lexer buffer
899 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
900 of Unicode characters. If not, they should be interpreted as Latin-1
901 characters. This is analogous to the C<SvUTF8> flag for scalars.
903 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
904 contains valid UTF-8. Lexing code must be robust in the face of invalid
907 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
908 is significant, but not the whole story regarding the input character
909 encoding. Normally, when a file is being read, the scalar contains octets
910 and its C<SvUTF8> flag is off, but the octets should be interpreted as
911 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
912 however, the scalar may have the C<SvUTF8> flag on, and in this case its
913 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
914 is in effect. This logic may change in the future; use this function
915 instead of implementing the logic yourself.
921 Perl_lex_bufutf8(pTHX)
927 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
929 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
930 at least C<len> octets (including terminating C<NUL>). Returns a
931 pointer to the reallocated buffer. This is necessary before making
932 any direct modification of the buffer that would increase its length.
933 L</lex_stuff_pvn> provides a more convenient way to insert text into
936 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
937 this function updates all of the lexer's variables that point directly
944 Perl_lex_grow_linestr(pTHX_ STRLEN len)
948 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
949 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
952 linestr = PL_parser->linestr;
953 buf = SvPVX(linestr);
954 if (len <= SvLEN(linestr))
957 /* Is the lex_shared linestr SV the same as the current linestr SV?
958 * Only in this case does re_eval_start need adjusting, since it
959 * points within lex_shared->ls_linestr's buffer */
960 current = ( !PL_parser->lex_shared->ls_linestr
961 || linestr == PL_parser->lex_shared->ls_linestr);
963 bufend_pos = PL_parser->bufend - buf;
964 bufptr_pos = PL_parser->bufptr - buf;
965 oldbufptr_pos = PL_parser->oldbufptr - buf;
966 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
967 linestart_pos = PL_parser->linestart - buf;
968 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
969 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
970 re_eval_start_pos = (current && PL_parser->lex_shared->re_eval_start) ?
971 PL_parser->lex_shared->re_eval_start - buf : 0;
973 buf = sv_grow(linestr, len);
975 PL_parser->bufend = buf + bufend_pos;
976 PL_parser->bufptr = buf + bufptr_pos;
977 PL_parser->oldbufptr = buf + oldbufptr_pos;
978 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
979 PL_parser->linestart = buf + linestart_pos;
980 if (PL_parser->last_uni)
981 PL_parser->last_uni = buf + last_uni_pos;
982 if (PL_parser->last_lop)
983 PL_parser->last_lop = buf + last_lop_pos;
984 if (current && PL_parser->lex_shared->re_eval_start)
985 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
990 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
992 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
993 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
994 reallocating the buffer if necessary. This means that lexing code that
995 runs later will see the characters as if they had appeared in the input.
996 It is not recommended to do this as part of normal parsing, and most
997 uses of this facility run the risk of the inserted characters being
998 interpreted in an unintended manner.
1000 The string to be inserted is represented by C<len> octets starting
1001 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
1002 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
1003 The characters are recoded for the lexer buffer, according to how the
1004 buffer is currently being interpreted (L</lex_bufutf8>). If a string
1005 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
1006 function is more convenient.
1012 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1016 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1017 if (flags & ~(LEX_STUFF_UTF8))
1018 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1020 if (flags & LEX_STUFF_UTF8) {
1023 STRLEN highhalf = 0; /* Count of variants */
1024 const char *p, *e = pv+len;
1025 for (p = pv; p != e; p++) {
1026 if (! UTF8_IS_INVARIANT(*p)) {
1032 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1033 bufptr = PL_parser->bufptr;
1034 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1035 SvCUR_set(PL_parser->linestr,
1036 SvCUR(PL_parser->linestr) + len+highhalf);
1037 PL_parser->bufend += len+highhalf;
1038 for (p = pv; p != e; p++) {
1040 if (! UTF8_IS_INVARIANT(c)) {
1041 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1042 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1044 *bufptr++ = (char)c;
1049 if (flags & LEX_STUFF_UTF8) {
1050 STRLEN highhalf = 0;
1051 const char *p, *e = pv+len;
1052 for (p = pv; p != e; p++) {
1054 if (UTF8_IS_ABOVE_LATIN1(c)) {
1055 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1056 "non-Latin-1 character into Latin-1 input");
1057 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1060 } else assert(UTF8_IS_INVARIANT(c));
1064 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1065 bufptr = PL_parser->bufptr;
1066 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1067 SvCUR_set(PL_parser->linestr,
1068 SvCUR(PL_parser->linestr) + len-highhalf);
1069 PL_parser->bufend += len-highhalf;
1072 if (UTF8_IS_INVARIANT(*p)) {
1078 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1084 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1085 bufptr = PL_parser->bufptr;
1086 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1087 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1088 PL_parser->bufend += len;
1089 Copy(pv, bufptr, len, char);
1095 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1097 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1098 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1099 reallocating the buffer if necessary. This means that lexing code that
1100 runs later will see the characters as if they had appeared in the input.
1101 It is not recommended to do this as part of normal parsing, and most
1102 uses of this facility run the risk of the inserted characters being
1103 interpreted in an unintended manner.
1105 The string to be inserted is represented by octets starting at C<pv>
1106 and continuing to the first nul. These octets are interpreted as either
1107 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1108 in C<flags>. The characters are recoded for the lexer buffer, according
1109 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1110 If it is not convenient to nul-terminate a string to be inserted, the
1111 L</lex_stuff_pvn> function is more appropriate.
1117 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1119 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1120 lex_stuff_pvn(pv, strlen(pv), flags);
1124 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1126 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1127 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1128 reallocating the buffer if necessary. This means that lexing code that
1129 runs later will see the characters as if they had appeared in the input.
1130 It is not recommended to do this as part of normal parsing, and most
1131 uses of this facility run the risk of the inserted characters being
1132 interpreted in an unintended manner.
1134 The string to be inserted is the string value of C<sv>. The characters
1135 are recoded for the lexer buffer, according to how the buffer is currently
1136 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1137 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1138 need to construct a scalar.
1144 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1148 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1150 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1152 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1156 =for apidoc Amx|void|lex_unstuff|char *ptr
1158 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1159 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1160 This hides the discarded text from any lexing code that runs later,
1161 as if the text had never appeared.
1163 This is not the normal way to consume lexed text. For that, use
1170 Perl_lex_unstuff(pTHX_ char *ptr)
1174 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1175 buf = PL_parser->bufptr;
1177 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1180 bufend = PL_parser->bufend;
1182 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1183 unstuff_len = ptr - buf;
1184 Move(ptr, buf, bufend+1-ptr, char);
1185 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1186 PL_parser->bufend = bufend - unstuff_len;
1190 =for apidoc Amx|void|lex_read_to|char *ptr
1192 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1193 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1194 performing the correct bookkeeping whenever a newline character is passed.
1195 This is the normal way to consume lexed text.
1197 Interpretation of the buffer's octets can be abstracted out by
1198 using the slightly higher-level functions L</lex_peek_unichar> and
1199 L</lex_read_unichar>.
1205 Perl_lex_read_to(pTHX_ char *ptr)
1208 PERL_ARGS_ASSERT_LEX_READ_TO;
1209 s = PL_parser->bufptr;
1210 if (ptr < s || ptr > PL_parser->bufend)
1211 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1212 for (; s != ptr; s++)
1214 COPLINE_INC_WITH_HERELINES;
1215 PL_parser->linestart = s+1;
1217 PL_parser->bufptr = ptr;
1221 =for apidoc Amx|void|lex_discard_to|char *ptr
1223 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1224 up to C<ptr>. The remaining content of the buffer will be moved, and
1225 all pointers into the buffer updated appropriately. C<ptr> must not
1226 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1227 it is not permitted to discard text that has yet to be lexed.
1229 Normally it is not necessarily to do this directly, because it suffices to
1230 use the implicit discarding behaviour of L</lex_next_chunk> and things
1231 based on it. However, if a token stretches across multiple lines,
1232 and the lexing code has kept multiple lines of text in the buffer for
1233 that purpose, then after completion of the token it would be wise to
1234 explicitly discard the now-unneeded earlier lines, to avoid future
1235 multi-line tokens growing the buffer without bound.
1241 Perl_lex_discard_to(pTHX_ char *ptr)
1245 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1246 buf = SvPVX(PL_parser->linestr);
1248 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1251 if (ptr > PL_parser->bufptr)
1252 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1253 discard_len = ptr - buf;
1254 if (PL_parser->oldbufptr < ptr)
1255 PL_parser->oldbufptr = ptr;
1256 if (PL_parser->oldoldbufptr < ptr)
1257 PL_parser->oldoldbufptr = ptr;
1258 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1259 PL_parser->last_uni = NULL;
1260 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1261 PL_parser->last_lop = NULL;
1262 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1263 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1264 PL_parser->bufend -= discard_len;
1265 PL_parser->bufptr -= discard_len;
1266 PL_parser->oldbufptr -= discard_len;
1267 PL_parser->oldoldbufptr -= discard_len;
1268 if (PL_parser->last_uni)
1269 PL_parser->last_uni -= discard_len;
1270 if (PL_parser->last_lop)
1271 PL_parser->last_lop -= discard_len;
1275 Perl_notify_parser_that_changed_to_utf8(pTHX)
1277 /* Called when $^H is changed to indicate that HINT_UTF8 has changed from
1278 * off to on. At compile time, this has the effect of entering a 'use
1279 * utf8' section. This means that any input was not previously checked for
1280 * UTF-8 (because it was off), but now we do need to check it, or our
1281 * assumptions about the input being sane could be wrong, and we could
1282 * segfault. This routine just sets a flag so that the next time we look
1283 * at the input we do the well-formed UTF-8 check. If we aren't in the
1284 * proper phase, there may not be a parser object, but if there is, setting
1285 * the flag is harmless */
1288 PL_parser->recheck_utf8_validity = TRUE;
1293 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1295 Reads in the next chunk of text to be lexed, appending it to
1296 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1297 looked to the end of the current chunk and wants to know more. It is
1298 usual, but not necessary, for lexing to have consumed the entirety of
1299 the current chunk at this time.
1301 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1302 chunk (i.e., the current chunk has been entirely consumed), normally the
1303 current chunk will be discarded at the same time that the new chunk is
1304 read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1305 will not be discarded. If the current chunk has not been entirely
1306 consumed, then it will not be discarded regardless of the flag.
1308 Returns true if some new text was added to the buffer, or false if the
1309 buffer has reached the end of the input text.
1314 #define LEX_FAKE_EOF 0x80000000
1315 #define LEX_NO_TERM 0x40000000 /* here-doc */
1318 Perl_lex_next_chunk(pTHX_ U32 flags)
1322 STRLEN old_bufend_pos, new_bufend_pos;
1323 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1324 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1325 bool got_some_for_debugger = 0;
1328 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1329 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1330 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1332 linestr = PL_parser->linestr;
1333 buf = SvPVX(linestr);
1334 if (!(flags & LEX_KEEP_PREVIOUS)
1335 && PL_parser->bufptr == PL_parser->bufend)
1337 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1339 if (PL_parser->last_uni != PL_parser->bufend)
1340 PL_parser->last_uni = NULL;
1341 if (PL_parser->last_lop != PL_parser->bufend)
1342 PL_parser->last_lop = NULL;
1343 last_uni_pos = last_lop_pos = 0;
1347 old_bufend_pos = PL_parser->bufend - buf;
1348 bufptr_pos = PL_parser->bufptr - buf;
1349 oldbufptr_pos = PL_parser->oldbufptr - buf;
1350 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1351 linestart_pos = PL_parser->linestart - buf;
1352 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1353 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1355 if (flags & LEX_FAKE_EOF) {
1357 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1359 } else if (filter_gets(linestr, old_bufend_pos)) {
1361 got_some_for_debugger = 1;
1362 } else if (flags & LEX_NO_TERM) {
1365 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1368 /* End of real input. Close filehandle (unless it was STDIN),
1369 * then add implicit termination.
1371 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1372 PerlIO_clearerr(PL_parser->rsfp);
1373 else if (PL_parser->rsfp)
1374 (void)PerlIO_close(PL_parser->rsfp);
1375 PL_parser->rsfp = NULL;
1376 PL_parser->in_pod = PL_parser->filtered = 0;
1377 if (!PL_in_eval && PL_minus_p) {
1379 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1380 PL_minus_n = PL_minus_p = 0;
1381 } else if (!PL_in_eval && PL_minus_n) {
1382 sv_catpvs(linestr, /*{*/";}");
1385 sv_catpvs(linestr, ";");
1388 buf = SvPVX(linestr);
1389 new_bufend_pos = SvCUR(linestr);
1390 PL_parser->bufend = buf + new_bufend_pos;
1391 PL_parser->bufptr = buf + bufptr_pos;
1394 const U8* first_bad_char_loc;
1395 if (UNLIKELY(! is_utf8_string_loc(
1396 (U8 *) PL_parser->bufptr,
1397 PL_parser->bufend - PL_parser->bufptr,
1398 &first_bad_char_loc)))
1400 _force_out_malformed_utf8_message(first_bad_char_loc,
1401 (U8 *) PL_parser->bufend,
1403 1 /* 1 means die */ );
1404 NOT_REACHED; /* NOTREACHED */
1408 PL_parser->oldbufptr = buf + oldbufptr_pos;
1409 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1410 PL_parser->linestart = buf + linestart_pos;
1411 if (PL_parser->last_uni)
1412 PL_parser->last_uni = buf + last_uni_pos;
1413 if (PL_parser->last_lop)
1414 PL_parser->last_lop = buf + last_lop_pos;
1415 if (PL_parser->preambling != NOLINE) {
1416 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1417 PL_parser->preambling = NOLINE;
1419 if ( got_some_for_debugger
1420 && PERLDB_LINE_OR_SAVESRC
1421 && PL_curstash != PL_debstash)
1423 /* debugger active and we're not compiling the debugger code,
1424 * so store the line into the debugger's array of lines
1426 update_debugger_info(NULL, buf+old_bufend_pos,
1427 new_bufend_pos-old_bufend_pos);
1433 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1435 Looks ahead one (Unicode) character in the text currently being lexed.
1436 Returns the codepoint (unsigned integer value) of the next character,
1437 or -1 if lexing has reached the end of the input text. To consume the
1438 peeked character, use L</lex_read_unichar>.
1440 If the next character is in (or extends into) the next chunk of input
1441 text, the next chunk will be read in. Normally the current chunk will be
1442 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1443 bit set, then the current chunk will not be discarded.
1445 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1446 is encountered, an exception is generated.
1452 Perl_lex_peek_unichar(pTHX_ U32 flags)
1456 if (flags & ~(LEX_KEEP_PREVIOUS))
1457 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1458 s = PL_parser->bufptr;
1459 bufend = PL_parser->bufend;
1465 if (!lex_next_chunk(flags))
1467 s = PL_parser->bufptr;
1468 bufend = PL_parser->bufend;
1471 if (UTF8_IS_INVARIANT(head))
1473 if (UTF8_IS_START(head)) {
1474 len = UTF8SKIP(&head);
1475 while ((STRLEN)(bufend-s) < len) {
1476 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1478 s = PL_parser->bufptr;
1479 bufend = PL_parser->bufend;
1482 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1483 if (retlen == (STRLEN)-1) {
1484 _force_out_malformed_utf8_message((U8 *) s,
1487 1 /* 1 means die */ );
1488 NOT_REACHED; /* NOTREACHED */
1493 if (!lex_next_chunk(flags))
1495 s = PL_parser->bufptr;
1502 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1504 Reads the next (Unicode) character in the text currently being lexed.
1505 Returns the codepoint (unsigned integer value) of the character read,
1506 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1507 if lexing has reached the end of the input text. To non-destructively
1508 examine the next character, use L</lex_peek_unichar> instead.
1510 If the next character is in (or extends into) the next chunk of input
1511 text, the next chunk will be read in. Normally the current chunk will be
1512 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1513 bit set, then the current chunk will not be discarded.
1515 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1516 is encountered, an exception is generated.
1522 Perl_lex_read_unichar(pTHX_ U32 flags)
1525 if (flags & ~(LEX_KEEP_PREVIOUS))
1526 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1527 c = lex_peek_unichar(flags);
1530 COPLINE_INC_WITH_HERELINES;
1532 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1534 ++(PL_parser->bufptr);
1540 =for apidoc Amx|void|lex_read_space|U32 flags
1542 Reads optional spaces, in Perl style, in the text currently being
1543 lexed. The spaces may include ordinary whitespace characters and
1544 Perl-style comments. C<#line> directives are processed if encountered.
1545 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1546 at a non-space character (or the end of the input text).
1548 If spaces extend into the next chunk of input text, the next chunk will
1549 be read in. Normally the current chunk will be discarded at the same
1550 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1551 chunk will not be discarded.
1556 #define LEX_NO_INCLINE 0x40000000
1557 #define LEX_NO_NEXT_CHUNK 0x80000000
1560 Perl_lex_read_space(pTHX_ U32 flags)
1563 const bool can_incline = !(flags & LEX_NO_INCLINE);
1564 bool need_incline = 0;
1565 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1566 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1567 s = PL_parser->bufptr;
1568 bufend = PL_parser->bufend;
1574 } while (!(c == '\n' || (c == 0 && s == bufend)));
1575 } else if (c == '\n') {
1578 PL_parser->linestart = s;
1584 } else if (isSPACE(c)) {
1586 } else if (c == 0 && s == bufend) {
1589 if (flags & LEX_NO_NEXT_CHUNK)
1591 PL_parser->bufptr = s;
1592 l = CopLINE(PL_curcop);
1593 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1594 got_more = lex_next_chunk(flags);
1595 CopLINE_set(PL_curcop, l);
1596 s = PL_parser->bufptr;
1597 bufend = PL_parser->bufend;
1600 if (can_incline && need_incline && PL_parser->rsfp) {
1610 PL_parser->bufptr = s;
1615 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1617 This function performs syntax checking on a prototype, C<proto>.
1618 If C<warn> is true, any illegal characters or mismatched brackets
1619 will trigger illegalproto warnings, declaring that they were
1620 detected in the prototype for C<name>.
1622 The return value is C<true> if this is a valid prototype, and
1623 C<false> if it is not, regardless of whether C<warn> was C<true> or
1626 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1633 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1635 STRLEN len, origlen;
1637 bool bad_proto = FALSE;
1638 bool in_brackets = FALSE;
1639 bool after_slash = FALSE;
1640 char greedy_proto = ' ';
1641 bool proto_after_greedy_proto = FALSE;
1642 bool must_be_last = FALSE;
1643 bool underscore = FALSE;
1644 bool bad_proto_after_underscore = FALSE;
1646 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1651 p = SvPV(proto, len);
1653 for (; len--; p++) {
1656 proto_after_greedy_proto = TRUE;
1658 if (!strchr(";@%", *p))
1659 bad_proto_after_underscore = TRUE;
1662 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1669 in_brackets = FALSE;
1670 else if ((*p == '@' || *p == '%')
1674 must_be_last = TRUE;
1683 after_slash = FALSE;
1688 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1691 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1692 origlen, UNI_DISPLAY_ISPRINT)
1693 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1695 if (proto_after_greedy_proto)
1696 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1697 "Prototype after '%c' for %" SVf " : %s",
1698 greedy_proto, SVfARG(name), p);
1700 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1701 "Missing ']' in prototype for %" SVf " : %s",
1704 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1705 "Illegal character in prototype for %" SVf " : %s",
1707 if (bad_proto_after_underscore)
1708 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1709 "Illegal character after '_' in prototype for %" SVf " : %s",
1713 return (! (proto_after_greedy_proto || bad_proto) );
1718 * This subroutine has nothing to do with tilting, whether at windmills
1719 * or pinball tables. Its name is short for "increment line". It
1720 * increments the current line number in CopLINE(PL_curcop) and checks
1721 * to see whether the line starts with a comment of the form
1722 * # line 500 "foo.pm"
1723 * If so, it sets the current line number and file to the values in the comment.
1727 S_incline(pTHX_ const char *s)
1735 PERL_ARGS_ASSERT_INCLINE;
1737 COPLINE_INC_WITH_HERELINES;
1738 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1739 && s+1 == PL_bufend && *s == ';') {
1740 /* fake newline in string eval */
1741 CopLINE_dec(PL_curcop);
1746 while (SPACE_OR_TAB(*s))
1748 if (strEQs(s, "line"))
1752 if (SPACE_OR_TAB(*s))
1756 while (SPACE_OR_TAB(*s))
1764 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1766 while (SPACE_OR_TAB(*s))
1768 if (*s == '"' && (t = strchr(s+1, '"'))) {
1774 while (*t && !isSPACE(*t))
1778 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1780 if (*e != '\n' && *e != '\0')
1781 return; /* false alarm */
1783 if (!grok_atoUV(n, &uv, &e))
1785 line_num = ((line_t)uv) - 1;
1788 const STRLEN len = t - s;
1790 if (!PL_rsfp && !PL_parser->filtered) {
1791 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1792 * to *{"::_<newfilename"} */
1793 /* However, the long form of evals is only turned on by the
1794 debugger - usually they're "(eval %lu)" */
1795 GV * const cfgv = CopFILEGV(PL_curcop);
1798 STRLEN tmplen2 = len;
1802 if (tmplen2 + 2 <= sizeof smallbuf)
1805 Newx(tmpbuf2, tmplen2 + 2, char);
1810 memcpy(tmpbuf2 + 2, s, tmplen2);
1813 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1815 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1816 /* adjust ${"::_<newfilename"} to store the new file name */
1817 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1818 /* The line number may differ. If that is the case,
1819 alias the saved lines that are in the array.
1820 Otherwise alias the whole array. */
1821 if (CopLINE(PL_curcop) == line_num) {
1822 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1823 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1825 else if (GvAV(cfgv)) {
1826 AV * const av = GvAV(cfgv);
1827 const I32 start = CopLINE(PL_curcop)+1;
1828 I32 items = AvFILLp(av) - start;
1830 AV * const av2 = GvAVn(gv2);
1831 SV **svp = AvARRAY(av) + start;
1832 I32 l = (I32)line_num+1;
1834 av_store(av2, l++, SvREFCNT_inc(*svp++));
1839 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1842 CopFILE_free(PL_curcop);
1843 CopFILE_setn(PL_curcop, s, len);
1845 CopLINE_set(PL_curcop, line_num);
1849 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1851 AV *av = CopFILEAVx(PL_curcop);
1854 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1856 sv = *av_fetch(av, 0, 1);
1857 SvUPGRADE(sv, SVt_PVMG);
1859 if (!SvPOK(sv)) SvPVCLEAR(sv);
1861 sv_catsv(sv, orig_sv);
1863 sv_catpvn(sv, buf, len);
1868 if (PL_parser->preambling == NOLINE)
1869 av_store(av, CopLINE(PL_curcop), sv);
1875 * Called to gobble the appropriate amount and type of whitespace.
1876 * Skips comments as well.
1877 * Returns the next character after the whitespace that is skipped.
1880 * Same thing, but look ahead without incrementing line numbers or
1881 * adjusting PL_linestart.
1884 #define skipspace(s) skipspace_flags(s, 0)
1885 #define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
1888 S_skipspace_flags(pTHX_ char *s, U32 flags)
1890 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1891 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1892 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1895 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1897 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1898 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1899 LEX_NO_NEXT_CHUNK : 0));
1901 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1902 if (PL_linestart > PL_bufptr)
1903 PL_bufptr = PL_linestart;
1911 * Check the unary operators to ensure there's no ambiguity in how they're
1912 * used. An ambiguous piece of code would be:
1914 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1915 * the +5 is its argument.
1924 if (PL_oldoldbufptr != PL_last_uni)
1926 while (isSPACE(*PL_last_uni))
1929 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-')
1930 s += UTF ? UTF8SKIP(s) : 1;
1931 if ((t = strchr(s, '(')) && t < PL_bufptr)
1934 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1935 "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous",
1936 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1940 * LOP : macro to build a list operator. Its behaviour has been replaced
1941 * with a subroutine, S_lop() for which LOP is just another name.
1944 #define LOP(f,x) return lop(f,x,s)
1948 * Build a list operator (or something that might be one). The rules:
1949 * - if we have a next token, then it's a list operator (no parens) for
1950 * which the next token has already been parsed; e.g.,
1953 * - if the next thing is an opening paren, then it's a function
1954 * - else it's a list operator
1958 S_lop(pTHX_ I32 f, U8 x, char *s)
1960 PERL_ARGS_ASSERT_LOP;
1965 PL_last_lop = PL_oldbufptr;
1966 PL_last_lop_op = (OPCODE)f;
1971 return REPORT(FUNC);
1974 return REPORT(FUNC);
1977 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1978 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1979 return REPORT(LSTOP);
1985 * When the lexer realizes it knows the next token (for instance,
1986 * it is reordering tokens for the parser) then it can call S_force_next
1987 * to know what token to return the next time the lexer is called. Caller
1988 * will need to set PL_nextval[] and possibly PL_expect to ensure
1989 * the lexer handles the token correctly.
1993 S_force_next(pTHX_ I32 type)
1997 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1998 tokereport(type, &NEXTVAL_NEXTTOKE);
2001 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
2002 PL_nexttype[PL_nexttoke] = type;
2009 * This subroutine handles postfix deref syntax after the arrow has already
2010 * been emitted. @* $* etc. are emitted as two separate token right here.
2011 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
2012 * only the first, leaving yylex to find the next.
2016 S_postderef(pTHX_ int const funny, char const next)
2018 assert(funny == DOLSHARP || strchr("$@%&*", funny));
2020 PL_expect = XOPERATOR;
2021 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
2022 assert('@' == funny || '$' == funny || DOLSHARP == funny);
2023 PL_lex_state = LEX_INTERPEND;
2025 force_next(POSTJOIN);
2031 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
2032 && !PL_lex_brackets)
2034 PL_expect = XOPERATOR;
2043 int yyc = PL_parser->yychar;
2044 if (yyc != YYEMPTY) {
2046 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2047 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2048 PL_lex_allbrackets--;
2050 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2051 } else if (yyc == '('/*)*/) {
2052 PL_lex_allbrackets--;
2057 PL_parser->yychar = YYEMPTY;
2062 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2064 SV * const sv = newSVpvn_utf8(start, len,
2067 && !is_utf8_invariant_string((const U8*)start, len)
2068 && is_utf8_string((const U8*)start, len));
2074 * When the lexer knows the next thing is a word (for instance, it has
2075 * just seen -> and it knows that the next char is a word char, then
2076 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2080 * char *start : buffer position (must be within PL_linestr)
2081 * int token : PL_next* will be this type of bare word
2082 * (e.g., METHOD,BAREWORD)
2083 * int check_keyword : if true, Perl checks to make sure the word isn't
2084 * a keyword (do this if the word is a label, e.g. goto FOO)
2085 * int allow_pack : if true, : characters will also be allowed (require,
2086 * use, etc. do this)
2090 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2095 PERL_ARGS_ASSERT_FORCE_WORD;
2097 start = skipspace(start);
2099 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
2100 || (allow_pack && *s == ':' && s[1] == ':') )
2102 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2103 if (check_keyword) {
2104 char *s2 = PL_tokenbuf;
2106 if (allow_pack && len > 6 && strEQs(s2, "CORE::"))
2108 if (keyword(s2, len2, 0))
2111 if (token == METHOD) {
2116 PL_expect = XOPERATOR;
2119 NEXTVAL_NEXTTOKE.opval
2120 = newSVOP(OP_CONST,0,
2121 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2122 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2130 * Called when the lexer wants $foo *foo &foo etc, but the program
2131 * text only contains the "foo" portion. The first argument is a pointer
2132 * to the "foo", and the second argument is the type symbol to prefix.
2133 * Forces the next token to be a "BAREWORD".
2134 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2138 S_force_ident(pTHX_ const char *s, int kind)
2140 PERL_ARGS_ASSERT_FORCE_IDENT;
2143 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2144 OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2145 UTF ? SVf_UTF8 : 0));
2146 NEXTVAL_NEXTTOKE.opval = o;
2147 force_next(BAREWORD);
2149 o->op_private = OPpCONST_ENTERED;
2150 /* XXX see note in pp_entereval() for why we forgo typo
2151 warnings if the symbol must be introduced in an eval.
2153 gv_fetchpvn_flags(s, len,
2154 (PL_in_eval ? GV_ADDMULTI
2155 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2156 kind == '$' ? SVt_PV :
2157 kind == '@' ? SVt_PVAV :
2158 kind == '%' ? SVt_PVHV :
2166 S_force_ident_maybe_lex(pTHX_ char pit)
2168 NEXTVAL_NEXTTOKE.ival = pit;
2173 Perl_str_to_version(pTHX_ SV *sv)
2178 const char *start = SvPV_const(sv,len);
2179 const char * const end = start + len;
2180 const bool utf = cBOOL(SvUTF8(sv));
2182 PERL_ARGS_ASSERT_STR_TO_VERSION;
2184 while (start < end) {
2188 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2193 retval += ((NV)n)/nshift;
2202 * Forces the next token to be a version number.
2203 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2204 * and if "guessing" is TRUE, then no new token is created (and the caller
2205 * must use an alternative parsing method).
2209 S_force_version(pTHX_ char *s, int guessing)
2214 PERL_ARGS_ASSERT_FORCE_VERSION;
2222 while (isDIGIT(*d) || *d == '_' || *d == '.')
2224 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2226 s = scan_num(s, &pl_yylval);
2227 version = pl_yylval.opval;
2228 ver = cSVOPx(version)->op_sv;
2229 if (SvPOK(ver) && !SvNIOK(ver)) {
2230 SvUPGRADE(ver, SVt_PVNV);
2231 SvNV_set(ver, str_to_version(ver));
2232 SvNOK_on(ver); /* hint that it is a version */
2235 else if (guessing) {
2240 /* NOTE: The parser sees the package name and the VERSION swapped */
2241 NEXTVAL_NEXTTOKE.opval = version;
2242 force_next(BAREWORD);
2248 * S_force_strict_version
2249 * Forces the next token to be a version number using strict syntax rules.
2253 S_force_strict_version(pTHX_ char *s)
2256 const char *errstr = NULL;
2258 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2260 while (isSPACE(*s)) /* leading whitespace */
2263 if (is_STRICT_VERSION(s,&errstr)) {
2265 s = (char *)scan_version(s, ver, 0);
2266 version = newSVOP(OP_CONST, 0, ver);
2268 else if ((*s != ';' && *s != '{' && *s != '}' )
2269 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2273 yyerror(errstr); /* version required */
2277 /* NOTE: The parser sees the package name and the VERSION swapped */
2278 NEXTVAL_NEXTTOKE.opval = version;
2279 force_next(BAREWORD);
2286 * Turns any \\ into \ in a quoted string passed in in 'sv', returning 'sv',
2287 * modified as necessary. However, if HINT_NEW_STRING is on, 'sv' is
2288 * unchanged, and a new SV containing the modified input is returned.
2292 S_tokeq(pTHX_ SV *sv)
2299 PERL_ARGS_ASSERT_TOKEQ;
2303 assert (!SvIsCOW(sv));
2304 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2308 /* This is relying on the SV being "well formed" with a trailing '\0' */
2309 while (s < send && !(*s == '\\' && s[1] == '\\'))
2314 if ( PL_hints & HINT_NEW_STRING ) {
2315 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2316 SVs_TEMP | SvUTF8(sv));
2320 if (s + 1 < send && (s[1] == '\\'))
2321 s++; /* all that, just for this */
2326 SvCUR_set(sv, d - SvPVX_const(sv));
2328 if ( PL_hints & HINT_NEW_STRING )
2329 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2334 * Now come three functions related to double-quote context,
2335 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2336 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2337 * interact with PL_lex_state, and create fake ( ... ) argument lists
2338 * to handle functions and concatenation.
2342 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2347 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2349 * Pattern matching will set PL_lex_op to the pattern-matching op to
2350 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2352 * OP_CONST is easy--just make the new op and return.
2354 * Everything else becomes a FUNC.
2356 * Sets PL_lex_state to LEX_INTERPPUSH unless ival was OP_NULL or we
2357 * had an OP_CONST. This just sets us up for a
2358 * call to S_sublex_push().
2362 S_sublex_start(pTHX)
2364 const I32 op_type = pl_yylval.ival;
2366 if (op_type == OP_NULL) {
2367 pl_yylval.opval = PL_lex_op;
2371 if (op_type == OP_CONST) {
2372 SV *sv = PL_lex_stuff;
2373 PL_lex_stuff = NULL;
2376 if (SvTYPE(sv) == SVt_PVIV) {
2377 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2379 const char * const p = SvPV_const(sv, len);
2380 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2384 pl_yylval.opval = newSVOP(op_type, 0, sv);
2388 PL_parser->lex_super_state = PL_lex_state;
2389 PL_parser->lex_sub_inwhat = (U16)op_type;
2390 PL_parser->lex_sub_op = PL_lex_op;
2391 PL_lex_state = LEX_INTERPPUSH;
2395 pl_yylval.opval = PL_lex_op;
2405 * Create a new scope to save the lexing state. The scope will be
2406 * ended in S_sublex_done. Returns a '(', starting the function arguments
2407 * to the uc, lc, etc. found before.
2408 * Sets PL_lex_state to LEX_INTERPCONCAT.
2415 const bool is_heredoc = PL_multi_close == '<';
2418 PL_lex_state = PL_parser->lex_super_state;
2419 SAVEI8(PL_lex_dojoin);
2420 SAVEI32(PL_lex_brackets);
2421 SAVEI32(PL_lex_allbrackets);
2422 SAVEI32(PL_lex_formbrack);
2423 SAVEI8(PL_lex_fakeeof);
2424 SAVEI32(PL_lex_casemods);
2425 SAVEI32(PL_lex_starts);
2426 SAVEI8(PL_lex_state);
2427 SAVESPTR(PL_lex_repl);
2428 SAVEVPTR(PL_lex_inpat);
2429 SAVEI16(PL_lex_inwhat);
2432 SAVECOPLINE(PL_curcop);
2433 SAVEI32(PL_multi_end);
2434 SAVEI32(PL_parser->herelines);
2435 PL_parser->herelines = 0;
2437 SAVEIV(PL_multi_close);
2438 SAVEPPTR(PL_bufptr);
2439 SAVEPPTR(PL_bufend);
2440 SAVEPPTR(PL_oldbufptr);
2441 SAVEPPTR(PL_oldoldbufptr);
2442 SAVEPPTR(PL_last_lop);
2443 SAVEPPTR(PL_last_uni);
2444 SAVEPPTR(PL_linestart);
2445 SAVESPTR(PL_linestr);
2446 SAVEGENERICPV(PL_lex_brackstack);
2447 SAVEGENERICPV(PL_lex_casestack);
2448 SAVEGENERICPV(PL_parser->lex_shared);
2449 SAVEBOOL(PL_parser->lex_re_reparsing);
2450 SAVEI32(PL_copline);
2452 /* The here-doc parser needs to be able to peek into outer lexing
2453 scopes to find the body of the here-doc. So we put PL_linestr and
2454 PL_bufptr into lex_shared, to ‘share’ those values.
2456 PL_parser->lex_shared->ls_linestr = PL_linestr;
2457 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2459 PL_linestr = PL_lex_stuff;
2460 PL_lex_repl = PL_parser->lex_sub_repl;
2461 PL_lex_stuff = NULL;
2462 PL_parser->lex_sub_repl = NULL;
2464 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2465 set for an inner quote-like operator and then an error causes scope-
2466 popping. We must not have a PL_lex_stuff value left dangling, as
2467 that breaks assumptions elsewhere. See bug #123617. */
2468 SAVEGENERICSV(PL_lex_stuff);
2469 SAVEGENERICSV(PL_parser->lex_sub_repl);
2471 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2472 = SvPVX(PL_linestr);
2473 PL_bufend += SvCUR(PL_linestr);
2474 PL_last_lop = PL_last_uni = NULL;
2475 SAVEFREESV(PL_linestr);
2476 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2478 PL_lex_dojoin = FALSE;
2479 PL_lex_brackets = PL_lex_formbrack = 0;
2480 PL_lex_allbrackets = 0;
2481 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2482 Newx(PL_lex_brackstack, 120, char);
2483 Newx(PL_lex_casestack, 12, char);
2484 PL_lex_casemods = 0;
2485 *PL_lex_casestack = '\0';
2487 PL_lex_state = LEX_INTERPCONCAT;
2489 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2490 PL_copline = NOLINE;
2492 Newxz(shared, 1, LEXSHARED);
2493 shared->ls_prev = PL_parser->lex_shared;
2494 PL_parser->lex_shared = shared;
2496 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
2497 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2498 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2499 PL_lex_inpat = PL_parser->lex_sub_op;
2501 PL_lex_inpat = NULL;
2503 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2504 PL_in_eval &= ~EVAL_RE_REPARSING;
2511 * Restores lexer state after a S_sublex_push.
2517 if (!PL_lex_starts++) {
2518 SV * const sv = newSVpvs("");
2519 if (SvUTF8(PL_linestr))
2521 PL_expect = XOPERATOR;
2522 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
2526 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2527 PL_lex_state = LEX_INTERPCASEMOD;
2531 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2532 assert(PL_lex_inwhat != OP_TRANSR);
2534 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2535 PL_linestr = PL_lex_repl;
2537 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2538 PL_bufend += SvCUR(PL_linestr);
2539 PL_last_lop = PL_last_uni = NULL;
2540 PL_lex_dojoin = FALSE;
2541 PL_lex_brackets = 0;
2542 PL_lex_allbrackets = 0;
2543 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2544 PL_lex_casemods = 0;
2545 *PL_lex_casestack = '\0';
2547 if (SvEVALED(PL_lex_repl)) {
2548 PL_lex_state = LEX_INTERPNORMAL;
2550 /* we don't clear PL_lex_repl here, so that we can check later
2551 whether this is an evalled subst; that means we rely on the
2552 logic to ensure sublex_done() is called again only via the
2553 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2556 PL_lex_state = LEX_INTERPCONCAT;
2559 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2560 CopLINE(PL_curcop) +=
2561 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
2562 + PL_parser->herelines;
2563 PL_parser->herelines = 0;
2568 const line_t l = CopLINE(PL_curcop);
2570 if (PL_multi_close == '<')
2571 PL_parser->herelines += l - PL_multi_end;
2572 PL_bufend = SvPVX(PL_linestr);
2573 PL_bufend += SvCUR(PL_linestr);
2574 PL_expect = XOPERATOR;
2580 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2582 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2583 * interior, hence to the "}". Finds what the name resolves to, returning
2584 * an SV* containing it; NULL if no valid one found */
2586 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2593 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2595 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2598 deprecate_fatal_in("5.28", "Unknown charname '' is deprecated");
2602 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2603 /* include the <}> */
2604 e - backslash_ptr + 1);
2606 SvREFCNT_dec_NN(res);
2610 /* See if the charnames handler is the Perl core's, and if so, we can skip
2611 * the validation needed for a user-supplied one, as Perl's does its own
2613 table = GvHV(PL_hintgv); /* ^H */
2614 cvp = hv_fetchs(table, "charnames", FALSE);
2615 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2616 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2618 const char * const name = HvNAME(stash);
2619 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2620 && strEQ(name, "_charnames")) {
2625 /* Here, it isn't Perl's charname handler. We can't rely on a
2626 * user-supplied handler to validate the input name. For non-ut8 input,
2627 * look to see that the first character is legal. Then loop through the
2628 * rest checking that each is a continuation */
2630 /* This code makes the reasonable assumption that the only Latin1-range
2631 * characters that begin a character name alias are alphabetic, otherwise
2632 * would have to create a isCHARNAME_BEGIN macro */
2635 if (! isALPHAU(*s)) {
2640 if (! isCHARNAME_CONT(*s)) {
2643 if (*s == ' ' && *(s-1) == ' ') {
2650 /* Similarly for utf8. For invariants can check directly; for other
2651 * Latin1, can calculate their code point and check; otherwise use a
2653 if (UTF8_IS_INVARIANT(*s)) {
2654 if (! isALPHAU(*s)) {
2658 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2659 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2665 if (! PL_utf8_charname_begin) {
2666 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2667 PL_utf8_charname_begin = _core_swash_init("utf8",
2668 "_Perl_Charname_Begin",
2670 1, 0, NULL, &flags);
2672 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2679 if (UTF8_IS_INVARIANT(*s)) {
2680 if (! isCHARNAME_CONT(*s)) {
2683 if (*s == ' ' && *(s-1) == ' ') {
2688 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2689 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2696 if (! PL_utf8_charname_continue) {
2697 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2698 PL_utf8_charname_continue = _core_swash_init("utf8",
2699 "_Perl_Charname_Continue",
2701 1, 0, NULL, &flags);
2703 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2710 if (*(s-1) == ' ') {
2713 "charnames alias definitions may not contain trailing "
2714 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2715 (int)(s - backslash_ptr + 1), backslash_ptr,
2716 (int)(e - s + 1), s + 1
2718 UTF ? SVf_UTF8 : 0);
2722 if (SvUTF8(res)) { /* Don't accept malformed input */
2723 const U8* first_bad_char_loc;
2725 const char* const str = SvPV_const(res, len);
2726 if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len,
2727 &first_bad_char_loc)))
2729 _force_out_malformed_utf8_message(first_bad_char_loc,
2730 (U8 *) PL_parser->bufend,
2732 0 /* 0 means don't die */ );
2735 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2736 (int) (e - backslash_ptr + 1), backslash_ptr,
2737 (int) ((char *) first_bad_char_loc - str), str
2748 /* The final %.*s makes sure that should the trailing NUL be missing
2749 * that this print won't run off the end of the string */
2752 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2753 (int)(s - backslash_ptr + 1), backslash_ptr,
2754 (int)(e - s + 1), s + 1
2756 UTF ? SVf_UTF8 : 0);
2763 "charnames alias definitions may not contain a sequence of "
2764 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2765 (int)(s - backslash_ptr + 1), backslash_ptr,
2766 (int)(e - s + 1), s + 1
2768 UTF ? SVf_UTF8 : 0);
2775 Extracts the next constant part of a pattern, double-quoted string,
2776 or transliteration. This is terrifying code.
2778 For example, in parsing the double-quoted string "ab\x63$d", it would
2779 stop at the '$' and return an OP_CONST containing 'abc'.
2781 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2782 processing a pattern (PL_lex_inpat is true), a transliteration
2783 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2785 Returns a pointer to the character scanned up to. If this is
2786 advanced from the start pointer supplied (i.e. if anything was
2787 successfully parsed), will leave an OP_CONST for the substring scanned
2788 in pl_yylval. Caller must intuit reason for not parsing further
2789 by looking at the next characters herself.
2793 \N{FOO} => \N{U+hex_for_character_FOO}
2794 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2797 all other \-char, including \N and \N{ apart from \N{ABC}
2800 @ and $ where it appears to be a var, but not for $ as tail anchor
2804 In transliterations:
2805 characters are VERY literal, except for - not at the start or end
2806 of the string, which indicates a range. However some backslash sequences
2807 are recognized: \r, \n, and the like
2808 \007 \o{}, \x{}, \N{}
2809 If all elements in the transliteration are below 256,
2810 scan_const expands the range to the full set of intermediate
2811 characters. If the range is in utf8, the hyphen is replaced with
2812 a certain range mark which will be handled by pmtrans() in op.c.
2814 In double-quoted strings:
2816 all those recognized in transliterations
2817 deprecated backrefs: \1 (in substitution replacements)
2818 case and quoting: \U \Q \E
2821 scan_const does *not* construct ops to handle interpolated strings.
2822 It stops processing as soon as it finds an embedded $ or @ variable
2823 and leaves it to the caller to work out what's going on.
2825 embedded arrays (whether in pattern or not) could be:
2826 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2828 $ in double-quoted strings must be the symbol of an embedded scalar.
2830 $ in pattern could be $foo or could be tail anchor. Assumption:
2831 it's a tail anchor if $ is the last thing in the string, or if it's
2832 followed by one of "()| \r\n\t"
2834 \1 (backreferences) are turned into $1 in substitutions
2836 The structure of the code is
2837 while (there's a character to process) {
2838 handle transliteration ranges
2839 skip regexp comments /(?#comment)/ and codes /(?{code})/
2840 skip #-initiated comments in //x patterns
2841 check for embedded arrays
2842 check for embedded scalars
2844 deprecate \1 in substitution replacements
2845 handle string-changing backslashes \l \U \Q \E, etc.
2846 switch (what was escaped) {
2847 handle \- in a transliteration (becomes a literal -)
2848 if a pattern and not \N{, go treat as regular character
2849 handle \132 (octal characters)
2850 handle \x15 and \x{1234} (hex characters)
2851 handle \N{name} (named characters, also \N{3,5} in a pattern)
2852 handle \cV (control characters)
2853 handle printf-style backslashes (\f, \r, \n, etc)
2856 } (end if backslash)
2857 handle regular character
2858 } (end while character to read)
2863 S_scan_const(pTHX_ char *start)
2865 char *send = PL_bufend; /* end of the constant */
2866 SV *sv = newSV(send - start); /* sv for the constant. See note below
2868 char *s = start; /* start of the constant */
2869 char *d = SvPVX(sv); /* destination for copies */
2870 bool dorange = FALSE; /* are we in a translit range? */
2871 bool didrange = FALSE; /* did we just finish a range? */
2872 bool in_charclass = FALSE; /* within /[...]/ */
2873 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2874 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2875 UTF8? But, this can show as true
2876 when the source isn't utf8, as for
2877 example when it is entirely composed
2879 STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
2880 number of characters found so far
2881 that will expand (into 2 bytes)
2882 should we have to convert to
2884 SV *res; /* result from charnames */
2885 STRLEN offset_to_max; /* The offset in the output to where the range
2886 high-end character is temporarily placed */
2888 /* Does something require special handling in tr/// ? This avoids extra
2889 * work in a less likely case. As such, khw didn't feel it was worth
2890 * adding any branches to the more mainline code to handle this, which
2891 * means that this doesn't get set in some circumstances when things like
2892 * \x{100} get expanded out. As a result there needs to be extra testing
2893 * done in the tr code */
2894 bool has_above_latin1 = FALSE;
2896 /* Note on sizing: The scanned constant is placed into sv, which is
2897 * initialized by newSV() assuming one byte of output for every byte of
2898 * input. This routine expects newSV() to allocate an extra byte for a
2899 * trailing NUL, which this routine will append if it gets to the end of
2900 * the input. There may be more bytes of input than output (eg., \N{LATIN
2901 * CAPITAL LETTER A}), or more output than input if the constant ends up
2902 * recoded to utf8, but each time a construct is found that might increase
2903 * the needed size, SvGROW() is called. Its size parameter each time is
2904 * based on the best guess estimate at the time, namely the length used so
2905 * far, plus the length the current construct will occupy, plus room for
2906 * the trailing NUL, plus one byte for every input byte still unscanned */
2908 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2911 int backslash_N = 0; /* ? was the character from \N{} */
2912 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2913 platform-specific like \x65 */
2916 PERL_ARGS_ASSERT_SCAN_CONST;
2918 assert(PL_lex_inwhat != OP_TRANSR);
2919 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
2920 /* If we are doing a trans and we know we want UTF8 set expectation */
2921 has_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2922 this_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2925 /* Protect sv from errors and fatal warnings. */
2926 ENTER_with_name("scan_const");
2930 || dorange /* Handle tr/// range at right edge of input */
2933 /* get transliterations out of the way (they're most literal) */
2934 if (PL_lex_inwhat == OP_TRANS) {
2936 /* But there isn't any special handling necessary unless there is a
2937 * range, so for most cases we just drop down and handle the value
2938 * as any other. There are two exceptions.
2940 * 1. A hyphen indicates that we are actually going to have a
2941 * range. In this case, skip the '-', set a flag, then drop
2942 * down to handle what should be the end range value.
2943 * 2. After we've handled that value, the next time through, that
2944 * flag is set and we fix up the range.
2946 * Ranges entirely within Latin1 are expanded out entirely, in
2947 * order to make the transliteration a simple table look-up.
2948 * Ranges that extend above Latin1 have to be done differently, so
2949 * there is no advantage to expanding them here, so they are
2950 * stored here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte
2951 * signifies a hyphen without any possible ambiguity. On EBCDIC
2952 * machines, if the range is expressed as Unicode, the Latin1
2953 * portion is expanded out even if the range extends above
2954 * Latin1. This is because each code point in it has to be
2955 * processed here individually to get its native translation */
2959 /* Here, we don't think we're in a range. If the new character
2960 * is not a hyphen; or if it is a hyphen, but it's too close to
2961 * either edge to indicate a range, then it's a regular
2963 if (*s != '-' || s >= send - 1 || s == start) {
2965 /* A regular character. Process like any other, but first
2966 * clear any flags */
2970 non_portable_endpoint = 0;
2973 /* The tests here for being above Latin1 and similar ones
2974 * in the following 'else' suffice to find all such
2975 * occurences in the constant, except those added by a
2976 * backslash escape sequence, like \x{100}. Mostly, those
2977 * set 'has_above_latin1' as appropriate */
2978 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
2979 has_above_latin1 = TRUE;
2982 /* Drops down to generic code to process current byte */
2984 else { /* Is a '-' in the context where it means a range */
2985 if (didrange) { /* Something like y/A-C-Z// */
2986 Perl_croak(aTHX_ "Ambiguous range in transliteration"
2992 s++; /* Skip past the hyphen */
2994 /* d now points to where the end-range character will be
2995 * placed. Save it so won't have to go finding it later,
2996 * and drop down to get that character. (Actually we
2997 * instead save the offset, to handle the case where a
2998 * realloc in the meantime could change the actual
2999 * pointer). We'll finish processing the range the next
3000 * time through the loop */
3001 offset_to_max = d - SvPVX_const(sv);
3003 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3004 has_above_latin1 = TRUE;
3007 /* Drops down to generic code to process current byte */
3009 } /* End of not a range */
3011 /* Here we have parsed a range. Now must handle it. At this
3013 * 'sv' is a SV* that contains the output string we are
3014 * constructing. The final two characters in that string
3015 * are the range start and range end, in order.
3016 * 'd' points to just beyond the range end in the 'sv' string,
3017 * where we would next place something
3018 * 'offset_to_max' is the offset in 'sv' at which the character
3019 * (the range's maximum end point) before 'd' begins.
3021 char * max_ptr = SvPVX(sv) + offset_to_max;
3024 IV range_max; /* last character in range */
3026 Size_t offset_to_min = 0;
3029 bool convert_unicode;
3030 IV real_range_max = 0;
3032 /* Get the code point values of the range ends. */
3034 /* We know the utf8 is valid, because we just constructed
3035 * it ourselves in previous loop iterations */
3036 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
3037 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
3038 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
3040 /* This compensates for not all code setting
3041 * 'has_above_latin1', so that we don't skip stuff that
3042 * should be executed */
3043 if (range_max > 255) {
3044 has_above_latin1 = TRUE;
3048 min_ptr = max_ptr - 1;
3049 range_min = * (U8*) min_ptr;
3050 range_max = * (U8*) max_ptr;
3053 /* If the range is just a single code point, like tr/a-a/.../,
3054 * that code point is already in the output, twice. We can
3055 * just back up over the second instance and avoid all the rest
3056 * of the work. But if it is a variant character, it's been
3057 * counted twice, so decrement. (This unlikely scenario is
3058 * special cased, like the one for a range of 2 code points
3059 * below, only because the main-line code below needs a range
3060 * of 3 or more to work without special casing. Might as well
3061 * get it out of the way now.) */
3062 if (UNLIKELY(range_max == range_min)) {
3064 if (! has_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
3065 utf8_variant_count--;
3071 /* On EBCDIC platforms, we may have to deal with portable
3072 * ranges. These happen if at least one range endpoint is a
3073 * Unicode value (\N{...}), or if the range is a subset of
3074 * [A-Z] or [a-z], and both ends are literal characters,
3075 * like 'A', and not like \x{C1} */
3077 cBOOL(backslash_N) /* \N{} forces Unicode,
3078 hence portable range */
3079 || ( ! non_portable_endpoint
3080 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3081 || (isUPPER_A(range_min) && isUPPER_A(range_max))));
3082 if (convert_unicode) {
3084 /* Special handling is needed for these portable ranges.
3085 * They are defined to be in Unicode terms, which includes
3086 * all the Unicode code points between the end points.
3087 * Convert to Unicode to get the Unicode range. Later we
3088 * will convert each code point in the range back to
3090 range_min = NATIVE_TO_UNI(range_min);
3091 range_max = NATIVE_TO_UNI(range_max);
3095 if (range_min > range_max) {
3097 if (convert_unicode) {
3098 /* Need to convert back to native for meaningful
3099 * messages for this platform */
3100 range_min = UNI_TO_NATIVE(range_min);
3101 range_max = UNI_TO_NATIVE(range_max);
3104 /* Use the characters themselves for the error message if
3105 * ASCII printables; otherwise some visible representation
3107 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3109 "Invalid range \"%c-%c\" in transliteration operator",
3110 (char)range_min, (char)range_max);
3113 else if (convert_unicode) {
3114 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3116 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04"
3117 UVXf "}\" in transliteration operator",
3118 range_min, range_max);
3122 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3124 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
3125 " in transliteration operator",
3126 range_min, range_max);
3130 /* If the range is exactly two code points long, they are
3131 * already both in the output */
3132 if (UNLIKELY(range_min + 1 == range_max)) {
3136 /* Here the range contains at least 3 code points */
3140 /* If everything in the transliteration is below 256, we
3141 * can avoid special handling later. A translation table
3142 * for each of those bytes is created by op.c. So we
3143 * expand out all ranges to their constituent code points.
3144 * But if we've encountered something above 255, the
3145 * expanding won't help, so skip doing that. But if it's
3146 * EBCDIC, we may have to look at each character below 256
3147 * if we have to convert to/from Unicode values */
3148 if ( has_above_latin1
3150 && (range_min > 255 || ! convert_unicode)
3153 /* Move the high character one byte to the right; then
3154 * insert between it and the range begin, an illegal
3155 * byte which serves to indicate this is a range (using
3156 * a '-' would be ambiguous). */
3158 while (e-- > max_ptr) {
3161 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3165 /* Here, we're going to expand out the range. For EBCDIC
3166 * the range can extend above 255 (not so in ASCII), so
3167 * for EBCDIC, split it into the parts above and below
3170 if (range_max > 255) {
3171 real_range_max = range_max;
3177 /* Here we need to expand out the string to contain each
3178 * character in the range. Grow the output to handle this.
3179 * For non-UTF8, we need a byte for each code point in the
3180 * range, minus the three that we've already allocated for: the
3181 * hyphen, the min, and the max. For UTF-8, we need this
3182 * plus an extra byte for each code point that occupies two
3183 * bytes (is variant) when in UTF-8 (except we've already
3184 * allocated for the end points, including if they are
3185 * variants). For ASCII platforms and Unicode ranges on EBCDIC
3186 * platforms, it's easy to calculate a precise number. To
3187 * start, we count the variants in the range, which we need
3188 * elsewhere in this function anyway. (For the case where it
3189 * isn't easy to calculate, 'extras' has been initialized to 0,
3190 * and the calculation is done in a loop further down.) */
3192 if (convert_unicode)
3195 /* This is executed unconditionally on ASCII, and for
3196 * Unicode ranges on EBCDIC. Under these conditions, all
3197 * code points above a certain value are variant; and none
3198 * under that value are. We just need to find out how much
3199 * of the range is above that value. We don't count the
3200 * end points here, as they will already have been counted
3201 * as they were parsed. */
3202 if (range_min >= UTF_CONTINUATION_MARK) {
3204 /* The whole range is made up of variants */
3205 extras = (range_max - 1) - (range_min + 1) + 1;
3207 else if (range_max >= UTF_CONTINUATION_MARK) {
3209 /* Only the higher portion of the range is variants */
3210 extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1;
3213 utf8_variant_count += extras;
3216 /* The base growth is the number of code points in the range,
3217 * not including the endpoints, which have already been sized
3218 * for (and output). We don't subtract for the hyphen, as it
3219 * has been parsed but not output, and the SvGROW below is
3220 * based only on what's been output plus what's left to parse.
3222 grow = (range_max - 1) - (range_min + 1) + 1;
3226 /* In some cases in EBCDIC, we haven't yet calculated a
3227 * precise amount needed for the UTF-8 variants. Just
3228 * assume the worst case, that everything will expand by a
3230 if (! convert_unicode) {
3236 /* Otherwise we know exactly how many variants there
3237 * are in the range. */
3242 /* Grow, but position the output to overwrite the range min end
3243 * point, because in some cases we overwrite that */
3244 SvCUR_set(sv, d - SvPVX_const(sv));
3245 offset_to_min = min_ptr - SvPVX_const(sv);
3247 /* See Note on sizing above. */
3248 d = offset_to_min + SvGROW(sv, SvCUR(sv)
3251 + 1 /* Trailing NUL */ );
3253 /* Now, we can expand out the range. */
3255 if (convert_unicode) {
3258 /* Recall that the min and max are now in Unicode terms, so
3259 * we have to convert each character to its native
3262 for (i = range_min; i <= range_max; i++) {
3263 append_utf8_from_native_byte(
3264 LATIN1_TO_NATIVE((U8) i),
3269 for (i = range_min; i <= range_max; i++) {
3270 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3276 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3278 /* Here, no conversions are necessary, which means that the
3279 * first character in the range is already in 'd' and
3280 * valid, so we can skip overwriting it */
3284 for (i = range_min + 1; i <= range_max; i++) {
3285 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3291 assert(range_min + 1 <= range_max);
3292 for (i = range_min + 1; i < range_max; i++) {
3294 /* In this case on EBCDIC, we haven't calculated
3295 * the variants. Do it here, as we go along */
3296 if (! UVCHR_IS_INVARIANT(i)) {
3297 utf8_variant_count++;
3303 /* The range_max is done outside the loop so as to
3304 * avoid having to special case not incrementing
3305 * 'utf8_variant_count' on EBCDIC (it's already been
3306 * counted when originally parsed) */
3307 *d++ = (char) range_max;
3312 /* If the original range extended above 255, add in that
3314 if (real_range_max) {
3315 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3316 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3317 if (real_range_max > 0x100) {
3318 if (real_range_max > 0x101) {
3319 *d++ = (char) ILLEGAL_UTF8_BYTE;
3321 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3327 /* mark the range as done, and continue */
3331 non_portable_endpoint = 0;
3335 } /* End of is a range */
3336 } /* End of transliteration. Joins main code after these else's */
3337 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3340 while (s1 >= start && *s1-- == '\\')
3343 in_charclass = TRUE;
3345 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3348 while (s1 >= start && *s1-- == '\\')
3351 in_charclass = FALSE;
3353 /* skip for regexp comments /(?#comment)/, except for the last
3354 * char, which will be done separately. Stop on (?{..}) and
3356 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3358 while (s+1 < send && *s != ')')
3361 else if (!PL_lex_casemods
3362 && ( s[2] == '{' /* This should match regcomp.c */
3363 || (s[2] == '?' && s[3] == '{')))
3368 /* likewise skip #-initiated comments in //x patterns */
3372 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3374 while (s < send && *s != '\n')
3377 /* no further processing of single-quoted regex */
3378 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3379 goto default_action;
3381 /* check for embedded arrays
3382 * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3384 else if (*s == '@' && s[1]) {
3386 ? isIDFIRST_utf8_safe(s+1, send)
3387 : isWORDCHAR_A(s[1]))
3391 if (strchr(":'{$", s[1]))
3393 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3394 break; /* in regexp, neither @+ nor @- are interpolated */
3396 /* check for embedded scalars. only stop if we're sure it's a
3398 else if (*s == '$') {
3399 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3401 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3403 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3404 "Possible unintended interpolation of $\\ in regex");
3406 break; /* in regexp, $ might be tail anchor */
3410 /* End of else if chain - OP_TRANS rejoin rest */
3412 if (UNLIKELY(s >= send)) {
3418 if (*s == '\\' && s+1 < send) {
3419 char* e; /* Can be used for ending '}', etc. */
3423 /* warn on \1 - \9 in substitution replacements, but note that \11
3424 * is an octal; and \19 is \1 followed by '9' */
3425 if (PL_lex_inwhat == OP_SUBST
3431 /* diag_listed_as: \%d better written as $%d */
3432 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3437 /* string-change backslash escapes */
3438 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3442 /* In a pattern, process \N, but skip any other backslash escapes.
3443 * This is because we don't want to translate an escape sequence
3444 * into a meta symbol and have the regex compiler use the meta
3445 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3446 * in spite of this, we do have to process \N here while the proper
3447 * charnames handler is in scope. See bugs #56444 and #62056.
3449 * There is a complication because \N in a pattern may also stand
3450 * for 'match a non-nl', and not mean a charname, in which case its
3451 * processing should be deferred to the regex compiler. To be a
3452 * charname it must be followed immediately by a '{', and not look
3453 * like \N followed by a curly quantifier, i.e., not something like
3454 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3456 else if (PL_lex_inpat
3459 || regcurly(s + 1)))
3462 goto default_action;
3468 if ((isALPHANUMERIC(*s)))
3469 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3470 "Unrecognized escape \\%c passed through",
3472 /* default action is to copy the quoted character */
3473 goto default_action;
3476 /* eg. \132 indicates the octal constant 0132 */
3477 case '0': case '1': case '2': case '3':
3478 case '4': case '5': case '6': case '7':
3480 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3482 uv = grok_oct(s, &len, &flags, NULL);
3484 if (len < 3 && s < send && isDIGIT(*s)
3485 && ckWARN(WARN_MISC))
3487 Perl_warner(aTHX_ packWARN(WARN_MISC),
3488 "%s", form_short_octal_warning(s, len));
3491 goto NUM_ESCAPE_INSERT;
3493 /* eg. \o{24} indicates the octal constant \024 */
3498 bool valid = grok_bslash_o(&s, &uv, &error,
3499 TRUE, /* Output warning */
3500 FALSE, /* Not strict */
3501 TRUE, /* Output warnings for
3506 uv = 0; /* drop through to ensure range ends are set */
3508 goto NUM_ESCAPE_INSERT;
3511 /* eg. \x24 indicates the hex constant 0x24 */
3516 bool valid = grok_bslash_x(&s, &uv, &error,
3517 TRUE, /* Output warning */
3518 FALSE, /* Not strict */
3519 TRUE, /* Output warnings for
3524 uv = 0; /* drop through to ensure range ends are set */
3529 /* Insert oct or hex escaped character. */
3531 /* Here uv is the ordinal of the next character being added */
3532 if (UVCHR_IS_INVARIANT(uv)) {
3536 if (!has_utf8 && uv > 255) {
3538 /* Here, 'uv' won't fit unless we convert to UTF-8.
3539 * If we've only seen invariants so far, all we have to
3540 * do is turn on the flag */
3541 if (utf8_variant_count == 0) {
3545 SvCUR_set(sv, d - SvPVX_const(sv));
3549 sv_utf8_upgrade_flags_grow(
3551 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3553 /* Since we're having to grow here,
3554 * make sure we have enough room for
3555 * this escape and a NUL, so the
3556 * code immediately below won't have
3557 * to actually grow again */
3559 + (STRLEN)(send - s) + 1);
3560 d = SvPVX(sv) + SvCUR(sv);
3563 has_above_latin1 = TRUE;
3569 utf8_variant_count++;
3572 /* Usually, there will already be enough room in 'sv'
3573 * since such escapes are likely longer than any UTF-8
3574 * sequence they can end up as. This isn't the case on
3575 * EBCDIC where \x{40000000} contains 12 bytes, and the
3576 * UTF-8 for it contains 14. And, we have to allow for
3577 * a trailing NUL. It probably can't happen on ASCII
3578 * platforms, but be safe. See Note on sizing above. */
3579 const STRLEN needed = d - SvPVX(sv)
3583 if (UNLIKELY(needed > SvLEN(sv))) {
3584 SvCUR_set(sv, d - SvPVX_const(sv));
3585 d = SvCUR(sv) + SvGROW(sv, needed);
3588 d = (char*)uvchr_to_utf8((U8*)d, uv);
3589 if (PL_lex_inwhat == OP_TRANS
3590 && PL_parser->lex_sub_op)
3592 PL_parser->lex_sub_op->op_private |=
3593 (PL_lex_repl ? OPpTRANS_FROM_UTF
3599 non_portable_endpoint++;
3604 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3605 * named character, like \N{LATIN SMALL LETTER A}, or a named
3606 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3607 * GRAVE} (except y/// can't handle the latter, croaking). For
3608 * convenience all three forms are referred to as "named
3609 * characters" below.
3611 * For patterns, \N also can mean to match a non-newline. Code
3612 * before this 'switch' statement should already have handled
3613 * this situation, and hence this code only has to deal with
3614 * the named character cases.
3616 * For non-patterns, the named characters are converted to
3617 * their string equivalents. In patterns, named characters are
3618 * not converted to their ultimate forms for the same reasons
3619 * that other escapes aren't. Instead, they are converted to
3620 * the \N{U+...} form to get the value from the charnames that
3621 * is in effect right now, while preserving the fact that it
3622 * was a named character, so that the regex compiler knows
3625 * The structure of this section of code (besides checking for
3626 * errors and upgrading to utf8) is:
3627 * If the named character is of the form \N{U+...}, pass it
3628 * through if a pattern; otherwise convert the code point
3630 * Otherwise must be some \N{NAME}: convert to
3631 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3633 * Transliteration is an exception. The conversion to utf8 is
3634 * only done if the code point requires it to be representable.
3636 * Here, 's' points to the 'N'; the test below is guaranteed to
3637 * succeed if we are being called on a pattern, as we already
3638 * know from a test above that the next character is a '{'. A
3639 * non-pattern \N must mean 'named character', which requires
3643 yyerror("Missing braces on \\N{}");
3649 /* If there is no matching '}', it is an error. */
3650 if (! (e = strchr(s, '}'))) {
3651 if (! PL_lex_inpat) {
3652 yyerror("Missing right brace on \\N{}");
3654 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3656 yyquit(); /* Have exhausted the input. */
3659 /* Here it looks like a named character */
3661 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3662 s += 2; /* Skip to next char after the 'U+' */
3665 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3666 /* Check the syntax. */
3669 if (!isXDIGIT(*s)) {
3672 "Invalid hexadecimal number in \\N{U+...}"
3681 else if ((*s == '.' || *s == '_')
3687 /* Pass everything through unchanged.
3688 * +1 is for the '}' */
3689 Copy(orig_s, d, e - orig_s + 1, char);
3690 d += e - orig_s + 1;
3692 else { /* Not a pattern: convert the hex to string */
3693 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3694 | PERL_SCAN_SILENT_ILLDIGIT
3695 | PERL_SCAN_DISALLOW_PREFIX;
3697 uv = grok_hex(s, &len, &flags, NULL);
3698 if (len == 0 || (len != (STRLEN)(e - s)))
3701 /* For non-tr///, if the destination is not in utf8,
3702 * unconditionally recode it to be so. This is
3703 * because \N{} implies Unicode semantics, and scalars
3704 * have to be in utf8 to guarantee those semantics.
3705 * tr/// doesn't care about Unicode rules, so no need
3706 * there to upgrade to UTF-8 for small enough code
3708 if (! has_utf8 && ( uv > 0xFF
3709 || PL_lex_inwhat != OP_TRANS))
3711 /* See Note on sizing above. */
3712 const STRLEN extra = OFFUNISKIP(uv) + (send - e) + 1;
3714 SvCUR_set(sv, d - SvPVX_const(sv));
3718 if (utf8_variant_count == 0) {
3720 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3723 sv_utf8_upgrade_flags_grow(
3725 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3727 d = SvPVX(sv) + SvCUR(sv);
3731 has_above_latin1 = TRUE;
3734 /* Add the (Unicode) code point to the output. */
3735 if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
3736 *d++ = (char) LATIN1_TO_NATIVE(uv);
3739 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3743 else /* Here is \N{NAME} but not \N{U+...}. */
3744 if ((res = get_and_check_backslash_N_name(s, e)))
3747 const char *str = SvPV_const(res, len);
3750 if (! len) { /* The name resolved to an empty string */
3751 Copy("\\N{}", d, 4, char);
3755 /* In order to not lose information for the regex
3756 * compiler, pass the result in the specially made
3757 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3758 * the code points in hex of each character
3759 * returned by charnames */
3761 const char *str_end = str + len;
3762 const STRLEN off = d - SvPVX_const(sv);
3764 if (! SvUTF8(res)) {
3765 /* For the non-UTF-8 case, we can determine the
3766 * exact length needed without having to parse
3767 * through the string. Each character takes up
3768 * 2 hex digits plus either a trailing dot or
3770 const char initial_text[] = "\\N{U+";
3771 const STRLEN initial_len = sizeof(initial_text)
3773 d = off + SvGROW(sv, off
3776 /* +1 for trailing NUL */
3779 + (STRLEN)(send - e));
3780 Copy(initial_text, d, initial_len, char);
3782 while (str < str_end) {
3785 my_snprintf(hex_string,
3789 /* The regex compiler is
3790 * expecting Unicode, not
3792 NATIVE_TO_LATIN1(*str));
3793 PERL_MY_SNPRINTF_POST_GUARD(len,
3794 sizeof(hex_string));
3795 Copy(hex_string, d, 3, char);
3799 d--; /* Below, we will overwrite the final
3800 dot with a right brace */
3803 STRLEN char_length; /* cur char's byte length */
3805 /* and the number of bytes after this is
3806 * translated into hex digits */
3807 STRLEN output_length;
3809 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3810 * for max('U+', '.'); and 1 for NUL */
3811 char hex_string[2 * UTF8_MAXBYTES + 5];
3813 /* Get the first character of the result. */
3814 U32 uv = utf8n_to_uvchr((U8 *) str,
3818 /* Convert first code point to Unicode hex,
3819 * including the boiler plate before it. */
3821 my_snprintf(hex_string, sizeof(hex_string),
3823 (unsigned int) NATIVE_TO_UNI(uv));
3825 /* Make sure there is enough space to hold it */
3826 d = off + SvGROW(sv, off
3828 + (STRLEN)(send - e)
3829 + 2); /* '}' + NUL */
3831 Copy(hex_string, d, output_length, char);
3834 /* For each subsequent character, append dot and
3835 * its Unicode code point in hex */
3836 while ((str += char_length) < str_end) {
3837 const STRLEN off = d - SvPVX_const(sv);
3838 U32 uv = utf8n_to_uvchr((U8 *) str,
3843 my_snprintf(hex_string,
3846 (unsigned int) NATIVE_TO_UNI(uv));
3848 d = off + SvGROW(sv, off
3850 + (STRLEN)(send - e)
3851 + 2); /* '}' + NUL */
3852 Copy(hex_string, d, output_length, char);
3857 *d++ = '}'; /* Done. Add the trailing brace */
3860 else { /* Here, not in a pattern. Convert the name to a
3863 if (PL_lex_inwhat == OP_TRANS) {
3864 str = SvPV_const(res, len);
3865 if (len > ((SvUTF8(res))
3869 yyerror(Perl_form(aTHX_
3870 "%.*s must not be a named sequence"
3871 " in transliteration operator",
3872 /* +1 to include the "}" */
3873 (int) (e + 1 - start), start));
3875 goto end_backslash_N;
3878 if (SvUTF8(res) && UTF8_IS_ABOVE_LATIN1(*str)) {
3879 has_above_latin1 = TRUE;
3883 else if (! SvUTF8(res)) {
3884 /* Make sure \N{} return is UTF-8. This is because
3885 * \N{} implies Unicode semantics, and scalars have
3886 * to be in utf8 to guarantee those semantics; but
3887 * not needed in tr/// */
3888 sv_utf8_upgrade_flags(res, 0);
3889 str = SvPV_const(res, len);
3892 /* Upgrade destination to be utf8 if this new
3894 if (! has_utf8 && SvUTF8(res)) {
3895 /* See Note on sizing above. */
3896 const STRLEN extra = len + (send - s) + 1;
3898 SvCUR_set(sv, d - SvPVX_const(sv));
3902 if (utf8_variant_count == 0) {
3904 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3907 sv_utf8_upgrade_flags_grow(sv,
3908 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3910 d = SvPVX(sv) + SvCUR(sv);
3913 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3915 /* See Note on sizing above. (NOTE: SvCUR() is not
3916 * set correctly here). */
3917 const STRLEN extra = len + (send - e) + 1;
3918 const STRLEN off = d - SvPVX_const(sv);
3919 d = off + SvGROW(sv, off + extra);
3921 Copy(str, d, len, char);
3927 } /* End \N{NAME} */
3931 backslash_N++; /* \N{} is defined to be Unicode */
3933 s = e + 1; /* Point to just after the '}' */
3936 /* \c is a control character */
3940 *d++ = grok_bslash_c(*s, 1);
3943 yyerror("Missing control char name in \\c");
3944 yyquit(); /* Are at end of input, no sense continuing */
3947 non_portable_endpoint++;
3951 /* printf-style backslashes, formfeeds, newlines, etc */
3977 } /* end if (backslash) */
3980 /* Just copy the input to the output, though we may have to convert
3983 * If the input has the same representation in UTF-8 as not, it will be
3984 * a single byte, and we don't care about UTF8ness; just copy the byte */
3985 if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) {
3988 else if (! this_utf8 && ! has_utf8) {
3989 /* If neither source nor output is UTF-8, is also a single byte,
3990 * just copy it; but this byte counts should we later have to
3991 * convert to UTF-8 */
3993 utf8_variant_count++;
3995 else if (this_utf8 && has_utf8) { /* Both UTF-8, can just copy */
3996 const STRLEN len = UTF8SKIP(s);
3998 /* We expect the source to have already been checked for
4000 assert(isUTF8_CHAR((U8 *) s, (U8 *) send));
4002 Copy(s, d, len, U8);
4006 else { /* UTF8ness matters and doesn't match, need to convert */
4008 const UV nextuv = (this_utf8)
4009 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
4011 STRLEN need = UVCHR_SKIP(nextuv);
4014 SvCUR_set(sv, d - SvPVX_const(sv));
4018 /* See Note on sizing above. */
4019 need += (STRLEN)(send - s) + 1;
4021 if (utf8_variant_count == 0) {
4023 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
4026 sv_utf8_upgrade_flags_grow(sv,
4027 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4029 d = SvPVX(sv) + SvCUR(sv);
4032 } else if (need > len) {
4033 /* encoded value larger than old, may need extra space (NOTE:
4034 * SvCUR() is not set correctly here). See Note on sizing
4036 const STRLEN extra = need + (send - s) + 1;
4037 const STRLEN off = d - SvPVX_const(sv);
4038 d = off + SvGROW(sv, off + extra);
4042 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
4044 } /* while loop to process each character */
4046 /* terminate the string and set up the sv */
4048 SvCUR_set(sv, d - SvPVX_const(sv));
4049 if (SvCUR(sv) >= SvLEN(sv))
4050 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %" UVuf
4051 " >= %" UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
4056 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
4057 PL_parser->lex_sub_op->op_private |=
4058 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
4062 /* shrink the sv if we allocated more than we used */
4063 if (SvCUR(sv) + 5 < SvLEN(sv)) {
4064 SvPV_shrink_to_cur(sv);
4067 /* return the substring (via pl_yylval) only if we parsed anything */
4070 for (; s2 < s; s2++) {
4072 COPLINE_INC_WITH_HERELINES;
4074 SvREFCNT_inc_simple_void_NN(sv);
4075 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
4076 && ! PL_parser->lex_re_reparsing)
4078 const char *const key = PL_lex_inpat ? "qr" : "q";
4079 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
4083 if (PL_lex_inwhat == OP_TRANS) {
4086 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
4089 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
4097 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
4100 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
4102 LEAVE_with_name("scan_const");
4107 * Returns TRUE if there's more to the expression (e.g., a subscript),
4110 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
4112 * ->[ and ->{ return TRUE
4113 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
4114 * { and [ outside a pattern are always subscripts, so return TRUE
4115 * if we're outside a pattern and it's not { or [, then return FALSE
4116 * if we're in a pattern and the first char is a {
4117 * {4,5} (any digits around the comma) returns FALSE
4118 * if we're in a pattern and the first char is a [
4120 * [SOMETHING] has a funky algorithm to decide whether it's a
4121 * character class or not. It has to deal with things like
4122 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
4123 * anything else returns TRUE
4126 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
4129 S_intuit_more(pTHX_ char *s)
4131 PERL_ARGS_ASSERT_INTUIT_MORE;
4133 if (PL_lex_brackets)
4135 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
4137 if (*s == '-' && s[1] == '>'
4138 && FEATURE_POSTDEREF_QQ_IS_ENABLED
4139 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
4140 ||(s[2] == '@' && strchr("*[{",s[3])) ))
4142 if (*s != '{' && *s != '[')
4147 /* In a pattern, so maybe we have {n,m}. */
4155 /* On the other hand, maybe we have a character class */
4158 if (*s == ']' || *s == '^')
4161 /* this is terrifying, and it works */
4164 const char * const send = strchr(s,']');
4165 unsigned char un_char, last_un_char;
4166 char tmpbuf[sizeof PL_tokenbuf * 4];
4168 if (!send) /* has to be an expression */
4170 weight = 2; /* let's weigh the evidence */
4174 else if (isDIGIT(*s)) {
4176 if (isDIGIT(s[1]) && s[2] == ']')
4182 Zero(seen,256,char);
4184 for (; s < send; s++) {
4185 last_un_char = un_char;
4186 un_char = (unsigned char)*s;
4191 weight -= seen[un_char] * 10;
4192 if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) {
4194 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
4195 len = (int)strlen(tmpbuf);
4196 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
4197 UTF ? SVf_UTF8 : 0, SVt_PV))
4204 && strchr("[#!%*<>()-=",s[1]))
4206 if (/*{*/ strchr("])} =",s[2]))
4215 if (strchr("wds]",s[1]))
4217 else if (seen[(U8)'\''] || seen[(U8)'"'])
4219 else if (strchr("rnftbxcav",s[1]))
4221 else if (isDIGIT(s[1])) {
4223 while (s[1] && isDIGIT(s[1]))
4233 if (strchr("aA01! ",last_un_char))
4235 if (strchr("zZ79~",s[1]))
4237 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4238 weight -= 5; /* cope with negative subscript */
4241 if (!isWORDCHAR(last_un_char)
4242 && !(last_un_char == '$' || last_un_char == '@'
4243 || last_un_char == '&')
4244 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4248 if (keyword(d, s - d, 0))
4251 if (un_char == last_un_char + 1)
4253 weight -= seen[un_char];
4258 if (weight >= 0) /* probably a character class */
4268 * Does all the checking to disambiguate
4270 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4271 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4273 * First argument is the stuff after the first token, e.g. "bar".
4275 * Not a method if foo is a filehandle.
4276 * Not a method if foo is a subroutine prototyped to take a filehandle.
4277 * Not a method if it's really "Foo $bar"
4278 * Method if it's "foo $bar"
4279 * Not a method if it's really "print foo $bar"
4280 * Method if it's really "foo package::" (interpreted as package->foo)
4281 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4282 * Not a method if bar is a filehandle or package, but is quoted with
4287 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4289 char *s = start + (*start == '$');
4290 char tmpbuf[sizeof PL_tokenbuf];
4293 /* Mustn't actually add anything to a symbol table.
4294 But also don't want to "initialise" any placeholder
4295 constants that might already be there into full
4296 blown PVGVs with attached PVCV. */
4298 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4300 PERL_ARGS_ASSERT_INTUIT_METHOD;
4302 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4304 if (cv && SvPOK(cv)) {
4305 const char *proto = CvPROTO(cv);
4307 while (*proto && (isSPACE(*proto) || *proto == ';'))
4314 if (*start == '$') {
4315 SSize_t start_off = start - SvPVX(PL_linestr);
4316 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4317 || isUPPER(*PL_tokenbuf))
4319 /* this could be $# */
4322 PL_bufptr = SvPVX(PL_linestr) + start_off;
4324 return *s == '(' ? FUNCMETH : METHOD;
4327 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4328 /* start is the beginning of the possible filehandle/object,
4329 * and s is the end of it
4330 * tmpbuf is a copy of it (but with single quotes as double colons)
4333 if (!keyword(tmpbuf, len, 0)) {
4334 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4339 indirgv = gv_fetchpvn_flags(tmpbuf, len,
4340 GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
4342 if (indirgv && SvTYPE(indirgv) != SVt_NULL
4343 && (!isGV(indirgv) || GvCVu(indirgv)))
4345 /* filehandle or package name makes it a method */
4346 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4348 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4349 return 0; /* no assumptions -- "=>" quotes bareword */
4351 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0,
4352 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4353 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4355 force_next(BAREWORD);
4357 return *s == '(' ? FUNCMETH : METHOD;
4363 /* Encoded script support. filter_add() effectively inserts a
4364 * 'pre-processing' function into the current source input stream.
4365 * Note that the filter function only applies to the current source file
4366 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4368 * The datasv parameter (which may be NULL) can be used to pass
4369 * private data to this instance of the filter. The filter function
4370 * can recover the SV using the FILTER_DATA macro and use it to
4371 * store private buffers and state information.
4373 * The supplied datasv parameter is upgraded to a PVIO type
4374 * and the IoDIRP/IoANY field is used to store the function pointer,
4375 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4376 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4377 * private use must be set using malloc'd pointers.
4381 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4389 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4390 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4392 if (!PL_rsfp_filters)
4393 PL_rsfp_filters = newAV();
4396 SvUPGRADE(datasv, SVt_PVIO);
4397 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4398 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4399 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4400 FPTR2DPTR(void *, IoANY(datasv)),
4401 SvPV_nolen(datasv)));
4402 av_unshift(PL_rsfp_filters, 1);
4403 av_store(PL_rsfp_filters, 0, datasv) ;
4405 !PL_parser->filtered
4406 && PL_parser->lex_flags & LEX_EVALBYTES
4407 && PL_bufptr < PL_bufend
4409 const char *s = PL_bufptr;
4410 while (s < PL_bufend) {
4412 SV *linestr = PL_parser->linestr;
4413 char *buf = SvPVX(linestr);
4414 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4415 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4416 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4417 STRLEN const linestart_pos = PL_parser->linestart - buf;
4418 STRLEN const last_uni_pos =
4419 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4420 STRLEN const last_lop_pos =
4421 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4422 av_push(PL_rsfp_filters, linestr);
4423 PL_parser->linestr =
4424 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4425 buf = SvPVX(PL_parser->linestr);
4426 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4427 PL_parser->bufptr = buf + bufptr_pos;
4428 PL_parser->oldbufptr = buf + oldbufptr_pos;
4429 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4430 PL_parser->linestart = buf + linestart_pos;
4431 if (PL_parser->last_uni)
4432 PL_parser->last_uni = buf + last_uni_pos;
4433 if (PL_parser->last_lop)
4434 PL_parser->last_lop = buf + last_lop_pos;
4435 SvLEN(linestr) = SvCUR(linestr);
4436 SvCUR(linestr) = s-SvPVX(linestr);
4437 PL_parser->filtered = 1;
4447 /* Delete most recently added instance of this filter function. */
4449 Perl_filter_del(pTHX_ filter_t funcp)
4453 PERL_ARGS_ASSERT_FILTER_DEL;
4456 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4457 FPTR2DPTR(void*, funcp)));
4459 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4461 /* if filter is on top of stack (usual case) just pop it off */
4462 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4463 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4464 sv_free(av_pop(PL_rsfp_filters));
4468 /* we need to search for the correct entry and clear it */
4469 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4473 /* Invoke the idxth filter function for the current rsfp. */
4474 /* maxlen 0 = read one text line */
4476 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4480 /* This API is bad. It should have been using unsigned int for maxlen.
4481 Not sure if we want to change the API, but if not we should sanity
4482 check the value here. */
4483 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4485 PERL_ARGS_ASSERT_FILTER_READ;
4487 if (!PL_parser || !PL_rsfp_filters)
4489 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4490 /* Provide a default input filter to make life easy. */
4491 /* Note that we append to the line. This is handy. */
4492 DEBUG_P(PerlIO_printf(Perl_debug_log,
4493 "filter_read %d: from rsfp\n", idx));
4494 if (correct_length) {
4497 const int old_len = SvCUR(buf_sv);
4499 /* ensure buf_sv is large enough */
4500 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4501 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4502 correct_length)) <= 0) {
4503 if (PerlIO_error(PL_rsfp))
4504 return -1; /* error */
4506 return 0 ; /* end of file */
4508 SvCUR_set(buf_sv, old_len + len) ;
4509 SvPVX(buf_sv)[old_len + len] = '\0';
4512 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4513 if (PerlIO_error(PL_rsfp))
4514 return -1; /* error */
4516 return 0 ; /* end of file */
4519 return SvCUR(buf_sv);
4521 /* Skip this filter slot if filter has been deleted */
4522 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4523 DEBUG_P(PerlIO_printf(Perl_debug_log,
4524 "filter_read %d: skipped (filter deleted)\n",
4526 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4528 if (SvTYPE(datasv) != SVt_PVIO) {
4529 if (correct_length) {
4531 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4532 if (!remainder) return 0; /* eof */
4533 if (correct_length > remainder) correct_length = remainder;
4534 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4535 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4538 const char *s = SvEND(datasv);
4539 const char *send = SvPVX(datasv) + SvLEN(datasv);
4547 if (s == send) return 0; /* eof */
4548 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4549 SvCUR_set(datasv, s-SvPVX(datasv));
4551 return SvCUR(buf_sv);
4553 /* Get function pointer hidden within datasv */
4554 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4555 DEBUG_P(PerlIO_printf(Perl_debug_log,
4556 "filter_read %d: via function %p (%s)\n",
4557 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4558 /* Call function. The function is expected to */
4559 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4560 /* Return: <0:error, =0:eof, >0:not eof */
4561 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4565 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4567 PERL_ARGS_ASSERT_FILTER_GETS;
4569 #ifdef PERL_CR_FILTER
4570 if (!PL_rsfp_filters) {
4571 filter_add(S_cr_textfilter,NULL);
4574 if (PL_rsfp_filters) {
4576 SvCUR_set(sv, 0); /* start with empty line */
4577 if (FILTER_READ(0, sv, 0) > 0)
4578 return ( SvPVX(sv) ) ;
4583 return (sv_gets(sv, PL_rsfp, append));
4587 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4591 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4593 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4597 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4598 && (gv = gv_fetchpvn_flags(pkgname,
4600 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4602 return GvHV(gv); /* Foo:: */
4605 /* use constant CLASS => 'MyClass' */
4606 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4607 if (gv && GvCV(gv)) {
4608 SV * const sv = cv_const_sv(GvCV(gv));
4610 return gv_stashsv(sv, 0);
4613 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4618 S_tokenize_use(pTHX_ int is_use, char *s) {
4619 PERL_ARGS_ASSERT_TOKENIZE_USE;
4621 if (PL_expect != XSTATE)
4622 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4623 is_use ? "use" : "no"));
4626 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4627 s = force_version(s, TRUE);
4628 if (*s == ';' || *s == '}'
4629 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4630 NEXTVAL_NEXTTOKE.opval = NULL;
4631 force_next(BAREWORD);
4633 else if (*s == 'v') {
4634 s = force_word(s,BAREWORD,FALSE,TRUE);
4635 s = force_version(s, FALSE);
4639 s = force_word(s,BAREWORD,FALSE,TRUE);
4640 s = force_version(s, FALSE);
4642 pl_yylval.ival = is_use;
4646 static const char* const exp_name[] =
4647 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4648 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4649 "SIGVAR", "TERMORDORDOR"
4653 #define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l)
4655 S_word_takes_any_delimiter(char *p, STRLEN len)
4657 return (len == 1 && strchr("msyq", p[0]))
4659 && ((p[0] == 't' && p[1] == 'r')
4660 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4664 S_check_scalar_slice(pTHX_ char *s)
4667 while (SPACE_OR_TAB(*s)) s++;
4668 if (*s == 'q' && s[1] == 'w' && !isWORDCHAR_lazy_if_safe(s+2,
4674 while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)
4675 || (*s && strchr(" \t$#+-'\"", *s)))
4677 s += UTF ? UTF8SKIP(s) : 1;
4679 if (*s == '}' || *s == ']')
4680 pl_yylval.ival = OPpSLICEWARNING;
4683 #define lex_token_boundary() S_lex_token_boundary(aTHX)
4685 S_lex_token_boundary(pTHX)
4687 PL_oldoldbufptr = PL_oldbufptr;
4688 PL_oldbufptr = PL_bufptr;
4691 #define vcs_conflict_marker(s) S_vcs_conflict_marker(aTHX_ s)
4693 S_vcs_conflict_marker(pTHX_ char *s)
4695 lex_token_boundary();
4697 yyerror("Version control conflict marker");
4698 while (s < PL_bufend && *s != '\n')
4706 Works out what to call the token just pulled out of the input
4707 stream. The yacc parser takes care of taking the ops we return and
4708 stitching them into a tree.
4711 The type of the next token
4714 Check if we have already built the token; if so, use it.
4715 Switch based on the current state:
4716 - if we have a case modifier in a string, deal with that
4717 - handle other cases of interpolation inside a string
4718 - scan the next line if we are inside a format
4719 In the normal state, switch on the next character:
4721 if alphabetic, go to key lookup
4722 unrecognized character - croak
4723 - 0/4/26: handle end-of-line or EOF
4724 - cases for whitespace
4725 - \n and #: handle comments and line numbers
4726 - various operators, brackets and sigils
4729 - 'v': vstrings (or go to key lookup)
4730 - 'x' repetition operator (or go to key lookup)
4731 - other ASCII alphanumerics (key lookup begins here):
4734 scan built-in keyword (but do nothing with it yet)
4735 check for statement label
4736 check for lexical subs
4737 goto just_a_word if there is one
4738 see whether built-in keyword is overridden
4739 switch on keyword number:
4740 - default: just_a_word:
4741 not a built-in keyword; handle bareword lookup
4742 disambiguate between method and sub call
4743 fall back to bareword
4744 - cases for built-in keywords
4752 char *s = PL_bufptr;
4756 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4760 /* orig_keyword, gvp, and gv are initialized here because
4761 * jump to the label just_a_word_zero can bypass their
4762 * initialization later. */
4763 I32 orig_keyword = 0;
4767 if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
4768 const U8* first_bad_char_loc;
4769 if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
4770 PL_bufend - PL_bufptr,
4771 &first_bad_char_loc)))
4773 _force_out_malformed_utf8_message(first_bad_char_loc,
4776 1 /* 1 means die */ );
4777 NOT_REACHED; /* NOTREACHED */
4779 PL_parser->recheck_utf8_validity = FALSE;
4782 SV* tmp = newSVpvs("");
4783 PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
4784 (IV)CopLINE(PL_curcop),
4785 lex_state_names[PL_lex_state],
4786 exp_name[PL_expect],
4787 pv_display(tmp, s, strlen(s), 0, 60));
4791 /* when we've already built the next token, just pull it out of the queue */
4794 pl_yylval = PL_nextval[PL_nexttoke];
4797 next_type = PL_nexttype[PL_nexttoke];
4798 if (next_type & (7<<24)) {
4799 if (next_type & (1<<24)) {
4800 if (PL_lex_brackets > 100)
4801 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4802 PL_lex_brackstack[PL_lex_brackets++] =
4803 (char) ((next_type >> 16) & 0xff);
4805 if (next_type & (2<<24))
4806 PL_lex_allbrackets++;
4807 if (next_type & (4<<24))
4808 PL_lex_allbrackets--;
4809 next_type &= 0xffff;
4811 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4815 switch (PL_lex_state) {
4817 case LEX_INTERPNORMAL:
4820 /* interpolated case modifiers like \L \U, including \Q and \E.
4821 when we get here, PL_bufptr is at the \
4823 case LEX_INTERPCASEMOD:
4825 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4827 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4828 PL_bufptr, PL_bufend, *PL_bufptr);
4830 /* handle \E or end of string */
4831 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4833 if (PL_lex_casemods) {
4834 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4835 PL_lex_casestack[PL_lex_casemods] = '\0';
4837 if (PL_bufptr != PL_bufend
4838 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4839 || oldmod == 'F')) {
4841 PL_lex_state = LEX_INTERPCONCAT;
4843 PL_lex_allbrackets--;
4846 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4847 /* Got an unpaired \E */
4848 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4849 "Useless use of \\E");
4851 if (PL_bufptr != PL_bufend)
4853 PL_lex_state = LEX_INTERPCONCAT;
4857 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4858 "### Saw case modifier\n"); });
4860 if (s[1] == '\\' && s[2] == 'E') {
4862 PL_lex_state = LEX_INTERPCONCAT;
4867 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4868 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4869 if ((*s == 'L' || *s == 'U' || *s == 'F')
4870 && (strpbrk(PL_lex_casestack, "LUF")))
4872 PL_lex_casestack[--PL_lex_casemods] = '\0';
4873 PL_lex_allbrackets--;
4876 if (PL_lex_casemods > 10)
4877 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4878 PL_lex_casestack[PL_lex_casemods++] = *s;
4879 PL_lex_casestack[PL_lex_casemods] = '\0';
4880 PL_lex_state = LEX_INTERPCONCAT;
4881 NEXTVAL_NEXTTOKE.ival = 0;
4882 force_next((2<<24)|'(');
4884 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4886 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4888 NEXTVAL_NEXTTOKE.ival = OP_LC;
4890 NEXTVAL_NEXTTOKE.ival = OP_UC;
4892 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4894 NEXTVAL_NEXTTOKE.ival = OP_FC;
4896 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4900 if (PL_lex_starts) {
4903 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4904 if (PL_lex_casemods == 1 && PL_lex_inpat)
4907 AopNOASSIGN(OP_CONCAT);
4913 case LEX_INTERPPUSH:
4914 return REPORT(sublex_push());
4916 case LEX_INTERPSTART:
4917 if (PL_bufptr == PL_bufend)
4918 return REPORT(sublex_done());
4919 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4920 "### Interpolated variable\n"); });
4922 /* for /@a/, we leave the joining for the regex engine to do
4923 * (unless we're within \Q etc) */
4924 PL_lex_dojoin = (*PL_bufptr == '@'
4925 && (!PL_lex_inpat || PL_lex_casemods));
4926 PL_lex_state = LEX_INTERPNORMAL;
4927 if (PL_lex_dojoin) {
4928 NEXTVAL_NEXTTOKE.ival = 0;
4930 force_ident("\"", '$');
4931 NEXTVAL_NEXTTOKE.ival = 0;
4933 NEXTVAL_NEXTTOKE.ival = 0;
4934 force_next((2<<24)|'(');
4935 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4938 /* Convert (?{...}) and friends to 'do {...}' */
4939 if (PL_lex_inpat && *PL_bufptr == '(') {
4940 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4942 if (*PL_bufptr != '{')
4944 PL_expect = XTERMBLOCK;
4948 if (PL_lex_starts++) {
4950 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4951 if (!PL_lex_casemods && PL_lex_inpat)
4954 AopNOASSIGN(OP_CONCAT);
4958 case LEX_INTERPENDMAYBE:
4959 if (intuit_more(PL_bufptr)) {
4960 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4966 if (PL_lex_dojoin) {
4967 const U8 dojoin_was = PL_lex_dojoin;
4968 PL_lex_dojoin = FALSE;
4969 PL_lex_state = LEX_INTERPCONCAT;
4970 PL_lex_allbrackets--;
4971 return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
4973 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4974 && SvEVALED(PL_lex_repl))
4976 if (PL_bufptr != PL_bufend)
4977 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4980 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4981 re_eval_str. If the here-doc body’s length equals the previous
4982 value of re_eval_start, re_eval_start will now be null. So
4983 check re_eval_str as well. */
4984 if (PL_parser->lex_shared->re_eval_start
4985 || PL_parser->lex_shared->re_eval_str) {
4987 if (*PL_bufptr != ')')
4988 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4990 /* having compiled a (?{..}) expression, return the original
4991 * text too, as a const */
4992 if (PL_parser->lex_shared->re_eval_str) {
4993 sv = PL_parser->lex_shared->re_eval_str;
4994 PL_parser->lex_shared->re_eval_str = NULL;
4996 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4997 SvPV_shrink_to_cur(sv);
4999 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5000 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5001 NEXTVAL_NEXTTOKE.opval =
5002 newSVOP(OP_CONST, 0,
5005 PL_parser->lex_shared->re_eval_start = NULL;
5011 case LEX_INTERPCONCAT:
5013 if (PL_lex_brackets)
5014 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5015 (long) PL_lex_brackets);
5017 if (PL_bufptr == PL_bufend)
5018 return REPORT(sublex_done());
5020 /* m'foo' still needs to be parsed for possible (?{...}) */
5021 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5022 SV *sv = newSVsv(PL_linestr);
5024 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
5028 int save_error_count = PL_error_count;
5030 s = scan_const(PL_bufptr);
5032 /* Set flag if this was a pattern and there were errors. op.c will
5033 * refuse to compile a pattern with this flag set. Otherwise, we
5034 * could get segfaults, etc. */
5035 if (PL_lex_inpat && PL_error_count > save_error_count) {
5036 ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
5039 PL_lex_state = LEX_INTERPCASEMOD;
5041 PL_lex_state = LEX_INTERPSTART;
5044 if (s != PL_bufptr) {
5045 NEXTVAL_NEXTTOKE = pl_yylval;
5048 if (PL_lex_starts++) {
5049 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5050 if (!PL_lex_casemods && PL_lex_inpat)
5053 AopNOASSIGN(OP_CONCAT);
5063 s = scan_formline(PL_bufptr);
5064 if (!PL_lex_formbrack)
5073 /* We really do *not* want PL_linestr ever becoming a COW. */
5074 assert (!SvIsCOW(PL_linestr));
5076 PL_oldoldbufptr = PL_oldbufptr;
5078 PL_parser->saw_infix_sigil = 0;
5080 if (PL_in_my == KEY_sigvar) {
5081 /* we expect the sigil and optional var name part of a
5082 * signature element here. Since a '$' is not necessarily
5083 * followed by a var name, handle it specially here; the general
5084 * yylex code would otherwise try to interpret whatever follows
5085 * as a var; e.g. ($, ...) would be seen as the var '$,'
5092 PL_bufptr = s; /* for error reporting */
5097 /* spot stuff that looks like an prototype */
5098 if (strchr("$:@%&*;\\[]", *s)) {
5099 yyerror("Illegal character following sigil in a subroutine signature");
5102 /* '$#' is banned, while '$ # comment' isn't */
5104 yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
5108 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5109 char *dest = PL_tokenbuf + 1;
5110 /* read var name, including sigil, into PL_tokenbuf */
5111 PL_tokenbuf[0] = sigil;
5112 parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
5113 0, cBOOL(UTF), FALSE);
5115 assert(PL_tokenbuf[1]); /* we have a variable name */
5116 NEXTVAL_NEXTTOKE.ival = sigil;
5117 force_next('p'); /* force a signature pending identifier */
5121 PL_expect = XOPERATOR;
5127 case ',': /* handle ($a,,$b) */
5132 yyerror("A signature parameter must start with '$', '@' or '%'");
5133 /* very crude error recovery: skip to likely next signature
5135 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5146 if (isIDFIRST_utf8_safe(s, PL_bufend)) {
5150 else if (isALNUMC(*s)) {
5154 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5157 STRLEN skiplen = UTF8SKIP(s);
5158 STRLEN stravail = PL_bufend - s;
5159 c = sv_uni_display(dsv, newSVpvn_flags(s,
5160 skiplen > stravail ? stravail : skiplen,
5161 SVs_TEMP | SVf_UTF8),
5162 10, UNI_DISPLAY_ISPRINT);
5165 c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5167 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
5168 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5169 d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)PL_linestart) : s - UNRECOGNIZED_PRECEDE_COUNT;
5173 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
5174 UTF8fARG(UTF, (s - d), d),
5179 goto fake_eof; /* emulate EOF on ^D or ^Z */
5181 if ((!PL_rsfp || PL_lex_inwhat)
5182 && (!PL_parser->filtered || s+1 < PL_bufend)) {
5186 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
5188 yyerror((const char *)
5190 ? "Format not terminated"
5191 : "Missing right curly or square bracket"));
5193 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5194 "### Tokener got EOF\n");
5198 if (s++ < PL_bufend)
5199 goto retry; /* ignore stray nulls */
5202 if (!PL_in_eval && !PL_preambled) {
5203 PL_preambled = TRUE;
5205 /* Generate a string of Perl code to load the debugger.
5206 * If PERL5DB is set, it will return the contents of that,
5207 * otherwise a compile-time require of perl5db.pl. */
5209 const char * const pdb = PerlEnv_getenv("PERL5DB");
5212 sv_setpv(PL_linestr, pdb);
5213 sv_catpvs(PL_linestr,";");
5215 SETERRNO(0,SS_NORMAL);
5216 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5218 PL_parser->preambling = CopLINE(PL_curcop);
5220 SvPVCLEAR(PL_linestr);
5221 if (PL_preambleav) {
5222 SV **svp = AvARRAY(PL_preambleav);
5223 SV **const end = svp + AvFILLp(PL_preambleav);
5225 sv_catsv(PL_linestr, *svp);
5227 sv_catpvs(PL_linestr, ";");
5229 sv_free(MUTABLE_SV(PL_preambleav));
5230 PL_preambleav = NULL;
5233 sv_catpvs(PL_linestr,
5234 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5235 if (PL_minus_n || PL_minus_p) {
5236 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5238 sv_catpvs(PL_linestr,"chomp;");
5241 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
5242 || *PL_splitstr == '"')
5243 && strchr(PL_splitstr + 1, *PL_splitstr))
5244 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5246 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5247 bytes can be used as quoting characters. :-) */
5248 const char *splits = PL_splitstr;
5249 sv_catpvs(PL_linestr, "our @F=split(q\0");
5252 if (*splits == '\\')
5253 sv_catpvn(PL_linestr, splits, 1);
5254 sv_catpvn(PL_linestr, splits, 1);
5255 } while (*splits++);
5256 /* This loop will embed the trailing NUL of
5257 PL_linestr as the last thing it does before
5259 sv_catpvs(PL_linestr, ");");
5263 sv_catpvs(PL_linestr,"our @F=split(' ');");
5266 sv_catpvs(PL_linestr, "\n");
5267 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5268 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5269 PL_last_lop = PL_last_uni = NULL;
5270 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
5271 update_debugger_info(PL_linestr, NULL, 0);
5276 bof = cBOOL(PL_rsfp);
5279 fake_eof = LEX_FAKE_EOF;
5281 PL_bufptr = PL_bufend;
5282 COPLINE_INC_WITH_HERELINES;
5283 if (!lex_next_chunk(fake_eof)) {
5284 CopLINE_dec(PL_curcop);
5286 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5288 CopLINE_dec(PL_curcop);
5290 /* If it looks like the start of a BOM or raw UTF-16,
5291 * check if it in fact is. */
5294 || *(U8*)s == BOM_UTF8_FIRST_BYTE
5298 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5299 bof = (offset == (Off_t)SvCUR(PL_linestr));
5300 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5301 /* offset may include swallowed CR */
5303 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5306 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5307 s = swallow_bom((U8*)s);
5310 if (PL_parser->in_pod) {
5311 /* Incest with pod. */
5312 if (*s == '=' && strEQs(s, "=cut") && !isALPHA(s[4])) {
5313 SvPVCLEAR(PL_linestr);
5314 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5315 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5316 PL_last_lop = PL_last_uni = NULL;
5317 PL_parser->in_pod = 0;
5320 if (PL_rsfp || PL_parser->filtered)
5322 } while (PL_parser->in_pod);
5323 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5324 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5325 PL_last_lop = PL_last_uni = NULL;
5326 if (CopLINE(PL_curcop) == 1) {
5327 while (s < PL_bufend && isSPACE(*s))
5329 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5333 if (*s == '#' && *(s+1) == '!')
5335 #ifdef ALTERNATE_SHEBANG
5337 static char const as[] = ALTERNATE_SHEBANG;
5338 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5339 d = s + (sizeof(as) - 1);
5341 #endif /* ALTERNATE_SHEBANG */
5350 while (*d && !isSPACE(*d))
5354 #ifdef ARG_ZERO_IS_SCRIPT
5355 if (ipathend > ipath) {
5357 * HP-UX (at least) sets argv[0] to the script name,
5358 * which makes $^X incorrect. And Digital UNIX and Linux,
5359 * at least, set argv[0] to the basename of the Perl
5360 * interpreter. So, having found "#!", we'll set it right.
5362 SV* copfilesv = CopFILESV(PL_curcop);
5365 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5367 assert(SvPOK(x) || SvGMAGICAL(x));
5368 if (sv_eq(x, copfilesv)) {
5369 sv_setpvn(x, ipath, ipathend - ipath);
5375 const char *bstart = SvPV_const(copfilesv, blen);
5376 const char * const lstart = SvPV_const(x, llen);
5378 bstart += blen - llen;
5379 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5380 sv_setpvn(x, ipath, ipathend - ipath);
5387 /* Anything to do if no copfilesv? */
5389 TAINT_NOT; /* $^X is always tainted, but that's OK */
5391 #endif /* ARG_ZERO_IS_SCRIPT */
5396 d = instr(s,"perl -");
5398 d = instr(s,"perl");
5400 /* avoid getting into infinite loops when shebang
5401 * line contains "Perl" rather than "perl" */
5403 for (d = ipathend-4; d >= ipath; --d) {
5404 if (isALPHA_FOLD_EQ(*d, 'p')
5405 && !ibcmp(d, "perl", 4))
5415 #ifdef ALTERNATE_SHEBANG
5417 * If the ALTERNATE_SHEBANG on this system starts with a
5418 * character that can be part of a Perl expression, then if
5419 * we see it but not "perl", we're probably looking at the
5420 * start of Perl code, not a request to hand off to some
5421 * other interpreter. Similarly, if "perl" is there, but
5422 * not in the first 'word' of the line, we assume the line
5423 * contains the start of the Perl program.
5425 if (d && *s != '#') {
5426 const char *c = ipath;
5427 while (*c && !strchr("; \t\r\n\f\v#", *c))
5430 d = NULL; /* "perl" not in first word; ignore */
5432 *s = '#'; /* Don't try to parse shebang line */
5434 #endif /* ALTERNATE_SHEBANG */
5439 && !instr(s,"indir")
5440 && instr(PL_origargv[0],"perl"))
5447 while (s < PL_bufend && isSPACE(*s))
5449 if (s < PL_bufend) {
5450 Newx(newargv,PL_origargc+3,char*);
5452 while (s < PL_bufend && !isSPACE(*s))
5455 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5458 newargv = PL_origargv;
5461 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5463 Perl_croak(aTHX_ "Can't exec %s", ipath);
5466 while (*d && !isSPACE(*d))
5468 while (SPACE_OR_TAB(*d))
5472 const bool switches_done = PL_doswitches;
5473 const U32 oldpdb = PL_perldb;
5474 const bool oldn = PL_minus_n;
5475 const bool oldp = PL_minus_p;
5479 bool baduni = FALSE;
5481 const char *d2 = d1 + 1;
5482 if (parse_unicode_opts((const char **)&d2)
5486 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
5487 const char * const m = d1;
5488 while (*d1 && !isSPACE(*d1))
5490 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5493 d1 = moreswitches(d1);
5495 if (PL_doswitches && !switches_done) {
5496 int argc = PL_origargc;
5497 char **argv = PL_origargv;
5500 } while (argc && argv[0][0] == '-' && argv[0][1]);
5501 init_argv_symbols(argc,argv);
5503 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
5504 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5505 /* if we have already added "LINE: while (<>) {",
5506 we must not do it again */
5508 SvPVCLEAR(PL_linestr);
5509 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5510 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5511 PL_last_lop = PL_last_uni = NULL;
5512 PL_preambled = FALSE;
5513 if (PERLDB_LINE_OR_SAVESRC)
5514 (void)gv_fetchfile(PL_origfilename);
5521 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5522 PL_lex_state = LEX_FORMLINE;
5523 force_next(FORMRBRACK);
5528 #ifdef PERL_STRICT_CR
5529 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5531 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5533 case ' ': case '\t': case '\f': case '\v':
5538 if (PL_lex_state != LEX_NORMAL
5539 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5541 const bool in_comment = *s == '#';
5542 if (*s == '#' && s == PL_linestart && PL_in_eval
5543 && !PL_rsfp && !PL_parser->filtered) {
5544 /* handle eval qq[#line 1 "foo"\n ...] */
5545 CopLINE_dec(PL_curcop);
5549 while (d < PL_bufend && *d != '\n')
5553 else if (d > PL_bufend)
5554 /* Found by Ilya: feed random input to Perl. */
5555 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5558 if (in_comment && d == PL_bufend
5559 && PL_lex_state == LEX_INTERPNORMAL
5560 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5561 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5564 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5565 PL_lex_state = LEX_FORMLINE;
5566 force_next(FORMRBRACK);
5571 while (s < PL_bufend && *s != '\n')
5579 else if (s > PL_bufend)
5580 /* Found by Ilya: feed random input to Perl. */
5581 Perl_croak(aTHX_ "panic: input overflow");
5585 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5593 while (s < PL_bufend && SPACE_OR_TAB(*s))
5596 if (strEQs(s,"=>")) {
5597 s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
5598 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5599 OPERATOR('-'); /* unary minus */
5602 case 'r': ftst = OP_FTEREAD; break;
5603 case 'w': ftst = OP_FTEWRITE; break;
5604 case 'x': ftst = OP_FTEEXEC; break;
5605 case 'o': ftst = OP_FTEOWNED; break;
5606 case 'R': ftst = OP_FTRREAD; break;
5607 case 'W': ftst = OP_FTRWRITE; break;
5608 case 'X': ftst = OP_FTREXEC; break;
5609 case 'O': ftst = OP_FTROWNED; break;
5610 case 'e': ftst = OP_FTIS; break;
5611 case 'z': ftst = OP_FTZERO; break;
5612 case 's': ftst = OP_FTSIZE; break;
5613 case 'f': ftst = OP_FTFILE; break;
5614 case 'd': ftst = OP_FTDIR; break;
5615 case 'l': ftst = OP_FTLINK; break;
5616 case 'p': ftst = OP_FTPIPE; break;
5617 case 'S': ftst = OP_FTSOCK; break;
5618 case 'u': ftst = OP_FTSUID; break;
5619 case 'g': ftst = OP_FTSGID; break;
5620 case 'k': ftst = OP_FTSVTX; break;
5621 case 'b': ftst = OP_FTBLK; break;
5622 case 'c': ftst = OP_FTCHR; break;
5623 case 't': ftst = OP_FTTTY; break;
5624 case 'T': ftst = OP_FTTEXT; break;
5625 case 'B': ftst = OP_FTBINARY; break;
5626 case 'M': case 'A': case 'C':
5627 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5629 case 'M': ftst = OP_FTMTIME; break;
5630 case 'A': ftst = OP_FTATIME; break;
5631 case 'C': ftst = OP_FTCTIME; break;
5639 PL_last_uni = PL_oldbufptr;
5640 PL_last_lop_op = (OPCODE)ftst;
5641 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5642 "### Saw file test %c\n", (int)tmp);
5647 /* Assume it was a minus followed by a one-letter named
5648 * subroutine call (or a -bareword), then. */
5649 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5650 "### '-%c' looked like a file test but was not\n",
5657 const char tmp = *s++;
5660 if (PL_expect == XOPERATOR)
5665 else if (*s == '>') {
5668 if (((*s == '$' || *s == '&') && s[1] == '*')
5669 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5670 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5671 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5674 PL_expect = XPOSTDEREF;
5677 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5678 s = force_word(s,METHOD,FALSE,TRUE);
5686 if (PL_expect == XOPERATOR) {
5688 && !PL_lex_allbrackets
5689 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5697 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5699 OPERATOR('-'); /* unary minus */
5705 const char tmp = *s++;
5708 if (PL_expect == XOPERATOR)
5713 if (PL_expect == XOPERATOR) {
5715 && !PL_lex_allbrackets
5716 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5724 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5731 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5732 if (PL_expect != XOPERATOR) {
5733 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5734 PL_expect = XOPERATOR;
5735 force_ident(PL_tokenbuf, '*');
5743 if (*s == '=' && !PL_lex_allbrackets
5744 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5752 && !PL_lex_allbrackets
5753 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5758 PL_parser->saw_infix_sigil = 1;
5763 if (PL_expect == XOPERATOR) {
5765 && !PL_lex_allbrackets
5766 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5771 PL_parser->saw_infix_sigil = 1;
5774 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5775 PL_tokenbuf[0] = '%';
5776 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5778 if (!PL_tokenbuf[1]) {
5781 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5783 PL_tokenbuf[0] = '@';
5785 PL_expect = XOPERATOR;
5786 force_ident_maybe_lex('%');
5791 bof = FEATURE_BITWISE_IS_ENABLED;
5792 if (bof && s[1] == '.')
5794 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5795 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5801 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5803 if (PL_lex_brackets > 100)
5804 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5805 PL_lex_brackstack[PL_lex_brackets++] = 0;
5806 PL_lex_allbrackets++;
5808 const char tmp = *s++;
5813 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5815 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5818 Perl_ck_warner_d(aTHX_
5819 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5820 "Smartmatch is experimental");
5824 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5826 BCop(OP_SCOMPLEMENT);
5828 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5830 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5837 goto just_a_word_zero_gv;
5843 switch (PL_expect) {
5845 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5847 PL_bufptr = s; /* update in case we back off */
5850 "Use of := for an empty attribute list is not allowed");
5857 PL_expect = XTERMBLOCK;
5861 while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5864 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5865 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5866 if (tmp < 0) tmp = -tmp;
5881 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5883 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5888 Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
5890 COPLINE_SET_FROM_MULTI_END;
5893 sv_catsv(sv, PL_lex_stuff);
5894 attrs = op_append_elem(OP_LIST, attrs,
5895 newSVOP(OP_CONST, 0, sv));
5896 SvREFCNT_dec_NN(PL_lex_stuff);
5897 PL_lex_stuff = NULL;
5900 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5902 if (PL_in_my == KEY_our) {
5903 deprecate_disappears_in("5.28",
5904 "Attribute \"unique\" is deprecated");
5907 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5910 /* NOTE: any CV attrs applied here need to be part of
5911 the CVf_BUILTIN_ATTRS define in cv.h! */
5912 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5914 CvLVALUE_on(PL_compcv);
5916 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5918 deprecate_disappears_in("5.28",
5919 "Attribute \"locked\" is deprecated");
5921 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5923 CvMETHOD_on(PL_compcv);
5925 else if (!PL_in_my && len == 5
5926 && strnEQ(SvPVX(sv), "const", len))
5929 Perl_ck_warner_d(aTHX_
5930 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
5931 ":const is experimental"
5933 CvANONCONST_on(PL_compcv);
5934 if (!CvANON(PL_compcv))
5935 yyerror(":const is not permitted on named "
5938 /* After we've set the flags, it could be argued that
5939 we don't need to do the attributes.pm-based setting
5940 process, and shouldn't bother appending recognized
5941 flags. To experiment with that, uncomment the
5942 following "else". (Note that's already been
5943 uncommented. That keeps the above-applied built-in
5944 attributes from being intercepted (and possibly
5945 rejected) by a package's attribute routines, but is
5946 justified by the performance win for the common case
5947 of applying only built-in attributes.) */
5949 attrs = op_append_elem(OP_LIST, attrs,
5950 newSVOP(OP_CONST, 0,
5954 if (*s == ':' && s[1] != ':')
5957 break; /* require real whitespace or :'s */
5958 /* XXX losing whitespace on sequential attributes here */
5963 && !(PL_expect == XOPERATOR
5964 ? (*s == '=' || *s == ')')
5965 : (*s == '{' || *s == '(')))
5967 const char q = ((*s == '\'') ? '"' : '\'');
5968 /* If here for an expression, and parsed no attrs, back
5970 if (PL_expect == XOPERATOR && !attrs) {
5974 /* MUST advance bufptr here to avoid bogus "at end of line"
5975 context messages from yyerror().
5978 yyerror( (const char *)
5980 ? Perl_form(aTHX_ "Invalid separator character "
5981 "%c%c%c in attribute list", q, *s, q)
5982 : "Unterminated attribute list" ) );
5990 NEXTVAL_NEXTTOKE.opval = attrs;
5996 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6000 PL_lex_allbrackets--;
6004 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6005 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6009 PL_lex_allbrackets++;
6012 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6019 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6022 PL_lex_allbrackets--;
6028 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6031 if (PL_lex_brackets <= 0)
6032 /* diag_listed_as: Unmatched right %s bracket */
6033 yyerror("Unmatched right square bracket");
6036 PL_lex_allbrackets--;
6037 if (PL_lex_state == LEX_INTERPNORMAL) {
6038 if (PL_lex_brackets == 0) {
6039 if (*s == '-' && s[1] == '>')
6040 PL_lex_state = LEX_INTERPENDMAYBE;
6041 else if (*s != '[' && *s != '{')
6042 PL_lex_state = LEX_INTERPEND;
6049 if (PL_lex_brackets > 100) {
6050 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6052 switch (PL_expect) {
6055 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6056 PL_lex_allbrackets++;
6057 OPERATOR(HASHBRACK);
6059 while (s < PL_bufend && SPACE_OR_TAB(*s))
6062 PL_tokenbuf[0] = '\0';
6063 if (d < PL_bufend && *d == '-') {
6064 PL_tokenbuf[0] = '-';
6066 while (d < PL_bufend && SPACE_OR_TAB(*d))
6069 if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
6070 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6072 while (d < PL_bufend && SPACE_OR_TAB(*d))
6075 const char minus = (PL_tokenbuf[0] == '-');
6076 s = force_word(s + minus, BAREWORD, FALSE, TRUE);
6084 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6085 PL_lex_allbrackets++;
6090 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6091 PL_lex_allbrackets++;
6095 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6096 PL_lex_allbrackets++;
6101 if (PL_oldoldbufptr == PL_last_lop)
6102 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6104 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6105 PL_lex_allbrackets++;
6108 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6110 /* This hack is to get the ${} in the message. */
6112 yyerror("syntax error");
6115 OPERATOR(HASHBRACK);
6117 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
6118 /* ${...} or @{...} etc., but not print {...}
6119 * Skip the disambiguation and treat this as a block.
6121 goto block_expectation;
6123 /* This hack serves to disambiguate a pair of curlies
6124 * as being a block or an anon hash. Normally, expectation
6125 * determines that, but in cases where we're not in a
6126 * position to expect anything in particular (like inside
6127 * eval"") we have to resolve the ambiguity. This code
6128 * covers the case where the first term in the curlies is a
6129 * quoted string. Most other cases need to be explicitly
6130 * disambiguated by prepending a "+" before the opening
6131 * curly in order to force resolution as an anon hash.
6133 * XXX should probably propagate the outer expectation
6134 * into eval"" to rely less on this hack, but that could
6135 * potentially break current behavior of eval"".
6139 if (*s == '\'' || *s == '"' || *s == '`') {
6140 /* common case: get past first string, handling escapes */
6141 for (t++; t < PL_bufend && *t != *s;)
6146 else if (*s == 'q') {
6149 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6150 && !isWORDCHAR(*t))))
6152 /* skip q//-like construct */
6154 char open, close, term;
6157 while (t < PL_bufend && isSPACE(*t))
6159 /* check for q => */
6160 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6161 OPERATOR(HASHBRACK);
6165 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6169 for (t++; t < PL_bufend; t++) {
6170 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6172 else if (*t == open)
6176 for (t++; t < PL_bufend; t++) {
6177 if (*t == '\\' && t+1 < PL_bufend)
6179 else if (*t == close && --brackets <= 0)
6181 else if (*t == open)
6188 /* skip plain q word */
6189 while ( t < PL_bufend
6190 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6192 t += UTF ? UTF8SKIP(t) : 1;
6195 else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
6196 t += UTF ? UTF8SKIP(t) : 1;
6197 while ( t < PL_bufend
6198 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6200 t += UTF ? UTF8SKIP(t) : 1;
6203 while (t < PL_bufend && isSPACE(*t))
6205 /* if comma follows first term, call it an anon hash */
6206 /* XXX it could be a comma expression with loop modifiers */
6207 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6208 || (*t == '=' && t[1] == '>')))
6209 OPERATOR(HASHBRACK);
6210 if (PL_expect == XREF)
6213 /* If there is an opening brace or 'sub:', treat it
6214 as a term to make ${{...}}{k} and &{sub:attr...}
6215 dwim. Otherwise, treat it as a statement, so
6216 map {no strict; ...} works.
6223 if (strEQs(s, "sub")) {
6234 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6240 pl_yylval.ival = CopLINE(PL_curcop);
6241 PL_copline = NOLINE; /* invalidate current command line number */
6242 TOKEN(formbrack ? '=' : '{');
6244 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6248 if (PL_lex_brackets <= 0)
6249 /* diag_listed_as: Unmatched right %s bracket */
6250 yyerror("Unmatched right curly bracket");
6252 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6253 PL_lex_allbrackets--;
6254 if (PL_lex_state == LEX_INTERPNORMAL) {
6255 if (PL_lex_brackets == 0) {
6256 if (PL_expect & XFAKEBRACK) {
6257 PL_expect &= XENUMMASK;
6258 PL_lex_state = LEX_INTERPEND;
6260 return yylex(); /* ignore fake brackets */
6262 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6263 && SvEVALED(PL_lex_repl))
6264 PL_lex_state = LEX_INTERPEND;
6265 else if (*s == '-' && s[1] == '>')
6266 PL_lex_state = LEX_INTERPENDMAYBE;
6267 else if (*s != '[' && *s != '{')
6268 PL_lex_state = LEX_INTERPEND;
6271 if (PL_expect & XFAKEBRACK) {
6272 PL_expect &= XENUMMASK;
6274 return yylex(); /* ignore fake brackets */
6276 force_next(formbrack ? '.' : '}');
6277 if (formbrack) LEAVE;
6278 if (formbrack == 2) { /* means . where arguments were expected */
6284 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
6287 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6288 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6295 if (PL_expect == XOPERATOR) {
6296 if ( PL_bufptr == PL_linestart
6297 && ckWARN(WARN_SEMICOLON)
6298 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
6300 CopLINE_dec(PL_curcop);
6301 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6302 CopLINE_inc(PL_curcop);
6305 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6307 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6308 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6314 PL_parser->saw_infix_sigil = 1;
6315 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
6321 PL_tokenbuf[0] = '&';
6322 s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
6323 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6324 if (PL_tokenbuf[1]) {
6325 force_ident_maybe_lex('&');
6334 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6335 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6343 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6345 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6346 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6350 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6354 const char tmp = *s++;
6356 if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, "=====")) {
6357 s = vcs_conflict_marker(s + 5);
6360 if (!PL_lex_allbrackets
6361 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6369 if (!PL_lex_allbrackets
6370 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
6379 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6380 && strchr("+-*/%.^&|<",tmp))
6381 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6382 "Reversed %c= operator",(int)tmp);
6384 if (PL_expect == XSTATE
6386 && (s == PL_linestart+1 || s[-2] == '\n') )
6388 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6389 || PL_lex_state != LEX_NORMAL) {
6394 if (strEQs(s,"=cut")) {
6408 PL_parser->in_pod = 1;
6412 if (PL_expect == XBLOCK) {
6414 #ifdef PERL_STRICT_CR
6415 while (SPACE_OR_TAB(*t))
6417 while (SPACE_OR_TAB(*t) || *t == '\r')
6420 if (*t == '\n' || *t == '#') {
6423 SAVEI8(PL_parser->form_lex_state);
6424 SAVEI32(PL_lex_formbrack);
6425 PL_parser->form_lex_state = PL_lex_state;
6426 PL_lex_formbrack = PL_lex_brackets + 1;
6430 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6439 const char tmp = *s++;
6441 /* was this !=~ where !~ was meant?
6442 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6444 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6445 const char *t = s+1;
6447 while (t < PL_bufend && isSPACE(*t))
6450 if (*t == '/' || *t == '?'
6451 || ((*t == 'm' || *t == 's' || *t == 'y')
6452 && !isWORDCHAR(t[1]))
6453 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6454 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6455 "!=~ should be !~");
6457 if (!PL_lex_allbrackets
6458 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6471 if (PL_expect != XOPERATOR) {
6472 if (s[1] != '<' && !strchr(s,'>'))
6474 if (s[1] == '<' && s[2] != '>') {
6475 if ((s == PL_linestart || s[-1] == '\n') && strEQs(s+2, "<<<<<")) {
6476 s = vcs_conflict_marker(s + 7);
6479 s = scan_heredoc(s);
6482 s = scan_inputsymbol(s);
6483 PL_expect = XOPERATOR;
6484 TOKEN(sublex_start());
6490 if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, "<<<<<")) {
6491 s = vcs_conflict_marker(s + 5);
6494 if (*s == '=' && !PL_lex_allbrackets
6495 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6500 SHop(OP_LEFT_SHIFT);
6505 if (!PL_lex_allbrackets
6506 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6514 if (!PL_lex_allbrackets
6515 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6524 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6532 const char tmp = *s++;
6534 if ((s == PL_linestart+2 || s[-3] == '\n') && strEQs(s, ">>>>>")) {
6535 s = vcs_conflict_marker(s + 5);
6538 if (*s == '=' && !PL_lex_allbrackets
6539 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6544 SHop(OP_RIGHT_SHIFT);
6546 else if (tmp == '=') {
6547 if (!PL_lex_allbrackets
6548 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6557 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6566 if (PL_expect == XOPERATOR) {
6567 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6568 return deprecate_commaless_var_list();
6571 else if (PL_expect == XPOSTDEREF) {
6574 POSTDEREF(DOLSHARP);
6580 && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
6581 || strchr("{$:+-@", s[2])))
6583 PL_tokenbuf[0] = '@';
6584 s = scan_ident(s + 1, PL_tokenbuf + 1,
6585 sizeof PL_tokenbuf - 1, FALSE);
6586 if (PL_expect == XOPERATOR) {
6588 if (PL_bufptr > s) {
6590 PL_bufptr = PL_oldbufptr;
6592 no_op("Array length", d);
6594 if (!PL_tokenbuf[1])
6596 PL_expect = XOPERATOR;
6597 force_ident_maybe_lex('#');
6601 PL_tokenbuf[0] = '$';
6602 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6603 if (PL_expect == XOPERATOR) {
6605 if (PL_bufptr > s) {
6607 PL_bufptr = PL_oldbufptr;
6611 if (!PL_tokenbuf[1]) {
6613 yyerror("Final $ should be \\$ or $name");
6619 const char tmp = *s;
6620 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6623 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6624 && intuit_more(s)) {
6626 PL_tokenbuf[0] = '@';
6627 if (ckWARN(WARN_SYNTAX)) {
6631 || isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)
6634 t += UTF ? UTF8SKIP(t) : 1;
6637 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6638 while (t < PL_bufend && *t != ']')
6640 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6641 "Multidimensional syntax %" UTF8f " not supported",
6642 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6646 else if (*s == '{') {
6648 PL_tokenbuf[0] = '%';
6649 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6650 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6652 char tmpbuf[sizeof PL_tokenbuf];
6655 } while (isSPACE(*t));
6656 if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
6658 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6663 && get_cvn_flags(tmpbuf, len, UTF
6667 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6668 "You need to quote \"%" UTF8f "\"",
6669 UTF8fARG(UTF, len, tmpbuf));
6676 PL_expect = XOPERATOR;
6677 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6678 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6679 if (!islop || PL_last_lop_op == OP_GREPSTART)
6680 PL_expect = XOPERATOR;
6681 else if (strchr("$@\"'`q", *s))
6682 PL_expect = XTERM; /* e.g. print $fh "foo" */
6683 else if ( strchr("&*<%", *s)
6684 && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
6686 PL_expect = XTERM; /* e.g. print $fh &sub */
6688 else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6689 char tmpbuf[sizeof PL_tokenbuf];
6691 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6692 if ((t2 = keyword(tmpbuf, len, 0))) {
6693 /* binary operators exclude handle interpretations */
6705 PL_expect = XTERM; /* e.g. print $fh length() */
6710 PL_expect = XTERM; /* e.g. print $fh subr() */
6713 else if (isDIGIT(*s))
6714 PL_expect = XTERM; /* e.g. print $fh 3 */
6715 else if (*s == '.' && isDIGIT(s[1]))
6716 PL_expect = XTERM; /* e.g. print $fh .3 */
6717 else if ((*s == '?' || *s == '-' || *s == '+')
6718 && !isSPACE(s[1]) && s[1] != '=')
6719 PL_expect = XTERM; /* e.g. print $fh -1 */
6720 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6722 PL_expect = XTERM; /* e.g. print $fh /.../
6723 XXX except DORDOR operator
6725 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6727 PL_expect = XTERM; /* print $fh <<"EOF" */
6730 force_ident_maybe_lex('$');
6734 if (PL_expect == XPOSTDEREF)
6736 PL_tokenbuf[0] = '@';
6737 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6738 if (PL_expect == XOPERATOR) {
6740 if (PL_bufptr > s) {
6742 PL_bufptr = PL_oldbufptr;
6747 if (!PL_tokenbuf[1]) {
6750 if (PL_lex_state == LEX_NORMAL)
6752 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6754 PL_tokenbuf[0] = '%';
6756 /* Warn about @ where they meant $. */
6757 if (*s == '[' || *s == '{') {
6758 if (ckWARN(WARN_SYNTAX)) {
6759 S_check_scalar_slice(aTHX_ s);
6763 PL_expect = XOPERATOR;
6764 force_ident_maybe_lex('@');
6767 case '/': /* may be division, defined-or, or pattern */
6768 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6769 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6770 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6775 else if (PL_expect == XOPERATOR) {
6777 if (*s == '=' && !PL_lex_allbrackets
6778 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6786 /* Disable warning on "study /blah/" */
6787 if ( PL_oldoldbufptr == PL_last_uni
6788 && ( *PL_last_uni != 's' || s - PL_last_uni < 5
6789 || memNE(PL_last_uni, "study", 5)
6790 || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
6793 s = scan_pat(s,OP_MATCH);
6794 TERM(sublex_start());
6797 case '?': /* conditional */
6799 if (!PL_lex_allbrackets
6800 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6805 PL_lex_allbrackets++;
6809 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6810 #ifdef PERL_STRICT_CR
6813 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6815 && (s == PL_linestart || s[-1] == '\n') )
6818 formbrack = 2; /* dot seen where arguments expected */
6821 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6825 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6828 if (!PL_lex_allbrackets
6829 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
6837 pl_yylval.ival = OPf_SPECIAL;
6843 if (*s == '=' && !PL_lex_allbrackets
6844 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6852 case '0': case '1': case '2': case '3': case '4':
6853 case '5': case '6': case '7': case '8': case '9':
6854 s = scan_num(s, &pl_yylval);
6855 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6856 if (PL_expect == XOPERATOR)
6861 if ( PL_expect == XOPERATOR
6862 && (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack))
6863 return deprecate_commaless_var_list();
6865 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6868 COPLINE_SET_FROM_MULTI_END;
6869 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6870 if (PL_expect == XOPERATOR) {
6873 pl_yylval.ival = OP_CONST;
6874 TERM(sublex_start());
6877 if ( PL_expect == XOPERATOR
6878 && (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack))
6879 return deprecate_commaless_var_list();
6881 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6884 printbuf("### Saw string before %s\n", s);
6886 PerlIO_printf(Perl_debug_log,
6887 "### Saw unterminated string\n");
6889 if (PL_expect == XOPERATOR) {
6894 pl_yylval.ival = OP_CONST;
6895 /* FIXME. I think that this can be const if char *d is replaced by
6896 more localised variables. */
6897 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6898 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6899 pl_yylval.ival = OP_STRINGIFY;
6903 if (pl_yylval.ival == OP_CONST)
6904 COPLINE_SET_FROM_MULTI_END;
6905 TERM(sublex_start());
6908 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6911 printbuf("### Saw backtick string before %s\n", s);
6913 PerlIO_printf(Perl_debug_log,
6914 "### Saw unterminated backtick string\n");
6916 if (PL_expect == XOPERATOR)
6917 no_op("Backticks",s);
6920 pl_yylval.ival = OP_BACKTICK;
6921 TERM(sublex_start());
6925 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6927 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6929 if (PL_expect == XOPERATOR)
6930 no_op("Backslash",s);
6934 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6935 char *start = s + 2;
6936 while (isDIGIT(*start) || *start == '_')
6938 if (*start == '.' && isDIGIT(start[1])) {
6939 s = scan_num(s, &pl_yylval);
6942 else if ((*start == ':' && start[1] == ':')
6943 || (PL_expect == XSTATE && *start == ':'))
6945 else if (PL_expect == XSTATE) {
6947 while (d < PL_bufend && isSPACE(*d)) d++;
6948 if (*d == ':') goto keylookup;
6950 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6951 if (!isALPHA(*start) && (PL_expect == XTERM
6952 || PL_expect == XREF || PL_expect == XSTATE
6953 || PL_expect == XTERMORDORDOR)) {
6954 GV *const gv = gv_fetchpvn_flags(s, start - s,
6955 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6957 s = scan_num(s, &pl_yylval);
6964 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
7017 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7019 /* Some keywords can be followed by any delimiter, including ':' */
7020 anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
7022 /* x::* is just a word, unless x is "CORE" */
7023 if (!anydelim && *s == ':' && s[1] == ':') {
7024 if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
7029 while (d < PL_bufend && isSPACE(*d))
7030 d++; /* no comments skipped here, or s### is misparsed */
7032 /* Is this a word before a => operator? */
7033 if (*d == '=' && d[1] == '>') {
7037 = newSVOP(OP_CONST, 0,
7038 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
7039 pl_yylval.opval->op_private = OPpCONST_BARE;
7043 /* Check for plugged-in keyword */
7047 char *saved_bufptr = PL_bufptr;
7049 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
7051 if (result == KEYWORD_PLUGIN_DECLINE) {
7052 /* not a plugged-in keyword */
7053 PL_bufptr = saved_bufptr;
7054 } else if (result == KEYWORD_PLUGIN_STMT) {
7055 pl_yylval.opval = o;
7057 if (!PL_nexttoke) PL_expect = XSTATE;
7058 return REPORT(PLUGSTMT);
7059 } else if (result == KEYWORD_PLUGIN_EXPR) {
7060 pl_yylval.opval = o;
7062 if (!PL_nexttoke) PL_expect = XOPERATOR;
7063 return REPORT(PLUGEXPR);
7065 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
7070 /* Check for built-in keyword */
7071 tmp = keyword(PL_tokenbuf, len, 0);
7073 /* Is this a label? */
7074 if (!anydelim && PL_expect == XSTATE
7075 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
7077 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
7078 pl_yylval.pval[len] = '\0';
7079 pl_yylval.pval[len+1] = UTF ? 1 : 0;
7084 /* Check for lexical sub */
7085 if (PL_expect != XOPERATOR) {
7086 char tmpbuf[sizeof PL_tokenbuf + 1];
7088 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7089 off = pad_findmy_pvn(tmpbuf, len+1, 0);
7090 if (off != NOT_IN_PAD) {
7091 assert(off); /* we assume this is boolean-true below */
7092 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7093 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7094 HEK * const stashname = HvNAME_HEK(stash);
7095 sv = newSVhek(stashname);
7096 sv_catpvs(sv, "::");
7097 sv_catpvn_flags(sv, PL_tokenbuf, len,
7098 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7099 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7109 rv2cv_op = newOP(OP_PADANY, 0);
7110 rv2cv_op->op_targ = off;
7111 cv = find_lexical_cv(off);
7119 if (tmp < 0) { /* second-class keyword? */
7120 GV *ogv = NULL; /* override (winner) */
7121 GV *hgv = NULL; /* hidden (loser) */
7122 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7124 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7125 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
7127 && (cv = GvCVu(gv)))
7129 if (GvIMPORTED_CV(gv))
7131 else if (! CvMETHOD(cv))
7135 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7138 && (isGV_with_GP(gv)
7139 ? GvCVu(gv) && GvIMPORTED_CV(gv)
7140 : SvPCS_IMPORTED(gv)
7141 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
7149 tmp = 0; /* overridden by import or by GLOBAL */
7152 && -tmp==KEY_lock /* XXX generalizable kludge */
7155 tmp = 0; /* any sub overrides "weak" keyword */
7157 else { /* no override */
7159 if (tmp == KEY_dump) {
7160 Perl_ck_warner_d(aTHX_ packWARN2(WARN_MISC,WARN_DEPRECATED),
7161 "dump() better written as CORE::dump(). "
7162 "dump() will no longer be available "
7167 if (hgv && tmp != KEY_x) /* never ambiguous */
7168 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7169 "Ambiguous call resolved as CORE::%s(), "
7170 "qualify as such or use &",
7175 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
7176 && (!anydelim || *s != '#')) {
7177 /* no override, and not s### either; skipspace is safe here
7178 * check for => on following line */
7180 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
7181 STRLEN soff = s - SvPVX(PL_linestr);
7183 arrow = *s == '=' && s[1] == '>';
7184 PL_bufptr = SvPVX(PL_linestr) + bufoff;
7185 s = SvPVX(PL_linestr) + soff;
7193 /* Trade off - by using this evil construction we can pull the
7194 variable gv into the block labelled keylookup. If not, then
7195 we have to give it function scope so that the goto from the
7196 earlier ':' case doesn't bypass the initialisation. */
7197 just_a_word_zero_gv:
7206 default: /* not a keyword */
7209 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7213 /* Get the rest if it looks like a package qualifier */
7215 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7217 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7220 Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
7221 UTF8fARG(UTF, len, PL_tokenbuf),
7222 *s == '\'' ? "'" : "::");
7227 if (PL_expect == XOPERATOR) {
7228 if (PL_bufptr == PL_linestart) {
7229 CopLINE_dec(PL_curcop);
7230 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7231 CopLINE_inc(PL_curcop);
7234 no_op("Bareword",s);
7237 /* See if the name is "Foo::",
7238 in which case Foo is a bareword
7239 (and a package name). */
7242 && PL_tokenbuf[len - 2] == ':'
7243 && PL_tokenbuf[len - 1] == ':')
7245 if (ckWARN(WARN_BAREWORD)
7246 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7247 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7248 "Bareword \"%" UTF8f
7249 "\" refers to nonexistent package",
7250 UTF8fARG(UTF, len, PL_tokenbuf));
7252 PL_tokenbuf[len] = '\0';
7261 /* if we saw a global override before, get the right name */
7264 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7267 SV * const tmp_sv = sv;
7268 sv = newSVpvs("CORE::GLOBAL::");
7269 sv_catsv(sv, tmp_sv);
7270 SvREFCNT_dec(tmp_sv);
7274 /* Presume this is going to be a bareword of some sort. */
7276 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
7277 pl_yylval.opval->op_private = OPpCONST_BARE;
7279 /* And if "Foo::", then that's what it certainly is. */
7285 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7286 const_op->op_private = OPpCONST_BARE;
7288 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
7292 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
7295 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
7298 /* Use this var to track whether intuit_method has been
7299 called. intuit_method returns 0 or > 255. */
7302 /* See if it's the indirect object for a list operator. */
7305 && PL_oldoldbufptr < PL_bufptr
7306 && (PL_oldoldbufptr == PL_last_lop
7307 || PL_oldoldbufptr == PL_last_uni)
7308 && /* NO SKIPSPACE BEFORE HERE! */
7310 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
7313 bool immediate_paren = *s == '(';
7316 /* (Now we can afford to cross potential line boundary.) */
7319 /* intuit_method() can indirectly call lex_next_chunk(),
7322 s_off = s - SvPVX(PL_linestr);
7323 /* Two barewords in a row may indicate method call. */
7324 if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
7326 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7328 /* the code at method: doesn't use s */
7331 s = SvPVX(PL_linestr) + s_off;
7333 /* If not a declared subroutine, it's an indirect object. */
7334 /* (But it's an indir obj regardless for sort.) */
7335 /* Also, if "_" follows a filetest operator, it's a bareword */
7338 ( !immediate_paren && (PL_last_lop_op == OP_SORT
7340 && (PL_last_lop_op != OP_MAPSTART
7341 && PL_last_lop_op != OP_GREPSTART))))
7342 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7343 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
7347 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7352 PL_expect = XOPERATOR;
7355 /* Is this a word before a => operator? */
7356 if (*s == '=' && s[1] == '>' && !pkgname) {
7359 if (gvp || (lex && !off)) {
7360 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
7361 /* This is our own scalar, created a few lines
7362 above, so this is safe. */
7364 sv_setpv(sv, PL_tokenbuf);
7365 if (UTF && !IN_BYTES
7366 && is_utf8_string((U8*)PL_tokenbuf, len))
7373 /* If followed by a paren, it's certainly a subroutine. */
7378 while (SPACE_OR_TAB(*d))
7380 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
7385 NEXTVAL_NEXTTOKE.opval =
7386 off ? rv2cv_op : pl_yylval.opval;
7388 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7389 else op_free(rv2cv_op), force_next(BAREWORD);
7394 /* If followed by var or block, call it a method (unless sub) */
7396 if ((*s == '$' || *s == '{') && !cv) {
7398 PL_last_lop = PL_oldbufptr;
7399 PL_last_lop_op = OP_METHOD;
7400 if (!PL_lex_allbrackets
7401 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7403 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7405 PL_expect = XBLOCKTERM;
7407 return REPORT(METHOD);
7410 /* If followed by a bareword, see if it looks like indir obj. */
7414 && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
7415 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7419 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
7421 sv_setpvn(sv, PL_tokenbuf, len);
7422 if (UTF && !IN_BYTES
7423 && is_utf8_string((U8*)PL_tokenbuf, len))
7425 else SvUTF8_off(sv);
7428 if (tmp == METHOD && !PL_lex_allbrackets
7429 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7431 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7436 /* Not a method, so call it a subroutine (if defined) */
7439 /* Check for a constant sub */
7440 if ((sv = cv_const_sv_or_av(cv))) {
7443 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7444 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7445 if (SvTYPE(sv) == SVt_PVAV)
7446 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7449 pl_yylval.opval->op_private = 0;
7450 pl_yylval.opval->op_folded = 1;
7451 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7456 op_free(pl_yylval.opval);
7458 off ? newCVREF(0, rv2cv_op) : rv2cv_op;
7459 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7460 PL_last_lop = PL_oldbufptr;
7461 PL_last_lop_op = OP_ENTERSUB;
7462 /* Is there a prototype? */
7466 STRLEN protolen = CvPROTOLEN(cv);
7467 const char *proto = CvPROTO(cv);
7469 proto = S_strip_spaces(aTHX_ proto, &protolen);
7472 if ((optional = *proto == ';'))
7475 while (*proto == ';');
7479 *proto == '$' || *proto == '_'
7480 || *proto == '*' || *proto == '+'
7485 *proto == '\\' && proto[1] && proto[2] == '\0'
7488 UNIPROTO(UNIOPSUB,optional);
7489 if (*proto == '\\' && proto[1] == '[') {
7490 const char *p = proto + 2;
7491 while(*p && *p != ']')
7493 if(*p == ']' && !p[1])
7494 UNIPROTO(UNIOPSUB,optional);
7496 if (*proto == '&' && *s == '{') {
7498 sv_setpvs(PL_subname, "__ANON__");
7500 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7501 if (!PL_lex_allbrackets
7502 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7504 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7509 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7511 force_next(off ? PRIVATEREF : BAREWORD);
7512 if (!PL_lex_allbrackets
7513 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7515 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7520 /* Call it a bare word */
7522 if (PL_hints & HINT_STRICT_SUBS)
7523 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7526 /* after "print" and similar functions (corresponding to
7527 * "F? L" in opcode.pl), whatever wasn't already parsed as
7528 * a filehandle should be subject to "strict subs".
7529 * Likewise for the optional indirect-object argument to system
7530 * or exec, which can't be a bareword */
7531 if ((PL_last_lop_op == OP_PRINT
7532 || PL_last_lop_op == OP_PRTF
7533 || PL_last_lop_op == OP_SAY
7534 || PL_last_lop_op == OP_SYSTEM
7535 || PL_last_lop_op == OP_EXEC)
7536 && (PL_hints & HINT_STRICT_SUBS))
7537 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7538 if (lastchar != '-') {
7539 if (ckWARN(WARN_RESERVED)) {
7543 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7545 /* PL_warn_reserved is constant */
7546 GCC_DIAG_IGNORE(-Wformat-nonliteral);
7547 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7557 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7558 && saw_infix_sigil) {
7559 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7560 "Operator or semicolon missing before %c%" UTF8f,
7562 UTF8fARG(UTF, strlen(PL_tokenbuf),
7564 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7565 "Ambiguous use of %c resolved as operator %c",
7566 lastchar, lastchar);
7573 newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7578 newSVOP(OP_CONST, 0,
7579 Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
7582 case KEY___PACKAGE__:
7584 newSVOP(OP_CONST, 0,
7586 ? newSVhek(HvNAME_HEK(PL_curstash))
7593 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7594 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7597 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7599 gv_init(gv,stash,"DATA",4,0);
7602 GvIOp(gv) = newIO();
7603 IoIFP(GvIOp(gv)) = PL_rsfp;
7604 #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
7606 const int fd = PerlIO_fileno(PL_rsfp);
7608 fcntl(fd,F_SETFD, FD_CLOEXEC);
7612 /* Mark this internal pseudo-handle as clean */
7613 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7614 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7615 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7617 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7618 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7619 /* if the script was opened in binmode, we need to revert
7620 * it to text mode for compatibility; but only iff it has CRs
7621 * XXX this is a questionable hack at best. */
7622 if (PL_bufend-PL_bufptr > 2
7623 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7626 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7627 loc = PerlIO_tell(PL_rsfp);
7628 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7631 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7633 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7634 #endif /* NETWARE */
7636 PerlIO_seek(PL_rsfp, loc, 0);
7640 #ifdef PERLIO_LAYERS
7643 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7652 FUN0OP(CvCLONE(PL_compcv)
7653 ? newOP(OP_RUNCV, 0)
7654 : newPVOP(OP_RUNCV,0,NULL));
7663 if (PL_expect == XSTATE) {
7674 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7675 if ((*s == ':' && s[1] == ':')
7676 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7680 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7684 Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
7685 UTF8fARG(UTF, len, PL_tokenbuf));
7688 else if (tmp == KEY_require || tmp == KEY_do
7690 /* that's a way to remember we saw "CORE::" */
7702 LOP(OP_ACCEPT,XTERM);
7705 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7710 LOP(OP_ATAN2,XTERM);
7716 LOP(OP_BINMODE,XTERM);
7719 LOP(OP_BLESS,XTERM);
7728 /* We have to disambiguate the two senses of
7729 "continue". If the next token is a '{' then
7730 treat it as the start of a continue block;
7731 otherwise treat it as a control operator.
7741 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7751 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7760 if (!PL_cryptseen) {
7761 PL_cryptseen = TRUE;
7765 LOP(OP_CRYPT,XTERM);
7768 LOP(OP_CHMOD,XTERM);
7771 LOP(OP_CHOWN,XTERM);
7774 LOP(OP_CONNECT,XTERM);
7794 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7796 if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
7797 && !keyword(PL_tokenbuf + 1, len, 0)) {
7798 SSize_t off = s-SvPVX(PL_linestr);
7800 s = SvPVX(PL_linestr)+off;
7802 force_ident_maybe_lex('&');
7807 if (orig_keyword == KEY_do) {
7816 PL_hints |= HINT_BLOCK_SCOPE;
7826 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7827 STR_WITH_LEN("NDBM_File::"),
7828 STR_WITH_LEN("DB_File::"),
7829 STR_WITH_LEN("GDBM_File::"),
7830 STR_WITH_LEN("SDBM_File::"),
7831 STR_WITH_LEN("ODBM_File::"),
7833 LOP(OP_DBMOPEN,XTERM);
7845 pl_yylval.ival = CopLINE(PL_curcop);
7849 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7861 if (*s == '{') { /* block eval */
7862 PL_expect = XTERMBLOCK;
7863 UNIBRACK(OP_ENTERTRY);
7865 else { /* string eval */
7867 UNIBRACK(OP_ENTEREVAL);
7872 UNIBRACK(-OP_ENTEREVAL);
7886 case KEY_endhostent:
7892 case KEY_endservent:
7895 case KEY_endprotoent:
7906 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7908 pl_yylval.ival = CopLINE(PL_curcop);
7910 if ( PL_expect == XSTATE
7911 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
7914 SSize_t s_off = s - SvPVX(PL_linestr);
7916 if ((PL_bufend - p) >= 3
7917 && strEQs(p, "my") && isSPACE(*(p + 2)))
7921 else if ((PL_bufend - p) >= 4
7922 && strEQs(p, "our") && isSPACE(*(p + 3)))
7925 /* skip optional package name, as in "for my abc $x (..)" */
7926 if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
7927 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7930 if (*p != '$' && *p != '\\')
7931 Perl_croak(aTHX_ "Missing $ on loop variable");
7933 /* The buffer may have been reallocated, update s */
7934 s = SvPVX(PL_linestr) + s_off;
7939 LOP(OP_FORMLINE,XTERM);
7948 LOP(OP_FCNTL,XTERM);
7954 LOP(OP_FLOCK,XTERM);
7957 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7962 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7967 LOP(OP_GREPSTART, XREF);
7984 case KEY_getpriority:
7985 LOP(OP_GETPRIORITY,XTERM);
7987 case KEY_getprotobyname:
7990 case KEY_getprotobynumber:
7991 LOP(OP_GPBYNUMBER,XTERM);
7993 case KEY_getprotoent:
8005 case KEY_getpeername:
8006 UNI(OP_GETPEERNAME);
8008 case KEY_gethostbyname:
8011 case KEY_gethostbyaddr:
8012 LOP(OP_GHBYADDR,XTERM);
8014 case KEY_gethostent:
8017 case KEY_getnetbyname:
8020 case KEY_getnetbyaddr:
8021 LOP(OP_GNBYADDR,XTERM);
8026 case KEY_getservbyname:
8027 LOP(OP_GSBYNAME,XTERM);
8029 case KEY_getservbyport:
8030 LOP(OP_GSBYPORT,XTERM);
8032 case KEY_getservent:
8035 case KEY_getsockname:
8036 UNI(OP_GETSOCKNAME);
8038 case KEY_getsockopt:
8039 LOP(OP_GSOCKOPT,XTERM);
8054 pl_yylval.ival = CopLINE(PL_curcop);
8055 Perl_ck_warner_d(aTHX_
8056 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8057 "given is experimental");
8062 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
8070 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8072 pl_yylval.ival = CopLINE(PL_curcop);
8076 LOP(OP_INDEX,XTERM);
8082 LOP(OP_IOCTL,XTERM);
8109 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8114 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8128 LOP(OP_LISTEN,XTERM);
8137 s = scan_pat(s,OP_MATCH);
8138 TERM(sublex_start());
8141 LOP(OP_MAPSTART, XREF);
8144 LOP(OP_MKDIR,XTERM);
8147 LOP(OP_MSGCTL,XTERM);
8150 LOP(OP_MSGGET,XTERM);
8153 LOP(OP_MSGRCV,XTERM);
8156 LOP(OP_MSGSND,XTERM);
8163 yyerror(Perl_form(aTHX_
8164 "Can't redeclare \"%s\" in \"%s\"",
8165 tmp == KEY_my ? "my" :
8166 tmp == KEY_state ? "state" : "our",
8167 PL_in_my == KEY_my ? "my" :
8168 PL_in_my == KEY_state ? "state" : "our"));
8170 PL_in_my = (U16)tmp;
8172 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8173 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8174 if (len == 3 && strEQs(PL_tokenbuf, "sub"))
8176 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8177 if (!PL_in_my_stash) {
8181 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8182 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
8183 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8186 else if (*s == '\\') {
8187 if (!FEATURE_MYREF_IS_ENABLED)
8188 Perl_croak(aTHX_ "The experimental declared_refs "
8189 "feature is not enabled");
8190 Perl_ck_warner_d(aTHX_
8191 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
8192 "Declaring references is experimental");
8200 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8205 s = tokenize_use(0, s);
8209 if (*s == '(' || (s = skipspace(s), *s == '('))
8212 if (!PL_lex_allbrackets
8213 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8215 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8222 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8224 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8226 for (t=d; isSPACE(*t);)
8228 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8230 && !(t[0] == '=' && t[1] == '>')
8231 && !(t[0] == ':' && t[1] == ':')
8232 && !keyword(s, d-s, 0)
8234 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8235 "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
8236 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8242 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8244 pl_yylval.ival = OP_OR;
8254 LOP(OP_OPEN_DIR,XTERM);
8257 checkcomma(s,PL_tokenbuf,"filehandle");
8261 checkcomma(s,PL_tokenbuf,"filehandle");
8280 s = force_word(s,BAREWORD,FALSE,TRUE);
8282 s = force_strict_version(s);
8286 LOP(OP_PIPE_OP,XTERM);
8289 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8292 COPLINE_SET_FROM_MULTI_END;
8293 pl_yylval.ival = OP_CONST;
8294 TERM(sublex_start());
8301 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8304 COPLINE_SET_FROM_MULTI_END;
8305 PL_expect = XOPERATOR;
8306 if (SvCUR(PL_lex_stuff)) {
8307 int warned_comma = !ckWARN(WARN_QW);
8308 int warned_comment = warned_comma;
8309 d = SvPV_force(PL_lex_stuff, len);
8311 for (; isSPACE(*d) && len; --len, ++d)
8316 if (!warned_comma || !warned_comment) {
8317 for (; !isSPACE(*d) && len; --len, ++d) {
8318 if (!warned_comma && *d == ',') {
8319 Perl_warner(aTHX_ packWARN(WARN_QW),
8320 "Possible attempt to separate words with commas");
8323 else if (!warned_comment && *d == '#') {
8324 Perl_warner(aTHX_ packWARN(WARN_QW),
8325 "Possible attempt to put comments in qw() list");
8331 for (; !isSPACE(*d) && len; --len, ++d)
8334 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8335 words = op_append_elem(OP_LIST, words,
8336 newSVOP(OP_CONST, 0, tokeq(sv)));
8341 words = newNULLLIST();
8342 SvREFCNT_dec_NN(PL_lex_stuff);
8343 PL_lex_stuff = NULL;
8344 PL_expect = XOPERATOR;
8345 pl_yylval.opval = sawparens(words);
8350 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8353 pl_yylval.ival = OP_STRINGIFY;
8354 if (SvIVX(PL_lex_stuff) == '\'')
8355 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8356 TERM(sublex_start());
8359 s = scan_pat(s,OP_QR);
8360 TERM(sublex_start());
8363 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8366 pl_yylval.ival = OP_BACKTICK;
8367 TERM(sublex_start());
8375 s = force_version(s, FALSE);
8377 else if (*s != 'v' || !isDIGIT(s[1])
8378 || (s = force_version(s, TRUE), *s == 'v'))
8380 *PL_tokenbuf = '\0';
8381 s = force_word(s,BAREWORD,TRUE,TRUE);
8382 if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
8383 PL_tokenbuf + sizeof(PL_tokenbuf),
8386 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8387 GV_ADD | (UTF ? SVf_UTF8 : 0));
8390 yyerror("<> at require-statement should be quotes");
8392 if (orig_keyword == KEY_require) {
8398 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
8400 PL_last_uni = PL_oldbufptr;
8401 PL_last_lop_op = OP_REQUIRE;
8403 return REPORT( (int)REQUIRE );
8412 LOP(OP_RENAME,XTERM);
8421 LOP(OP_RINDEX,XTERM);
8430 UNIDOR(OP_READLINE);
8433 UNIDOR(OP_BACKTICK);
8442 LOP(OP_REVERSE,XTERM);
8445 UNIDOR(OP_READLINK);
8452 if (pl_yylval.opval)
8453 TERM(sublex_start());
8455 TOKEN(1); /* force error */
8458 checkcomma(s,PL_tokenbuf,"filehandle");
8468 LOP(OP_SELECT,XTERM);
8474 LOP(OP_SEMCTL,XTERM);
8477 LOP(OP_SEMGET,XTERM);
8480 LOP(OP_SEMOP,XTERM);
8486 LOP(OP_SETPGRP,XTERM);
8488 case KEY_setpriority:
8489 LOP(OP_SETPRIORITY,XTERM);
8491 case KEY_sethostent:
8497 case KEY_setservent:
8500 case KEY_setprotoent:
8510 LOP(OP_SEEKDIR,XTERM);
8512 case KEY_setsockopt:
8513 LOP(OP_SSOCKOPT,XTERM);
8519 LOP(OP_SHMCTL,XTERM);
8522 LOP(OP_SHMGET,XTERM);
8525 LOP(OP_SHMREAD,XTERM);
8528 LOP(OP_SHMWRITE,XTERM);
8531 LOP(OP_SHUTDOWN,XTERM);
8540 LOP(OP_SOCKET,XTERM);
8542 case KEY_socketpair:
8543 LOP(OP_SOCKPAIR,XTERM);
8546 checkcomma(s,PL_tokenbuf,"subroutine name");
8549 s = force_word(s,BAREWORD,TRUE,TRUE);
8553 LOP(OP_SPLIT,XTERM);
8556 LOP(OP_SPRINTF,XTERM);
8559 LOP(OP_SPLICE,XTERM);
8574 LOP(OP_SUBSTR,XTERM);
8580 char * const tmpbuf = PL_tokenbuf + 1;
8581 expectation attrful;
8582 bool have_name, have_proto;
8583 const int key = tmp;
8584 SV *format_name = NULL;
8586 SSize_t off = s-SvPVX(PL_linestr);
8588 d = SvPVX(PL_linestr)+off;
8590 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
8592 || (*s == ':' && s[1] == ':'))
8596 attrful = XATTRBLOCK;
8597 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8599 if (key == KEY_format)
8600 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8602 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8604 PL_tokenbuf, len + 1, 0
8606 sv_setpvn(PL_subname, tmpbuf, len);
8608 sv_setsv(PL_subname,PL_curstname);
8609 sv_catpvs(PL_subname,"::");
8610 sv_catpvn(PL_subname,tmpbuf,len);
8612 if (SvUTF8(PL_linestr))
8613 SvUTF8_on(PL_subname);
8620 if (key == KEY_my || key == KEY_our || key==KEY_state)
8623 /* diag_listed_as: Missing name in "%s sub" */
8625 "Missing name in \"%s\"", PL_bufptr);
8627 PL_expect = XTERMBLOCK;
8628 attrful = XATTRTERM;
8629 sv_setpvs(PL_subname,"?");
8633 if (key == KEY_format) {
8635 NEXTVAL_NEXTTOKE.opval
8636 = newSVOP(OP_CONST,0, format_name);
8637 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8638 force_next(BAREWORD);
8643 /* Look for a prototype */
8644 if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
8645 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8646 COPLINE_SET_FROM_MULTI_END;
8648 Perl_croak(aTHX_ "Prototype not terminated");
8649 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8657 if (*s == ':' && s[1] != ':')
8658 PL_expect = attrful;
8659 else if ((*s != '{' && *s != '(') && key != KEY_format) {
8660 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8661 key == KEY_DESTROY || key == KEY_BEGIN ||
8662 key == KEY_UNITCHECK || key == KEY_CHECK ||
8663 key == KEY_INIT || key == KEY_END ||
8664 key == KEY_my || key == KEY_state ||
8667 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8668 else if (*s != ';' && *s != '}')
8669 Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
8673 NEXTVAL_NEXTTOKE.opval =
8674 newSVOP(OP_CONST, 0, PL_lex_stuff);
8675 PL_lex_stuff = NULL;
8680 sv_setpvs(PL_subname, "__ANON__");
8682 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8685 force_ident_maybe_lex('&');
8690 LOP(OP_SYSTEM,XREF);
8693 LOP(OP_SYMLINK,XTERM);
8696 LOP(OP_SYSCALL,XTERM);
8699 LOP(OP_SYSOPEN,XTERM);
8702 LOP(OP_SYSSEEK,XTERM);
8705 LOP(OP_SYSREAD,XTERM);
8708 LOP(OP_SYSWRITE,XTERM);
8713 TERM(sublex_start());
8734 LOP(OP_TRUNCATE,XTERM);
8746 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8748 pl_yylval.ival = CopLINE(PL_curcop);
8752 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8754 pl_yylval.ival = CopLINE(PL_curcop);
8758 LOP(OP_UNLINK,XTERM);
8764 LOP(OP_UNPACK,XTERM);
8767 LOP(OP_UTIME,XTERM);
8773 LOP(OP_UNSHIFT,XTERM);
8776 s = tokenize_use(1, s);
8786 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8788 pl_yylval.ival = CopLINE(PL_curcop);
8789 Perl_ck_warner_d(aTHX_
8790 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8791 "when is experimental");
8795 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8797 pl_yylval.ival = CopLINE(PL_curcop);
8801 PL_hints |= HINT_BLOCK_SCOPE;
8808 LOP(OP_WAITPID,XTERM);
8814 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8815 * we use the same number on EBCDIC */
8816 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8820 if (PL_expect == XOPERATOR) {
8821 if (*s == '=' && !PL_lex_allbrackets
8822 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8832 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8834 pl_yylval.ival = OP_XOR;
8843 Looks up an identifier in the pad or in a package
8845 is_sig indicates that this is a subroutine signature variable
8846 rather than a plain pad var.
8849 PRIVATEREF if this is a lexical name.
8850 BAREWORD if this belongs to a package.
8853 if we're in a my declaration
8854 croak if they tried to say my($foo::bar)
8855 build the ops for a my() declaration
8856 if it's an access to a my() variable
8857 build ops for access to a my() variable
8858 if in a dq string, and they've said @foo and we can't find @foo
8860 build ops for a bareword
8864 S_pending_ident(pTHX)
8867 const char pit = (char)pl_yylval.ival;
8868 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8869 /* All routes through this function want to know if there is a colon. */
8870 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8872 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8873 "### Pending identifier '%s'\n", PL_tokenbuf); });
8875 /* if we're in a my(), we can't allow dynamics here.
8876 $foo'bar has already been turned into $foo::bar, so
8877 just check for colons.
8879 if it's a legal name, the OP is a PADANY.
8882 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8884 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8885 "variable %s in \"our\"",
8886 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8887 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8892 /* "my" variable %s can't be in a package */
8893 /* PL_no_myglob is constant */
8894 GCC_DIAG_IGNORE(-Wformat-nonliteral);
8895 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8896 PL_in_my == KEY_my ? "my" : "state",
8897 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
8899 UTF ? SVf_UTF8 : 0);
8903 if (PL_in_my == KEY_sigvar) {
8904 /* A signature 'padop' needs in addition, an op_first to
8905 * point to a child sigdefelem, and an extra field to hold
8906 * the signature index. We can achieve both by using an
8907 * UNOP_AUX and (ab)using the op_aux field to hold the
8908 * index. If we ever need more fields, use a real malloced
8909 * aux strut instead.
8911 o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
8912 INT2PTR(UNOP_AUX_item *,
8913 (PL_parser->sig_elems)));
8914 o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
8915 : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
8919 o = newOP(OP_PADANY, 0);
8920 o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8921 UTF ? SVf_UTF8 : 0);
8922 if (PL_in_my == KEY_sigvar)
8925 pl_yylval.opval = o;
8931 build the ops for accesses to a my() variable.
8936 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8938 if (tmp != NOT_IN_PAD) {
8939 /* might be an "our" variable" */
8940 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8941 /* build ops for a bareword */
8942 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8943 HEK * const stashname = HvNAME_HEK(stash);
8944 SV * const sym = newSVhek(stashname);
8945 sv_catpvs(sym, "::");
8946 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8947 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
8948 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8952 ((PL_tokenbuf[0] == '$') ? SVt_PV
8953 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8958 pl_yylval.opval = newOP(OP_PADANY, 0);
8959 pl_yylval.opval->op_targ = tmp;
8965 Whine if they've said @foo or @foo{key} in a doublequoted string,
8966 and @foo (or %foo) isn't a variable we can find in the symbol
8969 if (ckWARN(WARN_AMBIGUOUS)
8971 && PL_lex_state != LEX_NORMAL
8972 && !PL_lex_brackets)
8974 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8975 ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
8977 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8980 /* Downgraded from fatal to warning 20000522 mjd */
8981 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8982 "Possible unintended interpolation of %" UTF8f
8984 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
8988 /* build ops for a bareword */
8989 pl_yylval.opval = newSVOP(OP_CONST, 0,
8990 newSVpvn_flags(PL_tokenbuf + 1,
8992 UTF ? SVf_UTF8 : 0 ));
8993 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8995 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8996 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
8997 | ( UTF ? SVf_UTF8 : 0 ),
8998 ((PL_tokenbuf[0] == '$') ? SVt_PV
8999 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9005 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9007 PERL_ARGS_ASSERT_CHECKCOMMA;
9009 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9010 if (ckWARN(WARN_SYNTAX)) {
9013 for (w = s+2; *w && level; w++) {
9021 /* the list of chars below is for end of statements or
9022 * block / parens, boolean operators (&&, ||, //) and branch
9023 * constructs (or, and, if, until, unless, while, err, for).
9024 * Not a very solid hack... */
9025 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9026 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9027 "%s (...) interpreted as function",name);
9030 while (s < PL_bufend && isSPACE(*s))
9034 while (s < PL_bufend && isSPACE(*s))
9036 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
9037 const char * const w = s;
9038 s += UTF ? UTF8SKIP(s) : 1;
9039 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9040 s += UTF ? UTF8SKIP(s) : 1;
9041 while (s < PL_bufend && isSPACE(*s))
9045 if (keyword(w, s - w, 0))
9048 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9049 if (gv && GvCVu(gv))
9054 Copy(w, tmpbuf+1, s - w, char);
9056 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
9057 if (off != NOT_IN_PAD) return;
9059 Perl_croak(aTHX_ "No comma allowed after %s", what);
9064 /* S_new_constant(): do any overload::constant lookup.
9066 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9067 Best used as sv=new_constant(..., sv, ...).
9068 If s, pv are NULL, calls subroutine with one argument,
9069 and <type> is used with error messages only.
9070 <type> is assumed to be well formed UTF-8 */
9073 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9074 SV *sv, SV *pv, const char *type, STRLEN typelen)
9077 HV * table = GvHV(PL_hintgv); /* ^H */
9082 const char *why1 = "", *why2 = "", *why3 = "";
9084 PERL_ARGS_ASSERT_NEW_CONSTANT;
9085 /* We assume that this is true: */
9086 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9089 /* charnames doesn't work well if there have been errors found */
9090 if (PL_error_count > 0 && *key == 'c')
9092 SvREFCNT_dec_NN(sv);
9093 return &PL_sv_undef;
9096 sv_2mortal(sv); /* Parent created it permanently */
9098 || ! (PL_hints & HINT_LOCALIZE_HH)
9099 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9104 /* Here haven't found what we're looking for. If it is charnames,
9105 * perhaps it needs to be loaded. Try doing that before giving up */
9107 Perl_load_module(aTHX_
9109 newSVpvs("_charnames"),
9110 /* version parameter; no need to specify it, as if
9111 * we get too early a version, will fail anyway,
9112 * not being able to find '_charnames' */
9117 assert(sp == PL_stack_sp);
9118 table = GvHV(PL_hintgv);
9120 && (PL_hints & HINT_LOCALIZE_HH)
9121 && (cvp = hv_fetch(table, key, keylen, FALSE))
9127 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9128 msg = Perl_form(aTHX_
9129 "Constant(%.*s) unknown",
9130 (int)(type ? typelen : len),
9136 why3 = "} is not defined";
9139 msg = Perl_form(aTHX_
9140 /* The +3 is for '\N{'; -4 for that, plus '}' */
9141 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9145 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9146 (int)(type ? typelen : len),
9147 (type ? type: s), why1, why2, why3);
9150 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9151 return SvREFCNT_inc_simple_NN(sv);
9156 pv = newSVpvn_flags(s, len, SVs_TEMP);
9158 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9160 typesv = &PL_sv_undef;
9162 PUSHSTACKi(PERLSI_OVERLOAD);
9174 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9178 /* Check the eval first */
9179 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9181 const char * errstr;
9182 sv_catpvs(errsv, "Propagated");
9183 errstr = SvPV_const(errsv, errlen);
9184 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9186 res = SvREFCNT_inc_simple_NN(sv);
9190 SvREFCNT_inc_simple_void_NN(res);
9199 why1 = "Call to &{$^H{";
9201 why3 = "}} did not return a defined value";
9203 (void)sv_2mortal(sv);
9210 PERL_STATIC_INLINE void
9211 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package,
9212 bool is_utf8, bool check_dollar)
9214 PERL_ARGS_ASSERT_PARSE_IDENT;
9216 while (*s < PL_bufend) {
9218 Perl_croak(aTHX_ "%s", ident_too_long);
9219 if (is_utf8 && isIDFIRST_utf8_safe(*s, PL_bufend)) {
9220 /* The UTF-8 case must come first, otherwise things
9221 * like c\N{COMBINING TILDE} would start failing, as the
9222 * isWORDCHAR_A case below would gobble the 'c' up.
9225 char *t = *s + UTF8SKIP(*s);
9226 while (isIDCONT_utf8_safe((const U8*) t, (const U8*) PL_bufend)) {
9229 if (*d + (t - *s) > e)
9230 Perl_croak(aTHX_ "%s", ident_too_long);
9231 Copy(*s, *d, t - *s, char);
9235 else if ( isWORDCHAR_A(**s) ) {
9238 } while (isWORDCHAR_A(**s) && *d < e);
9240 else if ( allow_package
9242 && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8))
9248 else if (allow_package && **s == ':' && (*s)[1] == ':'
9249 /* Disallow things like Foo::$bar. For the curious, this is
9250 * the code path that triggers the "Bad name after" warning
9251 * when looking for barewords.
9253 && !(check_dollar && (*s)[2] == '$')) {
9263 /* Returns a NUL terminated string, with the length of the string written to
9267 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9270 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9271 bool is_utf8 = cBOOL(UTF);
9273 PERL_ARGS_ASSERT_SCAN_WORD;
9275 parse_ident(&s, &d, e, allow_package, is_utf8, TRUE);
9281 /* Is the byte 'd' a legal single character identifier name? 'u' is true
9282 * iff Unicode semantics are to be used. The legal ones are any of:
9283 * a) all ASCII characters except:
9284 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
9286 * The final case currently doesn't get this far in the program, so we
9287 * don't test for it. If that were to change, it would be ok to allow it.
9288 * b) When not under Unicode rules, any upper Latin1 character
9289 * c) Otherwise, when unicode rules are used, all XIDS characters.
9291 * Because all ASCII characters have the same representation whether
9292 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
9293 * '{' without knowing if is UTF-8 or not. */
9294 #define VALID_LEN_ONE_IDENT(s, e, is_utf8) \
9295 (isGRAPH_A(*(s)) || ((is_utf8) \
9296 ? isIDFIRST_utf8_safe(s, e) \
9298 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
9301 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
9303 I32 herelines = PL_parser->herelines;
9304 SSize_t bracket = -1;
9307 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9308 bool is_utf8 = cBOOL(UTF);
9309 I32 orig_copline = 0, tmp_copline = 0;
9311 PERL_ARGS_ASSERT_SCAN_IDENT;
9313 if (isSPACE(*s) || !*s)
9316 while (isDIGIT(*s)) {
9318 Perl_croak(aTHX_ "%s", ident_too_long);
9322 else { /* See if it is a "normal" identifier */
9323 parse_ident(&s, &d, e, 1, is_utf8, FALSE);
9328 /* Either a digit variable, or parse_ident() found an identifier
9329 (anything valid as a bareword), so job done and return. */
9330 if (PL_lex_state != LEX_NORMAL)
9331 PL_lex_state = LEX_INTERPENDMAYBE;
9335 /* Here, it is not a run-of-the-mill identifier name */
9337 if (*s == '$' && s[1]
9338 && ( isIDFIRST_lazy_if_safe(s+1, PL_bufend, is_utf8)
9339 || isDIGIT_A((U8)s[1])
9342 || strEQs(s+1,"::")) )
9344 /* Dereferencing a value in a scalar variable.
9345 The alternatives are different syntaxes for a scalar variable.
9346 Using ' as a leading package separator isn't allowed. :: is. */
9349 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9351 bracket = s - SvPVX(PL_linestr);
9353 orig_copline = CopLINE(PL_curcop);
9354 if (s < PL_bufend && isSPACE(*s)) {
9358 if ((s <= PL_bufend - (is_utf8)
9361 && VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
9364 const STRLEN skip = UTF8SKIP(s);
9367 for ( i = 0; i < skip; i++ )
9375 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9376 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9380 /* Warn about ambiguous code after unary operators if {...} notation isn't
9381 used. There's no difference in ambiguity; it's merely a heuristic
9382 about when not to warn. */
9383 else if (ck_uni && bracket == -1)
9385 if (bracket != -1) {
9388 /* If we were processing {...} notation then... */
9389 if (isIDFIRST_lazy_if_safe(d, e, is_utf8)) {
9390 /* if it starts as a valid identifier, assume that it is one.
9391 (the later check for } being at the expected point will trap
9392 cases where this doesn't pan out.) */
9393 d += is_utf8 ? UTF8SKIP(d) : 1;
9394 parse_ident(&s, &d, e, 1, is_utf8, TRUE);
9396 tmp_copline = CopLINE(PL_curcop);
9397 if (s < PL_bufend && isSPACE(*s)) {
9400 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9401 /* ${foo[0]} and ${foo{bar}} notation. */
9402 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9403 const char * const brack =
9405 ((*s == '[') ? "[...]" : "{...}");
9406 orig_copline = CopLINE(PL_curcop);
9407 CopLINE_set(PL_curcop, tmp_copline);
9408 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9409 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9410 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9411 funny, dest, brack, funny, dest, brack);
9412 CopLINE_set(PL_curcop, orig_copline);
9415 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9416 PL_lex_allbrackets++;
9420 /* Handle extended ${^Foo} variables
9421 * 1999-02-27 mjd-perl-patch@plover.com */
9422 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9426 while (isWORDCHAR(*s) && d < e) {
9430 Perl_croak(aTHX_ "%s", ident_too_long);
9435 tmp_copline = CopLINE(PL_curcop);
9436 if ((skip = s < PL_bufend && isSPACE(*s)))
9437 /* Avoid incrementing line numbers or resetting PL_linestart,
9438 in case we have to back up. */
9443 /* Expect to find a closing } after consuming any trailing whitespace.
9446 /* Now increment line numbers if applicable. */
9450 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9451 PL_lex_state = LEX_INTERPEND;
9454 if (PL_lex_state == LEX_NORMAL) {
9455 if (ckWARN(WARN_AMBIGUOUS)
9456 && (keyword(dest, d - dest, 0)
9457 || get_cvn_flags(dest, d - dest, is_utf8
9461 SV *tmp = newSVpvn_flags( dest, d - dest,
9462 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9465 orig_copline = CopLINE(PL_curcop);
9466 CopLINE_set(PL_curcop, tmp_copline);
9467 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9468 "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf,
9469 funny, SVfARG(tmp), funny, SVfARG(tmp));
9470 CopLINE_set(PL_curcop, orig_copline);
9475 /* Didn't find the closing } at the point we expected, so restore
9476 state such that the next thing to process is the opening { and */
9477 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
9478 CopLINE_set(PL_curcop, orig_copline);
9479 PL_parser->herelines = herelines;
9483 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9484 PL_lex_state = LEX_INTERPEND;
9489 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
9491 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
9492 * found in the parse starting at 's', based on the subset that are valid
9493 * in this context input to this routine in 'valid_flags'. Advances s.
9494 * Returns TRUE if the input should be treated as a valid flag, so the next
9495 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
9496 * upon first call on the current regex. This routine will set it to any
9497 * charset modifier found. The caller shouldn't change it. This way,
9498 * another charset modifier encountered in the parse can be detected as an
9499 * error, as we have decided to allow only one */
9502 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9504 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9505 if (isWORDCHAR_lazy_if_safe( *s, PL_bufend, UTF)) {
9506 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9507 UTF ? SVf_UTF8 : 0);
9509 /* Pretend that it worked, so will continue processing before
9518 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
9519 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9520 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9521 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9522 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9523 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9524 case LOCALE_PAT_MOD:
9526 goto multiple_charsets;
9528 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9531 case UNICODE_PAT_MOD:
9533 goto multiple_charsets;
9535 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9538 case ASCII_RESTRICT_PAT_MOD:
9540 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9544 /* Error if previous modifier wasn't an 'a', but if it was, see
9545 * if, and accept, a second occurrence (only) */
9547 || get_regex_charset(*pmfl)
9548 != REGEX_ASCII_RESTRICTED_CHARSET)
9550 goto multiple_charsets;
9552 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9556 case DEPENDS_PAT_MOD:
9558 goto multiple_charsets;
9560 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9569 if (*charset != c) {
9570 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9572 else if (c == 'a') {
9573 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9574 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9577 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9580 /* Pretend that it worked, so will continue processing before dieing */
9586 S_scan_pat(pTHX_ char *start, I32 type)
9590 const char * const valid_flags =
9591 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9592 char charset = '\0'; /* character set modifier */
9593 unsigned int x_mod_count = 0;
9595 PERL_ARGS_ASSERT_SCAN_PAT;
9597 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9599 Perl_croak(aTHX_ "Search pattern not terminated");
9601 pm = (PMOP*)newPMOP(type, 0);
9602 if (PL_multi_open == '?') {
9603 /* This is the only point in the code that sets PMf_ONCE: */
9604 pm->op_pmflags |= PMf_ONCE;
9606 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9607 allows us to restrict the list needed by reset to just the ??
9609 assert(type != OP_TRANS);
9611 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9614 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9617 elements = mg->mg_len / sizeof(PMOP**);
9618 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9619 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9620 mg->mg_len = elements * sizeof(PMOP**);
9621 PmopSTASH_set(pm,PL_curstash);
9625 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9626 * anon CV. False positives like qr/[(?{]/ are harmless */
9628 if (type == OP_QR) {
9630 char *e, *p = SvPV(PL_lex_stuff, len);
9632 for (; p < e; p++) {
9633 if (p[0] == '(' && p[1] == '?'
9634 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9636 pm->op_pmflags |= PMf_HAS_CV;
9640 pm->op_pmflags |= PMf_IS_QR;
9643 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9644 &s, &charset, &x_mod_count))
9646 /* issue a warning if /c is specified,but /g is not */
9647 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9649 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9650 "Use of /c modifier is meaningless without /g" );
9653 PL_lex_op = (OP*)pm;
9654 pl_yylval.ival = OP_MATCH;
9659 S_scan_subst(pTHX_ char *start)
9665 line_t linediff = 0;
9667 char charset = '\0'; /* character set modifier */
9668 unsigned int x_mod_count = 0;
9671 PERL_ARGS_ASSERT_SCAN_SUBST;
9673 pl_yylval.ival = OP_NULL;
9675 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9678 Perl_croak(aTHX_ "Substitution pattern not terminated");
9682 first_start = PL_multi_start;
9683 first_line = CopLINE(PL_curcop);
9684 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9686 SvREFCNT_dec_NN(PL_lex_stuff);
9687 PL_lex_stuff = NULL;
9688 Perl_croak(aTHX_ "Substitution replacement not terminated");
9690 PL_multi_start = first_start; /* so whole substitution is taken together */
9692 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9696 if (*s == EXEC_PAT_MOD) {
9700 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9701 &s, &charset, &x_mod_count))
9707 if ((pm->op_pmflags & PMf_CONTINUE)) {
9708 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9712 SV * const repl = newSVpvs("");
9715 pm->op_pmflags |= PMf_EVAL;
9718 sv_catpvs(repl, "eval ");
9720 sv_catpvs(repl, "do ");
9722 sv_catpvs(repl, "{");
9723 sv_catsv(repl, PL_parser->lex_sub_repl);
9724 sv_catpvs(repl, "}");
9725 SvREFCNT_dec(PL_parser->lex_sub_repl);
9726 PL_parser->lex_sub_repl = repl;
9731 linediff = CopLINE(PL_curcop) - first_line;
9733 CopLINE_set(PL_curcop, first_line);
9735 if (linediff || es) {
9736 /* the IVX field indicates that the replacement string is a s///e;
9737 * the NVX field indicates how many src code lines the replacement
9739 sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
9740 ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = 0;
9741 ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
9745 PL_lex_op = (OP*)pm;
9746 pl_yylval.ival = OP_SUBST;
9751 S_scan_trans(pTHX_ char *start)
9758 bool nondestruct = 0;
9761 PERL_ARGS_ASSERT_SCAN_TRANS;
9763 pl_yylval.ival = OP_NULL;
9765 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9767 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9771 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9773 SvREFCNT_dec_NN(PL_lex_stuff);
9774 PL_lex_stuff = NULL;
9775 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9778 complement = del = squash = 0;
9782 complement = OPpTRANS_COMPLEMENT;
9785 del = OPpTRANS_DELETE;
9788 squash = OPpTRANS_SQUASH;
9800 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9801 o->op_private &= ~OPpTRANS_ALL;
9802 o->op_private |= del|squash|complement|
9803 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9804 (DO_UTF8(PL_parser->lex_sub_repl) ? OPpTRANS_TO_UTF : 0);
9807 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9814 Takes a pointer to the first < in <<FOO.
9815 Returns a pointer to the byte following <<FOO.
9817 This function scans a heredoc, which involves different methods
9818 depending on whether we are in a string eval, quoted construct, etc.
9819 This is because PL_linestr could containing a single line of input, or
9820 a whole string being evalled, or the contents of the current quote-
9823 The two basic methods are:
9824 - Steal lines from the input stream
9825 - Scan the heredoc in PL_linestr and remove it therefrom
9827 In a file scope or filtered eval, the first method is used; in a
9828 string eval, the second.
9830 In a quote-like operator, we have to choose between the two,
9831 depending on where we can find a newline. We peek into outer lex-
9832 ing scopes until we find one with a newline in it. If we reach the
9833 outermost lexing scope and it is a file, we use the stream method.
9834 Otherwise it is treated as an eval.
9838 S_scan_heredoc(pTHX_ char *s)
9840 I32 op_type = OP_SCALAR;
9849 bool indented = FALSE;
9850 const bool infile = PL_rsfp || PL_parser->filtered;
9851 const line_t origline = CopLINE(PL_curcop);
9852 LEXSHARED *shared = PL_parser->lex_shared;
9854 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9857 d = PL_tokenbuf + 1;
9858 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9859 *PL_tokenbuf = '\n';
9865 while (SPACE_OR_TAB(*peek))
9867 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9870 s = delimcpy(d, e, s, PL_bufend, term, &len);
9872 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9878 /* <<\FOO is equivalent to <<'FOO' */
9882 if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9883 deprecate_fatal_in("5.28", "Use of bare << to mean <<\"\" is deprecated");
9886 isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF))
9888 peek += UTF ? UTF8SKIP(peek) : 1;
9890 len = (peek - s >= e - d) ? (e - d) : (peek - s);
9891 Copy(s, d, len, char);
9895 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9896 Perl_croak(aTHX_ "Delimiter for here document is too long");
9899 len = d - PL_tokenbuf;
9901 #ifndef PERL_STRICT_CR
9902 d = strchr(s, '\r');
9904 char * const olds = s;
9906 while (s < PL_bufend) {
9912 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9921 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9926 tmpstr = newSV_type(SVt_PVIV);
9930 SvIV_set(tmpstr, -1);
9932 else if (term == '`') {
9933 op_type = OP_BACKTICK;
9934 SvIV_set(tmpstr, '\\');
9937 PL_multi_start = origline + 1 + PL_parser->herelines;
9938 PL_multi_open = PL_multi_close = '<';
9939 /* inside a string eval or quote-like operator */
9940 if (!infile || PL_lex_inwhat) {
9943 char * const olds = s;
9944 PERL_CONTEXT * const cx = CX_CUR();
9945 /* These two fields are not set until an inner lexing scope is
9946 entered. But we need them set here. */
9947 shared->ls_bufptr = s;
9948 shared->ls_linestr = PL_linestr;
9950 /* Look for a newline. If the current buffer does not have one,
9951 peek into the line buffer of the parent lexing scope, going
9952 up as many levels as necessary to find one with a newline
9955 while (!(s = (char *)memchr(
9956 (void *)shared->ls_bufptr, '\n',
9957 SvEND(shared->ls_linestr)-shared->ls_bufptr
9959 shared = shared->ls_prev;
9960 /* shared is only null if we have gone beyond the outermost
9961 lexing scope. In a file, we will have broken out of the
9962 loop in the previous iteration. In an eval, the string buf-
9963 fer ends with "\n;", so the while condition above will have
9964 evaluated to false. So shared can never be null. Or so you
9965 might think. Odd syntax errors like s;@{<<; can gobble up
9966 the implicit semicolon at the end of a flie, causing the
9967 file handle to be closed even when we are not in a string
9968 eval. So shared may be null in that case.
9969 (Closing '}' here to balance the earlier open brace for
9970 editors that look for matched pairs.) */
9971 if (UNLIKELY(!shared))
9973 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9974 most lexing scope. In a file, shared->ls_linestr at that
9975 level is just one line, so there is no body to steal. */
9976 if (infile && !shared->ls_prev) {
9981 else { /* eval or we've already hit EOF */
9982 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9986 linestr = shared->ls_linestr;
9987 bufend = SvEND(linestr);
9992 while (s < bufend - len + 1) {
9994 ++PL_parser->herelines;
9996 if (memEQ(s, PL_tokenbuf + 1, len - 1)) {
10000 /* Only valid if it's preceded by whitespace only */
10001 while (backup != myolds && --backup >= myolds) {
10002 if (! SPACE_OR_TAB(*backup)) {
10009 /* No whitespace or all! */
10010 if (backup == s || *backup == '\n') {
10011 Newxz(indent, indent_len + 1, char);
10012 memcpy(indent, backup + 1, indent_len);
10013 s--; /* before our delimiter */
10014 PL_parser->herelines--; /* this line doesn't count */
10020 while (s < bufend - len + 1
10021 && memNE(s,PL_tokenbuf,len) )
10024 ++PL_parser->herelines;
10028 if (s >= bufend - len + 1) {
10031 sv_setpvn(tmpstr,d+1,s-d);
10033 /* the preceding stmt passes a newline */
10034 PL_parser->herelines++;
10036 /* s now points to the newline after the heredoc terminator.
10037 d points to the newline before the body of the heredoc.
10040 /* We are going to modify linestr in place here, so set
10041 aside copies of the string if necessary for re-evals or
10043 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10044 check shared->re_eval_str. */
10045 if (shared->re_eval_start || shared->re_eval_str) {
10046 /* Set aside the rest of the regexp */
10047 if (!shared->re_eval_str)
10048 shared->re_eval_str =
10049 newSVpvn(shared->re_eval_start,
10050 bufend - shared->re_eval_start);
10051 shared->re_eval_start -= s-d;
10053 if (cxstack_ix >= 0
10054 && CxTYPE(cx) == CXt_EVAL
10055 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
10056 && cx->blk_eval.cur_text == linestr)
10058 cx->blk_eval.cur_text = newSVsv(linestr);
10059 cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
10061 /* Copy everything from s onwards back to d. */
10062 Move(s,d,bufend-s + 1,char);
10063 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10064 /* Setting PL_bufend only applies when we have not dug deeper
10065 into other scopes, because sublex_done sets PL_bufend to
10066 SvEND(PL_linestr). */
10067 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10073 char *oldbufptr_save;
10074 char *oldoldbufptr_save;
10076 SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
10077 term = PL_tokenbuf[1];
10079 linestr_save = PL_linestr; /* must restore this afterwards */
10080 d = s; /* and this */
10081 oldbufptr_save = PL_oldbufptr;
10082 oldoldbufptr_save = PL_oldoldbufptr;
10083 PL_linestr = newSVpvs("");
10084 PL_bufend = SvPVX(PL_linestr);
10086 PL_bufptr = PL_bufend;
10087 CopLINE_set(PL_curcop,
10088 origline + 1 + PL_parser->herelines);
10089 if (!lex_next_chunk(LEX_NO_TERM)
10090 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10091 /* Simply freeing linestr_save might seem simpler here, as it
10092 does not matter what PL_linestr points to, since we are
10093 about to croak; but in a quote-like op, linestr_save
10094 will have been prospectively freed already, via
10095 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
10096 restore PL_linestr. */
10097 SvREFCNT_dec_NN(PL_linestr);
10098 PL_linestr = linestr_save;
10099 PL_oldbufptr = oldbufptr_save;
10100 PL_oldoldbufptr = oldoldbufptr_save;
10103 CopLINE_set(PL_curcop, origline);
10104 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10105 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10106 /* ^That should be enough to avoid this needing to grow: */
10107 sv_catpvs(PL_linestr, "\n\0");
10108 assert(s == SvPVX(PL_linestr));
10109 PL_bufend = SvEND(PL_linestr);
10112 PL_parser->herelines++;
10113 PL_last_lop = PL_last_uni = NULL;
10114 #ifndef PERL_STRICT_CR
10115 if (PL_bufend - PL_linestart >= 2) {
10116 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
10117 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10119 PL_bufend[-2] = '\n';
10121 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10123 else if (PL_bufend[-1] == '\r')
10124 PL_bufend[-1] = '\n';
10126 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10127 PL_bufend[-1] = '\n';
10129 if (indented && (PL_bufend-s) >= len) {
10130 char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
10133 char *backup = found;
10136 /* Only valid if it's preceded by whitespace only */
10137 while (backup != s && --backup >= s) {
10138 if (! SPACE_OR_TAB(*backup)) {
10144 /* All whitespace or none! */
10145 if (backup == found || SPACE_OR_TAB(*backup)) {
10146 Newxz(indent, indent_len + 1, char);
10147 memcpy(indent, backup, indent_len);
10148 SvREFCNT_dec(PL_linestr);
10149 PL_linestr = linestr_save;
10150 PL_linestart = SvPVX(linestr_save);
10151 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10152 PL_oldbufptr = oldbufptr_save;
10153 PL_oldoldbufptr = oldoldbufptr_save;
10159 /* Didn't find it */
10160 sv_catsv(tmpstr,PL_linestr);
10162 if (*s == term && PL_bufend-s >= len
10163 && memEQ(s,PL_tokenbuf + 1,len))
10165 SvREFCNT_dec(PL_linestr);
10166 PL_linestr = linestr_save;
10167 PL_linestart = SvPVX(linestr_save);
10168 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10169 PL_oldbufptr = oldbufptr_save;
10170 PL_oldoldbufptr = oldoldbufptr_save;
10174 sv_catsv(tmpstr,PL_linestr);
10179 PL_multi_end = origline + PL_parser->herelines;
10180 if (indented && indent) {
10181 STRLEN linecount = 1;
10182 STRLEN herelen = SvCUR(tmpstr);
10183 char *ss = SvPVX(tmpstr);
10184 char *se = ss + herelen;
10185 SV *newstr = newSV(herelen+1);
10188 /* Trim leading whitespace */
10190 /* newline only? Copy and move on */
10192 sv_catpv(newstr,"\n");
10196 /* Found our indentation? Strip it */
10197 } else if (se - ss >= indent_len
10198 && memEQ(ss, indent, indent_len))
10204 while ((ss + le) < se && *(ss + le) != '\n')
10207 sv_catpvn(newstr, ss, le);
10211 /* Line doesn't begin with our indentation? Croak */
10214 "Indentation on line %d of here-doc doesn't match delimiter",
10219 /* avoid sv_setsv() as we dont wan't to COW here */
10220 sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
10222 SvREFCNT_dec_NN(newstr);
10224 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10225 SvPV_shrink_to_cur(tmpstr);
10228 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10231 PL_lex_stuff = tmpstr;
10232 pl_yylval.ival = op_type;
10236 SvREFCNT_dec(tmpstr);
10237 CopLINE_set(PL_curcop, origline);
10238 missingterm(PL_tokenbuf + 1);
10241 /* scan_inputsymbol
10242 takes: position of first '<' in input buffer
10243 returns: position of first char following the matching '>' in
10245 side-effects: pl_yylval and lex_op are set.
10250 <<>> read from ARGV without magic open
10251 <FH> read from filehandle
10252 <pkg::FH> read from package qualified filehandle
10253 <pkg'FH> read from package qualified filehandle
10254 <$fh> read from filehandle in $fh
10255 <*.h> filename glob
10260 S_scan_inputsymbol(pTHX_ char *start)
10262 char *s = start; /* current position in buffer */
10265 bool nomagicopen = FALSE;
10266 char *d = PL_tokenbuf; /* start of temp holding space */
10267 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10269 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10271 end = strchr(s, '\n');
10274 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
10275 nomagicopen = TRUE;
10281 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10283 /* die if we didn't have space for the contents of the <>,
10284 or if it didn't end, or if we see a newline
10287 if (len >= (I32)sizeof PL_tokenbuf)
10288 Perl_croak(aTHX_ "Excessively long <> operator");
10290 Perl_croak(aTHX_ "Unterminated <> operator");
10295 Remember, only scalar variables are interpreted as filehandles by
10296 this code. Anything more complex (e.g., <$fh{$num}>) will be
10297 treated as a glob() call.
10298 This code makes use of the fact that except for the $ at the front,
10299 a scalar variable and a filehandle look the same.
10301 if (*d == '$' && d[1]) d++;
10303 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10304 while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') {
10305 d += UTF ? UTF8SKIP(d) : 1;
10308 /* If we've tried to read what we allow filehandles to look like, and
10309 there's still text left, then it must be a glob() and not a getline.
10310 Use scan_str to pull out the stuff between the <> and treat it
10311 as nothing more than a string.
10314 if (d - PL_tokenbuf != len) {
10315 pl_yylval.ival = OP_GLOB;
10316 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
10318 Perl_croak(aTHX_ "Glob not terminated");
10322 bool readline_overriden = FALSE;
10324 /* we're in a filehandle read situation */
10327 /* turn <> into <ARGV> */
10329 Copy("ARGV",d,5,char);
10331 /* Check whether readline() is overriden */
10332 if ((gv_readline = gv_override("readline",8)))
10333 readline_overriden = TRUE;
10335 /* if <$fh>, create the ops to turn the variable into a
10339 /* try to find it in the pad for this block, otherwise find
10340 add symbol table ops
10342 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
10343 if (tmp != NOT_IN_PAD) {
10344 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10345 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10346 HEK * const stashname = HvNAME_HEK(stash);
10347 SV * const sym = sv_2mortal(newSVhek(stashname));
10348 sv_catpvs(sym, "::");
10349 sv_catpv(sym, d+1);
10354 OP * const o = newOP(OP_PADSV, 0);
10356 PL_lex_op = readline_overriden
10357 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10358 op_append_elem(OP_LIST, o,
10359 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10360 : newUNOP(OP_READLINE, 0, o);
10368 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
10370 PL_lex_op = readline_overriden
10371 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10372 op_append_elem(OP_LIST,
10373 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10374 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10375 : newUNOP(OP_READLINE, 0,
10376 newUNOP(OP_RV2SV, 0,
10377 newGVOP(OP_GV, 0, gv)));
10379 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10380 pl_yylval.ival = OP_NULL;
10383 /* If it's none of the above, it must be a literal filehandle
10384 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10386 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10387 PL_lex_op = readline_overriden
10388 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10389 op_append_elem(OP_LIST,
10390 newGVOP(OP_GV, 0, gv),
10391 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10392 : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
10393 pl_yylval.ival = OP_NULL;
10403 start position in buffer
10404 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
10405 only if they are of the open/close form
10406 keep_delims preserve the delimiters around the string
10407 re_reparse compiling a run-time /(?{})/:
10408 collapse // to /, and skip encoding src
10409 delimp if non-null, this is set to the position of
10410 the closing delimiter, or just after it if
10411 the closing and opening delimiters differ
10412 (i.e., the opening delimiter of a substitu-
10414 returns: position to continue reading from buffer
10415 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10416 updates the read buffer.
10418 This subroutine pulls a string out of the input. It is called for:
10419 q single quotes q(literal text)
10420 ' single quotes 'literal text'
10421 qq double quotes qq(interpolate $here please)
10422 " double quotes "interpolate $here please"
10423 qx backticks qx(/bin/ls -l)
10424 ` backticks `/bin/ls -l`
10425 qw quote words @EXPORT_OK = qw( func() $spam )
10426 m// regexp match m/this/
10427 s/// regexp substitute s/this/that/
10428 tr/// string transliterate tr/this/that/
10429 y/// string transliterate y/this/that/
10430 ($*@) sub prototypes sub foo ($)
10431 (stuff) sub attr parameters sub foo : attr(stuff)
10432 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10434 In most of these cases (all but <>, patterns and transliterate)
10435 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10436 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10437 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10440 It skips whitespace before the string starts, and treats the first
10441 character as the delimiter. If the delimiter is one of ([{< then
10442 the corresponding "close" character )]}> is used as the closing
10443 delimiter. It allows quoting of delimiters, and if the string has
10444 balanced delimiters ([{<>}]) it allows nesting.
10446 On success, the SV with the resulting string is put into lex_stuff or,
10447 if that is already non-NULL, into lex_repl. The second case occurs only
10448 when parsing the RHS of the special constructs s/// and tr/// (y///).
10449 For convenience, the terminating delimiter character is stuffed into
10454 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
10458 SV *sv; /* scalar value: string */
10459 const char *tmps; /* temp string, used for delimiter matching */
10460 char *s = start; /* current position in the buffer */
10461 char term; /* terminating character */
10462 char *to; /* current position in the sv's data */
10463 I32 brackets = 1; /* bracket nesting level */
10464 bool has_utf8 = FALSE; /* is there any utf8 content? */
10465 IV termcode; /* terminating char. code */
10466 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10467 STRLEN termlen; /* length of terminating string */
10470 /* The delimiters that have a mirror-image closing one */
10471 const char * opening_delims = "([{<";
10472 const char * closing_delims = ")]}>";
10474 const char * non_grapheme_msg = "Use of unassigned code point or"
10475 " non-standalone grapheme for a delimiter"
10476 " will be a fatal error starting in Perl"
10478 /* The only non-UTF character that isn't a stand alone grapheme is
10479 * white-space, hence can't be a delimiter. So can skip for non-UTF-8 */
10480 bool check_grapheme = UTF && ckWARN_d(WARN_DEPRECATED);
10482 PERL_ARGS_ASSERT_SCAN_STR;
10484 /* skip space before the delimiter */
10489 /* mark where we are, in case we need to report errors */
10492 /* after skipping whitespace, the next character is the terminator */
10494 if (!UTF || UTF8_IS_INVARIANT(term)) {
10495 termcode = termstr[0] = term;
10499 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10500 if (check_grapheme) {
10501 if ( UNLIKELY(UNICODE_IS_SUPER(termcode))
10502 || UNLIKELY(UNICODE_IS_NONCHAR(termcode)))
10504 /* These are considered graphemes, and since the ending
10505 * delimiter will be the same, we don't have to check the other
10507 check_grapheme = FALSE;
10509 else if (UNLIKELY(! _is_grapheme((U8 *) start,
10514 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "%s", non_grapheme_msg);
10516 /* Don't have to check the other end, as have already warned at
10518 check_grapheme = FALSE;
10522 Copy(s, termstr, termlen, U8);
10525 /* mark where we are */
10526 PL_multi_start = CopLINE(PL_curcop);
10527 PL_multi_open = termcode;
10528 herelines = PL_parser->herelines;
10530 /* If the delimiter has a mirror-image closing one, get it */
10531 if (term && (tmps = strchr(opening_delims, term))) {
10532 termcode = termstr[0] = term = closing_delims[tmps - opening_delims];
10535 PL_multi_close = termcode;
10537 if (PL_multi_open == PL_multi_close) {
10538 keep_bracketed_quoted = FALSE;
10541 /* create a new SV to hold the contents. 79 is the SV's initial length.
10542 What a random number. */
10543 sv = newSV_type(SVt_PVIV);
10545 SvIV_set(sv, termcode);
10546 (void)SvPOK_only(sv); /* validate pointer */
10548 /* move past delimiter and try to read a complete string */
10550 sv_catpvn(sv, s, termlen);
10553 /* extend sv if need be */
10554 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10555 /* set 'to' to the next character in the sv's string */
10556 to = SvPVX(sv)+SvCUR(sv);
10558 /* if open delimiter is the close delimiter read unbridle */
10559 if (PL_multi_open == PL_multi_close) {
10560 for (; s < PL_bufend; s++,to++) {
10561 /* embedded newlines increment the current line number */
10562 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10563 COPLINE_INC_WITH_HERELINES;
10564 /* handle quoted delimiters */
10565 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10566 if (!keep_bracketed_quoted
10568 || (re_reparse && s[1] == '\\'))
10571 else /* any other quotes are simply copied straight through */
10574 /* terminate when run out of buffer (the for() condition), or
10575 have found the terminator */
10576 else if (*s == term) { /* First byte of terminator matches */
10577 if (termlen == 1) /* If is the only byte, are done */
10580 /* If the remainder of the terminator matches, also are
10581 * done, after checking that is a separate grapheme */
10582 if ( s + termlen <= PL_bufend
10583 && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
10585 if ( check_grapheme
10586 && UNLIKELY(! _is_grapheme((U8 *) start,
10591 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10592 "%s", non_grapheme_msg);
10597 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
10605 /* if the terminator isn't the same as the start character (e.g.,
10606 matched brackets), we have to allow more in the quoting, and
10607 be prepared for nested brackets.
10610 /* read until we run out of string, or we find the terminator */
10611 for (; s < PL_bufend; s++,to++) {
10612 /* embedded newlines increment the line count */
10613 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10614 COPLINE_INC_WITH_HERELINES;
10615 /* backslashes can escape the open or closing characters */
10616 if (*s == '\\' && s+1 < PL_bufend) {
10617 if (!keep_bracketed_quoted
10618 && ( ((UV)s[1] == PL_multi_open)
10619 || ((UV)s[1] == PL_multi_close) ))
10626 /* allow nested opens and closes */
10627 else if ((UV)*s == PL_multi_close && --brackets <= 0)
10629 else if ((UV)*s == PL_multi_open)
10631 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10636 /* terminate the copied string and update the sv's end-of-string */
10638 SvCUR_set(sv, to - SvPVX_const(sv));
10641 * this next chunk reads more into the buffer if we're not done yet
10645 break; /* handle case where we are done yet :-) */
10647 #ifndef PERL_STRICT_CR
10648 if (to - SvPVX_const(sv) >= 2) {
10649 if ( (to[-2] == '\r' && to[-1] == '\n')
10650 || (to[-2] == '\n' && to[-1] == '\r'))
10654 SvCUR_set(sv, to - SvPVX_const(sv));
10656 else if (to[-1] == '\r')
10659 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10663 /* if we're out of file, or a read fails, bail and reset the current
10664 line marker so we can report where the unterminated string began
10666 COPLINE_INC_WITH_HERELINES;
10667 PL_bufptr = PL_bufend;
10668 if (!lex_next_chunk(0)) {
10670 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10673 s = start = PL_bufptr;
10676 /* at this point, we have successfully read the delimited string */
10679 sv_catpvn(sv, s, termlen);
10685 PL_multi_end = CopLINE(PL_curcop);
10686 CopLINE_set(PL_curcop, PL_multi_start);
10687 PL_parser->herelines = herelines;
10689 /* if we allocated too much space, give some back */
10690 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10691 SvLEN_set(sv, SvCUR(sv) + 1);
10692 SvPV_renew(sv, SvLEN(sv));
10695 /* decide whether this is the first or second quoted string we've read
10700 PL_parser->lex_sub_repl = sv;
10703 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10709 takes: pointer to position in buffer
10710 returns: pointer to new position in buffer
10711 side-effects: builds ops for the constant in pl_yylval.op
10713 Read a number in any of the formats that Perl accepts:
10715 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10716 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10717 0b[01](_?[01])* binary integers
10718 0[0-7](_?[0-7])* octal integers
10719 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10720 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10722 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10725 If it reads a number without a decimal point or an exponent, it will
10726 try converting the number to an integer and see if it can do so
10727 without loss of precision.
10731 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10733 const char *s = start; /* current position in buffer */
10734 char *d; /* destination in temp buffer */
10735 char *e; /* end of temp buffer */
10736 NV nv; /* number read, as a double */
10737 SV *sv = NULL; /* place to put the converted number */
10738 bool floatit; /* boolean: int or float? */
10739 const char *lastub = NULL; /* position of last underbar */
10740 static const char* const number_too_long = "Number too long";
10741 bool warned_about_underscore = 0;
10742 #define WARN_ABOUT_UNDERSCORE() \
10744 if (!warned_about_underscore) { \
10745 warned_about_underscore = 1; \
10746 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \
10747 "Misplaced _ in number"); \
10750 /* Hexadecimal floating point.
10752 * In many places (where we have quads and NV is IEEE 754 double)
10753 * we can fit the mantissa bits of a NV into an unsigned quad.
10754 * (Note that UVs might not be quads even when we have quads.)
10755 * This will not work everywhere, though (either no quads, or
10756 * using long doubles), in which case we have to resort to NV,
10757 * which will probably mean horrible loss of precision due to
10758 * multiple fp operations. */
10759 bool hexfp = FALSE;
10760 int total_bits = 0;
10761 int significant_bits = 0;
10762 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10763 # define HEXFP_UQUAD
10764 Uquad_t hexfp_uquad = 0;
10765 int hexfp_frac_bits = 0;
10770 NV hexfp_mult = 1.0;
10771 UV high_non_zero = 0; /* highest digit */
10772 int non_zero_integer_digits = 0;
10774 PERL_ARGS_ASSERT_SCAN_NUM;
10776 /* We use the first character to decide what type of number this is */
10780 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10782 /* if it starts with a 0, it could be an octal number, a decimal in
10783 0.13 disguise, or a hexadecimal number, or a binary number. */
10787 u holds the "number so far"
10788 shift the power of 2 of the base
10789 (hex == 4, octal == 3, binary == 1)
10790 overflowed was the number more than we can hold?
10792 Shift is used when we add a digit. It also serves as an "are
10793 we in octal/hex/binary?" indicator to disallow hex characters
10794 when in octal mode.
10799 bool overflowed = FALSE;
10800 bool just_zero = TRUE; /* just plain 0 or binary number? */
10801 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10802 static const char* const bases[5] =
10803 { "", "binary", "", "octal", "hexadecimal" };
10804 static const char* const Bases[5] =
10805 { "", "Binary", "", "Octal", "Hexadecimal" };
10806 static const char* const maxima[5] =
10808 "0b11111111111111111111111111111111",
10812 const char *base, *Base, *max;
10814 /* check for hex */
10815 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10819 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10824 /* check for a decimal in disguise */
10825 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10827 /* so it must be octal */
10834 WARN_ABOUT_UNDERSCORE();
10838 base = bases[shift];
10839 Base = Bases[shift];
10840 max = maxima[shift];
10842 /* read the rest of the number */
10844 /* x is used in the overflow test,
10845 b is the digit we're adding on. */
10850 /* if we don't mention it, we're done */
10854 /* _ are ignored -- but warned about if consecutive */
10856 if (lastub && s == lastub + 1)
10857 WARN_ABOUT_UNDERSCORE();
10861 /* 8 and 9 are not octal */
10862 case '8': case '9':
10864 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10868 case '2': case '3': case '4':
10869 case '5': case '6': case '7':
10871 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10874 case '0': case '1':
10875 b = *s++ & 15; /* ASCII digit -> value of digit */
10879 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10880 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10881 /* make sure they said 0x */
10884 b = (*s++ & 7) + 9;
10886 /* Prepare to put the digit we have onto the end
10887 of the number so far. We check for overflows.
10893 x = u << shift; /* make room for the digit */
10895 total_bits += shift;
10897 if ((x >> shift) != u
10898 && !(PL_hints & HINT_NEW_BINARY)) {
10901 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10902 "Integer overflow in %s number",
10905 u = x | b; /* add the digit to the end */
10908 n *= nvshift[shift];
10909 /* If an NV has not enough bits in its
10910 * mantissa to represent an UV this summing of
10911 * small low-order numbers is a waste of time
10912 * (because the NV cannot preserve the
10913 * low-order bits anyway): we could just
10914 * remember when did we overflow and in the
10915 * end just multiply n by the right
10920 if (high_non_zero == 0 && b > 0)
10924 non_zero_integer_digits++;
10926 /* this could be hexfp, but peek ahead
10927 * to avoid matching ".." */
10928 if (UNLIKELY(HEXFP_PEEK(s))) {
10936 /* if we get here, we had success: make a scalar value from
10941 /* final misplaced underbar check */
10943 WARN_ABOUT_UNDERSCORE();
10945 if (UNLIKELY(HEXFP_PEEK(s))) {
10946 /* Do sloppy (on the underbars) but quick detection
10947 * (and value construction) for hexfp, the decimal
10948 * detection will shortly be more thorough with the
10949 * underbar checks. */
10951 significant_bits = non_zero_integer_digits * shift;
10954 #else /* HEXFP_NV */
10957 /* Ignore the leading zero bits of
10958 * the high (first) non-zero digit. */
10959 if (high_non_zero) {
10960 if (high_non_zero < 0x8)
10961 significant_bits--;
10962 if (high_non_zero < 0x4)
10963 significant_bits--;
10964 if (high_non_zero < 0x2)
10965 significant_bits--;
10972 bool accumulate = TRUE;
10973 for (h++; (isXDIGIT(*h) || *h == '_'); h++) {
10974 if (isXDIGIT(*h)) {
10975 U8 b = XDIGIT_VALUE(*h);
10976 significant_bits += shift;
10979 if (significant_bits < NV_MANT_DIG) {
10980 /* We are in the long "run" of xdigits,
10981 * accumulate the full four bits. */
10982 hexfp_uquad <<= shift;
10984 hexfp_frac_bits += shift;
10986 /* We are at a hexdigit either at,
10987 * or straddling, the edge of mantissa.
10988 * We will try grabbing as many as
10989 * possible bits. */
10991 significant_bits - NV_MANT_DIG;
10994 hexfp_uquad <<= tail;
10995 hexfp_uquad |= b >> (shift - tail);
10996 hexfp_frac_bits += tail;
10998 /* Ignore the trailing zero bits
10999 * of the last non-zero xdigit.
11001 * The assumption here is that if
11002 * one has input of e.g. the xdigit
11003 * eight (0x8), there is only one
11004 * bit being input, not the full
11005 * four bits. Conversely, if one
11006 * specifies a zero xdigit, the
11007 * assumption is that one really
11008 * wants all those bits to be zero. */
11010 if ((b & 0x1) == 0x0) {
11011 significant_bits--;
11012 if ((b & 0x2) == 0x0) {
11013 significant_bits--;
11014 if ((b & 0x4) == 0x0) {
11015 significant_bits--;
11021 accumulate = FALSE;
11024 /* Keep skipping the xdigits, and
11025 * accumulating the significant bits,
11026 * but do not shift the uquad
11027 * (which would catastrophically drop
11028 * high-order bits) or accumulate the
11029 * xdigits anymore. */
11031 #else /* HEXFP_NV */
11035 hexfp_nv += b * nv_mult;
11037 accumulate = FALSE;
11041 if (significant_bits >= NV_MANT_DIG)
11042 accumulate = FALSE;
11046 if ((total_bits > 0 || significant_bits > 0) &&
11047 isALPHA_FOLD_EQ(*h, 'p')) {
11048 bool negexp = FALSE;
11052 else if (*h == '-') {
11058 while (isDIGIT(*h) || *h == '_') {
11061 hexfp_exp += *h - '0';
11064 && -hexfp_exp < NV_MIN_EXP - 1) {
11065 /* NOTE: this means that the exponent
11066 * underflow warning happens for
11067 * the IEEE 754 subnormals (denormals),
11068 * because DBL_MIN_EXP etc are the lowest
11069 * possible binary (or, rather, DBL_RADIX-base)
11070 * exponent for normals, not subnormals.
11072 * This may or may not be a good thing. */
11073 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11074 "Hexadecimal float: exponent underflow");
11080 && hexfp_exp > NV_MAX_EXP - 1) {
11081 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11082 "Hexadecimal float: exponent overflow");
11090 hexfp_exp = -hexfp_exp;
11092 hexfp_exp -= hexfp_frac_bits;
11094 hexfp_mult = Perl_pow(2.0, hexfp_exp);
11102 if (n > 4294967295.0)
11103 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11104 "%s number > %s non-portable",
11110 if (u > 0xffffffff)
11111 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11112 "%s number > %s non-portable",
11117 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11118 sv = new_constant(start, s - start, "integer",
11119 sv, NULL, NULL, 0);
11120 else if (PL_hints & HINT_NEW_BINARY)
11121 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11126 handle decimal numbers.
11127 we're also sent here when we read a 0 as the first digit
11129 case '1': case '2': case '3': case '4': case '5':
11130 case '6': case '7': case '8': case '9': case '.':
11133 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11142 /* read next group of digits and _ and copy into d */
11145 || UNLIKELY(hexfp && isXDIGIT(*s)))
11147 /* skip underscores, checking for misplaced ones
11151 if (lastub && s == lastub + 1)
11152 WARN_ABOUT_UNDERSCORE();
11156 /* check for end of fixed-length buffer */
11158 Perl_croak(aTHX_ "%s", number_too_long);
11159 /* if we're ok, copy the character */
11164 /* final misplaced underbar check */
11165 if (lastub && s == lastub + 1)
11166 WARN_ABOUT_UNDERSCORE();
11168 /* read a decimal portion if there is one. avoid
11169 3..5 being interpreted as the number 3. followed
11172 if (*s == '.' && s[1] != '.') {
11177 WARN_ABOUT_UNDERSCORE();
11181 /* copy, ignoring underbars, until we run out of digits.
11185 || UNLIKELY(hexfp && isXDIGIT(*s));
11188 /* fixed length buffer check */
11190 Perl_croak(aTHX_ "%s", number_too_long);
11192 if (lastub && s == lastub + 1)
11193 WARN_ABOUT_UNDERSCORE();
11199 /* fractional part ending in underbar? */
11201 WARN_ABOUT_UNDERSCORE();
11202 if (*s == '.' && isDIGIT(s[1])) {
11203 /* oops, it's really a v-string, but without the "v" */
11209 /* read exponent part, if present */
11210 if ((isALPHA_FOLD_EQ(*s, 'e')
11211 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
11212 && strchr("+-0123456789_", s[1]))
11216 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
11217 ditto for p (hexfloats) */
11218 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
11219 /* At least some Mach atof()s don't grok 'E' */
11222 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
11229 /* stray preinitial _ */
11231 WARN_ABOUT_UNDERSCORE();
11235 /* allow positive or negative exponent */
11236 if (*s == '+' || *s == '-')
11239 /* stray initial _ */
11241 WARN_ABOUT_UNDERSCORE();
11245 /* read digits of exponent */
11246 while (isDIGIT(*s) || *s == '_') {
11249 Perl_croak(aTHX_ "%s", number_too_long);
11253 if (((lastub && s == lastub + 1)
11254 || (!isDIGIT(s[1]) && s[1] != '_')))
11255 WARN_ABOUT_UNDERSCORE();
11263 We try to do an integer conversion first if no characters
11264 indicating "float" have been found.
11269 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11271 if (flags == IS_NUMBER_IN_UV) {
11273 sv = newSViv(uv); /* Prefer IVs over UVs. */
11276 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11277 if (uv <= (UV) IV_MIN)
11278 sv = newSViv(-(IV)uv);
11285 STORE_LC_NUMERIC_UNDERLYING_SET_STANDARD();
11286 /* terminate the string */
11288 if (UNLIKELY(hexfp)) {
11289 # ifdef NV_MANT_DIG
11290 if (significant_bits > NV_MANT_DIG)
11291 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11292 "Hexadecimal float: mantissa overflow");
11295 nv = hexfp_uquad * hexfp_mult;
11296 #else /* HEXFP_NV */
11297 nv = hexfp_nv * hexfp_mult;
11300 nv = Atof(PL_tokenbuf);
11302 RESTORE_LC_NUMERIC_UNDERLYING();
11307 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11308 const char *const key = floatit ? "float" : "integer";
11309 const STRLEN keylen = floatit ? 5 : 7;
11310 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11311 key, keylen, sv, NULL, NULL, 0);
11315 /* if it starts with a v, it could be a v-string */
11318 sv = newSV(5); /* preallocate storage space */
11319 ENTER_with_name("scan_vstring");
11321 s = scan_vstring(s, PL_bufend, sv);
11322 SvREFCNT_inc_simple_void_NN(sv);
11323 LEAVE_with_name("scan_vstring");
11327 /* make the op for the constant and return */
11330 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11332 lvalp->opval = NULL;
11338 S_scan_formline(pTHX_ char *s)
11340 SV * const stuff = newSVpvs("");
11341 bool needargs = FALSE;
11342 bool eofmt = FALSE;
11344 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11346 while (!needargs) {
11350 #ifdef PERL_STRICT_CR
11351 while (SPACE_OR_TAB(*t))
11354 while (SPACE_OR_TAB(*t) || *t == '\r')
11357 if (*t == '\n' || t == PL_bufend) {
11362 eol = (char *) memchr(s,'\n',PL_bufend-s);
11367 for (t = s; t < eol; t++) {
11368 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11370 goto enough; /* ~~ must be first line in formline */
11372 if (*t == '@' || *t == '^')
11376 sv_catpvn(stuff, s, eol-s);
11377 #ifndef PERL_STRICT_CR
11378 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11379 char *end = SvPVX(stuff) + SvCUR(stuff);
11382 SvCUR_set(stuff, SvCUR(stuff) - 1);
11390 if ((PL_rsfp || PL_parser->filtered)
11391 && PL_parser->form_lex_state == LEX_NORMAL) {
11393 PL_bufptr = PL_bufend;
11394 COPLINE_INC_WITH_HERELINES;
11395 got_some = lex_next_chunk(0);
11396 CopLINE_dec(PL_curcop);
11404 if (!SvCUR(stuff) || needargs)
11405 PL_lex_state = PL_parser->form_lex_state;
11406 if (SvCUR(stuff)) {
11407 PL_expect = XSTATE;
11409 const char *s2 = s;
11410 while (isSPACE(*s2) && *s2 != '\n')
11413 PL_expect = XTERMBLOCK;
11414 NEXTVAL_NEXTTOKE.ival = 0;
11417 NEXTVAL_NEXTTOKE.ival = 0;
11418 force_next(FORMLBRACK);
11421 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11424 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
11428 SvREFCNT_dec(stuff);
11430 PL_lex_formbrack = 0;
11436 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11438 const I32 oldsavestack_ix = PL_savestack_ix;
11439 CV* const outsidecv = PL_compcv;
11441 SAVEI32(PL_subline);
11442 save_item(PL_subname);
11443 SAVESPTR(PL_compcv);
11445 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11446 CvFLAGS(PL_compcv) |= flags;
11448 PL_subline = CopLINE(PL_curcop);
11449 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11450 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11451 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11452 if (outsidecv && CvPADLIST(outsidecv))
11453 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
11455 return oldsavestack_ix;
11459 S_yywarn(pTHX_ const char *const s, U32 flags)
11461 PERL_ARGS_ASSERT_YYWARN;
11463 PL_in_eval |= EVAL_WARNONLY;
11464 yyerror_pv(s, flags);
11469 Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
11471 PERL_ARGS_ASSERT_ABORT_EXECUTION;
11474 Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
11477 "%sExecution of %s aborted due to compilation errors.\n", msg, name);
11479 NOT_REACHED; /* NOTREACHED */
11485 /* Called, after at least one error has been found, to abort the parse now,
11486 * instead of trying to forge ahead */
11488 yyerror_pvn(NULL, 0, 0);
11492 Perl_yyerror(pTHX_ const char *const s)
11494 PERL_ARGS_ASSERT_YYERROR;
11495 return yyerror_pvn(s, strlen(s), 0);
11499 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11501 PERL_ARGS_ASSERT_YYERROR_PV;
11502 return yyerror_pvn(s, strlen(s), flags);
11506 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11508 const char *context = NULL;
11511 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11512 int yychar = PL_parser->yychar;
11514 /* Output error message 's' with length 'len'. 'flags' are SV flags that
11515 * apply. If the number of errors found is large enough, it abandons
11516 * parsing. If 's' is NULL, there is no message, and it abandons
11517 * processing unconditionally */
11520 if (!yychar || (yychar == ';' && !PL_rsfp))
11521 sv_catpvs(where_sv, "at EOF");
11522 else if ( PL_oldoldbufptr
11523 && PL_bufptr > PL_oldoldbufptr
11524 && PL_bufptr - PL_oldoldbufptr < 200
11525 && PL_oldoldbufptr != PL_oldbufptr
11526 && PL_oldbufptr != PL_bufptr)
11530 The code below is removed for NetWare because it
11531 abends/crashes on NetWare when the script has error such as
11532 not having the closing quotes like:
11533 if ($var eq "value)
11534 Checking of white spaces is anyway done in NetWare code.
11537 while (isSPACE(*PL_oldoldbufptr))
11540 context = PL_oldoldbufptr;
11541 contlen = PL_bufptr - PL_oldoldbufptr;
11543 else if ( PL_oldbufptr
11544 && PL_bufptr > PL_oldbufptr
11545 && PL_bufptr - PL_oldbufptr < 200
11546 && PL_oldbufptr != PL_bufptr) {
11549 The code below is removed for NetWare because it
11550 abends/crashes on NetWare when the script has error such as
11551 not having the closing quotes like:
11552 if ($var eq "value)
11553 Checking of white spaces is anyway done in NetWare code.
11556 while (isSPACE(*PL_oldbufptr))
11559 context = PL_oldbufptr;
11560 contlen = PL_bufptr - PL_oldbufptr;
11562 else if (yychar > 255)
11563 sv_catpvs(where_sv, "next token ???");
11564 else if (yychar == YYEMPTY) {
11565 if (PL_lex_state == LEX_NORMAL)
11566 sv_catpvs(where_sv, "at end of line");
11567 else if (PL_lex_inpat)
11568 sv_catpvs(where_sv, "within pattern");
11570 sv_catpvs(where_sv, "within string");
11573 sv_catpvs(where_sv, "next char ");
11575 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11576 else if (isPRINT_LC(yychar)) {
11577 const char string = yychar;
11578 sv_catpvn(where_sv, &string, 1);
11581 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11583 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11584 Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
11585 OutCopFILE(PL_curcop),
11586 (IV)(PL_parser->preambling == NOLINE
11587 ? CopLINE(PL_curcop)
11588 : PL_parser->preambling));
11590 Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
11591 UTF8fARG(UTF, contlen, context));
11593 Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
11594 if ( PL_multi_start < PL_multi_end
11595 && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
11597 Perl_sv_catpvf(aTHX_ msg,
11598 " (Might be a runaway multi-line %c%c string starting on"
11599 " line %" IVdf ")\n",
11600 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11603 if (PL_in_eval & EVAL_WARNONLY) {
11604 PL_in_eval &= ~EVAL_WARNONLY;
11605 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
11611 if (s == NULL || PL_error_count >= 10) {
11612 const char * msg = "";
11613 const char * const name = OutCopFILE(PL_curcop);
11616 SV * errsv = ERRSV;
11617 if (SvCUR(errsv)) {
11618 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
11623 abort_execution(msg, name);
11626 Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
11630 PL_in_my_stash = NULL;
11635 S_swallow_bom(pTHX_ U8 *s)
11637 const STRLEN slen = SvCUR(PL_linestr);
11639 PERL_ARGS_ASSERT_SWALLOW_BOM;
11643 if (s[1] == 0xFE) {
11644 /* UTF-16 little-endian? (or UTF-32LE?) */
11645 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11646 /* diag_listed_as: Unsupported script encoding %s */
11647 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11648 #ifndef PERL_NO_UTF16_FILTER
11649 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11651 if (PL_bufend > (char*)s) {
11652 s = add_utf16_textfilter(s, TRUE);
11655 /* diag_listed_as: Unsupported script encoding %s */
11656 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11661 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11662 #ifndef PERL_NO_UTF16_FILTER
11663 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11665 if (PL_bufend > (char *)s) {
11666 s = add_utf16_textfilter(s, FALSE);
11669 /* diag_listed_as: Unsupported script encoding %s */
11670 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11674 case BOM_UTF8_FIRST_BYTE: {
11675 const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
11676 if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
11677 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11678 s += len + 1; /* UTF-8 */
11685 if (s[2] == 0xFE && s[3] == 0xFF) {
11686 /* UTF-32 big-endian */
11687 /* diag_listed_as: Unsupported script encoding %s */
11688 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11691 else if (s[2] == 0 && s[3] != 0) {
11694 * are a good indicator of UTF-16BE. */
11695 #ifndef PERL_NO_UTF16_FILTER
11696 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11697 s = add_utf16_textfilter(s, FALSE);
11699 /* diag_listed_as: Unsupported script encoding %s */
11700 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11707 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11710 * are a good indicator of UTF-16LE. */
11711 #ifndef PERL_NO_UTF16_FILTER
11712 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11713 s = add_utf16_textfilter(s, TRUE);
11715 /* diag_listed_as: Unsupported script encoding %s */
11716 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11724 #ifndef PERL_NO_UTF16_FILTER
11726 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11728 SV *const filter = FILTER_DATA(idx);
11729 /* We re-use this each time round, throwing the contents away before we
11731 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11732 SV *const utf8_buffer = filter;
11733 IV status = IoPAGE(filter);
11734 const bool reverse = cBOOL(IoLINES(filter));
11737 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11739 /* As we're automatically added, at the lowest level, and hence only called
11740 from this file, we can be sure that we're not called in block mode. Hence
11741 don't bother writing code to deal with block mode. */
11743 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11746 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status);
11748 DEBUG_P(PerlIO_printf(Perl_debug_log,
11749 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11750 FPTR2DPTR(void *, S_utf16_textfilter),
11751 reverse ? 'l' : 'b', idx, maxlen, status,
11752 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11759 /* First, look in our buffer of existing UTF-8 data: */
11760 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11764 } else if (status == 0) {
11766 IoPAGE(filter) = 0;
11767 nl = SvEND(utf8_buffer);
11770 STRLEN got = nl - SvPVX(utf8_buffer);
11771 /* Did we have anything to append? */
11773 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11774 /* Everything else in this code works just fine if SVp_POK isn't
11775 set. This, however, needs it, and we need it to work, else
11776 we loop infinitely because the buffer is never consumed. */
11777 sv_chop(utf8_buffer, nl);
11781 /* OK, not a complete line there, so need to read some more UTF-16.
11782 Read an extra octect if the buffer currently has an odd number. */
11786 if (SvCUR(utf16_buffer) >= 2) {
11787 /* Location of the high octet of the last complete code point.
11788 Gosh, UTF-16 is a pain. All the benefits of variable length,
11789 *coupled* with all the benefits of partial reads and
11791 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11792 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11794 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11798 /* We have the first half of a surrogate. Read more. */
11799 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11802 status = FILTER_READ(idx + 1, utf16_buffer,
11803 160 + (SvCUR(utf16_buffer) & 1));
11804 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer)));
11805 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11808 IoPAGE(filter) = status;
11813 chars = SvCUR(utf16_buffer) >> 1;
11814 have = SvCUR(utf8_buffer);
11815 SvGROW(utf8_buffer, have + chars * 3 + 1);
11818 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11819 (U8*)SvPVX_const(utf8_buffer) + have,
11820 chars * 2, &newlen);
11822 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11823 (U8*)SvPVX_const(utf8_buffer) + have,
11824 chars * 2, &newlen);
11826 SvCUR_set(utf8_buffer, have + newlen);
11829 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11830 it's private to us, and utf16_to_utf8{,reversed} take a
11831 (pointer,length) pair, rather than a NUL-terminated string. */
11832 if(SvCUR(utf16_buffer) & 1) {
11833 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11834 SvCUR_set(utf16_buffer, 1);
11836 SvCUR_set(utf16_buffer, 0);
11839 DEBUG_P(PerlIO_printf(Perl_debug_log,
11840 "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11842 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11843 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11848 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11850 SV *filter = filter_add(S_utf16_textfilter, NULL);
11852 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11854 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11856 IoLINES(filter) = reversed;
11857 IoPAGE(filter) = 1; /* Not EOF */
11859 /* Sadly, we have to return a valid pointer, come what may, so we have to
11860 ignore any error return from this. */
11861 SvCUR_set(PL_linestr, 0);
11862 if (FILTER_READ(0, PL_linestr, 0)) {
11863 SvUTF8_on(PL_linestr);
11865 SvUTF8_on(PL_linestr);
11867 PL_bufend = SvEND(PL_linestr);
11868 return (U8*)SvPVX(PL_linestr);
11873 Returns a pointer to the next character after the parsed
11874 vstring, as well as updating the passed in sv.
11876 Function must be called like
11878 sv = sv_2mortal(newSV(5));
11879 s = scan_vstring(s,e,sv);
11881 where s and e are the start and end of the string.
11882 The sv should already be large enough to store the vstring
11883 passed in, for performance reasons.
11885 This function may croak if fatal warnings are enabled in the
11886 calling scope, hence the sv_2mortal in the example (to prevent
11887 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11893 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11895 const char *pos = s;
11896 const char *start = s;
11898 PERL_ARGS_ASSERT_SCAN_VSTRING;
11900 if (*pos == 'v') pos++; /* get past 'v' */
11901 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11903 if ( *pos != '.') {
11904 /* this may not be a v-string if followed by => */
11905 const char *next = pos;
11906 while (next < e && isSPACE(*next))
11908 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11909 /* return string not v-string */
11910 sv_setpvn(sv,(char *)s,pos-s);
11911 return (char *)pos;
11915 if (!isALPHA(*pos)) {
11916 U8 tmpbuf[UTF8_MAXBYTES+1];
11919 s++; /* get past 'v' */
11924 /* this is atoi() that tolerates underscores */
11927 const char *end = pos;
11929 while (--end >= s) {
11931 const UV orev = rev;
11932 rev += (*end - '0') * mult;
11935 /* diag_listed_as: Integer overflow in %s number */
11936 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11937 "Integer overflow in decimal number");
11941 /* Append native character for the rev point */
11942 tmpend = uvchr_to_utf8(tmpbuf, rev);
11943 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11944 if (!UVCHR_IS_INVARIANT(rev))
11946 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11952 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11956 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11963 Perl_keyword_plugin_standard(pTHX_
11964 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11966 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11967 PERL_UNUSED_CONTEXT;
11968 PERL_UNUSED_ARG(keyword_ptr);
11969 PERL_UNUSED_ARG(keyword_len);
11970 PERL_UNUSED_ARG(op_ptr);
11971 return KEYWORD_PLUGIN_DECLINE;
11974 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11976 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11978 SAVEI32(PL_lex_brackets);
11979 if (PL_lex_brackets > 100)
11980 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11981 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11982 SAVEI32(PL_lex_allbrackets);
11983 PL_lex_allbrackets = 0;
11984 SAVEI8(PL_lex_fakeeof);
11985 PL_lex_fakeeof = (U8)fakeeof;
11986 if(yyparse(gramtype) && !PL_parser->error_count)
11987 qerror(Perl_mess(aTHX_ "Parse error"));
11990 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11992 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11996 SAVEVPTR(PL_eval_root);
11997 PL_eval_root = NULL;
11998 parse_recdescent(gramtype, fakeeof);
12004 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
12006 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
12009 if (flags & ~PARSE_OPTIONAL)
12010 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
12011 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
12012 if (!exprop && !(flags & PARSE_OPTIONAL)) {
12013 if (!PL_parser->error_count)
12014 qerror(Perl_mess(aTHX_ "Parse error"));
12015 exprop = newOP(OP_NULL, 0);
12021 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
12023 Parse a Perl arithmetic expression. This may contain operators of precedence
12024 down to the bit shift operators. The expression must be followed (and thus
12025 terminated) either by a comparison or lower-precedence operator or by
12026 something that would normally terminate an expression such as semicolon.
12027 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12028 otherwise it is mandatory. It is up to the caller to ensure that the
12029 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12030 the source of the code to be parsed and the lexical context for the
12033 The op tree representing the expression is returned. If an optional
12034 expression is absent, a null pointer is returned, otherwise the pointer
12037 If an error occurs in parsing or compilation, in most cases a valid op
12038 tree is returned anyway. The error is reflected in the parser state,
12039 normally resulting in a single exception at the top level of parsing
12040 which covers all the compilation errors that occurred. Some compilation
12041 errors, however, will throw an exception immediately.
12047 Perl_parse_arithexpr(pTHX_ U32 flags)
12049 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
12053 =for apidoc Amx|OP *|parse_termexpr|U32 flags
12055 Parse a Perl term expression. This may contain operators of precedence
12056 down to the assignment operators. The expression must be followed (and thus
12057 terminated) either by a comma or lower-precedence operator or by
12058 something that would normally terminate an expression such as semicolon.
12059 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12060 otherwise it is mandatory. It is up to the caller to ensure that the
12061 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12062 the source of the code to be parsed and the lexical context for the
12065 The op tree representing the expression is returned. If an optional
12066 expression is absent, a null pointer is returned, otherwise the pointer
12069 If an error occurs in parsing or compilation, in most cases a valid op
12070 tree is returned anyway. The error is reflected in the parser state,
12071 normally resulting in a single exception at the top level of parsing
12072 which covers all the compilation errors that occurred. Some compilation
12073 errors, however, will throw an exception immediately.
12079 Perl_parse_termexpr(pTHX_ U32 flags)
12081 return parse_expr(LEX_FAKEEOF_COMMA, flags);
12085 =for apidoc Amx|OP *|parse_listexpr|U32 flags
12087 Parse a Perl list expression. This may contain operators of precedence
12088 down to the comma operator. The expression must be followed (and thus
12089 terminated) either by a low-precedence logic operator such as C<or> or by
12090 something that would normally terminate an expression such as semicolon.
12091 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12092 otherwise it is mandatory. It is up to the caller to ensure that the
12093 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12094 the source of the code to be parsed and the lexical context for the
12097 The op tree representing the expression is returned. If an optional
12098 expression is absent, a null pointer is returned, otherwise the pointer
12101 If an error occurs in parsing or compilation, in most cases a valid op
12102 tree is returned anyway. The error is reflected in the parser state,
12103 normally resulting in a single exception at the top level of parsing
12104 which covers all the compilation errors that occurred. Some compilation
12105 errors, however, will throw an exception immediately.
12111 Perl_parse_listexpr(pTHX_ U32 flags)
12113 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12117 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
12119 Parse a single complete Perl expression. This allows the full
12120 expression grammar, including the lowest-precedence operators such
12121 as C<or>. The expression must be followed (and thus terminated) by a
12122 token that an expression would normally be terminated by: end-of-file,
12123 closing bracketing punctuation, semicolon, or one of the keywords that
12124 signals a postfix expression-statement modifier. If C<flags> has the
12125 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
12126 mandatory. It is up to the caller to ensure that the dynamic parser
12127 state (L</PL_parser> et al) is correctly set to reflect the source of
12128 the code to be parsed and the lexical context for the expression.
12130 The op tree representing the expression is returned. If an optional
12131 expression is absent, a null pointer is returned, otherwise the pointer
12134 If an error occurs in parsing or compilation, in most cases a valid op
12135 tree is returned anyway. The error is reflected in the parser state,
12136 normally resulting in a single exception at the top level of parsing
12137 which covers all the compilation errors that occurred. Some compilation
12138 errors, however, will throw an exception immediately.
12144 Perl_parse_fullexpr(pTHX_ U32 flags)
12146 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12150 =for apidoc Amx|OP *|parse_block|U32 flags
12152 Parse a single complete Perl code block. This consists of an opening
12153 brace, a sequence of statements, and a closing brace. The block
12154 constitutes a lexical scope, so C<my> variables and various compile-time
12155 effects can be contained within it. It is up to the caller to ensure
12156 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12157 reflect the source of the code to be parsed and the lexical context for
12160 The op tree representing the code block is returned. This is always a
12161 real op, never a null pointer. It will normally be a C<lineseq> list,
12162 including C<nextstate> or equivalent ops. No ops to construct any kind
12163 of runtime scope are included by virtue of it being a block.
12165 If an error occurs in parsing or compilation, in most cases a valid op
12166 tree (most likely null) is returned anyway. The error is reflected in
12167 the parser state, normally resulting in a single exception at the top
12168 level of parsing which covers all the compilation errors that occurred.
12169 Some compilation errors, however, will throw an exception immediately.
12171 The C<flags> parameter is reserved for future use, and must always
12178 Perl_parse_block(pTHX_ U32 flags)
12181 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12182 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12186 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12188 Parse a single unadorned Perl statement. This may be a normal imperative
12189 statement or a declaration that has compile-time effect. It does not
12190 include any label or other affixture. It is up to the caller to ensure
12191 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12192 reflect the source of the code to be parsed and the lexical context for
12195 The op tree representing the statement is returned. This may be a
12196 null pointer if the statement is null, for example if it was actually
12197 a subroutine definition (which has compile-time side effects). If not
12198 null, it will be ops directly implementing the statement, suitable to
12199 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12200 equivalent op (except for those embedded in a scope contained entirely
12201 within the statement).
12203 If an error occurs in parsing or compilation, in most cases a valid op
12204 tree (most likely null) is returned anyway. The error is reflected in
12205 the parser state, normally resulting in a single exception at the top
12206 level of parsing which covers all the compilation errors that occurred.
12207 Some compilation errors, however, will throw an exception immediately.
12209 The C<flags> parameter is reserved for future use, and must always
12216 Perl_parse_barestmt(pTHX_ U32 flags)
12219 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12220 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12224 =for apidoc Amx|SV *|parse_label|U32 flags
12226 Parse a single label, possibly optional, of the type that may prefix a
12227 Perl statement. It is up to the caller to ensure that the dynamic parser
12228 state (L</PL_parser> et al) is correctly set to reflect the source of
12229 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
12230 label is optional, otherwise it is mandatory.
12232 The name of the label is returned in the form of a fresh scalar. If an
12233 optional label is absent, a null pointer is returned.
12235 If an error occurs in parsing, which can only occur if the label is
12236 mandatory, a valid label is returned anyway. The error is reflected in
12237 the parser state, normally resulting in a single exception at the top
12238 level of parsing which covers all the compilation errors that occurred.
12244 Perl_parse_label(pTHX_ U32 flags)
12246 if (flags & ~PARSE_OPTIONAL)
12247 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12249 PL_parser->yychar = yylex();
12250 if (PL_parser->yychar == LABEL) {
12251 char * const lpv = pl_yylval.pval;
12252 STRLEN llen = strlen(lpv);
12253 PL_parser->yychar = YYEMPTY;
12254 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12261 STRLEN wlen, bufptr_pos;
12264 if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
12266 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12267 if (word_takes_any_delimiter(s, wlen))
12269 bufptr_pos = s - SvPVX(PL_linestr);
12271 lex_read_space(LEX_KEEP_PREVIOUS);
12273 s = SvPVX(PL_linestr) + bufptr_pos;
12274 if (t[0] == ':' && t[1] != ':') {
12275 PL_oldoldbufptr = PL_oldbufptr;
12278 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12282 if (flags & PARSE_OPTIONAL) {
12285 qerror(Perl_mess(aTHX_ "Parse error"));
12286 return newSVpvs("x");
12293 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12295 Parse a single complete Perl statement. This may be a normal imperative
12296 statement or a declaration that has compile-time effect, and may include
12297 optional labels. It is up to the caller to ensure that the dynamic
12298 parser state (L</PL_parser> et al) is correctly set to reflect the source
12299 of the code to be parsed and the lexical context for the statement.
12301 The op tree representing the statement is returned. This may be a
12302 null pointer if the statement is null, for example if it was actually
12303 a subroutine definition (which has compile-time side effects). If not
12304 null, it will be the result of a L</newSTATEOP> call, normally including
12305 a C<nextstate> or equivalent op.
12307 If an error occurs in parsing or compilation, in most cases a valid op
12308 tree (most likely null) is returned anyway. The error is reflected in
12309 the parser state, normally resulting in a single exception at the top
12310 level of parsing which covers all the compilation errors that occurred.
12311 Some compilation errors, however, will throw an exception immediately.
12313 The C<flags> parameter is reserved for future use, and must always
12320 Perl_parse_fullstmt(pTHX_ U32 flags)
12323 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12324 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12328 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12330 Parse a sequence of zero or more Perl statements. These may be normal
12331 imperative statements, including optional labels, or declarations
12332 that have compile-time effect, or any mixture thereof. The statement
12333 sequence ends when a closing brace or end-of-file is encountered in a
12334 place where a new statement could have validly started. It is up to
12335 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12336 is correctly set to reflect the source of the code to be parsed and the
12337 lexical context for the statements.
12339 The op tree representing the statement sequence is returned. This may
12340 be a null pointer if the statements were all null, for example if there
12341 were no statements or if there were only subroutine definitions (which
12342 have compile-time side effects). If not null, it will be a C<lineseq>
12343 list, normally including C<nextstate> or equivalent ops.
12345 If an error occurs in parsing or compilation, in most cases a valid op
12346 tree is returned anyway. The error is reflected in the parser state,
12347 normally resulting in a single exception at the top level of parsing
12348 which covers all the compilation errors that occurred. Some compilation
12349 errors, however, will throw an exception immediately.
12351 The C<flags> parameter is reserved for future use, and must always
12358 Perl_parse_stmtseq(pTHX_ U32 flags)
12363 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12364 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12365 c = lex_peek_unichar(0);
12366 if (c != -1 && c != /*{*/'}')
12367 qerror(Perl_mess(aTHX_ "Parse error"));
12372 * ex: set ts=8 sts=4 sw=4 et: