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_static.c"
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_defer (PL_parser->lex_defer)
56 #define PL_lex_dojoin (PL_parser->lex_dojoin)
57 #define PL_lex_expect (PL_parser->lex_expect)
58 #define PL_lex_formbrack (PL_parser->lex_formbrack)
59 #define PL_lex_inpat (PL_parser->lex_inpat)
60 #define PL_lex_inwhat (PL_parser->lex_inwhat)
61 #define PL_lex_op (PL_parser->lex_op)
62 #define PL_lex_repl (PL_parser->lex_repl)
63 #define PL_lex_starts (PL_parser->lex_starts)
64 #define PL_lex_stuff (PL_parser->lex_stuff)
65 #define PL_multi_start (PL_parser->multi_start)
66 #define PL_multi_open (PL_parser->multi_open)
67 #define PL_multi_close (PL_parser->multi_close)
68 #define PL_preambled (PL_parser->preambled)
69 #define PL_sublex_info (PL_parser->sublex_info)
70 #define PL_linestr (PL_parser->linestr)
71 #define PL_expect (PL_parser->expect)
72 #define PL_copline (PL_parser->copline)
73 #define PL_bufptr (PL_parser->bufptr)
74 #define PL_oldbufptr (PL_parser->oldbufptr)
75 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
76 #define PL_linestart (PL_parser->linestart)
77 #define PL_bufend (PL_parser->bufend)
78 #define PL_last_uni (PL_parser->last_uni)
79 #define PL_last_lop (PL_parser->last_lop)
80 #define PL_last_lop_op (PL_parser->last_lop_op)
81 #define PL_lex_state (PL_parser->lex_state)
82 #define PL_rsfp (PL_parser->rsfp)
83 #define PL_rsfp_filters (PL_parser->rsfp_filters)
84 #define PL_in_my (PL_parser->in_my)
85 #define PL_in_my_stash (PL_parser->in_my_stash)
86 #define PL_tokenbuf (PL_parser->tokenbuf)
87 #define PL_multi_end (PL_parser->multi_end)
88 #define PL_error_count (PL_parser->error_count)
90 # define PL_nexttoke (PL_parser->nexttoke)
91 # define PL_nexttype (PL_parser->nexttype)
92 # define PL_nextval (PL_parser->nextval)
94 static const char* const ident_too_long = "Identifier too long";
96 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
98 #define XENUMMASK 0x3f
100 #define XFAKEBRACK 0x80
102 #ifdef USE_UTF8_SCRIPTS
103 # define UTF (!IN_BYTES)
105 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
108 /* The maximum number of characters preceding the unrecognized one to display */
109 #define UNRECOGNIZED_PRECEDE_COUNT 10
111 /* In variables named $^X, these are the legal values for X.
112 * 1999-02-27 mjd-perl-patch@plover.com */
113 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
115 #define SPACE_OR_TAB(c) isBLANK_A(c)
117 #define HEXFP_PEEK(s) \
119 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
120 isALPHA_FOLD_EQ(s[0], 'p'))
122 /* LEX_* are values for PL_lex_state, the state of the lexer.
123 * They are arranged oddly so that the guard on the switch statement
124 * can get by with a single comparison (if the compiler is smart enough).
126 * These values refer to the various states within a sublex parse,
127 * i.e. within a double quotish string
130 /* #define LEX_NOTPARSING 11 is done in perl.h. */
132 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
133 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
134 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
135 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
136 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
138 /* at end of code, eg "$x" followed by: */
139 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
140 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
142 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
143 string or after \E, $foo, etc */
144 #define LEX_INTERPCONST 2 /* NOT USED */
145 #define LEX_FORMLINE 1 /* expecting a format line */
146 #define LEX_KNOWNEXT 0 /* next token known; just return it */
150 static const char* const lex_state_names[] = {
165 #include "keywords.h"
167 /* CLINE is a macro that ensures PL_copline has a sane value */
169 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
171 # define SKIPSPACE0(s) skipspace(s)
172 # define SKIPSPACE1(s) skipspace(s)
173 # define SKIPSPACE2(s,tsv) skipspace(s)
174 # define PEEKSPACE(s) skipspace(s)
177 * Convenience functions to return different tokens and prime the
178 * lexer for the next token. They all take an argument.
180 * TOKEN : generic token (used for '(', DOLSHARP, etc)
181 * OPERATOR : generic operator
182 * AOPERATOR : assignment operator
183 * PREBLOCK : beginning the block after an if, while, foreach, ...
184 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
185 * PREREF : *EXPR where EXPR is not a simple identifier
186 * TERM : expression term
187 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
188 * LOOPX : loop exiting command (goto, last, dump, etc)
189 * FTST : file test operator
190 * FUN0 : zero-argument function
191 * FUN0OP : zero-argument function, with its op created in this file
192 * FUN1 : not used, except for not, which isn't a UNIOP
193 * BOop : bitwise or or xor
195 * SHop : shift operator
196 * PWop : power operator
197 * PMop : pattern-matching operator
198 * Aop : addition-level operator
199 * AopNOASSIGN : addition-level operator that is never part of .=
200 * Mop : multiplication-level operator
201 * Eop : equality-testing operator
202 * Rop : relational operator <= != gt
204 * Also see LOP and lop() below.
207 #ifdef DEBUGGING /* Serve -DT. */
208 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
210 # define REPORT(retval) (retval)
213 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
214 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
215 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
216 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
217 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
218 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
219 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
220 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
221 #define LOOPX(f) return (PL_bufptr = force_word(s,WORD,TRUE,FALSE), \
223 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
225 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
226 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
227 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
228 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
229 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
230 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
231 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
232 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
233 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
234 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
235 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
236 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
237 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
238 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
240 /* This bit of chicanery makes a unary function followed by
241 * a parenthesis into a function with one argument, highest precedence.
242 * The UNIDOR macro is for unary functions that can be followed by the //
243 * operator (such as C<shift // 0>).
245 #define UNI3(f,x,have_x) { \
246 pl_yylval.ival = f; \
247 if (have_x) PL_expect = x; \
249 PL_last_uni = PL_oldbufptr; \
250 PL_last_lop_op = f; \
252 return REPORT( (int)FUNC1 ); \
254 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
256 #define UNI(f) UNI3(f,XTERM,1)
257 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
258 #define UNIPROTO(f,optional) { \
259 if (optional) PL_last_uni = PL_oldbufptr; \
263 #define UNIBRACK(f) UNI3(f,0,0)
265 /* grandfather return to old style */
268 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
269 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
270 pl_yylval.ival = (f); \
276 #define COPLINE_INC_WITH_HERELINES \
278 CopLINE_inc(PL_curcop); \
279 if (PL_parser->herelines) \
280 CopLINE(PL_curcop) += PL_parser->herelines, \
281 PL_parser->herelines = 0; \
283 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
284 * is no sublex_push to follow. */
285 #define COPLINE_SET_FROM_MULTI_END \
287 CopLINE_set(PL_curcop, PL_multi_end); \
288 if (PL_multi_end != PL_multi_start) \
289 PL_parser->herelines = 0; \
295 /* how to interpret the pl_yylval associated with the token */
299 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
304 static struct debug_tokens {
306 enum token_type type;
308 } const debug_tokens[] =
310 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
311 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
312 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
313 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
314 { ARROW, TOKENTYPE_NONE, "ARROW" },
315 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
316 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
317 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
318 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
319 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
320 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
321 { DO, TOKENTYPE_NONE, "DO" },
322 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
323 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
324 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
325 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
326 { ELSE, TOKENTYPE_NONE, "ELSE" },
327 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
328 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
329 { FOR, TOKENTYPE_IVAL, "FOR" },
330 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
331 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
332 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
333 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
334 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
335 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
336 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
337 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
338 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
339 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
340 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
341 { IF, TOKENTYPE_IVAL, "IF" },
342 { LABEL, TOKENTYPE_PVAL, "LABEL" },
343 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
344 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
345 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
346 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
347 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
348 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
349 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
350 { MY, TOKENTYPE_IVAL, "MY" },
351 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
352 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
353 { OROP, TOKENTYPE_IVAL, "OROP" },
354 { OROR, TOKENTYPE_NONE, "OROR" },
355 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
356 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
357 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
358 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
359 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
360 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
361 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
362 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
363 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
364 { PREINC, TOKENTYPE_NONE, "PREINC" },
365 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
366 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
367 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
368 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
369 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
370 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
371 { SUB, TOKENTYPE_NONE, "SUB" },
372 { THING, TOKENTYPE_OPVAL, "THING" },
373 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
374 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
375 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
376 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
377 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
378 { USE, TOKENTYPE_IVAL, "USE" },
379 { WHEN, TOKENTYPE_IVAL, "WHEN" },
380 { WHILE, TOKENTYPE_IVAL, "WHILE" },
381 { WORD, TOKENTYPE_OPVAL, "WORD" },
382 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
383 { 0, TOKENTYPE_NONE, NULL }
386 /* dump the returned token in rv, plus any optional arg in pl_yylval */
389 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
391 PERL_ARGS_ASSERT_TOKEREPORT;
394 const char *name = NULL;
395 enum token_type type = TOKENTYPE_NONE;
396 const struct debug_tokens *p;
397 SV* const report = newSVpvs("<== ");
399 for (p = debug_tokens; p->token; p++) {
400 if (p->token == (int)rv) {
407 Perl_sv_catpv(aTHX_ report, name);
408 else if ((char)rv > ' ' && (char)rv <= '~')
410 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
412 sv_catpvs(report, " (pending identifier)");
415 sv_catpvs(report, "EOF");
417 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
422 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
424 case TOKENTYPE_OPNUM:
425 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
426 PL_op_name[lvalp->ival]);
429 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
431 case TOKENTYPE_OPVAL:
433 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
434 PL_op_name[lvalp->opval->op_type]);
435 if (lvalp->opval->op_type == OP_CONST) {
436 Perl_sv_catpvf(aTHX_ report, " %s",
437 SvPEEK(cSVOPx_sv(lvalp->opval)));
442 sv_catpvs(report, "(opval=null)");
445 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
451 /* print the buffer with suitable escapes */
454 S_printbuf(pTHX_ const char *const fmt, const char *const s)
456 SV* const tmp = newSVpvs("");
458 PERL_ARGS_ASSERT_PRINTBUF;
460 GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
461 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
469 S_deprecate_commaless_var_list(pTHX) {
471 deprecate("comma-less variable list");
472 return REPORT(','); /* grandfather non-comma-format format */
478 * This subroutine looks for an '=' next to the operator that has just been
479 * parsed and turns it into an ASSIGNOP if it finds one.
483 S_ao(pTHX_ int toketype)
485 if (*PL_bufptr == '=') {
487 if (toketype == ANDAND)
488 pl_yylval.ival = OP_ANDASSIGN;
489 else if (toketype == OROR)
490 pl_yylval.ival = OP_ORASSIGN;
491 else if (toketype == DORDOR)
492 pl_yylval.ival = OP_DORASSIGN;
500 * When Perl expects an operator and finds something else, no_op
501 * prints the warning. It always prints "<something> found where
502 * operator expected. It prints "Missing semicolon on previous line?"
503 * if the surprise occurs at the start of the line. "do you need to
504 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
505 * where the compiler doesn't know if foo is a method call or a function.
506 * It prints "Missing operator before end of line" if there's nothing
507 * after the missing operator, or "... before <...>" if there is something
508 * after the missing operator.
512 S_no_op(pTHX_ const char *const what, char *s)
514 char * const oldbp = PL_bufptr;
515 const bool is_first = (PL_oldbufptr == PL_linestart);
517 PERL_ARGS_ASSERT_NO_OP;
523 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
524 if (ckWARN_d(WARN_SYNTAX)) {
526 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
527 "\t(Missing semicolon on previous line?)\n");
528 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
530 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
531 t += UTF ? UTF8SKIP(t) : 1)
533 if (t < PL_bufptr && isSPACE(*t))
534 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
535 "\t(Do you need to predeclare %"UTF8f"?)\n",
536 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
540 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
541 "\t(Missing operator before %"UTF8f"?)\n",
542 UTF8fARG(UTF, s - oldbp, oldbp));
550 * Complain about missing quote/regexp/heredoc terminator.
551 * If it's called with NULL then it cauterizes the line buffer.
552 * If we're in a delimited string and the delimiter is a control
553 * character, it's reformatted into a two-char sequence like ^C.
558 S_missingterm(pTHX_ char *s)
563 char * const nl = strrchr(s,'\n');
567 else if ((U8) PL_multi_close < 32) {
569 tmpbuf[1] = (char)toCTRL(PL_multi_close);
574 *tmpbuf = (char)PL_multi_close;
578 q = strchr(s,'"') ? '\'' : '"';
579 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
585 * Check whether the named feature is enabled.
588 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
590 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
592 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
594 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
596 if (namelen > MAX_FEATURE_LEN)
598 memcpy(&he_name[8], name, namelen);
600 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
601 REFCOUNTED_HE_EXISTS));
605 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
606 * utf16-to-utf8-reversed.
609 #ifdef PERL_CR_FILTER
613 const char *s = SvPVX_const(sv);
614 const char * const e = s + SvCUR(sv);
616 PERL_ARGS_ASSERT_STRIP_RETURN;
618 /* outer loop optimized to do nothing if there are no CR-LFs */
620 if (*s++ == '\r' && *s == '\n') {
621 /* hit a CR-LF, need to copy the rest */
625 if (*s == '\r' && s[1] == '\n')
636 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
638 const I32 count = FILTER_READ(idx+1, sv, maxlen);
639 if (count > 0 && !maxlen)
646 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
648 Creates and initialises a new lexer/parser state object, supplying
649 a context in which to lex and parse from a new source of Perl code.
650 A pointer to the new state object is placed in L</PL_parser>. An entry
651 is made on the save stack so that upon unwinding the new state object
652 will be destroyed and the former value of L</PL_parser> will be restored.
653 Nothing else need be done to clean up the parsing context.
655 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
656 non-null, provides a string (in SV form) containing code to be parsed.
657 A copy of the string is made, so subsequent modification of I<line>
658 does not affect parsing. I<rsfp>, if non-null, provides an input stream
659 from which code will be read to be parsed. If both are non-null, the
660 code in I<line> comes first and must consist of complete lines of input,
661 and I<rsfp> supplies the remainder of the source.
663 The I<flags> parameter is reserved for future use. Currently it is only
664 used by perl internally, so extensions should always pass zero.
669 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
670 can share filters with the current parser.
671 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
672 caller, hence isn't owned by the parser, so shouldn't be closed on parser
673 destruction. This is used to handle the case of defaulting to reading the
674 script from the standard input because no filename was given on the command
675 line (without getting confused by situation where STDIN has been closed, so
676 the script handle is opened on fd 0) */
679 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
681 const char *s = NULL;
682 yy_parser *parser, *oparser;
683 if (flags && flags & ~LEX_START_FLAGS)
684 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
686 /* create and initialise a parser */
688 Newxz(parser, 1, yy_parser);
689 parser->old_parser = oparser = PL_parser;
692 parser->stack = NULL;
694 parser->stack_size = 0;
696 /* on scope exit, free this parser and restore any outer one */
698 parser->saved_curcop = PL_curcop;
700 /* initialise lexer state */
702 parser->nexttoke = 0;
703 parser->error_count = oparser ? oparser->error_count : 0;
704 parser->copline = parser->preambling = NOLINE;
705 parser->lex_state = LEX_NORMAL;
706 parser->expect = XSTATE;
708 parser->rsfp_filters =
709 !(flags & LEX_START_SAME_FILTER) || !oparser
711 : MUTABLE_AV(SvREFCNT_inc(
712 oparser->rsfp_filters
713 ? oparser->rsfp_filters
714 : (oparser->rsfp_filters = newAV())
717 Newx(parser->lex_brackstack, 120, char);
718 Newx(parser->lex_casestack, 12, char);
719 *parser->lex_casestack = '\0';
720 Newxz(parser->lex_shared, 1, LEXSHARED);
724 s = SvPV_const(line, len);
725 parser->linestr = flags & LEX_START_COPIED
726 ? SvREFCNT_inc_simple_NN(line)
727 : newSVpvn_flags(s, len, SvUTF8(line));
728 sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
730 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
732 parser->oldoldbufptr =
735 parser->linestart = SvPVX(parser->linestr);
736 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
737 parser->last_lop = parser->last_uni = NULL;
739 assert(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
740 |LEX_DONT_CLOSE_RSFP));
741 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
742 |LEX_DONT_CLOSE_RSFP));
744 parser->in_pod = parser->filtered = 0;
748 /* delete a parser object */
751 Perl_parser_free(pTHX_ const yy_parser *parser)
753 PERL_ARGS_ASSERT_PARSER_FREE;
755 PL_curcop = parser->saved_curcop;
756 SvREFCNT_dec(parser->linestr);
758 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
759 PerlIO_clearerr(parser->rsfp);
760 else if (parser->rsfp && (!parser->old_parser ||
761 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
762 PerlIO_close(parser->rsfp);
763 SvREFCNT_dec(parser->rsfp_filters);
764 SvREFCNT_dec(parser->lex_stuff);
765 SvREFCNT_dec(parser->sublex_info.repl);
767 Safefree(parser->lex_brackstack);
768 Safefree(parser->lex_casestack);
769 Safefree(parser->lex_shared);
770 PL_parser = parser->old_parser;
775 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
777 I32 nexttoke = parser->nexttoke;
778 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
780 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
781 && parser->nextval[nexttoke].opval
782 && parser->nextval[nexttoke].opval->op_slabbed
783 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
784 op_free(parser->nextval[nexttoke].opval);
785 parser->nextval[nexttoke].opval = NULL;
792 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
794 Buffer scalar containing the chunk currently under consideration of the
795 text currently being lexed. This is always a plain string scalar (for
796 which C<SvPOK> is true). It is not intended to be used as a scalar by
797 normal scalar means; instead refer to the buffer directly by the pointer
798 variables described below.
800 The lexer maintains various C<char*> pointers to things in the
801 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
802 reallocated, all of these pointers must be updated. Don't attempt to
803 do this manually, but rather use L</lex_grow_linestr> if you need to
804 reallocate the buffer.
806 The content of the text chunk in the buffer is commonly exactly one
807 complete line of input, up to and including a newline terminator,
808 but there are situations where it is otherwise. The octets of the
809 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
810 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
811 flag on this scalar, which may disagree with it.
813 For direct examination of the buffer, the variable
814 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
815 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
816 of these pointers is usually preferable to examination of the scalar
817 through normal scalar means.
819 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
821 Direct pointer to the end of the chunk of text currently being lexed, the
822 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
823 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
824 always located at the end of the buffer, and does not count as part of
825 the buffer's contents.
827 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
829 Points to the current position of lexing inside the lexer buffer.
830 Characters around this point may be freely examined, within
831 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
832 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
833 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
835 Lexing code (whether in the Perl core or not) moves this pointer past
836 the characters that it consumes. It is also expected to perform some
837 bookkeeping whenever a newline character is consumed. This movement
838 can be more conveniently performed by the function L</lex_read_to>,
839 which handles newlines appropriately.
841 Interpretation of the buffer's octets can be abstracted out by
842 using the slightly higher-level functions L</lex_peek_unichar> and
843 L</lex_read_unichar>.
845 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
847 Points to the start of the current line inside the lexer buffer.
848 This is useful for indicating at which column an error occurred, and
849 not much else. This must be updated by any lexing code that consumes
850 a newline; the function L</lex_read_to> handles this detail.
856 =for apidoc Amx|bool|lex_bufutf8
858 Indicates whether the octets in the lexer buffer
859 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
860 of Unicode characters. If not, they should be interpreted as Latin-1
861 characters. This is analogous to the C<SvUTF8> flag for scalars.
863 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
864 contains valid UTF-8. Lexing code must be robust in the face of invalid
867 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
868 is significant, but not the whole story regarding the input character
869 encoding. Normally, when a file is being read, the scalar contains octets
870 and its C<SvUTF8> flag is off, but the octets should be interpreted as
871 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
872 however, the scalar may have the C<SvUTF8> flag on, and in this case its
873 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
874 is in effect. This logic may change in the future; use this function
875 instead of implementing the logic yourself.
881 Perl_lex_bufutf8(pTHX)
887 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
889 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
890 at least I<len> octets (including terminating C<NUL>). Returns a
891 pointer to the reallocated buffer. This is necessary before making
892 any direct modification of the buffer that would increase its length.
893 L</lex_stuff_pvn> provides a more convenient way to insert text into
896 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
897 this function updates all of the lexer's variables that point directly
904 Perl_lex_grow_linestr(pTHX_ STRLEN len)
908 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
909 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
910 linestr = PL_parser->linestr;
911 buf = SvPVX(linestr);
912 if (len <= SvLEN(linestr))
914 bufend_pos = PL_parser->bufend - buf;
915 bufptr_pos = PL_parser->bufptr - buf;
916 oldbufptr_pos = PL_parser->oldbufptr - buf;
917 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
918 linestart_pos = PL_parser->linestart - buf;
919 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
920 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
921 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
922 PL_parser->lex_shared->re_eval_start - buf : 0;
924 buf = sv_grow(linestr, len);
926 PL_parser->bufend = buf + bufend_pos;
927 PL_parser->bufptr = buf + bufptr_pos;
928 PL_parser->oldbufptr = buf + oldbufptr_pos;
929 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
930 PL_parser->linestart = buf + linestart_pos;
931 if (PL_parser->last_uni)
932 PL_parser->last_uni = buf + last_uni_pos;
933 if (PL_parser->last_lop)
934 PL_parser->last_lop = buf + last_lop_pos;
935 if (PL_parser->lex_shared->re_eval_start)
936 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
941 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
943 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
944 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
945 reallocating the buffer if necessary. This means that lexing code that
946 runs later will see the characters as if they had appeared in the input.
947 It is not recommended to do this as part of normal parsing, and most
948 uses of this facility run the risk of the inserted characters being
949 interpreted in an unintended manner.
951 The string to be inserted is represented by I<len> octets starting
952 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
953 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
954 The characters are recoded for the lexer buffer, according to how the
955 buffer is currently being interpreted (L</lex_bufutf8>). If a string
956 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
957 function is more convenient.
963 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
967 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
968 if (flags & ~(LEX_STUFF_UTF8))
969 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
971 if (flags & LEX_STUFF_UTF8) {
974 STRLEN highhalf = 0; /* Count of variants */
975 const char *p, *e = pv+len;
976 for (p = pv; p != e; p++) {
977 if (! UTF8_IS_INVARIANT(*p)) {
983 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
984 bufptr = PL_parser->bufptr;
985 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
986 SvCUR_set(PL_parser->linestr,
987 SvCUR(PL_parser->linestr) + len+highhalf);
988 PL_parser->bufend += len+highhalf;
989 for (p = pv; p != e; p++) {
991 if (! UTF8_IS_INVARIANT(c)) {
992 *bufptr++ = UTF8_TWO_BYTE_HI(c);
993 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1000 if (flags & LEX_STUFF_UTF8) {
1001 STRLEN highhalf = 0;
1002 const char *p, *e = pv+len;
1003 for (p = pv; p != e; p++) {
1005 if (UTF8_IS_ABOVE_LATIN1(c)) {
1006 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1007 "non-Latin-1 character into Latin-1 input");
1008 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1011 } else if (! UTF8_IS_INVARIANT(c)) {
1012 /* malformed UTF-8 */
1014 SAVESPTR(PL_warnhook);
1015 PL_warnhook = PERL_WARNHOOK_FATAL;
1016 utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1022 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1023 bufptr = PL_parser->bufptr;
1024 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1025 SvCUR_set(PL_parser->linestr,
1026 SvCUR(PL_parser->linestr) + len-highhalf);
1027 PL_parser->bufend += len-highhalf;
1030 if (UTF8_IS_INVARIANT(*p)) {
1036 *bufptr++ = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
1042 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1043 bufptr = PL_parser->bufptr;
1044 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1045 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1046 PL_parser->bufend += len;
1047 Copy(pv, bufptr, len, char);
1053 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1055 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1056 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1057 reallocating the buffer if necessary. This means that lexing code that
1058 runs later will see the characters as if they had appeared in the input.
1059 It is not recommended to do this as part of normal parsing, and most
1060 uses of this facility run the risk of the inserted characters being
1061 interpreted in an unintended manner.
1063 The string to be inserted is represented by octets starting at I<pv>
1064 and continuing to the first nul. These octets are interpreted as either
1065 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1066 in I<flags>. The characters are recoded for the lexer buffer, according
1067 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1068 If it is not convenient to nul-terminate a string to be inserted, the
1069 L</lex_stuff_pvn> function is more appropriate.
1075 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1077 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1078 lex_stuff_pvn(pv, strlen(pv), flags);
1082 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1084 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1085 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1086 reallocating the buffer if necessary. This means that lexing code that
1087 runs later will see the characters as if they had appeared in the input.
1088 It is not recommended to do this as part of normal parsing, and most
1089 uses of this facility run the risk of the inserted characters being
1090 interpreted in an unintended manner.
1092 The string to be inserted is the string value of I<sv>. The characters
1093 are recoded for the lexer buffer, according to how the buffer is currently
1094 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1095 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1096 need to construct a scalar.
1102 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1106 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1108 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1110 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1114 =for apidoc Amx|void|lex_unstuff|char *ptr
1116 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1117 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1118 This hides the discarded text from any lexing code that runs later,
1119 as if the text had never appeared.
1121 This is not the normal way to consume lexed text. For that, use
1128 Perl_lex_unstuff(pTHX_ char *ptr)
1132 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1133 buf = PL_parser->bufptr;
1135 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1138 bufend = PL_parser->bufend;
1140 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1141 unstuff_len = ptr - buf;
1142 Move(ptr, buf, bufend+1-ptr, char);
1143 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1144 PL_parser->bufend = bufend - unstuff_len;
1148 =for apidoc Amx|void|lex_read_to|char *ptr
1150 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1151 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1152 performing the correct bookkeeping whenever a newline character is passed.
1153 This is the normal way to consume lexed text.
1155 Interpretation of the buffer's octets can be abstracted out by
1156 using the slightly higher-level functions L</lex_peek_unichar> and
1157 L</lex_read_unichar>.
1163 Perl_lex_read_to(pTHX_ char *ptr)
1166 PERL_ARGS_ASSERT_LEX_READ_TO;
1167 s = PL_parser->bufptr;
1168 if (ptr < s || ptr > PL_parser->bufend)
1169 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1170 for (; s != ptr; s++)
1172 COPLINE_INC_WITH_HERELINES;
1173 PL_parser->linestart = s+1;
1175 PL_parser->bufptr = ptr;
1179 =for apidoc Amx|void|lex_discard_to|char *ptr
1181 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1182 up to I<ptr>. The remaining content of the buffer will be moved, and
1183 all pointers into the buffer updated appropriately. I<ptr> must not
1184 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1185 it is not permitted to discard text that has yet to be lexed.
1187 Normally it is not necessarily to do this directly, because it suffices to
1188 use the implicit discarding behaviour of L</lex_next_chunk> and things
1189 based on it. However, if a token stretches across multiple lines,
1190 and the lexing code has kept multiple lines of text in the buffer for
1191 that purpose, then after completion of the token it would be wise to
1192 explicitly discard the now-unneeded earlier lines, to avoid future
1193 multi-line tokens growing the buffer without bound.
1199 Perl_lex_discard_to(pTHX_ char *ptr)
1203 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1204 buf = SvPVX(PL_parser->linestr);
1206 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1209 if (ptr > PL_parser->bufptr)
1210 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1211 discard_len = ptr - buf;
1212 if (PL_parser->oldbufptr < ptr)
1213 PL_parser->oldbufptr = ptr;
1214 if (PL_parser->oldoldbufptr < ptr)
1215 PL_parser->oldoldbufptr = ptr;
1216 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1217 PL_parser->last_uni = NULL;
1218 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1219 PL_parser->last_lop = NULL;
1220 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1221 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1222 PL_parser->bufend -= discard_len;
1223 PL_parser->bufptr -= discard_len;
1224 PL_parser->oldbufptr -= discard_len;
1225 PL_parser->oldoldbufptr -= discard_len;
1226 if (PL_parser->last_uni)
1227 PL_parser->last_uni -= discard_len;
1228 if (PL_parser->last_lop)
1229 PL_parser->last_lop -= discard_len;
1233 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1235 Reads in the next chunk of text to be lexed, appending it to
1236 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1237 looked to the end of the current chunk and wants to know more. It is
1238 usual, but not necessary, for lexing to have consumed the entirety of
1239 the current chunk at this time.
1241 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1242 chunk (i.e., the current chunk has been entirely consumed), normally the
1243 current chunk will be discarded at the same time that the new chunk is
1244 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1245 will not be discarded. If the current chunk has not been entirely
1246 consumed, then it will not be discarded regardless of the flag.
1248 Returns true if some new text was added to the buffer, or false if the
1249 buffer has reached the end of the input text.
1254 #define LEX_FAKE_EOF 0x80000000
1255 #define LEX_NO_TERM 0x40000000
1258 Perl_lex_next_chunk(pTHX_ U32 flags)
1262 STRLEN old_bufend_pos, new_bufend_pos;
1263 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1264 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1265 bool got_some_for_debugger = 0;
1267 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1268 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1269 linestr = PL_parser->linestr;
1270 buf = SvPVX(linestr);
1271 if (!(flags & LEX_KEEP_PREVIOUS) &&
1272 PL_parser->bufptr == PL_parser->bufend) {
1273 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1275 if (PL_parser->last_uni != PL_parser->bufend)
1276 PL_parser->last_uni = NULL;
1277 if (PL_parser->last_lop != PL_parser->bufend)
1278 PL_parser->last_lop = NULL;
1279 last_uni_pos = last_lop_pos = 0;
1283 old_bufend_pos = PL_parser->bufend - buf;
1284 bufptr_pos = PL_parser->bufptr - buf;
1285 oldbufptr_pos = PL_parser->oldbufptr - buf;
1286 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1287 linestart_pos = PL_parser->linestart - buf;
1288 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1289 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1291 if (flags & LEX_FAKE_EOF) {
1293 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1295 } else if (filter_gets(linestr, old_bufend_pos)) {
1297 got_some_for_debugger = 1;
1298 } else if (flags & LEX_NO_TERM) {
1301 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1302 sv_setpvs(linestr, "");
1304 /* End of real input. Close filehandle (unless it was STDIN),
1305 * then add implicit termination.
1307 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1308 PerlIO_clearerr(PL_parser->rsfp);
1309 else if (PL_parser->rsfp)
1310 (void)PerlIO_close(PL_parser->rsfp);
1311 PL_parser->rsfp = NULL;
1312 PL_parser->in_pod = PL_parser->filtered = 0;
1313 if (!PL_in_eval && PL_minus_p) {
1315 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1316 PL_minus_n = PL_minus_p = 0;
1317 } else if (!PL_in_eval && PL_minus_n) {
1318 sv_catpvs(linestr, /*{*/";}");
1321 sv_catpvs(linestr, ";");
1324 buf = SvPVX(linestr);
1325 new_bufend_pos = SvCUR(linestr);
1326 PL_parser->bufend = buf + new_bufend_pos;
1327 PL_parser->bufptr = buf + bufptr_pos;
1328 PL_parser->oldbufptr = buf + oldbufptr_pos;
1329 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1330 PL_parser->linestart = buf + linestart_pos;
1331 if (PL_parser->last_uni)
1332 PL_parser->last_uni = buf + last_uni_pos;
1333 if (PL_parser->last_lop)
1334 PL_parser->last_lop = buf + last_lop_pos;
1335 if (PL_parser->preambling != NOLINE) {
1336 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1337 PL_parser->preambling = NOLINE;
1339 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1340 PL_curstash != PL_debstash) {
1341 /* debugger active and we're not compiling the debugger code,
1342 * so store the line into the debugger's array of lines
1344 update_debugger_info(NULL, buf+old_bufend_pos,
1345 new_bufend_pos-old_bufend_pos);
1351 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1353 Looks ahead one (Unicode) character in the text currently being lexed.
1354 Returns the codepoint (unsigned integer value) of the next character,
1355 or -1 if lexing has reached the end of the input text. To consume the
1356 peeked character, use L</lex_read_unichar>.
1358 If the next character is in (or extends into) the next chunk of input
1359 text, the next chunk will be read in. Normally the current chunk will be
1360 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1361 then the current chunk will not be discarded.
1363 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1364 is encountered, an exception is generated.
1370 Perl_lex_peek_unichar(pTHX_ U32 flags)
1374 if (flags & ~(LEX_KEEP_PREVIOUS))
1375 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1376 s = PL_parser->bufptr;
1377 bufend = PL_parser->bufend;
1383 if (!lex_next_chunk(flags))
1385 s = PL_parser->bufptr;
1386 bufend = PL_parser->bufend;
1389 if (UTF8_IS_INVARIANT(head))
1391 if (UTF8_IS_START(head)) {
1392 len = UTF8SKIP(&head);
1393 while ((STRLEN)(bufend-s) < len) {
1394 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1396 s = PL_parser->bufptr;
1397 bufend = PL_parser->bufend;
1400 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1401 if (retlen == (STRLEN)-1) {
1402 /* malformed UTF-8 */
1404 SAVESPTR(PL_warnhook);
1405 PL_warnhook = PERL_WARNHOOK_FATAL;
1406 utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1412 if (!lex_next_chunk(flags))
1414 s = PL_parser->bufptr;
1421 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1423 Reads the next (Unicode) character in the text currently being lexed.
1424 Returns the codepoint (unsigned integer value) of the character read,
1425 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1426 if lexing has reached the end of the input text. To non-destructively
1427 examine the next character, use L</lex_peek_unichar> instead.
1429 If the next character is in (or extends into) the next chunk of input
1430 text, the next chunk will be read in. Normally the current chunk will be
1431 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1432 then the current chunk will not be discarded.
1434 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1435 is encountered, an exception is generated.
1441 Perl_lex_read_unichar(pTHX_ U32 flags)
1444 if (flags & ~(LEX_KEEP_PREVIOUS))
1445 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1446 c = lex_peek_unichar(flags);
1449 COPLINE_INC_WITH_HERELINES;
1451 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1453 ++(PL_parser->bufptr);
1459 =for apidoc Amx|void|lex_read_space|U32 flags
1461 Reads optional spaces, in Perl style, in the text currently being
1462 lexed. The spaces may include ordinary whitespace characters and
1463 Perl-style comments. C<#line> directives are processed if encountered.
1464 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1465 at a non-space character (or the end of the input text).
1467 If spaces extend into the next chunk of input text, the next chunk will
1468 be read in. Normally the current chunk will be discarded at the same
1469 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1470 chunk will not be discarded.
1475 #define LEX_NO_INCLINE 0x40000000
1476 #define LEX_NO_NEXT_CHUNK 0x80000000
1479 Perl_lex_read_space(pTHX_ U32 flags)
1482 const bool can_incline = !(flags & LEX_NO_INCLINE);
1483 bool need_incline = 0;
1484 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1485 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1486 s = PL_parser->bufptr;
1487 bufend = PL_parser->bufend;
1493 } while (!(c == '\n' || (c == 0 && s == bufend)));
1494 } else if (c == '\n') {
1497 PL_parser->linestart = s;
1503 } else if (isSPACE(c)) {
1505 } else if (c == 0 && s == bufend) {
1508 if (flags & LEX_NO_NEXT_CHUNK)
1510 PL_parser->bufptr = s;
1511 l = CopLINE(PL_curcop);
1512 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1513 got_more = lex_next_chunk(flags);
1514 CopLINE_set(PL_curcop, l);
1515 s = PL_parser->bufptr;
1516 bufend = PL_parser->bufend;
1519 if (can_incline && need_incline && PL_parser->rsfp) {
1527 PL_parser->bufptr = s;
1532 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1534 This function performs syntax checking on a prototype, C<proto>.
1535 If C<warn> is true, any illegal characters or mismatched brackets
1536 will trigger illegalproto warnings, declaring that they were
1537 detected in the prototype for C<name>.
1539 The return value is C<true> if this is a valid prototype, and
1540 C<false> if it is not, regardless of whether C<warn> was C<true> or
1543 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1550 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1552 STRLEN len, origlen;
1553 char *p = proto ? SvPV(proto, len) : NULL;
1554 bool bad_proto = FALSE;
1555 bool in_brackets = FALSE;
1556 bool after_slash = FALSE;
1557 char greedy_proto = ' ';
1558 bool proto_after_greedy_proto = FALSE;
1559 bool must_be_last = FALSE;
1560 bool underscore = FALSE;
1561 bool bad_proto_after_underscore = FALSE;
1563 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1569 for (; len--; p++) {
1572 proto_after_greedy_proto = TRUE;
1574 if (!strchr(";@%", *p))
1575 bad_proto_after_underscore = TRUE;
1578 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1585 in_brackets = FALSE;
1586 else if ((*p == '@' || *p == '%') &&
1589 must_be_last = TRUE;
1598 after_slash = FALSE;
1603 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1606 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1607 origlen, UNI_DISPLAY_ISPRINT)
1608 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1610 if (proto_after_greedy_proto)
1611 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1612 "Prototype after '%c' for %"SVf" : %s",
1613 greedy_proto, SVfARG(name), p);
1615 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1616 "Missing ']' in prototype for %"SVf" : %s",
1619 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1620 "Illegal character in prototype for %"SVf" : %s",
1622 if (bad_proto_after_underscore)
1623 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1624 "Illegal character after '_' in prototype for %"SVf" : %s",
1628 return (! (proto_after_greedy_proto || bad_proto) );
1633 * This subroutine has nothing to do with tilting, whether at windmills
1634 * or pinball tables. Its name is short for "increment line". It
1635 * increments the current line number in CopLINE(PL_curcop) and checks
1636 * to see whether the line starts with a comment of the form
1637 * # line 500 "foo.pm"
1638 * If so, it sets the current line number and file to the values in the comment.
1642 S_incline(pTHX_ const char *s)
1649 PERL_ARGS_ASSERT_INCLINE;
1651 COPLINE_INC_WITH_HERELINES;
1652 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1653 && s+1 == PL_bufend && *s == ';') {
1654 /* fake newline in string eval */
1655 CopLINE_dec(PL_curcop);
1660 while (SPACE_OR_TAB(*s))
1662 if (strnEQ(s, "line", 4))
1666 if (SPACE_OR_TAB(*s))
1670 while (SPACE_OR_TAB(*s))
1678 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1680 while (SPACE_OR_TAB(*s))
1682 if (*s == '"' && (t = strchr(s+1, '"'))) {
1688 while (!isSPACE(*t))
1692 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1694 if (*e != '\n' && *e != '\0')
1695 return; /* false alarm */
1697 line_num = grok_atou(n, &e) - 1;
1700 const STRLEN len = t - s;
1702 if (!PL_rsfp && !PL_parser->filtered) {
1703 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1704 * to *{"::_<newfilename"} */
1705 /* However, the long form of evals is only turned on by the
1706 debugger - usually they're "(eval %lu)" */
1707 GV * const cfgv = CopFILEGV(PL_curcop);
1710 STRLEN tmplen2 = len;
1714 if (tmplen2 + 2 <= sizeof smallbuf)
1717 Newx(tmpbuf2, tmplen2 + 2, char);
1722 memcpy(tmpbuf2 + 2, s, tmplen2);
1725 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1727 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1728 /* adjust ${"::_<newfilename"} to store the new file name */
1729 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1730 /* The line number may differ. If that is the case,
1731 alias the saved lines that are in the array.
1732 Otherwise alias the whole array. */
1733 if (CopLINE(PL_curcop) == line_num) {
1734 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1735 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1737 else if (GvAV(cfgv)) {
1738 AV * const av = GvAV(cfgv);
1739 const I32 start = CopLINE(PL_curcop)+1;
1740 I32 items = AvFILLp(av) - start;
1742 AV * const av2 = GvAVn(gv2);
1743 SV **svp = AvARRAY(av) + start;
1744 I32 l = (I32)line_num+1;
1746 av_store(av2, l++, SvREFCNT_inc(*svp++));
1751 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1754 CopFILE_free(PL_curcop);
1755 CopFILE_setn(PL_curcop, s, len);
1757 CopLINE_set(PL_curcop, line_num);
1760 #define skipspace(s) skipspace_flags(s, 0)
1764 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1766 AV *av = CopFILEAVx(PL_curcop);
1769 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1771 sv = *av_fetch(av, 0, 1);
1772 SvUPGRADE(sv, SVt_PVMG);
1774 if (!SvPOK(sv)) sv_setpvs(sv,"");
1776 sv_catsv(sv, orig_sv);
1778 sv_catpvn(sv, buf, len);
1783 if (PL_parser->preambling == NOLINE)
1784 av_store(av, CopLINE(PL_curcop), sv);
1790 * Called to gobble the appropriate amount and type of whitespace.
1791 * Skips comments as well.
1795 S_skipspace_flags(pTHX_ char *s, U32 flags)
1797 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1798 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1799 while (s < PL_bufend && SPACE_OR_TAB(*s))
1802 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1804 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1805 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1806 LEX_NO_NEXT_CHUNK : 0));
1808 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1809 if (PL_linestart > PL_bufptr)
1810 PL_bufptr = PL_linestart;
1818 * Check the unary operators to ensure there's no ambiguity in how they're
1819 * used. An ambiguous piece of code would be:
1821 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1822 * the +5 is its argument.
1831 if (PL_oldoldbufptr != PL_last_uni)
1833 while (isSPACE(*PL_last_uni))
1836 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1838 if ((t = strchr(s, '(')) && t < PL_bufptr)
1841 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1842 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1843 (int)(s - PL_last_uni), PL_last_uni);
1847 * LOP : macro to build a list operator. Its behaviour has been replaced
1848 * with a subroutine, S_lop() for which LOP is just another name.
1851 #define LOP(f,x) return lop(f,x,s)
1855 * Build a list operator (or something that might be one). The rules:
1856 * - if we have a next token, then it's a list operator (no parens) for
1857 * which the next token has already been parsed; e.g.,
1860 * - if the next thing is an opening paren, then it's a function
1861 * - else it's a list operator
1865 S_lop(pTHX_ I32 f, int x, char *s)
1867 PERL_ARGS_ASSERT_LOP;
1872 PL_last_lop = PL_oldbufptr;
1873 PL_last_lop_op = (OPCODE)f;
1878 return REPORT(FUNC);
1881 return REPORT(FUNC);
1884 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1885 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1886 return REPORT(LSTOP);
1892 * When the lexer realizes it knows the next token (for instance,
1893 * it is reordering tokens for the parser) then it can call S_force_next
1894 * to know what token to return the next time the lexer is called. Caller
1895 * will need to set PL_nextval[] and possibly PL_expect to ensure
1896 * the lexer handles the token correctly.
1900 S_force_next(pTHX_ I32 type)
1904 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1905 tokereport(type, &NEXTVAL_NEXTTOKE);
1908 PL_nexttype[PL_nexttoke] = type;
1910 if (PL_lex_state != LEX_KNOWNEXT) {
1911 PL_lex_defer = PL_lex_state;
1912 PL_lex_state = LEX_KNOWNEXT;
1919 * This subroutine handles postfix deref syntax after the arrow has already
1920 * been emitted. @* $* etc. are emitted as two separate token right here.
1921 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
1922 * only the first, leaving yylex to find the next.
1926 S_postderef(pTHX_ int const funny, char const next)
1928 assert(funny == DOLSHARP || strchr("$@%&*", funny));
1929 assert(strchr("*[{", next));
1931 PL_expect = XOPERATOR;
1932 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
1933 assert('@' == funny || '$' == funny || DOLSHARP == funny);
1934 PL_lex_state = LEX_INTERPEND;
1935 force_next(POSTJOIN);
1941 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
1942 && !PL_lex_brackets)
1944 PL_expect = XOPERATOR;
1953 int yyc = PL_parser->yychar;
1954 if (yyc != YYEMPTY) {
1956 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1957 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1958 PL_lex_allbrackets--;
1960 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1961 } else if (yyc == '('/*)*/) {
1962 PL_lex_allbrackets--;
1967 PL_parser->yychar = YYEMPTY;
1972 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1974 SV * const sv = newSVpvn_utf8(start, len,
1977 && !is_ascii_string((const U8*)start, len)
1978 && is_utf8_string((const U8*)start, len));
1984 * When the lexer knows the next thing is a word (for instance, it has
1985 * just seen -> and it knows that the next char is a word char, then
1986 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1990 * char *start : buffer position (must be within PL_linestr)
1991 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1992 * int check_keyword : if true, Perl checks to make sure the word isn't
1993 * a keyword (do this if the word is a label, e.g. goto FOO)
1994 * int allow_pack : if true, : characters will also be allowed (require,
1995 * use, etc. do this)
1996 * int allow_initial_tick : used by the "sub" lexer only.
2000 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2005 PERL_ARGS_ASSERT_FORCE_WORD;
2007 start = SKIPSPACE1(start);
2009 if (isIDFIRST_lazy_if(s,UTF) ||
2010 (allow_pack && *s == ':') )
2012 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2013 if (check_keyword) {
2014 char *s2 = PL_tokenbuf;
2015 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2017 if (keyword(s2, len, 0))
2020 if (token == METHOD) {
2025 PL_expect = XOPERATOR;
2028 NEXTVAL_NEXTTOKE.opval
2029 = (OP*)newSVOP(OP_CONST,0,
2030 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2031 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2039 * Called when the lexer wants $foo *foo &foo etc, but the program
2040 * text only contains the "foo" portion. The first argument is a pointer
2041 * to the "foo", and the second argument is the type symbol to prefix.
2042 * Forces the next token to be a "WORD".
2043 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2047 S_force_ident(pTHX_ const char *s, int kind)
2049 PERL_ARGS_ASSERT_FORCE_IDENT;
2052 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2053 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2054 UTF ? SVf_UTF8 : 0));
2055 NEXTVAL_NEXTTOKE.opval = o;
2058 o->op_private = OPpCONST_ENTERED;
2059 /* XXX see note in pp_entereval() for why we forgo typo
2060 warnings if the symbol must be introduced in an eval.
2062 gv_fetchpvn_flags(s, len,
2063 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2064 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2065 kind == '$' ? SVt_PV :
2066 kind == '@' ? SVt_PVAV :
2067 kind == '%' ? SVt_PVHV :
2075 S_force_ident_maybe_lex(pTHX_ char pit)
2077 NEXTVAL_NEXTTOKE.ival = pit;
2082 Perl_str_to_version(pTHX_ SV *sv)
2087 const char *start = SvPV_const(sv,len);
2088 const char * const end = start + len;
2089 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2091 PERL_ARGS_ASSERT_STR_TO_VERSION;
2093 while (start < end) {
2097 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2102 retval += ((NV)n)/nshift;
2111 * Forces the next token to be a version number.
2112 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2113 * and if "guessing" is TRUE, then no new token is created (and the caller
2114 * must use an alternative parsing method).
2118 S_force_version(pTHX_ char *s, int guessing)
2123 PERL_ARGS_ASSERT_FORCE_VERSION;
2131 while (isDIGIT(*d) || *d == '_' || *d == '.')
2133 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2135 s = scan_num(s, &pl_yylval);
2136 version = pl_yylval.opval;
2137 ver = cSVOPx(version)->op_sv;
2138 if (SvPOK(ver) && !SvNIOK(ver)) {
2139 SvUPGRADE(ver, SVt_PVNV);
2140 SvNV_set(ver, str_to_version(ver));
2141 SvNOK_on(ver); /* hint that it is a version */
2144 else if (guessing) {
2149 /* NOTE: The parser sees the package name and the VERSION swapped */
2150 NEXTVAL_NEXTTOKE.opval = version;
2157 * S_force_strict_version
2158 * Forces the next token to be a version number using strict syntax rules.
2162 S_force_strict_version(pTHX_ char *s)
2165 const char *errstr = NULL;
2167 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2169 while (isSPACE(*s)) /* leading whitespace */
2172 if (is_STRICT_VERSION(s,&errstr)) {
2174 s = (char *)scan_version(s, ver, 0);
2175 version = newSVOP(OP_CONST, 0, ver);
2177 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2178 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2182 yyerror(errstr); /* version required */
2186 /* NOTE: The parser sees the package name and the VERSION swapped */
2187 NEXTVAL_NEXTTOKE.opval = version;
2195 * Tokenize a quoted string passed in as an SV. It finds the next
2196 * chunk, up to end of string or a backslash. It may make a new
2197 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2202 S_tokeq(pTHX_ SV *sv)
2209 PERL_ARGS_ASSERT_TOKEQ;
2213 assert (!SvIsCOW(sv));
2214 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2218 /* This is relying on the SV being "well formed" with a trailing '\0' */
2219 while (s < send && !(*s == '\\' && s[1] == '\\'))
2224 if ( PL_hints & HINT_NEW_STRING ) {
2225 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2226 SVs_TEMP | SvUTF8(sv));
2230 if (s + 1 < send && (s[1] == '\\'))
2231 s++; /* all that, just for this */
2236 SvCUR_set(sv, d - SvPVX_const(sv));
2238 if ( PL_hints & HINT_NEW_STRING )
2239 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2244 * Now come three functions related to double-quote context,
2245 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2246 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2247 * interact with PL_lex_state, and create fake ( ... ) argument lists
2248 * to handle functions and concatenation.
2252 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2257 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2259 * Pattern matching will set PL_lex_op to the pattern-matching op to
2260 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2262 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2264 * Everything else becomes a FUNC.
2266 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2267 * had an OP_CONST or OP_READLINE). This just sets us up for a
2268 * call to S_sublex_push().
2272 S_sublex_start(pTHX)
2274 const I32 op_type = pl_yylval.ival;
2276 if (op_type == OP_NULL) {
2277 pl_yylval.opval = PL_lex_op;
2281 if (op_type == OP_CONST) {
2282 SV *sv = tokeq(PL_lex_stuff);
2284 if (SvTYPE(sv) == SVt_PVIV) {
2285 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2287 const char * const p = SvPV_const(sv, len);
2288 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2292 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2293 PL_lex_stuff = NULL;
2297 PL_sublex_info.super_state = PL_lex_state;
2298 PL_sublex_info.sub_inwhat = (U16)op_type;
2299 PL_sublex_info.sub_op = PL_lex_op;
2300 PL_lex_state = LEX_INTERPPUSH;
2304 pl_yylval.opval = PL_lex_op;
2314 * Create a new scope to save the lexing state. The scope will be
2315 * ended in S_sublex_done. Returns a '(', starting the function arguments
2316 * to the uc, lc, etc. found before.
2317 * Sets PL_lex_state to LEX_INTERPCONCAT.
2324 const bool is_heredoc = PL_multi_close == '<';
2327 PL_lex_state = PL_sublex_info.super_state;
2328 SAVEI8(PL_lex_dojoin);
2329 SAVEI32(PL_lex_brackets);
2330 SAVEI32(PL_lex_allbrackets);
2331 SAVEI32(PL_lex_formbrack);
2332 SAVEI8(PL_lex_fakeeof);
2333 SAVEI32(PL_lex_casemods);
2334 SAVEI32(PL_lex_starts);
2335 SAVEI8(PL_lex_state);
2336 SAVESPTR(PL_lex_repl);
2337 SAVEVPTR(PL_lex_inpat);
2338 SAVEI16(PL_lex_inwhat);
2341 SAVECOPLINE(PL_curcop);
2342 SAVEI32(PL_multi_end);
2343 SAVEI32(PL_parser->herelines);
2344 PL_parser->herelines = 0;
2346 SAVEI8(PL_multi_close);
2347 SAVEPPTR(PL_bufptr);
2348 SAVEPPTR(PL_bufend);
2349 SAVEPPTR(PL_oldbufptr);
2350 SAVEPPTR(PL_oldoldbufptr);
2351 SAVEPPTR(PL_last_lop);
2352 SAVEPPTR(PL_last_uni);
2353 SAVEPPTR(PL_linestart);
2354 SAVESPTR(PL_linestr);
2355 SAVEGENERICPV(PL_lex_brackstack);
2356 SAVEGENERICPV(PL_lex_casestack);
2357 SAVEGENERICPV(PL_parser->lex_shared);
2358 SAVEBOOL(PL_parser->lex_re_reparsing);
2359 SAVEI32(PL_copline);
2361 /* The here-doc parser needs to be able to peek into outer lexing
2362 scopes to find the body of the here-doc. So we put PL_linestr and
2363 PL_bufptr into lex_shared, to ‘share’ those values.
2365 PL_parser->lex_shared->ls_linestr = PL_linestr;
2366 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2368 PL_linestr = PL_lex_stuff;
2369 PL_lex_repl = PL_sublex_info.repl;
2370 PL_lex_stuff = NULL;
2371 PL_sublex_info.repl = NULL;
2373 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2374 = SvPVX(PL_linestr);
2375 PL_bufend += SvCUR(PL_linestr);
2376 PL_last_lop = PL_last_uni = NULL;
2377 SAVEFREESV(PL_linestr);
2378 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2380 PL_lex_dojoin = FALSE;
2381 PL_lex_brackets = PL_lex_formbrack = 0;
2382 PL_lex_allbrackets = 0;
2383 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2384 Newx(PL_lex_brackstack, 120, char);
2385 Newx(PL_lex_casestack, 12, char);
2386 PL_lex_casemods = 0;
2387 *PL_lex_casestack = '\0';
2389 PL_lex_state = LEX_INTERPCONCAT;
2391 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2392 PL_copline = NOLINE;
2394 Newxz(shared, 1, LEXSHARED);
2395 shared->ls_prev = PL_parser->lex_shared;
2396 PL_parser->lex_shared = shared;
2398 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2399 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2400 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2401 PL_lex_inpat = PL_sublex_info.sub_op;
2403 PL_lex_inpat = NULL;
2405 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2406 PL_in_eval &= ~EVAL_RE_REPARSING;
2413 * Restores lexer state after a S_sublex_push.
2419 if (!PL_lex_starts++) {
2420 SV * const sv = newSVpvs("");
2421 if (SvUTF8(PL_linestr))
2423 PL_expect = XOPERATOR;
2424 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2428 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2429 PL_lex_state = LEX_INTERPCASEMOD;
2433 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2434 assert(PL_lex_inwhat != OP_TRANSR);
2436 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2437 PL_linestr = PL_lex_repl;
2439 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2440 PL_bufend += SvCUR(PL_linestr);
2441 PL_last_lop = PL_last_uni = NULL;
2442 PL_lex_dojoin = FALSE;
2443 PL_lex_brackets = 0;
2444 PL_lex_allbrackets = 0;
2445 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2446 PL_lex_casemods = 0;
2447 *PL_lex_casestack = '\0';
2449 if (SvEVALED(PL_lex_repl)) {
2450 PL_lex_state = LEX_INTERPNORMAL;
2452 /* we don't clear PL_lex_repl here, so that we can check later
2453 whether this is an evalled subst; that means we rely on the
2454 logic to ensure sublex_done() is called again only via the
2455 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2458 PL_lex_state = LEX_INTERPCONCAT;
2461 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2462 CopLINE(PL_curcop) +=
2463 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2464 + PL_parser->herelines;
2465 PL_parser->herelines = 0;
2470 const line_t l = CopLINE(PL_curcop);
2472 if (PL_multi_close == '<')
2473 PL_parser->herelines += l - PL_multi_end;
2474 PL_bufend = SvPVX(PL_linestr);
2475 PL_bufend += SvCUR(PL_linestr);
2476 PL_expect = XOPERATOR;
2477 PL_sublex_info.sub_inwhat = 0;
2482 PERL_STATIC_INLINE SV*
2483 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2485 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2486 * interior, hence to the "}". Finds what the name resolves to, returning
2487 * an SV* containing it; NULL if no valid one found */
2489 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2496 const U8* first_bad_char_loc;
2497 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2499 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2501 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2503 &first_bad_char_loc))
2505 /* If warnings are on, this will print a more detailed analysis of what
2506 * is wrong than the error message below */
2507 utf8n_to_uvchr(first_bad_char_loc,
2508 e - ((char *) first_bad_char_loc),
2511 /* We deliberately don't try to print the malformed character, which
2512 * might not print very well; it also may be just the first of many
2513 * malformations, so don't print what comes after it */
2514 yyerror(Perl_form(aTHX_
2515 "Malformed UTF-8 character immediately after '%.*s'",
2516 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2520 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2521 /* include the <}> */
2522 e - backslash_ptr + 1);
2524 SvREFCNT_dec_NN(res);
2528 /* See if the charnames handler is the Perl core's, and if so, we can skip
2529 * the validation needed for a user-supplied one, as Perl's does its own
2531 table = GvHV(PL_hintgv); /* ^H */
2532 cvp = hv_fetchs(table, "charnames", FALSE);
2533 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2534 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2536 const char * const name = HvNAME(stash);
2537 if (HvNAMELEN(stash) == sizeof("_charnames")-1
2538 && strEQ(name, "_charnames")) {
2543 /* Here, it isn't Perl's charname handler. We can't rely on a
2544 * user-supplied handler to validate the input name. For non-ut8 input,
2545 * look to see that the first character is legal. Then loop through the
2546 * rest checking that each is a continuation */
2548 /* This code makes the reasonable assumption that the only Latin1-range
2549 * characters that begin a character name alias are alphabetic, otherwise
2550 * would have to create a isCHARNAME_BEGIN macro */
2553 if (! isALPHAU(*s)) {
2558 if (! isCHARNAME_CONT(*s)) {
2561 if (*s == ' ' && *(s-1) == ' ') {
2564 if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2565 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2566 "NO-BREAK SPACE in a charnames "
2567 "alias definition is deprecated");
2573 /* Similarly for utf8. For invariants can check directly; for other
2574 * Latin1, can calculate their code point and check; otherwise use a
2576 if (UTF8_IS_INVARIANT(*s)) {
2577 if (! isALPHAU(*s)) {
2581 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2582 if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2588 if (! PL_utf8_charname_begin) {
2589 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2590 PL_utf8_charname_begin = _core_swash_init("utf8",
2591 "_Perl_Charname_Begin",
2593 1, 0, NULL, &flags);
2595 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2602 if (UTF8_IS_INVARIANT(*s)) {
2603 if (! isCHARNAME_CONT(*s)) {
2606 if (*s == ' ' && *(s-1) == ' ') {
2611 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2612 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2616 if (*s == *NBSP_UTF8
2617 && *(s+1) == *(NBSP_UTF8+1)
2618 && ckWARN_d(WARN_DEPRECATED))
2620 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2621 "NO-BREAK SPACE in a charnames "
2622 "alias definition is deprecated");
2627 if (! PL_utf8_charname_continue) {
2628 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2629 PL_utf8_charname_continue = _core_swash_init("utf8",
2630 "_Perl_Charname_Continue",
2632 1, 0, NULL, &flags);
2634 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2641 if (*(s-1) == ' ') {
2644 "charnames alias definitions may not contain trailing "
2645 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2646 (int)(s - backslash_ptr + 1), backslash_ptr,
2647 (int)(e - s + 1), s + 1
2649 UTF ? SVf_UTF8 : 0);
2653 if (SvUTF8(res)) { /* Don't accept malformed input */
2654 const U8* first_bad_char_loc;
2656 const char* const str = SvPV_const(res, len);
2657 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2658 /* If warnings are on, this will print a more detailed analysis of
2659 * what is wrong than the error message below */
2660 utf8n_to_uvchr(first_bad_char_loc,
2661 (char *) first_bad_char_loc - str,
2664 /* We deliberately don't try to print the malformed character,
2665 * which might not print very well; it also may be just the first
2666 * of many malformations, so don't print what comes after it */
2669 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2670 (int) (e - backslash_ptr + 1), backslash_ptr,
2671 (int) ((char *) first_bad_char_loc - str), str
2682 /* The final %.*s makes sure that should the trailing NUL be missing
2683 * that this print won't run off the end of the string */
2686 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2687 (int)(s - backslash_ptr + 1), backslash_ptr,
2688 (int)(e - s + 1), s + 1
2690 UTF ? SVf_UTF8 : 0);
2697 "charnames alias definitions may not contain a sequence of "
2698 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2699 (int)(s - backslash_ptr + 1), backslash_ptr,
2700 (int)(e - s + 1), s + 1
2702 UTF ? SVf_UTF8 : 0);
2709 Extracts the next constant part of a pattern, double-quoted string,
2710 or transliteration. This is terrifying code.
2712 For example, in parsing the double-quoted string "ab\x63$d", it would
2713 stop at the '$' and return an OP_CONST containing 'abc'.
2715 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2716 processing a pattern (PL_lex_inpat is true), a transliteration
2717 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2719 Returns a pointer to the character scanned up to. If this is
2720 advanced from the start pointer supplied (i.e. if anything was
2721 successfully parsed), will leave an OP_CONST for the substring scanned
2722 in pl_yylval. Caller must intuit reason for not parsing further
2723 by looking at the next characters herself.
2727 \N{FOO} => \N{U+hex_for_character_FOO}
2728 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2731 all other \-char, including \N and \N{ apart from \N{ABC}
2734 @ and $ where it appears to be a var, but not for $ as tail anchor
2739 In transliterations:
2740 characters are VERY literal, except for - not at the start or end
2741 of the string, which indicates a range. If the range is in bytes,
2742 scan_const expands the range to the full set of intermediate
2743 characters. If the range is in utf8, the hyphen is replaced with
2744 a certain range mark which will be handled by pmtrans() in op.c.
2746 In double-quoted strings:
2748 double-quoted style: \r and \n
2749 constants: \x31, etc.
2750 deprecated backrefs: \1 (in substitution replacements)
2751 case and quoting: \U \Q \E
2754 scan_const does *not* construct ops to handle interpolated strings.
2755 It stops processing as soon as it finds an embedded $ or @ variable
2756 and leaves it to the caller to work out what's going on.
2758 embedded arrays (whether in pattern or not) could be:
2759 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2761 $ in double-quoted strings must be the symbol of an embedded scalar.
2763 $ in pattern could be $foo or could be tail anchor. Assumption:
2764 it's a tail anchor if $ is the last thing in the string, or if it's
2765 followed by one of "()| \r\n\t"
2767 \1 (backreferences) are turned into $1 in substitutions
2769 The structure of the code is
2770 while (there's a character to process) {
2771 handle transliteration ranges
2772 skip regexp comments /(?#comment)/ and codes /(?{code})/
2773 skip #-initiated comments in //x patterns
2774 check for embedded arrays
2775 check for embedded scalars
2777 deprecate \1 in substitution replacements
2778 handle string-changing backslashes \l \U \Q \E, etc.
2779 switch (what was escaped) {
2780 handle \- in a transliteration (becomes a literal -)
2781 if a pattern and not \N{, go treat as regular character
2782 handle \132 (octal characters)
2783 handle \x15 and \x{1234} (hex characters)
2784 handle \N{name} (named characters, also \N{3,5} in a pattern)
2785 handle \cV (control characters)
2786 handle printf-style backslashes (\f, \r, \n, etc)
2789 } (end if backslash)
2790 handle regular character
2791 } (end while character to read)
2796 S_scan_const(pTHX_ char *start)
2798 char *send = PL_bufend; /* end of the constant */
2799 SV *sv = newSV(send - start); /* sv for the constant. See note below
2801 char *s = start; /* start of the constant */
2802 char *d = SvPVX(sv); /* destination for copies */
2803 bool dorange = FALSE; /* are we in a translit range? */
2804 bool didrange = FALSE; /* did we just finish a range? */
2805 bool in_charclass = FALSE; /* within /[...]/ */
2806 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2807 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2808 UTF8? But, this can show as true
2809 when the source isn't utf8, as for
2810 example when it is entirely composed
2812 SV *res; /* result from charnames */
2814 /* Note on sizing: The scanned constant is placed into sv, which is
2815 * initialized by newSV() assuming one byte of output for every byte of
2816 * input. This routine expects newSV() to allocate an extra byte for a
2817 * trailing NUL, which this routine will append if it gets to the end of
2818 * the input. There may be more bytes of input than output (eg., \N{LATIN
2819 * CAPITAL LETTER A}), or more output than input if the constant ends up
2820 * recoded to utf8, but each time a construct is found that might increase
2821 * the needed size, SvGROW() is called. Its size parameter each time is
2822 * based on the best guess estimate at the time, namely the length used so
2823 * far, plus the length the current construct will occupy, plus room for
2824 * the trailing NUL, plus one byte for every input byte still unscanned */
2826 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2829 UV literal_endpoint = 0;
2830 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2833 PERL_ARGS_ASSERT_SCAN_CONST;
2835 assert(PL_lex_inwhat != OP_TRANSR);
2836 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2837 /* If we are doing a trans and we know we want UTF8 set expectation */
2838 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2839 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2842 /* Protect sv from errors and fatal warnings. */
2843 ENTER_with_name("scan_const");
2846 while (s < send || dorange) {
2848 /* get transliterations out of the way (they're most literal) */
2849 if (PL_lex_inwhat == OP_TRANS) {
2850 /* expand a range A-Z to the full set of characters. AIE! */
2852 I32 i; /* current expanded character */
2853 I32 min; /* first character in range */
2854 I32 max; /* last character in range */
2865 char * const c = (char*)utf8_hop((U8*)d, -1);
2869 *c = (char) ILLEGAL_UTF8_BYTE;
2870 /* mark the range as done, and continue */
2876 i = d - SvPVX_const(sv); /* remember current offset */
2879 SvLEN(sv) + ((has_utf8)
2880 ? (512 - UTF_CONTINUATION_MARK
2883 /* How many two-byte within 0..255: 128 in UTF-8,
2884 * 96 in UTF-8-mod. */
2886 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2888 d = SvPVX(sv) + i; /* refresh d after realloc */
2892 for (j = 0; j <= 1; j++) {
2893 char * const c = (char*)utf8_hop((U8*)d, -1);
2894 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2900 max = (U8)0xff; /* only to \xff */
2901 uvmax = uv; /* \x{100} to uvmax */
2903 d = c; /* eat endpoint chars */
2908 d -= 2; /* eat the first char and the - */
2909 min = (U8)*d; /* first char in range */
2910 max = (U8)d[1]; /* last char in range */
2917 "Invalid range \"%c-%c\" in transliteration operator",
2918 (char)min, (char)max);
2922 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2923 * any subsets of these ranges into individual characters */
2924 if (literal_endpoint == 2 &&
2925 ((isLOWER_A(min) && isLOWER_A(max)) ||
2926 (isUPPER_A(min) && isUPPER_A(max))))
2928 for (i = min; i <= max; i++) {
2935 for (i = min; i <= max; i++)
2938 append_utf8_from_native_byte(i, &d);
2946 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2948 *d++ = (char) ILLEGAL_UTF8_BYTE;
2950 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2954 /* mark the range as done, and continue */
2958 literal_endpoint = 0;
2963 /* range begins (ignore - as first or last char) */
2964 else if (*s == '-' && s+1 < send && s != start) {
2966 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2973 *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
2983 literal_endpoint = 0;
2984 native_range = TRUE;
2989 /* if we get here, we're not doing a transliteration */
2991 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
2994 while (s1 >= start && *s1-- == '\\')
2997 in_charclass = TRUE;
3000 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3003 while (s1 >= start && *s1-- == '\\')
3006 in_charclass = FALSE;
3009 /* skip for regexp comments /(?#comment)/, except for the last
3010 * char, which will be done separately.
3011 * Stop on (?{..}) and friends */
3013 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3015 while (s+1 < send && *s != ')')
3018 else if (!PL_lex_casemods &&
3019 ( s[2] == '{' /* This should match regcomp.c */
3020 || (s[2] == '?' && s[3] == '{')))
3026 /* likewise skip #-initiated comments in //x patterns */
3027 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3028 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3029 while (s+1 < send && *s != '\n')
3033 /* no further processing of single-quoted regex */
3034 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3035 goto default_action;
3037 /* check for embedded arrays
3038 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3040 else if (*s == '@' && s[1]) {
3041 if (isWORDCHAR_lazy_if(s+1,UTF))
3043 if (strchr(":'{$", s[1]))
3045 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3046 break; /* in regexp, neither @+ nor @- are interpolated */
3049 /* check for embedded scalars. only stop if we're sure it's a
3052 else if (*s == '$') {
3053 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3055 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3057 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3058 "Possible unintended interpolation of $\\ in regex");
3060 break; /* in regexp, $ might be tail anchor */
3064 /* End of else if chain - OP_TRANS rejoin rest */
3067 if (*s == '\\' && s+1 < send) {
3068 char* e; /* Can be used for ending '}', etc. */
3072 /* warn on \1 - \9 in substitution replacements, but note that \11
3073 * is an octal; and \19 is \1 followed by '9' */
3074 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3075 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3077 /* diag_listed_as: \%d better written as $%d */
3078 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3083 /* string-change backslash escapes */
3084 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3088 /* In a pattern, process \N, but skip any other backslash escapes.
3089 * This is because we don't want to translate an escape sequence
3090 * into a meta symbol and have the regex compiler use the meta
3091 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3092 * in spite of this, we do have to process \N here while the proper
3093 * charnames handler is in scope. See bugs #56444 and #62056.
3094 * There is a complication because \N in a pattern may also stand
3095 * for 'match a non-nl', and not mean a charname, in which case its
3096 * processing should be deferred to the regex compiler. To be a
3097 * charname it must be followed immediately by a '{', and not look
3098 * like \N followed by a curly quantifier, i.e., not something like
3099 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3101 else if (PL_lex_inpat
3104 || regcurly(s + 1)))
3107 goto default_action;
3112 /* quoted - in transliterations */
3114 if (PL_lex_inwhat == OP_TRANS) {
3121 if ((isALPHANUMERIC(*s)))
3122 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3123 "Unrecognized escape \\%c passed through",
3125 /* default action is to copy the quoted character */
3126 goto default_action;
3129 /* eg. \132 indicates the octal constant 0132 */
3130 case '0': case '1': case '2': case '3':
3131 case '4': case '5': case '6': case '7':
3133 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3135 uv = grok_oct(s, &len, &flags, NULL);
3137 if (len < 3 && s < send && isDIGIT(*s)
3138 && ckWARN(WARN_MISC))
3140 Perl_warner(aTHX_ packWARN(WARN_MISC),
3141 "%s", form_short_octal_warning(s, len));
3144 goto NUM_ESCAPE_INSERT;
3146 /* eg. \o{24} indicates the octal constant \024 */
3151 bool valid = grok_bslash_o(&s, &uv, &error,
3152 TRUE, /* Output warning */
3153 FALSE, /* Not strict */
3154 TRUE, /* Output warnings for
3161 goto NUM_ESCAPE_INSERT;
3164 /* eg. \x24 indicates the hex constant 0x24 */
3169 bool valid = grok_bslash_x(&s, &uv, &error,
3170 TRUE, /* Output warning */
3171 FALSE, /* Not strict */
3172 TRUE, /* Output warnings for
3182 /* Insert oct or hex escaped character. There will always be
3183 * enough room in sv since such escapes will be longer than any
3184 * UTF-8 sequence they can end up as, except if they force us
3185 * to recode the rest of the string into utf8 */
3187 /* Here uv is the ordinal of the next character being added */
3188 if (!UVCHR_IS_INVARIANT(uv)) {
3189 if (!has_utf8 && uv > 255) {
3190 /* Might need to recode whatever we have accumulated so
3191 * far if it contains any chars variant in utf8 or
3194 SvCUR_set(sv, d - SvPVX_const(sv));
3197 /* See Note on sizing above. */
3198 sv_utf8_upgrade_flags_grow(sv,
3199 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3200 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3201 d = SvPVX(sv) + SvCUR(sv);
3206 d = (char*)uvchr_to_utf8((U8*)d, uv);
3207 if (PL_lex_inwhat == OP_TRANS &&
3208 PL_sublex_info.sub_op) {
3209 PL_sublex_info.sub_op->op_private |=
3210 (PL_lex_repl ? OPpTRANS_FROM_UTF
3214 if (uv > 255 && !dorange)
3215 native_range = FALSE;
3228 /* In a non-pattern \N must be a named character, like \N{LATIN
3229 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3230 * mean to match a non-newline. For non-patterns, named
3231 * characters are converted to their string equivalents. In
3232 * patterns, named characters are not converted to their
3233 * ultimate forms for the same reasons that other escapes
3234 * aren't. Instead, they are converted to the \N{U+...} form
3235 * to get the value from the charnames that is in effect right
3236 * now, while preserving the fact that it was a named character
3237 * so that the regex compiler knows this */
3239 /* The structure of this section of code (besides checking for
3240 * errors and upgrading to utf8) is:
3241 * Further disambiguate between the two meanings of \N, and if
3242 * not a charname, go process it elsewhere
3243 * If of form \N{U+...}, pass it through if a pattern;
3244 * otherwise convert to utf8
3245 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3246 * pattern; otherwise convert to utf8 */
3248 /* Here, s points to the 'N'; the test below is guaranteed to
3249 * succeed if we are being called on a pattern as we already
3250 * know from a test above that the next character is a '{'.
3251 * On a non-pattern \N must mean 'named sequence, which
3252 * requires braces */
3255 yyerror("Missing braces on \\N{}");
3260 /* If there is no matching '}', it is an error. */
3261 if (! (e = strchr(s, '}'))) {
3262 if (! PL_lex_inpat) {
3263 yyerror("Missing right brace on \\N{}");
3265 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3270 /* Here it looks like a named character */
3272 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3273 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3274 | PERL_SCAN_DISALLOW_PREFIX;
3277 /* For \N{U+...}, the '...' is a unicode value even on
3278 * EBCDIC machines */
3279 s += 2; /* Skip to next char after the 'U+' */
3281 uv = grok_hex(s, &len, &flags, NULL);
3282 if (len == 0 || len != (STRLEN)(e - s)) {
3283 yyerror("Invalid hexadecimal number in \\N{U+...}");
3290 /* On non-EBCDIC platforms, pass through to the regex
3291 * compiler unchanged. The reason we evaluated the
3292 * number above is to make sure there wasn't a syntax
3293 * error. But on EBCDIC we convert to native so
3294 * downstream code can continue to assume it's native
3296 s -= 5; /* Include the '\N{U+' */
3298 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3301 (unsigned int) UNI_TO_NATIVE(uv));
3303 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3307 else { /* Not a pattern: convert the hex to string */
3309 /* If destination is not in utf8, unconditionally
3310 * recode it to be so. This is because \N{} implies
3311 * Unicode semantics, and scalars have to be in utf8
3312 * to guarantee those semantics */
3314 SvCUR_set(sv, d - SvPVX_const(sv));
3317 /* See Note on sizing above. */
3318 sv_utf8_upgrade_flags_grow(
3320 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3321 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3322 d = SvPVX(sv) + SvCUR(sv);
3326 /* Add the (Unicode) code point to the output. */
3327 if (UNI_IS_INVARIANT(uv)) {
3328 *d++ = (char) LATIN1_TO_NATIVE(uv);
3331 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3335 else /* Here is \N{NAME} but not \N{U+...}. */
3336 if ((res = get_and_check_backslash_N_name(s, e)))
3339 const char *str = SvPV_const(res, len);
3342 if (! len) { /* The name resolved to an empty string */
3343 Copy("\\N{}", d, 4, char);
3347 /* In order to not lose information for the regex
3348 * compiler, pass the result in the specially made
3349 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3350 * the code points in hex of each character
3351 * returned by charnames */
3353 const char *str_end = str + len;
3354 const STRLEN off = d - SvPVX_const(sv);
3356 if (! SvUTF8(res)) {
3357 /* For the non-UTF-8 case, we can determine the
3358 * exact length needed without having to parse
3359 * through the string. Each character takes up
3360 * 2 hex digits plus either a trailing dot or
3362 d = off + SvGROW(sv, off
3364 + 6 /* For the "\N{U+", and
3366 + (STRLEN)(send - e));
3367 Copy("\\N{U+", d, 5, char);
3369 while (str < str_end) {
3372 my_snprintf(hex_string,
3374 "%02X.", (U8) *str);
3375 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string));
3376 Copy(hex_string, d, 3, char);
3380 d--; /* We will overwrite below the final
3381 dot with a right brace */
3384 STRLEN char_length; /* cur char's byte length */
3386 /* and the number of bytes after this is
3387 * translated into hex digits */
3388 STRLEN output_length;
3390 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3391 * for max('U+', '.'); and 1 for NUL */
3392 char hex_string[2 * UTF8_MAXBYTES + 5];
3394 /* Get the first character of the result. */
3395 U32 uv = utf8n_to_uvchr((U8 *) str,
3399 /* Convert first code point to hex, including
3400 * the boiler plate before it. */
3402 my_snprintf(hex_string, sizeof(hex_string),
3406 /* Make sure there is enough space to hold it */
3407 d = off + SvGROW(sv, off
3409 + (STRLEN)(send - e)
3410 + 2); /* '}' + NUL */
3412 Copy(hex_string, d, output_length, char);
3415 /* For each subsequent character, append dot and
3416 * its ordinal in hex */
3417 while ((str += char_length) < str_end) {
3418 const STRLEN off = d - SvPVX_const(sv);
3419 U32 uv = utf8n_to_uvchr((U8 *) str,
3424 my_snprintf(hex_string,
3429 d = off + SvGROW(sv, off
3431 + (STRLEN)(send - e)
3432 + 2); /* '}' + NUL */
3433 Copy(hex_string, d, output_length, char);
3438 *d++ = '}'; /* Done. Add the trailing brace */
3441 else { /* Here, not in a pattern. Convert the name to a
3444 /* If destination is not in utf8, unconditionally
3445 * recode it to be so. This is because \N{} implies
3446 * Unicode semantics, and scalars have to be in utf8
3447 * to guarantee those semantics */
3449 SvCUR_set(sv, d - SvPVX_const(sv));
3452 /* See Note on sizing above. */
3453 sv_utf8_upgrade_flags_grow(sv,
3454 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3455 len + (STRLEN)(send - s) + 1);
3456 d = SvPVX(sv) + SvCUR(sv);
3458 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3460 /* See Note on sizing above. (NOTE: SvCUR() is not
3461 * set correctly here). */
3462 const STRLEN off = d - SvPVX_const(sv);
3463 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3465 if (! SvUTF8(res)) { /* Make sure is \N{} return is UTF-8 */
3466 sv_utf8_upgrade(res);
3467 str = SvPV_const(res, len);
3469 Copy(str, d, len, char);
3475 } /* End \N{NAME} */
3478 native_range = FALSE; /* \N{} is defined to be Unicode */
3480 s = e + 1; /* Point to just after the '}' */
3483 /* \c is a control character */
3487 *d++ = grok_bslash_c(*s++, 1);
3490 yyerror("Missing control char name in \\c");
3494 /* printf-style backslashes, formfeeds, newlines, etc */
3520 } /* end if (backslash) */
3527 /* If we started with encoded form, or already know we want it,
3528 then encode the next character */
3529 if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3533 /* One might think that it is wasted effort in the case of the
3534 * source being utf8 (this_utf8 == TRUE) to take the next character
3535 * in the source, convert it to an unsigned value, and then convert
3536 * it back again. But the source has not been validated here. The
3537 * routine that does the conversion checks for errors like
3540 const UV nextuv = (this_utf8)
3541 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3543 const STRLEN need = UNISKIP(nextuv);
3545 SvCUR_set(sv, d - SvPVX_const(sv));
3548 /* See Note on sizing above. */
3549 sv_utf8_upgrade_flags_grow(sv,
3550 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3551 need + (STRLEN)(send - s) + 1);
3552 d = SvPVX(sv) + SvCUR(sv);
3554 } else if (need > len) {
3555 /* encoded value larger than old, may need extra space (NOTE:
3556 * SvCUR() is not set correctly here). See Note on sizing
3558 const STRLEN off = d - SvPVX_const(sv);
3559 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3563 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3565 if (uv > 255 && !dorange)
3566 native_range = FALSE;
3572 } /* while loop to process each character */
3574 /* terminate the string and set up the sv */
3576 SvCUR_set(sv, d - SvPVX_const(sv));
3577 if (SvCUR(sv) >= SvLEN(sv))
3578 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3579 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3582 if (PL_encoding && !has_utf8) {
3583 sv_recode_to_utf8(sv, PL_encoding);
3589 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3590 PL_sublex_info.sub_op->op_private |=
3591 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3595 /* shrink the sv if we allocated more than we used */
3596 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3597 SvPV_shrink_to_cur(sv);
3600 /* return the substring (via pl_yylval) only if we parsed anything */
3603 for (; s2 < s; s2++) {
3605 COPLINE_INC_WITH_HERELINES;
3607 SvREFCNT_inc_simple_void_NN(sv);
3608 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3609 && ! PL_parser->lex_re_reparsing)
3611 const char *const key = PL_lex_inpat ? "qr" : "q";
3612 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3616 if (PL_lex_inwhat == OP_TRANS) {
3619 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3622 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3630 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3633 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3635 LEAVE_with_name("scan_const");
3640 * Returns TRUE if there's more to the expression (e.g., a subscript),
3643 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3645 * ->[ and ->{ return TRUE
3646 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3647 * { and [ outside a pattern are always subscripts, so return TRUE
3648 * if we're outside a pattern and it's not { or [, then return FALSE
3649 * if we're in a pattern and the first char is a {
3650 * {4,5} (any digits around the comma) returns FALSE
3651 * if we're in a pattern and the first char is a [
3653 * [SOMETHING] has a funky algorithm to decide whether it's a
3654 * character class or not. It has to deal with things like
3655 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3656 * anything else returns TRUE
3659 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3662 S_intuit_more(pTHX_ char *s)
3664 PERL_ARGS_ASSERT_INTUIT_MORE;
3666 if (PL_lex_brackets)
3668 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3670 if (*s == '-' && s[1] == '>'
3671 && FEATURE_POSTDEREF_QQ_IS_ENABLED
3672 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3673 ||(s[2] == '@' && strchr("*[{",s[3])) ))
3675 if (*s != '{' && *s != '[')
3680 /* In a pattern, so maybe we have {n,m}. */
3688 /* On the other hand, maybe we have a character class */
3691 if (*s == ']' || *s == '^')
3694 /* this is terrifying, and it works */
3697 const char * const send = strchr(s,']');
3698 unsigned char un_char, last_un_char;
3699 char tmpbuf[sizeof PL_tokenbuf * 4];
3701 if (!send) /* has to be an expression */
3703 weight = 2; /* let's weigh the evidence */
3707 else if (isDIGIT(*s)) {
3709 if (isDIGIT(s[1]) && s[2] == ']')
3715 Zero(seen,256,char);
3717 for (; s < send; s++) {
3718 last_un_char = un_char;
3719 un_char = (unsigned char)*s;
3724 weight -= seen[un_char] * 10;
3725 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3727 char *tmp = PL_bufend;
3728 PL_bufend = (char*)send;
3729 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3731 len = (int)strlen(tmpbuf);
3732 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3733 UTF ? SVf_UTF8 : 0, SVt_PV))
3738 else if (*s == '$' && s[1] &&
3739 strchr("[#!%*<>()-=",s[1])) {
3740 if (/*{*/ strchr("])} =",s[2]))
3749 if (strchr("wds]",s[1]))
3751 else if (seen[(U8)'\''] || seen[(U8)'"'])
3753 else if (strchr("rnftbxcav",s[1]))
3755 else if (isDIGIT(s[1])) {
3757 while (s[1] && isDIGIT(s[1]))
3767 if (strchr("aA01! ",last_un_char))
3769 if (strchr("zZ79~",s[1]))
3771 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3772 weight -= 5; /* cope with negative subscript */
3775 if (!isWORDCHAR(last_un_char)
3776 && !(last_un_char == '$' || last_un_char == '@'
3777 || last_un_char == '&')
3778 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3783 if (keyword(tmpbuf, d - tmpbuf, 0))
3786 if (un_char == last_un_char + 1)
3788 weight -= seen[un_char];
3793 if (weight >= 0) /* probably a character class */
3803 * Does all the checking to disambiguate
3805 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3806 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3808 * First argument is the stuff after the first token, e.g. "bar".
3810 * Not a method if foo is a filehandle.
3811 * Not a method if foo is a subroutine prototyped to take a filehandle.
3812 * Not a method if it's really "Foo $bar"
3813 * Method if it's "foo $bar"
3814 * Not a method if it's really "print foo $bar"
3815 * Method if it's really "foo package::" (interpreted as package->foo)
3816 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3817 * Not a method if bar is a filehandle or package, but is quoted with
3822 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3824 char *s = start + (*start == '$');
3825 char tmpbuf[sizeof PL_tokenbuf];
3829 PERL_ARGS_ASSERT_INTUIT_METHOD;
3831 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3833 if (cv && SvPOK(cv)) {
3834 const char *proto = CvPROTO(cv);
3836 while (*proto && (isSPACE(*proto) || *proto == ';'))
3843 if (*start == '$') {
3844 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3845 isUPPER(*PL_tokenbuf))
3850 return *s == '(' ? FUNCMETH : METHOD;
3853 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3854 /* start is the beginning of the possible filehandle/object,
3855 * and s is the end of it
3856 * tmpbuf is a copy of it (but with single quotes as double colons)
3859 if (!keyword(tmpbuf, len, 0)) {
3860 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3865 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3866 if (indirgv && GvCVu(indirgv))
3868 /* filehandle or package name makes it a method */
3869 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3871 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3872 return 0; /* no assumptions -- "=>" quotes bareword */
3874 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3875 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3876 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3880 return *s == '(' ? FUNCMETH : METHOD;
3886 /* Encoded script support. filter_add() effectively inserts a
3887 * 'pre-processing' function into the current source input stream.
3888 * Note that the filter function only applies to the current source file
3889 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3891 * The datasv parameter (which may be NULL) can be used to pass
3892 * private data to this instance of the filter. The filter function
3893 * can recover the SV using the FILTER_DATA macro and use it to
3894 * store private buffers and state information.
3896 * The supplied datasv parameter is upgraded to a PVIO type
3897 * and the IoDIRP/IoANY field is used to store the function pointer,
3898 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3899 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3900 * private use must be set using malloc'd pointers.
3904 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3912 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3913 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3915 if (!PL_rsfp_filters)
3916 PL_rsfp_filters = newAV();
3919 SvUPGRADE(datasv, SVt_PVIO);
3920 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3921 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3922 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3923 FPTR2DPTR(void *, IoANY(datasv)),
3924 SvPV_nolen(datasv)));
3925 av_unshift(PL_rsfp_filters, 1);
3926 av_store(PL_rsfp_filters, 0, datasv) ;
3928 !PL_parser->filtered
3929 && PL_parser->lex_flags & LEX_EVALBYTES
3930 && PL_bufptr < PL_bufend
3932 const char *s = PL_bufptr;
3933 while (s < PL_bufend) {
3935 SV *linestr = PL_parser->linestr;
3936 char *buf = SvPVX(linestr);
3937 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3938 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3939 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3940 STRLEN const linestart_pos = PL_parser->linestart - buf;
3941 STRLEN const last_uni_pos =
3942 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3943 STRLEN const last_lop_pos =
3944 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3945 av_push(PL_rsfp_filters, linestr);
3946 PL_parser->linestr =
3947 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3948 buf = SvPVX(PL_parser->linestr);
3949 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3950 PL_parser->bufptr = buf + bufptr_pos;
3951 PL_parser->oldbufptr = buf + oldbufptr_pos;
3952 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3953 PL_parser->linestart = buf + linestart_pos;
3954 if (PL_parser->last_uni)
3955 PL_parser->last_uni = buf + last_uni_pos;
3956 if (PL_parser->last_lop)
3957 PL_parser->last_lop = buf + last_lop_pos;
3958 SvLEN(linestr) = SvCUR(linestr);
3959 SvCUR(linestr) = s-SvPVX(linestr);
3960 PL_parser->filtered = 1;
3970 /* Delete most recently added instance of this filter function. */
3972 Perl_filter_del(pTHX_ filter_t funcp)
3976 PERL_ARGS_ASSERT_FILTER_DEL;
3979 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3980 FPTR2DPTR(void*, funcp)));
3982 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3984 /* if filter is on top of stack (usual case) just pop it off */
3985 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3986 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3987 sv_free(av_pop(PL_rsfp_filters));
3991 /* we need to search for the correct entry and clear it */
3992 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3996 /* Invoke the idxth filter function for the current rsfp. */
3997 /* maxlen 0 = read one text line */
3999 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4003 /* This API is bad. It should have been using unsigned int for maxlen.
4004 Not sure if we want to change the API, but if not we should sanity
4005 check the value here. */
4006 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4008 PERL_ARGS_ASSERT_FILTER_READ;
4010 if (!PL_parser || !PL_rsfp_filters)
4012 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4013 /* Provide a default input filter to make life easy. */
4014 /* Note that we append to the line. This is handy. */
4015 DEBUG_P(PerlIO_printf(Perl_debug_log,
4016 "filter_read %d: from rsfp\n", idx));
4017 if (correct_length) {
4020 const int old_len = SvCUR(buf_sv);
4022 /* ensure buf_sv is large enough */
4023 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4024 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4025 correct_length)) <= 0) {
4026 if (PerlIO_error(PL_rsfp))
4027 return -1; /* error */
4029 return 0 ; /* end of file */
4031 SvCUR_set(buf_sv, old_len + len) ;
4032 SvPVX(buf_sv)[old_len + len] = '\0';
4035 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4036 if (PerlIO_error(PL_rsfp))
4037 return -1; /* error */
4039 return 0 ; /* end of file */
4042 return SvCUR(buf_sv);
4044 /* Skip this filter slot if filter has been deleted */
4045 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4046 DEBUG_P(PerlIO_printf(Perl_debug_log,
4047 "filter_read %d: skipped (filter deleted)\n",
4049 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4051 if (SvTYPE(datasv) != SVt_PVIO) {
4052 if (correct_length) {
4054 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4055 if (!remainder) return 0; /* eof */
4056 if (correct_length > remainder) correct_length = remainder;
4057 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4058 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4061 const char *s = SvEND(datasv);
4062 const char *send = SvPVX(datasv) + SvLEN(datasv);
4070 if (s == send) return 0; /* eof */
4071 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4072 SvCUR_set(datasv, s-SvPVX(datasv));
4074 return SvCUR(buf_sv);
4076 /* Get function pointer hidden within datasv */
4077 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4078 DEBUG_P(PerlIO_printf(Perl_debug_log,
4079 "filter_read %d: via function %p (%s)\n",
4080 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4081 /* Call function. The function is expected to */
4082 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4083 /* Return: <0:error, =0:eof, >0:not eof */
4084 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4088 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4090 PERL_ARGS_ASSERT_FILTER_GETS;
4092 #ifdef PERL_CR_FILTER
4093 if (!PL_rsfp_filters) {
4094 filter_add(S_cr_textfilter,NULL);
4097 if (PL_rsfp_filters) {
4099 SvCUR_set(sv, 0); /* start with empty line */
4100 if (FILTER_READ(0, sv, 0) > 0)
4101 return ( SvPVX(sv) ) ;
4106 return (sv_gets(sv, PL_rsfp, append));
4110 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4114 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4116 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4120 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4121 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4123 return GvHV(gv); /* Foo:: */
4126 /* use constant CLASS => 'MyClass' */
4127 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4128 if (gv && GvCV(gv)) {
4129 SV * const sv = cv_const_sv(GvCV(gv));
4131 pkgname = SvPV_const(sv, len);
4134 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4139 S_tokenize_use(pTHX_ int is_use, char *s) {
4140 PERL_ARGS_ASSERT_TOKENIZE_USE;
4142 if (PL_expect != XSTATE)
4143 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4144 is_use ? "use" : "no"));
4147 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4148 s = force_version(s, TRUE);
4149 if (*s == ';' || *s == '}'
4150 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4151 NEXTVAL_NEXTTOKE.opval = NULL;
4154 else if (*s == 'v') {
4155 s = force_word(s,WORD,FALSE,TRUE);
4156 s = force_version(s, FALSE);
4160 s = force_word(s,WORD,FALSE,TRUE);
4161 s = force_version(s, FALSE);
4163 pl_yylval.ival = is_use;
4167 static const char* const exp_name[] =
4168 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4169 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4174 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4176 S_word_takes_any_delimeter(char *p, STRLEN len)
4178 return (len == 1 && strchr("msyq", p[0])) ||
4180 (p[0] == 't' && p[1] == 'r') ||
4181 (p[0] == 'q' && strchr("qwxr", p[1]))));
4185 S_check_scalar_slice(pTHX_ char *s)
4188 while (*s == ' ' || *s == '\t') s++;
4189 if (*s == 'q' && s[1] == 'w'
4190 && !isWORDCHAR_lazy_if(s+2,UTF))
4192 while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4193 s += UTF ? UTF8SKIP(s) : 1;
4194 if (*s == '}' || *s == ']')
4195 pl_yylval.ival = OPpSLICEWARNING;
4201 Works out what to call the token just pulled out of the input
4202 stream. The yacc parser takes care of taking the ops we return and
4203 stitching them into a tree.
4206 The type of the next token
4209 Switch based on the current state:
4210 - if we already built the token before, use it
4211 - if we have a case modifier in a string, deal with that
4212 - handle other cases of interpolation inside a string
4213 - scan the next line if we are inside a format
4214 In the normal state switch on the next character:
4216 if alphabetic, go to key lookup
4217 unrecoginized character - croak
4218 - 0/4/26: handle end-of-line or EOF
4219 - cases for whitespace
4220 - \n and #: handle comments and line numbers
4221 - various operators, brackets and sigils
4224 - 'v': vstrings (or go to key lookup)
4225 - 'x' repetition operator (or go to key lookup)
4226 - other ASCII alphanumerics (key lookup begins here):
4229 scan built-in keyword (but do nothing with it yet)
4230 check for statement label
4231 check for lexical subs
4232 goto just_a_word if there is one
4233 see whether built-in keyword is overridden
4234 switch on keyword number:
4235 - default: just_a_word:
4236 not a built-in keyword; handle bareword lookup
4237 disambiguate between method and sub call
4238 fall back to bareword
4239 - cases for built-in keywords
4247 char *s = PL_bufptr;
4251 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4255 /* orig_keyword, gvp, and gv are initialized here because
4256 * jump to the label just_a_word_zero can bypass their
4257 * initialization later. */
4258 I32 orig_keyword = 0;
4263 SV* tmp = newSVpvs("");
4264 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4265 (IV)CopLINE(PL_curcop),
4266 lex_state_names[PL_lex_state],
4267 exp_name[PL_expect],
4268 pv_display(tmp, s, strlen(s), 0, 60));
4272 switch (PL_lex_state) {
4274 case LEX_INTERPNORMAL:
4277 /* when we've already built the next token, just pull it out of the queue */
4280 pl_yylval = PL_nextval[PL_nexttoke];
4282 PL_lex_state = PL_lex_defer;
4283 PL_lex_defer = LEX_NORMAL;
4287 next_type = PL_nexttype[PL_nexttoke];
4288 if (next_type & (7<<24)) {
4289 if (next_type & (1<<24)) {
4290 if (PL_lex_brackets > 100)
4291 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4292 PL_lex_brackstack[PL_lex_brackets++] =
4293 (char) ((next_type >> 16) & 0xff);
4295 if (next_type & (2<<24))
4296 PL_lex_allbrackets++;
4297 if (next_type & (4<<24))
4298 PL_lex_allbrackets--;
4299 next_type &= 0xffff;
4301 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4304 /* interpolated case modifiers like \L \U, including \Q and \E.
4305 when we get here, PL_bufptr is at the \
4307 case LEX_INTERPCASEMOD:
4309 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4311 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4312 PL_bufptr, PL_bufend, *PL_bufptr);
4314 /* handle \E or end of string */
4315 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4317 if (PL_lex_casemods) {
4318 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4319 PL_lex_casestack[PL_lex_casemods] = '\0';
4321 if (PL_bufptr != PL_bufend
4322 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4323 || oldmod == 'F')) {
4325 PL_lex_state = LEX_INTERPCONCAT;
4327 PL_lex_allbrackets--;
4330 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4331 /* Got an unpaired \E */
4332 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4333 "Useless use of \\E");
4335 if (PL_bufptr != PL_bufend)
4337 PL_lex_state = LEX_INTERPCONCAT;
4341 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4342 "### Saw case modifier\n"); });
4344 if (s[1] == '\\' && s[2] == 'E') {
4346 PL_lex_state = LEX_INTERPCONCAT;
4351 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4352 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4353 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4354 (strchr(PL_lex_casestack, 'L')
4355 || strchr(PL_lex_casestack, 'U')
4356 || strchr(PL_lex_casestack, 'F'))) {
4357 PL_lex_casestack[--PL_lex_casemods] = '\0';
4358 PL_lex_allbrackets--;
4361 if (PL_lex_casemods > 10)
4362 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4363 PL_lex_casestack[PL_lex_casemods++] = *s;
4364 PL_lex_casestack[PL_lex_casemods] = '\0';
4365 PL_lex_state = LEX_INTERPCONCAT;
4366 NEXTVAL_NEXTTOKE.ival = 0;
4367 force_next((2<<24)|'(');
4369 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4371 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4373 NEXTVAL_NEXTTOKE.ival = OP_LC;
4375 NEXTVAL_NEXTTOKE.ival = OP_UC;
4377 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4379 NEXTVAL_NEXTTOKE.ival = OP_FC;
4381 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4385 if (PL_lex_starts) {
4388 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4389 if (PL_lex_casemods == 1 && PL_lex_inpat)
4392 AopNOASSIGN(OP_CONCAT);
4398 case LEX_INTERPPUSH:
4399 return REPORT(sublex_push());
4401 case LEX_INTERPSTART:
4402 if (PL_bufptr == PL_bufend)