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
27 This is the lower layer of the Perl parser, managing characters and tokens.
29 =for apidoc AmU|yy_parser *|PL_parser
31 Pointer to a structure encapsulating the state of the parsing operation
32 currently in progress. The pointer can be locally changed to perform
33 a nested parse without interfering with the state of an outer parse.
34 Individual members of C<PL_parser> have their own documentation.
40 #define PERL_IN_TOKE_C
42 #include "dquote_static.c"
44 #define new_constant(a,b,c,d,e,f,g) \
45 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
47 #define pl_yylval (PL_parser->yylval)
49 /* XXX temporary backwards compatibility */
50 #define PL_lex_brackets (PL_parser->lex_brackets)
51 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
52 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
53 #define PL_lex_brackstack (PL_parser->lex_brackstack)
54 #define PL_lex_casemods (PL_parser->lex_casemods)
55 #define PL_lex_casestack (PL_parser->lex_casestack)
56 #define PL_lex_defer (PL_parser->lex_defer)
57 #define PL_lex_dojoin (PL_parser->lex_dojoin)
58 #define PL_lex_expect (PL_parser->lex_expect)
59 #define PL_lex_formbrack (PL_parser->lex_formbrack)
60 #define PL_lex_inpat (PL_parser->lex_inpat)
61 #define PL_lex_inwhat (PL_parser->lex_inwhat)
62 #define PL_lex_op (PL_parser->lex_op)
63 #define PL_lex_repl (PL_parser->lex_repl)
64 #define PL_lex_starts (PL_parser->lex_starts)
65 #define PL_lex_stuff (PL_parser->lex_stuff)
66 #define PL_multi_start (PL_parser->multi_start)
67 #define PL_multi_open (PL_parser->multi_open)
68 #define PL_multi_close (PL_parser->multi_close)
69 #define PL_preambled (PL_parser->preambled)
70 #define PL_sublex_info (PL_parser->sublex_info)
71 #define PL_linestr (PL_parser->linestr)
72 #define PL_expect (PL_parser->expect)
73 #define PL_copline (PL_parser->copline)
74 #define PL_bufptr (PL_parser->bufptr)
75 #define PL_oldbufptr (PL_parser->oldbufptr)
76 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
77 #define PL_linestart (PL_parser->linestart)
78 #define PL_bufend (PL_parser->bufend)
79 #define PL_last_uni (PL_parser->last_uni)
80 #define PL_last_lop (PL_parser->last_lop)
81 #define PL_last_lop_op (PL_parser->last_lop_op)
82 #define PL_lex_state (PL_parser->lex_state)
83 #define PL_rsfp (PL_parser->rsfp)
84 #define PL_rsfp_filters (PL_parser->rsfp_filters)
85 #define PL_in_my (PL_parser->in_my)
86 #define PL_in_my_stash (PL_parser->in_my_stash)
87 #define PL_tokenbuf (PL_parser->tokenbuf)
88 #define PL_multi_end (PL_parser->multi_end)
89 #define PL_error_count (PL_parser->error_count)
92 # define PL_endwhite (PL_parser->endwhite)
93 # define PL_faketokens (PL_parser->faketokens)
94 # define PL_lasttoke (PL_parser->lasttoke)
95 # define PL_nextwhite (PL_parser->nextwhite)
96 # define PL_realtokenstart (PL_parser->realtokenstart)
97 # define PL_skipwhite (PL_parser->skipwhite)
98 # define PL_thisclose (PL_parser->thisclose)
99 # define PL_thismad (PL_parser->thismad)
100 # define PL_thisopen (PL_parser->thisopen)
101 # define PL_thisstuff (PL_parser->thisstuff)
102 # define PL_thistoken (PL_parser->thistoken)
103 # define PL_thiswhite (PL_parser->thiswhite)
104 # define PL_thiswhite (PL_parser->thiswhite)
105 # define PL_nexttoke (PL_parser->nexttoke)
106 # define PL_curforce (PL_parser->curforce)
108 # define PL_nexttoke (PL_parser->nexttoke)
109 # define PL_nexttype (PL_parser->nexttype)
110 # define PL_nextval (PL_parser->nextval)
113 static const char* const ident_too_long = "Identifier too long";
116 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
117 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
119 # define CURMAD(slot,sv)
120 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
123 #define XENUMMASK 0x3f
124 #define XFAKEEOF 0x40
125 #define XFAKEBRACK 0x80
127 #ifdef USE_UTF8_SCRIPTS
128 # define UTF (!IN_BYTES)
130 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
133 /* The maximum number of characters preceding the unrecognized one to display */
134 #define UNRECOGNIZED_PRECEDE_COUNT 10
136 /* In variables named $^X, these are the legal values for X.
137 * 1999-02-27 mjd-perl-patch@plover.com */
138 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
140 #define SPACE_OR_TAB(c) isBLANK_A(c)
142 /* LEX_* are values for PL_lex_state, the state of the lexer.
143 * They are arranged oddly so that the guard on the switch statement
144 * can get by with a single comparison (if the compiler is smart enough).
146 * These values refer to the various states within a sublex parse,
147 * i.e. within a double quotish string
150 /* #define LEX_NOTPARSING 11 is done in perl.h. */
152 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
153 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
154 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
155 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
156 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
158 /* at end of code, eg "$x" followed by: */
159 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
160 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
162 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
163 string or after \E, $foo, etc */
164 #define LEX_INTERPCONST 2 /* NOT USED */
165 #define LEX_FORMLINE 1 /* expecting a format line */
166 #define LEX_KNOWNEXT 0 /* next token known; just return it */
170 static const char* const lex_state_names[] = {
189 #include "keywords.h"
191 /* CLINE is a macro that ensures PL_copline has a sane value */
196 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
199 # define SKIPSPACE0(s) skipspace0(s)
200 # define SKIPSPACE1(s) skipspace1(s)
201 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
202 # define PEEKSPACE(s) skipspace2(s,0)
204 # define SKIPSPACE0(s) skipspace(s)
205 # define SKIPSPACE1(s) skipspace(s)
206 # define SKIPSPACE2(s,tsv) skipspace(s)
207 # define PEEKSPACE(s) skipspace(s)
211 * Convenience functions to return different tokens and prime the
212 * lexer for the next token. They all take an argument.
214 * TOKEN : generic token (used for '(', DOLSHARP, etc)
215 * OPERATOR : generic operator
216 * AOPERATOR : assignment operator
217 * PREBLOCK : beginning the block after an if, while, foreach, ...
218 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
219 * PREREF : *EXPR where EXPR is not a simple identifier
220 * TERM : expression term
221 * LOOPX : loop exiting command (goto, last, dump, etc)
222 * FTST : file test operator
223 * FUN0 : zero-argument function
224 * FUN0OP : zero-argument function, with its op created in this file
225 * FUN1 : not used, except for not, which isn't a UNIOP
226 * BOop : bitwise or or xor
228 * SHop : shift operator
229 * PWop : power operator
230 * PMop : pattern-matching operator
231 * Aop : addition-level operator
232 * Mop : multiplication-level operator
233 * Eop : equality-testing operator
234 * Rop : relational operator <= != gt
236 * Also see LOP and lop() below.
239 #ifdef DEBUGGING /* Serve -DT. */
240 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
242 # define REPORT(retval) (retval)
245 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
246 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
247 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
248 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
249 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
250 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
251 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
252 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
253 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
254 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
255 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
256 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
257 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
258 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
259 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
260 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
261 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
262 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
263 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
264 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
265 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
267 /* This bit of chicanery makes a unary function followed by
268 * a parenthesis into a function with one argument, highest precedence.
269 * The UNIDOR macro is for unary functions that can be followed by the //
270 * operator (such as C<shift // 0>).
272 #define UNI3(f,x,have_x) { \
273 pl_yylval.ival = f; \
274 if (have_x) PL_expect = x; \
276 PL_last_uni = PL_oldbufptr; \
277 PL_last_lop_op = f; \
279 return REPORT( (int)FUNC1 ); \
281 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
283 #define UNI(f) UNI3(f,XTERM,1)
284 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
285 #define UNIPROTO(f,optional) { \
286 if (optional) PL_last_uni = PL_oldbufptr; \
290 #define UNIBRACK(f) UNI3(f,0,0)
292 /* grandfather return to old style */
295 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
296 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
297 pl_yylval.ival = (f); \
303 #define COPLINE_INC_WITH_HERELINES \
305 CopLINE_inc(PL_curcop); \
306 if (PL_parser->lex_shared->herelines) \
307 CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \
308 PL_parser->lex_shared->herelines = 0; \
314 /* how to interpret the pl_yylval associated with the token */
318 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
323 static struct debug_tokens {
325 enum token_type type;
327 } const debug_tokens[] =
329 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
330 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
331 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
332 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
333 { ARROW, TOKENTYPE_NONE, "ARROW" },
334 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
335 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
336 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
337 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
338 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
339 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
340 { DO, TOKENTYPE_NONE, "DO" },
341 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
342 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
343 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
344 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
345 { ELSE, TOKENTYPE_NONE, "ELSE" },
346 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
347 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
348 { FOR, TOKENTYPE_IVAL, "FOR" },
349 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
350 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
351 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
352 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
353 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
354 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
355 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
356 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
357 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
358 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
359 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
360 { IF, TOKENTYPE_IVAL, "IF" },
361 { LABEL, TOKENTYPE_PVAL, "LABEL" },
362 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
363 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
364 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
365 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
366 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
367 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
368 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
369 { MY, TOKENTYPE_IVAL, "MY" },
370 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
371 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
372 { OROP, TOKENTYPE_IVAL, "OROP" },
373 { OROR, TOKENTYPE_NONE, "OROR" },
374 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
375 { PEG, TOKENTYPE_NONE, "PEG" },
376 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
377 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
378 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
379 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
380 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
381 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
382 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
383 { PREINC, TOKENTYPE_NONE, "PREINC" },
384 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
385 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
386 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
387 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
388 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
389 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
390 { SUB, TOKENTYPE_NONE, "SUB" },
391 { THING, TOKENTYPE_OPVAL, "THING" },
392 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
393 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
394 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
395 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
396 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
397 { USE, TOKENTYPE_IVAL, "USE" },
398 { WHEN, TOKENTYPE_IVAL, "WHEN" },
399 { WHILE, TOKENTYPE_IVAL, "WHILE" },
400 { WORD, TOKENTYPE_OPVAL, "WORD" },
401 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
402 { 0, TOKENTYPE_NONE, NULL }
405 /* dump the returned token in rv, plus any optional arg in pl_yylval */
408 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
412 PERL_ARGS_ASSERT_TOKEREPORT;
415 const char *name = NULL;
416 enum token_type type = TOKENTYPE_NONE;
417 const struct debug_tokens *p;
418 SV* const report = newSVpvs("<== ");
420 for (p = debug_tokens; p->token; p++) {
421 if (p->token == (int)rv) {
428 Perl_sv_catpv(aTHX_ report, name);
429 else if ((char)rv > ' ' && (char)rv <= '~')
431 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
433 sv_catpvs(report, " (pending identifier)");
436 sv_catpvs(report, "EOF");
438 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
443 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
445 case TOKENTYPE_OPNUM:
446 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
447 PL_op_name[lvalp->ival]);
450 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
452 case TOKENTYPE_OPVAL:
454 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
455 PL_op_name[lvalp->opval->op_type]);
456 if (lvalp->opval->op_type == OP_CONST) {
457 Perl_sv_catpvf(aTHX_ report, " %s",
458 SvPEEK(cSVOPx_sv(lvalp->opval)));
463 sv_catpvs(report, "(opval=null)");
466 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
472 /* print the buffer with suitable escapes */
475 S_printbuf(pTHX_ const char *const fmt, const char *const s)
477 SV* const tmp = newSVpvs("");
479 PERL_ARGS_ASSERT_PRINTBUF;
481 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
488 S_deprecate_commaless_var_list(pTHX) {
490 deprecate("comma-less variable list");
491 return REPORT(','); /* grandfather non-comma-format format */
497 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
498 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
502 S_ao(pTHX_ int toketype)
505 if (*PL_bufptr == '=') {
507 if (toketype == ANDAND)
508 pl_yylval.ival = OP_ANDASSIGN;
509 else if (toketype == OROR)
510 pl_yylval.ival = OP_ORASSIGN;
511 else if (toketype == DORDOR)
512 pl_yylval.ival = OP_DORASSIGN;
520 * When Perl expects an operator and finds something else, no_op
521 * prints the warning. It always prints "<something> found where
522 * operator expected. It prints "Missing semicolon on previous line?"
523 * if the surprise occurs at the start of the line. "do you need to
524 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
525 * where the compiler doesn't know if foo is a method call or a function.
526 * It prints "Missing operator before end of line" if there's nothing
527 * after the missing operator, or "... before <...>" if there is something
528 * after the missing operator.
532 S_no_op(pTHX_ const char *const what, char *s)
535 char * const oldbp = PL_bufptr;
536 const bool is_first = (PL_oldbufptr == PL_linestart);
538 PERL_ARGS_ASSERT_NO_OP;
544 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
545 if (ckWARN_d(WARN_SYNTAX)) {
547 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
548 "\t(Missing semicolon on previous line?)\n");
549 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
551 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
552 t += UTF ? UTF8SKIP(t) : 1)
554 if (t < PL_bufptr && isSPACE(*t))
555 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
556 "\t(Do you need to predeclare %"SVf"?)\n",
557 SVfARG(newSVpvn_flags(PL_oldoldbufptr, (STRLEN)(t - PL_oldoldbufptr),
558 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
562 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
563 "\t(Missing operator before %"SVf"?)\n",
564 SVfARG(newSVpvn_flags(oldbp, (STRLEN)(s - oldbp),
565 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
573 * Complain about missing quote/regexp/heredoc terminator.
574 * If it's called with NULL then it cauterizes the line buffer.
575 * If we're in a delimited string and the delimiter is a control
576 * character, it's reformatted into a two-char sequence like ^C.
581 S_missingterm(pTHX_ char *s)
587 char * const nl = strrchr(s,'\n');
591 else if (isCNTRL(PL_multi_close)) {
593 tmpbuf[1] = (char)toCTRL(PL_multi_close);
598 *tmpbuf = (char)PL_multi_close;
602 q = strchr(s,'"') ? '\'' : '"';
603 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
609 * Check whether the named feature is enabled.
612 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
615 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
617 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
619 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
621 if (namelen > MAX_FEATURE_LEN)
623 memcpy(&he_name[8], name, namelen);
625 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
626 REFCOUNTED_HE_EXISTS));
630 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
631 * utf16-to-utf8-reversed.
634 #ifdef PERL_CR_FILTER
638 const char *s = SvPVX_const(sv);
639 const char * const e = s + SvCUR(sv);
641 PERL_ARGS_ASSERT_STRIP_RETURN;
643 /* outer loop optimized to do nothing if there are no CR-LFs */
645 if (*s++ == '\r' && *s == '\n') {
646 /* hit a CR-LF, need to copy the rest */
650 if (*s == '\r' && s[1] == '\n')
661 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
663 const I32 count = FILTER_READ(idx+1, sv, maxlen);
664 if (count > 0 && !maxlen)
671 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
673 Creates and initialises a new lexer/parser state object, supplying
674 a context in which to lex and parse from a new source of Perl code.
675 A pointer to the new state object is placed in L</PL_parser>. An entry
676 is made on the save stack so that upon unwinding the new state object
677 will be destroyed and the former value of L</PL_parser> will be restored.
678 Nothing else need be done to clean up the parsing context.
680 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
681 non-null, provides a string (in SV form) containing code to be parsed.
682 A copy of the string is made, so subsequent modification of I<line>
683 does not affect parsing. I<rsfp>, if non-null, provides an input stream
684 from which code will be read to be parsed. If both are non-null, the
685 code in I<line> comes first and must consist of complete lines of input,
686 and I<rsfp> supplies the remainder of the source.
688 The I<flags> parameter is reserved for future use. Currently it is only
689 used by perl internally, so extensions should always pass zero.
694 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
695 can share filters with the current parser.
696 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
697 caller, hence isn't owned by the parser, so shouldn't be closed on parser
698 destruction. This is used to handle the case of defaulting to reading the
699 script from the standard input because no filename was given on the command
700 line (without getting confused by situation where STDIN has been closed, so
701 the script handle is opened on fd 0) */
704 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
707 const char *s = NULL;
708 yy_parser *parser, *oparser;
709 if (flags && flags & ~LEX_START_FLAGS)
710 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
712 /* create and initialise a parser */
714 Newxz(parser, 1, yy_parser);
715 parser->old_parser = oparser = PL_parser;
718 parser->stack = NULL;
720 parser->stack_size = 0;
722 /* on scope exit, free this parser and restore any outer one */
724 parser->saved_curcop = PL_curcop;
726 /* initialise lexer state */
729 parser->curforce = -1;
731 parser->nexttoke = 0;
733 parser->error_count = oparser ? oparser->error_count : 0;
734 parser->copline = NOLINE;
735 parser->lex_state = LEX_NORMAL;
736 parser->expect = XSTATE;
738 parser->rsfp_filters =
739 !(flags & LEX_START_SAME_FILTER) || !oparser
741 : MUTABLE_AV(SvREFCNT_inc(
742 oparser->rsfp_filters
743 ? oparser->rsfp_filters
744 : (oparser->rsfp_filters = newAV())
747 Newx(parser->lex_brackstack, 120, char);
748 Newx(parser->lex_casestack, 12, char);
749 *parser->lex_casestack = '\0';
750 Newxz(parser->lex_shared, 1, LEXSHARED);
754 s = SvPV_const(line, len);
755 parser->linestr = flags & LEX_START_COPIED
756 ? SvREFCNT_inc_simple_NN(line)
757 : newSVpvn_flags(s, len, SvUTF8(line));
758 sv_catpvs(parser->linestr, "\n;");
760 parser->linestr = newSVpvs("\n;");
762 parser->oldoldbufptr =
765 parser->linestart = SvPVX(parser->linestr);
766 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
767 parser->last_lop = parser->last_uni = NULL;
768 parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
769 |LEX_DONT_CLOSE_RSFP);
771 parser->in_pod = parser->filtered = 0;
775 /* delete a parser object */
778 Perl_parser_free(pTHX_ const yy_parser *parser)
780 PERL_ARGS_ASSERT_PARSER_FREE;
782 PL_curcop = parser->saved_curcop;
783 SvREFCNT_dec(parser->linestr);
785 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
786 PerlIO_clearerr(parser->rsfp);
787 else if (parser->rsfp && (!parser->old_parser ||
788 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
789 PerlIO_close(parser->rsfp);
790 SvREFCNT_dec(parser->rsfp_filters);
791 SvREFCNT_dec(parser->lex_stuff);
792 SvREFCNT_dec(parser->sublex_info.repl);
794 Safefree(parser->lex_brackstack);
795 Safefree(parser->lex_casestack);
796 Safefree(parser->lex_shared);
797 PL_parser = parser->old_parser;
802 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
805 I32 nexttoke = parser->lasttoke;
807 I32 nexttoke = parser->nexttoke;
809 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
812 if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
814 && parser->nexttoke[nexttoke].next_val.opval
815 && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
816 && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
817 op_free(parser->nexttoke[nexttoke].next_val.opval);
818 parser->nexttoke[nexttoke].next_val.opval = NULL;
821 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
822 && parser->nextval[nexttoke].opval
823 && parser->nextval[nexttoke].opval->op_slabbed
824 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
825 op_free(parser->nextval[nexttoke].opval);
826 parser->nextval[nexttoke].opval = NULL;
834 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
836 Buffer scalar containing the chunk currently under consideration of the
837 text currently being lexed. This is always a plain string scalar (for
838 which C<SvPOK> is true). It is not intended to be used as a scalar by
839 normal scalar means; instead refer to the buffer directly by the pointer
840 variables described below.
842 The lexer maintains various C<char*> pointers to things in the
843 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
844 reallocated, all of these pointers must be updated. Don't attempt to
845 do this manually, but rather use L</lex_grow_linestr> if you need to
846 reallocate the buffer.
848 The content of the text chunk in the buffer is commonly exactly one
849 complete line of input, up to and including a newline terminator,
850 but there are situations where it is otherwise. The octets of the
851 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
852 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
853 flag on this scalar, which may disagree with it.
855 For direct examination of the buffer, the variable
856 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
857 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
858 of these pointers is usually preferable to examination of the scalar
859 through normal scalar means.
861 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
863 Direct pointer to the end of the chunk of text currently being lexed, the
864 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
865 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
866 always located at the end of the buffer, and does not count as part of
867 the buffer's contents.
869 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
871 Points to the current position of lexing inside the lexer buffer.
872 Characters around this point may be freely examined, within
873 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
874 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
875 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
877 Lexing code (whether in the Perl core or not) moves this pointer past
878 the characters that it consumes. It is also expected to perform some
879 bookkeeping whenever a newline character is consumed. This movement
880 can be more conveniently performed by the function L</lex_read_to>,
881 which handles newlines appropriately.
883 Interpretation of the buffer's octets can be abstracted out by
884 using the slightly higher-level functions L</lex_peek_unichar> and
885 L</lex_read_unichar>.
887 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
889 Points to the start of the current line inside the lexer buffer.
890 This is useful for indicating at which column an error occurred, and
891 not much else. This must be updated by any lexing code that consumes
892 a newline; the function L</lex_read_to> handles this detail.
898 =for apidoc Amx|bool|lex_bufutf8
900 Indicates whether the octets in the lexer buffer
901 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
902 of Unicode characters. If not, they should be interpreted as Latin-1
903 characters. This is analogous to the C<SvUTF8> flag for scalars.
905 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
906 contains valid UTF-8. Lexing code must be robust in the face of invalid
909 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
910 is significant, but not the whole story regarding the input character
911 encoding. Normally, when a file is being read, the scalar contains octets
912 and its C<SvUTF8> flag is off, but the octets should be interpreted as
913 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
914 however, the scalar may have the C<SvUTF8> flag on, and in this case its
915 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
916 is in effect. This logic may change in the future; use this function
917 instead of implementing the logic yourself.
923 Perl_lex_bufutf8(pTHX)
929 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
931 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
932 at least I<len> octets (including terminating NUL). Returns a
933 pointer to the reallocated buffer. This is necessary before making
934 any direct modification of the buffer that would increase its length.
935 L</lex_stuff_pvn> provides a more convenient way to insert text into
938 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
939 this function updates all of the lexer's variables that point directly
946 Perl_lex_grow_linestr(pTHX_ STRLEN len)
950 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
951 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
952 linestr = PL_parser->linestr;
953 buf = SvPVX(linestr);
954 if (len <= SvLEN(linestr))
956 bufend_pos = PL_parser->bufend - buf;
957 bufptr_pos = PL_parser->bufptr - buf;
958 oldbufptr_pos = PL_parser->oldbufptr - buf;
959 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
960 linestart_pos = PL_parser->linestart - buf;
961 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
962 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
963 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
964 PL_parser->lex_shared->re_eval_start - buf : 0;
966 buf = sv_grow(linestr, len);
968 PL_parser->bufend = buf + bufend_pos;
969 PL_parser->bufptr = buf + bufptr_pos;
970 PL_parser->oldbufptr = buf + oldbufptr_pos;
971 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
972 PL_parser->linestart = buf + linestart_pos;
973 if (PL_parser->last_uni)
974 PL_parser->last_uni = buf + last_uni_pos;
975 if (PL_parser->last_lop)
976 PL_parser->last_lop = buf + last_lop_pos;
977 if (PL_parser->lex_shared->re_eval_start)
978 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
983 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
985 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
986 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
987 reallocating the buffer if necessary. This means that lexing code that
988 runs later will see the characters as if they had appeared in the input.
989 It is not recommended to do this as part of normal parsing, and most
990 uses of this facility run the risk of the inserted characters being
991 interpreted in an unintended manner.
993 The string to be inserted is represented by I<len> octets starting
994 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
995 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
996 The characters are recoded for the lexer buffer, according to how the
997 buffer is currently being interpreted (L</lex_bufutf8>). If a string
998 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
999 function is more convenient.
1005 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1009 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1010 if (flags & ~(LEX_STUFF_UTF8))
1011 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1013 if (flags & LEX_STUFF_UTF8) {
1016 STRLEN highhalf = 0; /* Count of variants */
1017 const char *p, *e = pv+len;
1018 for (p = pv; p != e; p++) {
1019 if (! UTF8_IS_INVARIANT(*p)) {
1025 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1026 bufptr = PL_parser->bufptr;
1027 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1028 SvCUR_set(PL_parser->linestr,
1029 SvCUR(PL_parser->linestr) + len+highhalf);
1030 PL_parser->bufend += len+highhalf;
1031 for (p = pv; p != e; p++) {
1033 if (! UTF8_IS_INVARIANT(c)) {
1034 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1035 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1037 *bufptr++ = (char)c;
1042 if (flags & LEX_STUFF_UTF8) {
1043 STRLEN highhalf = 0;
1044 const char *p, *e = pv+len;
1045 for (p = pv; p != e; p++) {
1047 if (UTF8_IS_ABOVE_LATIN1(c)) {
1048 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1049 "non-Latin-1 character into Latin-1 input");
1050 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1053 } else if (! UTF8_IS_INVARIANT(c)) {
1054 /* malformed UTF-8 */
1056 SAVESPTR(PL_warnhook);
1057 PL_warnhook = PERL_WARNHOOK_FATAL;
1058 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
1064 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1065 bufptr = PL_parser->bufptr;
1066 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1067 SvCUR_set(PL_parser->linestr,
1068 SvCUR(PL_parser->linestr) + len-highhalf);
1069 PL_parser->bufend += len-highhalf;
1072 if (UTF8_IS_INVARIANT(*p)) {
1078 *bufptr++ = TWO_BYTE_UTF8_TO_UNI(*p, *(p+1));
1084 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1085 bufptr = PL_parser->bufptr;
1086 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1087 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1088 PL_parser->bufend += len;
1089 Copy(pv, bufptr, len, char);
1095 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1097 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1098 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1099 reallocating the buffer if necessary. This means that lexing code that
1100 runs later will see the characters as if they had appeared in the input.
1101 It is not recommended to do this as part of normal parsing, and most
1102 uses of this facility run the risk of the inserted characters being
1103 interpreted in an unintended manner.
1105 The string to be inserted is represented by octets starting at I<pv>
1106 and continuing to the first nul. These octets are interpreted as either
1107 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1108 in I<flags>. The characters are recoded for the lexer buffer, according
1109 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1110 If it is not convenient to nul-terminate a string to be inserted, the
1111 L</lex_stuff_pvn> function is more appropriate.
1117 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1119 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1120 lex_stuff_pvn(pv, strlen(pv), flags);
1124 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1126 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1127 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1128 reallocating the buffer if necessary. This means that lexing code that
1129 runs later will see the characters as if they had appeared in the input.
1130 It is not recommended to do this as part of normal parsing, and most
1131 uses of this facility run the risk of the inserted characters being
1132 interpreted in an unintended manner.
1134 The string to be inserted is the string value of I<sv>. The characters
1135 are recoded for the lexer buffer, according to how the buffer is currently
1136 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1137 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1138 need to construct a scalar.
1144 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1148 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1150 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1152 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1156 =for apidoc Amx|void|lex_unstuff|char *ptr
1158 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1159 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1160 This hides the discarded text from any lexing code that runs later,
1161 as if the text had never appeared.
1163 This is not the normal way to consume lexed text. For that, use
1170 Perl_lex_unstuff(pTHX_ char *ptr)
1174 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1175 buf = PL_parser->bufptr;
1177 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1180 bufend = PL_parser->bufend;
1182 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1183 unstuff_len = ptr - buf;
1184 Move(ptr, buf, bufend+1-ptr, char);
1185 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1186 PL_parser->bufend = bufend - unstuff_len;
1190 =for apidoc Amx|void|lex_read_to|char *ptr
1192 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1193 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1194 performing the correct bookkeeping whenever a newline character is passed.
1195 This is the normal way to consume lexed text.
1197 Interpretation of the buffer's octets can be abstracted out by
1198 using the slightly higher-level functions L</lex_peek_unichar> and
1199 L</lex_read_unichar>.
1205 Perl_lex_read_to(pTHX_ char *ptr)
1208 PERL_ARGS_ASSERT_LEX_READ_TO;
1209 s = PL_parser->bufptr;
1210 if (ptr < s || ptr > PL_parser->bufend)
1211 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1212 for (; s != ptr; s++)
1214 COPLINE_INC_WITH_HERELINES;
1215 PL_parser->linestart = s+1;
1217 PL_parser->bufptr = ptr;
1221 =for apidoc Amx|void|lex_discard_to|char *ptr
1223 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1224 up to I<ptr>. The remaining content of the buffer will be moved, and
1225 all pointers into the buffer updated appropriately. I<ptr> must not
1226 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1227 it is not permitted to discard text that has yet to be lexed.
1229 Normally it is not necessarily to do this directly, because it suffices to
1230 use the implicit discarding behaviour of L</lex_next_chunk> and things
1231 based on it. However, if a token stretches across multiple lines,
1232 and the lexing code has kept multiple lines of text in the buffer for
1233 that purpose, then after completion of the token it would be wise to
1234 explicitly discard the now-unneeded earlier lines, to avoid future
1235 multi-line tokens growing the buffer without bound.
1241 Perl_lex_discard_to(pTHX_ char *ptr)
1245 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1246 buf = SvPVX(PL_parser->linestr);
1248 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1251 if (ptr > PL_parser->bufptr)
1252 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1253 discard_len = ptr - buf;
1254 if (PL_parser->oldbufptr < ptr)
1255 PL_parser->oldbufptr = ptr;
1256 if (PL_parser->oldoldbufptr < ptr)
1257 PL_parser->oldoldbufptr = ptr;
1258 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1259 PL_parser->last_uni = NULL;
1260 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1261 PL_parser->last_lop = NULL;
1262 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1263 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1264 PL_parser->bufend -= discard_len;
1265 PL_parser->bufptr -= discard_len;
1266 PL_parser->oldbufptr -= discard_len;
1267 PL_parser->oldoldbufptr -= discard_len;
1268 if (PL_parser->last_uni)
1269 PL_parser->last_uni -= discard_len;
1270 if (PL_parser->last_lop)
1271 PL_parser->last_lop -= discard_len;
1275 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1277 Reads in the next chunk of text to be lexed, appending it to
1278 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1279 looked to the end of the current chunk and wants to know more. It is
1280 usual, but not necessary, for lexing to have consumed the entirety of
1281 the current chunk at this time.
1283 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1284 chunk (i.e., the current chunk has been entirely consumed), normally the
1285 current chunk will be discarded at the same time that the new chunk is
1286 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1287 will not be discarded. If the current chunk has not been entirely
1288 consumed, then it will not be discarded regardless of the flag.
1290 Returns true if some new text was added to the buffer, or false if the
1291 buffer has reached the end of the input text.
1296 #define LEX_FAKE_EOF 0x80000000
1297 #define LEX_NO_TERM 0x40000000
1300 Perl_lex_next_chunk(pTHX_ U32 flags)
1304 STRLEN old_bufend_pos, new_bufend_pos;
1305 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1306 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1307 bool got_some_for_debugger = 0;
1309 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1310 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1311 linestr = PL_parser->linestr;
1312 buf = SvPVX(linestr);
1313 if (!(flags & LEX_KEEP_PREVIOUS) &&
1314 PL_parser->bufptr == PL_parser->bufend) {
1315 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1317 if (PL_parser->last_uni != PL_parser->bufend)
1318 PL_parser->last_uni = NULL;
1319 if (PL_parser->last_lop != PL_parser->bufend)
1320 PL_parser->last_lop = NULL;
1321 last_uni_pos = last_lop_pos = 0;
1325 old_bufend_pos = PL_parser->bufend - buf;
1326 bufptr_pos = PL_parser->bufptr - buf;
1327 oldbufptr_pos = PL_parser->oldbufptr - buf;
1328 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1329 linestart_pos = PL_parser->linestart - buf;
1330 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1331 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1333 if (flags & LEX_FAKE_EOF) {
1335 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1337 } else if (filter_gets(linestr, old_bufend_pos)) {
1339 got_some_for_debugger = 1;
1340 } else if (flags & LEX_NO_TERM) {
1343 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1344 sv_setpvs(linestr, "");
1346 /* End of real input. Close filehandle (unless it was STDIN),
1347 * then add implicit termination.
1349 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1350 PerlIO_clearerr(PL_parser->rsfp);
1351 else if (PL_parser->rsfp)
1352 (void)PerlIO_close(PL_parser->rsfp);
1353 PL_parser->rsfp = NULL;
1354 PL_parser->in_pod = PL_parser->filtered = 0;
1356 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1359 if (!PL_in_eval && PL_minus_p) {
1361 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1362 PL_minus_n = PL_minus_p = 0;
1363 } else if (!PL_in_eval && PL_minus_n) {
1364 sv_catpvs(linestr, /*{*/";}");
1367 sv_catpvs(linestr, ";");
1370 buf = SvPVX(linestr);
1371 new_bufend_pos = SvCUR(linestr);
1372 PL_parser->bufend = buf + new_bufend_pos;
1373 PL_parser->bufptr = buf + bufptr_pos;
1374 PL_parser->oldbufptr = buf + oldbufptr_pos;
1375 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1376 PL_parser->linestart = buf + linestart_pos;
1377 if (PL_parser->last_uni)
1378 PL_parser->last_uni = buf + last_uni_pos;
1379 if (PL_parser->last_lop)
1380 PL_parser->last_lop = buf + last_lop_pos;
1381 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1382 PL_curstash != PL_debstash) {
1383 /* debugger active and we're not compiling the debugger code,
1384 * so store the line into the debugger's array of lines
1386 update_debugger_info(NULL, buf+old_bufend_pos,
1387 new_bufend_pos-old_bufend_pos);
1393 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1395 Looks ahead one (Unicode) character in the text currently being lexed.
1396 Returns the codepoint (unsigned integer value) of the next character,
1397 or -1 if lexing has reached the end of the input text. To consume the
1398 peeked character, use L</lex_read_unichar>.
1400 If the next character is in (or extends into) the next chunk of input
1401 text, the next chunk will be read in. Normally the current chunk will be
1402 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1403 then the current chunk will not be discarded.
1405 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1406 is encountered, an exception is generated.
1412 Perl_lex_peek_unichar(pTHX_ U32 flags)
1416 if (flags & ~(LEX_KEEP_PREVIOUS))
1417 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1418 s = PL_parser->bufptr;
1419 bufend = PL_parser->bufend;
1425 if (!lex_next_chunk(flags))
1427 s = PL_parser->bufptr;
1428 bufend = PL_parser->bufend;
1431 if (UTF8_IS_INVARIANT(head))
1433 if (UTF8_IS_START(head)) {
1434 len = UTF8SKIP(&head);
1435 while ((STRLEN)(bufend-s) < len) {
1436 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1438 s = PL_parser->bufptr;
1439 bufend = PL_parser->bufend;
1442 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1443 if (retlen == (STRLEN)-1) {
1444 /* malformed UTF-8 */
1446 SAVESPTR(PL_warnhook);
1447 PL_warnhook = PERL_WARNHOOK_FATAL;
1448 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1454 if (!lex_next_chunk(flags))
1456 s = PL_parser->bufptr;
1463 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1465 Reads the next (Unicode) character in the text currently being lexed.
1466 Returns the codepoint (unsigned integer value) of the character read,
1467 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1468 if lexing has reached the end of the input text. To non-destructively
1469 examine the next character, use L</lex_peek_unichar> instead.
1471 If the next character is in (or extends into) the next chunk of input
1472 text, the next chunk will be read in. Normally the current chunk will be
1473 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1474 then the current chunk will not be discarded.
1476 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1477 is encountered, an exception is generated.
1483 Perl_lex_read_unichar(pTHX_ U32 flags)
1486 if (flags & ~(LEX_KEEP_PREVIOUS))
1487 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1488 c = lex_peek_unichar(flags);
1491 COPLINE_INC_WITH_HERELINES;
1493 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1495 ++(PL_parser->bufptr);
1501 =for apidoc Amx|void|lex_read_space|U32 flags
1503 Reads optional spaces, in Perl style, in the text currently being
1504 lexed. The spaces may include ordinary whitespace characters and
1505 Perl-style comments. C<#line> directives are processed if encountered.
1506 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1507 at a non-space character (or the end of the input text).
1509 If spaces extend into the next chunk of input text, the next chunk will
1510 be read in. Normally the current chunk will be discarded at the same
1511 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1512 chunk will not be discarded.
1517 #define LEX_NO_NEXT_CHUNK 0x80000000
1520 Perl_lex_read_space(pTHX_ U32 flags)
1523 bool need_incline = 0;
1524 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
1525 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1528 sv_free(PL_skipwhite);
1529 PL_skipwhite = NULL;
1532 PL_skipwhite = newSVpvs("");
1533 #endif /* PERL_MAD */
1534 s = PL_parser->bufptr;
1535 bufend = PL_parser->bufend;
1541 } while (!(c == '\n' || (c == 0 && s == bufend)));
1542 } else if (c == '\n') {
1544 PL_parser->linestart = s;
1549 } else if (isSPACE(c)) {
1551 } else if (c == 0 && s == bufend) {
1555 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1556 #endif /* PERL_MAD */
1557 if (flags & LEX_NO_NEXT_CHUNK)
1559 PL_parser->bufptr = s;
1560 COPLINE_INC_WITH_HERELINES;
1561 got_more = lex_next_chunk(flags);
1562 CopLINE_dec(PL_curcop);
1563 s = PL_parser->bufptr;
1564 bufend = PL_parser->bufend;
1567 if (need_incline && PL_parser->rsfp) {
1577 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1578 #endif /* PERL_MAD */
1579 PL_parser->bufptr = s;
1584 * This subroutine has nothing to do with tilting, whether at windmills
1585 * or pinball tables. Its name is short for "increment line". It
1586 * increments the current line number in CopLINE(PL_curcop) and checks
1587 * to see whether the line starts with a comment of the form
1588 * # line 500 "foo.pm"
1589 * If so, it sets the current line number and file to the values in the comment.
1593 S_incline(pTHX_ const char *s)
1601 PERL_ARGS_ASSERT_INCLINE;
1603 COPLINE_INC_WITH_HERELINES;
1604 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1605 && s+1 == PL_bufend && *s == ';') {
1606 /* fake newline in string eval */
1607 CopLINE_dec(PL_curcop);
1612 while (SPACE_OR_TAB(*s))
1614 if (strnEQ(s, "line", 4))
1618 if (SPACE_OR_TAB(*s))
1622 while (SPACE_OR_TAB(*s))
1630 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1632 while (SPACE_OR_TAB(*s))
1634 if (*s == '"' && (t = strchr(s+1, '"'))) {
1640 while (!isSPACE(*t))
1644 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1646 if (*e != '\n' && *e != '\0')
1647 return; /* false alarm */
1649 line_num = atoi(n)-1;
1652 const STRLEN len = t - s;
1653 SV *const temp_sv = CopFILESV(PL_curcop);
1658 cf = SvPVX(temp_sv);
1659 tmplen = SvCUR(temp_sv);
1665 if (!PL_rsfp && !PL_parser->filtered) {
1666 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1667 * to *{"::_<newfilename"} */
1668 /* However, the long form of evals is only turned on by the
1669 debugger - usually they're "(eval %lu)" */
1673 STRLEN tmplen2 = len;
1674 if (tmplen + 2 <= sizeof smallbuf)
1677 Newx(tmpbuf, tmplen + 2, char);
1680 memcpy(tmpbuf + 2, cf, tmplen);
1682 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1687 if (tmplen2 + 2 <= sizeof smallbuf)
1690 Newx(tmpbuf2, tmplen2 + 2, char);
1692 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1693 /* Either they malloc'd it, or we malloc'd it,
1694 so no prefix is present in ours. */
1699 memcpy(tmpbuf2 + 2, s, tmplen2);
1702 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1704 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1705 /* adjust ${"::_<newfilename"} to store the new file name */
1706 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1707 /* The line number may differ. If that is the case,
1708 alias the saved lines that are in the array.
1709 Otherwise alias the whole array. */
1710 if (CopLINE(PL_curcop) == line_num) {
1711 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1712 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1714 else if (GvAV(*gvp)) {
1715 AV * const av = GvAV(*gvp);
1716 const I32 start = CopLINE(PL_curcop)+1;
1717 I32 items = AvFILLp(av) - start;
1719 AV * const av2 = GvAVn(gv2);
1720 SV **svp = AvARRAY(av) + start;
1721 I32 l = (I32)line_num+1;
1723 av_store(av2, l++, SvREFCNT_inc(*svp++));
1728 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1730 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1732 CopFILE_free(PL_curcop);
1733 CopFILE_setn(PL_curcop, s, len);
1735 CopLINE_set(PL_curcop, line_num);
1739 /* skip space before PL_thistoken */
1742 S_skipspace0(pTHX_ char *s)
1744 PERL_ARGS_ASSERT_SKIPSPACE0;
1751 PL_thiswhite = newSVpvs("");
1752 sv_catsv(PL_thiswhite, PL_skipwhite);
1753 sv_free(PL_skipwhite);
1756 PL_realtokenstart = s - SvPVX(PL_linestr);
1760 /* skip space after PL_thistoken */
1763 S_skipspace1(pTHX_ char *s)
1765 const char *start = s;
1766 I32 startoff = start - SvPVX(PL_linestr);
1768 PERL_ARGS_ASSERT_SKIPSPACE1;
1773 start = SvPVX(PL_linestr) + startoff;
1774 if (!PL_thistoken && PL_realtokenstart >= 0) {
1775 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1776 PL_thistoken = newSVpvn(tstart, start - tstart);
1778 PL_realtokenstart = -1;
1781 PL_nextwhite = newSVpvs("");
1782 sv_catsv(PL_nextwhite, PL_skipwhite);
1783 sv_free(PL_skipwhite);
1790 S_skipspace2(pTHX_ char *s, SV **svp)
1793 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1794 const I32 startoff = s - SvPVX(PL_linestr);
1796 PERL_ARGS_ASSERT_SKIPSPACE2;
1799 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1800 if (!PL_madskills || !svp)
1802 start = SvPVX(PL_linestr) + startoff;
1803 if (!PL_thistoken && PL_realtokenstart >= 0) {
1804 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1805 PL_thistoken = newSVpvn(tstart, start - tstart);
1806 PL_realtokenstart = -1;
1810 *svp = newSVpvs("");
1811 sv_setsv(*svp, PL_skipwhite);
1812 sv_free(PL_skipwhite);
1821 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1823 AV *av = CopFILEAVx(PL_curcop);
1825 SV * const sv = newSV_type(SVt_PVMG);
1827 sv_setsv(sv, orig_sv);
1829 sv_setpvn(sv, buf, len);
1832 av_store(av, (I32)CopLINE(PL_curcop), sv);
1838 * Called to gobble the appropriate amount and type of whitespace.
1839 * Skips comments as well.
1843 S_skipspace(pTHX_ char *s)
1847 #endif /* PERL_MAD */
1848 PERL_ARGS_ASSERT_SKIPSPACE;
1851 sv_free(PL_skipwhite);
1852 PL_skipwhite = NULL;
1854 #endif /* PERL_MAD */
1855 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1856 while (s < PL_bufend && SPACE_OR_TAB(*s))
1859 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1861 lex_read_space(LEX_KEEP_PREVIOUS |
1862 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1863 LEX_NO_NEXT_CHUNK : 0));
1865 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1866 if (PL_linestart > PL_bufptr)
1867 PL_bufptr = PL_linestart;
1872 PL_skipwhite = newSVpvn(start, s-start);
1873 #endif /* PERL_MAD */
1879 * Check the unary operators to ensure there's no ambiguity in how they're
1880 * used. An ambiguous piece of code would be:
1882 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1883 * the +5 is its argument.
1893 if (PL_oldoldbufptr != PL_last_uni)
1895 while (isSPACE(*PL_last_uni))
1898 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1900 if ((t = strchr(s, '(')) && t < PL_bufptr)
1903 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1904 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1905 (int)(s - PL_last_uni), PL_last_uni);
1909 * LOP : macro to build a list operator. Its behaviour has been replaced
1910 * with a subroutine, S_lop() for which LOP is just another name.
1913 #define LOP(f,x) return lop(f,x,s)
1917 * Build a list operator (or something that might be one). The rules:
1918 * - if we have a next token, then it's a list operator [why?]
1919 * - if the next thing is an opening paren, then it's a function
1920 * - else it's a list operator
1924 S_lop(pTHX_ I32 f, int x, char *s)
1928 PERL_ARGS_ASSERT_LOP;
1934 PL_last_lop = PL_oldbufptr;
1935 PL_last_lop_op = (OPCODE)f;
1944 return REPORT(FUNC);
1947 return REPORT(FUNC);
1950 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1951 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1952 return REPORT(LSTOP);
1959 * Sets up for an eventual force_next(). start_force(0) basically does
1960 * an unshift, while start_force(-1) does a push. yylex removes items
1965 S_start_force(pTHX_ int where)
1969 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1970 where = PL_lasttoke;
1971 assert(PL_curforce < 0 || PL_curforce == where);
1972 if (PL_curforce != where) {
1973 for (i = PL_lasttoke; i > where; --i) {
1974 PL_nexttoke[i] = PL_nexttoke[i-1];
1978 if (PL_curforce < 0) /* in case of duplicate start_force() */
1979 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1980 PL_curforce = where;
1983 curmad('^', newSVpvs(""));
1984 CURMAD('_', PL_nextwhite);
1989 S_curmad(pTHX_ char slot, SV *sv)
1995 if (PL_curforce < 0)
1996 where = &PL_thismad;
1998 where = &PL_nexttoke[PL_curforce].next_mad;
2004 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2006 else if (PL_encoding) {
2007 sv_recode_to_utf8(sv, PL_encoding);
2012 /* keep a slot open for the head of the list? */
2013 if (slot != '_' && *where && (*where)->mad_key == '^') {
2014 (*where)->mad_key = slot;
2015 sv_free(MUTABLE_SV(((*where)->mad_val)));
2016 (*where)->mad_val = (void*)sv;
2019 addmad(newMADsv(slot, sv), where, 0);
2022 # define start_force(where) NOOP
2023 # define curmad(slot, sv) NOOP
2028 * When the lexer realizes it knows the next token (for instance,
2029 * it is reordering tokens for the parser) then it can call S_force_next
2030 * to know what token to return the next time the lexer is called. Caller
2031 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2032 * and possibly PL_expect to ensure the lexer handles the token correctly.
2036 S_force_next(pTHX_ I32 type)
2041 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2042 tokereport(type, &NEXTVAL_NEXTTOKE);
2046 if (PL_curforce < 0)
2047 start_force(PL_lasttoke);
2048 PL_nexttoke[PL_curforce].next_type = type;
2049 if (PL_lex_state != LEX_KNOWNEXT)
2050 PL_lex_defer = PL_lex_state;
2051 PL_lex_state = LEX_KNOWNEXT;
2052 PL_lex_expect = PL_expect;
2055 PL_nexttype[PL_nexttoke] = type;
2057 if (PL_lex_state != LEX_KNOWNEXT) {
2058 PL_lex_defer = PL_lex_state;
2059 PL_lex_expect = PL_expect;
2060 PL_lex_state = LEX_KNOWNEXT;
2068 int yyc = PL_parser->yychar;
2069 if (yyc != YYEMPTY) {
2072 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2073 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2074 PL_lex_allbrackets--;
2076 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2077 } else if (yyc == '('/*)*/) {
2078 PL_lex_allbrackets--;
2083 PL_parser->yychar = YYEMPTY;
2088 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2091 SV * const sv = newSVpvn_utf8(start, len,
2094 && !is_ascii_string((const U8*)start, len)
2095 && is_utf8_string((const U8*)start, len));
2101 * When the lexer knows the next thing is a word (for instance, it has
2102 * just seen -> and it knows that the next char is a word char, then
2103 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2107 * char *start : buffer position (must be within PL_linestr)
2108 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2109 * int check_keyword : if true, Perl checks to make sure the word isn't
2110 * a keyword (do this if the word is a label, e.g. goto FOO)
2111 * int allow_pack : if true, : characters will also be allowed (require,
2112 * use, etc. do this)
2113 * int allow_initial_tick : used by the "sub" lexer only.
2117 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2123 PERL_ARGS_ASSERT_FORCE_WORD;
2125 start = SKIPSPACE1(start);
2127 if (isIDFIRST_lazy_if(s,UTF) ||
2128 (allow_pack && *s == ':') )
2130 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2131 if (check_keyword) {
2132 char *s2 = PL_tokenbuf;
2133 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2135 if (keyword(s2, len, 0))
2138 start_force(PL_curforce);
2140 curmad('X', newSVpvn(start,s-start));
2141 if (token == METHOD) {
2146 PL_expect = XOPERATOR;
2150 curmad('g', newSVpvs( "forced" ));
2151 NEXTVAL_NEXTTOKE.opval
2152 = (OP*)newSVOP(OP_CONST,0,
2153 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2154 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2162 * Called when the lexer wants $foo *foo &foo etc, but the program
2163 * text only contains the "foo" portion. The first argument is a pointer
2164 * to the "foo", and the second argument is the type symbol to prefix.
2165 * Forces the next token to be a "WORD".
2166 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2170 S_force_ident(pTHX_ const char *s, int kind)
2174 PERL_ARGS_ASSERT_FORCE_IDENT;
2177 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2178 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2179 UTF ? SVf_UTF8 : 0));
2180 start_force(PL_curforce);
2181 NEXTVAL_NEXTTOKE.opval = o;
2184 o->op_private = OPpCONST_ENTERED;
2185 /* XXX see note in pp_entereval() for why we forgo typo
2186 warnings if the symbol must be introduced in an eval.
2188 gv_fetchpvn_flags(s, len,
2189 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2190 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2191 kind == '$' ? SVt_PV :
2192 kind == '@' ? SVt_PVAV :
2193 kind == '%' ? SVt_PVHV :
2201 S_force_ident_maybe_lex(pTHX_ char pit)
2203 start_force(PL_curforce);
2204 NEXTVAL_NEXTTOKE.ival = pit;
2209 Perl_str_to_version(pTHX_ SV *sv)
2214 const char *start = SvPV_const(sv,len);
2215 const char * const end = start + len;
2216 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2218 PERL_ARGS_ASSERT_STR_TO_VERSION;
2220 while (start < end) {
2224 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2229 retval += ((NV)n)/nshift;
2238 * Forces the next token to be a version number.
2239 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2240 * and if "guessing" is TRUE, then no new token is created (and the caller
2241 * must use an alternative parsing method).
2245 S_force_version(pTHX_ char *s, int guessing)
2251 I32 startoff = s - SvPVX(PL_linestr);
2254 PERL_ARGS_ASSERT_FORCE_VERSION;
2262 while (isDIGIT(*d) || *d == '_' || *d == '.')
2266 start_force(PL_curforce);
2267 curmad('X', newSVpvn(s,d-s));
2270 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2272 #ifdef USE_LOCALE_NUMERIC
2273 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2274 setlocale(LC_NUMERIC, "C");
2276 s = scan_num(s, &pl_yylval);
2277 #ifdef USE_LOCALE_NUMERIC
2278 setlocale(LC_NUMERIC, loc);
2281 version = pl_yylval.opval;
2282 ver = cSVOPx(version)->op_sv;
2283 if (SvPOK(ver) && !SvNIOK(ver)) {
2284 SvUPGRADE(ver, SVt_PVNV);
2285 SvNV_set(ver, str_to_version(ver));
2286 SvNOK_on(ver); /* hint that it is a version */
2289 else if (guessing) {
2292 sv_free(PL_nextwhite); /* let next token collect whitespace */
2294 s = SvPVX(PL_linestr) + startoff;
2302 if (PL_madskills && !version) {
2303 sv_free(PL_nextwhite); /* let next token collect whitespace */
2305 s = SvPVX(PL_linestr) + startoff;
2308 /* NOTE: The parser sees the package name and the VERSION swapped */
2309 start_force(PL_curforce);
2310 NEXTVAL_NEXTTOKE.opval = version;
2317 * S_force_strict_version
2318 * Forces the next token to be a version number using strict syntax rules.
2322 S_force_strict_version(pTHX_ char *s)
2327 I32 startoff = s - SvPVX(PL_linestr);
2329 const char *errstr = NULL;
2331 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2333 while (isSPACE(*s)) /* leading whitespace */
2336 if (is_STRICT_VERSION(s,&errstr)) {
2338 s = (char *)scan_version(s, ver, 0);
2339 version = newSVOP(OP_CONST, 0, ver);
2341 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2342 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2346 yyerror(errstr); /* version required */
2351 if (PL_madskills && !version) {
2352 sv_free(PL_nextwhite); /* let next token collect whitespace */
2354 s = SvPVX(PL_linestr) + startoff;
2357 /* NOTE: The parser sees the package name and the VERSION swapped */
2358 start_force(PL_curforce);
2359 NEXTVAL_NEXTTOKE.opval = version;
2367 * Tokenize a quoted string passed in as an SV. It finds the next
2368 * chunk, up to end of string or a backslash. It may make a new
2369 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2374 S_tokeq(pTHX_ SV *sv)
2383 PERL_ARGS_ASSERT_TOKEQ;
2388 s = SvPV_force(sv, len);
2389 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2392 /* This is relying on the SV being "well formed" with a trailing '\0' */
2393 while (s < send && !(*s == '\\' && s[1] == '\\'))
2398 if ( PL_hints & HINT_NEW_STRING ) {
2399 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2403 if (s + 1 < send && (s[1] == '\\'))
2404 s++; /* all that, just for this */
2409 SvCUR_set(sv, d - SvPVX_const(sv));
2411 if ( PL_hints & HINT_NEW_STRING )
2412 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2417 * Now come three functions related to double-quote context,
2418 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2419 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2420 * interact with PL_lex_state, and create fake ( ... ) argument lists
2421 * to handle functions and concatenation.
2425 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2430 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2432 * Pattern matching will set PL_lex_op to the pattern-matching op to
2433 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2435 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2437 * Everything else becomes a FUNC.
2439 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2440 * had an OP_CONST or OP_READLINE). This just sets us up for a
2441 * call to S_sublex_push().
2445 S_sublex_start(pTHX)
2448 const I32 op_type = pl_yylval.ival;
2450 if (op_type == OP_NULL) {
2451 pl_yylval.opval = PL_lex_op;
2455 if (op_type == OP_CONST || op_type == OP_READLINE) {
2456 SV *sv = tokeq(PL_lex_stuff);
2458 if (SvTYPE(sv) == SVt_PVIV) {
2459 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2461 const char * const p = SvPV_const(sv, len);
2462 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2466 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2467 PL_lex_stuff = NULL;
2468 /* Allow <FH> // "foo" */
2469 if (op_type == OP_READLINE)
2470 PL_expect = XTERMORDORDOR;
2473 else if (op_type == OP_BACKTICK && PL_lex_op) {
2474 /* readpipe() vas overriden */
2475 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2476 pl_yylval.opval = PL_lex_op;
2478 PL_lex_stuff = NULL;
2482 PL_sublex_info.super_state = PL_lex_state;
2483 PL_sublex_info.sub_inwhat = (U16)op_type;
2484 PL_sublex_info.sub_op = PL_lex_op;
2485 PL_lex_state = LEX_INTERPPUSH;
2489 pl_yylval.opval = PL_lex_op;
2499 * Create a new scope to save the lexing state. The scope will be
2500 * ended in S_sublex_done. Returns a '(', starting the function arguments
2501 * to the uc, lc, etc. found before.
2502 * Sets PL_lex_state to LEX_INTERPCONCAT.
2512 PL_lex_state = PL_sublex_info.super_state;
2513 SAVEBOOL(PL_lex_dojoin);
2514 SAVEI32(PL_lex_brackets);
2515 SAVEI32(PL_lex_allbrackets);
2516 SAVEI32(PL_lex_formbrack);
2517 SAVEI8(PL_lex_fakeeof);
2518 SAVEI32(PL_lex_casemods);
2519 SAVEI32(PL_lex_starts);
2520 SAVEI8(PL_lex_state);
2521 SAVESPTR(PL_lex_repl);
2522 SAVEVPTR(PL_lex_inpat);
2523 SAVEI16(PL_lex_inwhat);
2524 SAVECOPLINE(PL_curcop);
2525 SAVEPPTR(PL_bufptr);
2526 SAVEPPTR(PL_bufend);
2527 SAVEPPTR(PL_oldbufptr);
2528 SAVEPPTR(PL_oldoldbufptr);
2529 SAVEPPTR(PL_last_lop);
2530 SAVEPPTR(PL_last_uni);
2531 SAVEPPTR(PL_linestart);
2532 SAVESPTR(PL_linestr);
2533 SAVEGENERICPV(PL_lex_brackstack);
2534 SAVEGENERICPV(PL_lex_casestack);
2535 SAVEGENERICPV(PL_parser->lex_shared);
2536 SAVEBOOL(PL_parser->lex_re_reparsing);
2538 /* The here-doc parser needs to be able to peek into outer lexing
2539 scopes to find the body of the here-doc. So we put PL_linestr and
2540 PL_bufptr into lex_shared, to ‘share’ those values.
2542 PL_parser->lex_shared->ls_linestr = PL_linestr;
2543 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2545 PL_linestr = PL_lex_stuff;
2546 PL_lex_repl = PL_sublex_info.repl;
2547 PL_lex_stuff = NULL;
2548 PL_sublex_info.repl = NULL;
2550 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2551 = SvPVX(PL_linestr);
2552 PL_bufend += SvCUR(PL_linestr);
2553 PL_last_lop = PL_last_uni = NULL;
2554 SAVEFREESV(PL_linestr);
2555 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2557 PL_lex_dojoin = FALSE;
2558 PL_lex_brackets = PL_lex_formbrack = 0;
2559 PL_lex_allbrackets = 0;
2560 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2561 Newx(PL_lex_brackstack, 120, char);
2562 Newx(PL_lex_casestack, 12, char);
2563 PL_lex_casemods = 0;
2564 *PL_lex_casestack = '\0';
2566 PL_lex_state = LEX_INTERPCONCAT;
2567 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2569 Newxz(shared, 1, LEXSHARED);
2570 shared->ls_prev = PL_parser->lex_shared;
2571 PL_parser->lex_shared = shared;
2573 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2574 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2575 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2576 PL_lex_inpat = PL_sublex_info.sub_op;
2578 PL_lex_inpat = NULL;
2580 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2581 PL_in_eval &= ~EVAL_RE_REPARSING;
2588 * Restores lexer state after a S_sublex_push.
2595 if (!PL_lex_starts++) {
2596 SV * const sv = newSVpvs("");
2597 if (SvUTF8(PL_linestr))
2599 PL_expect = XOPERATOR;
2600 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2604 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2605 PL_lex_state = LEX_INTERPCASEMOD;
2609 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2610 assert(PL_lex_inwhat != OP_TRANSR);
2611 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2612 PL_linestr = PL_lex_repl;
2614 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2615 PL_bufend += SvCUR(PL_linestr);
2616 PL_last_lop = PL_last_uni = NULL;
2617 PL_lex_dojoin = FALSE;
2618 PL_lex_brackets = 0;
2619 PL_lex_allbrackets = 0;
2620 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2621 PL_lex_casemods = 0;
2622 *PL_lex_casestack = '\0';
2624 if (SvEVALED(PL_lex_repl)) {
2625 PL_lex_state = LEX_INTERPNORMAL;
2627 /* we don't clear PL_lex_repl here, so that we can check later
2628 whether this is an evalled subst; that means we rely on the
2629 logic to ensure sublex_done() is called again only via the
2630 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2633 PL_lex_state = LEX_INTERPCONCAT;
2643 PL_endwhite = newSVpvs("");
2644 sv_catsv(PL_endwhite, PL_thiswhite);
2648 sv_setpvs(PL_thistoken,"");
2650 PL_realtokenstart = -1;
2654 PL_bufend = SvPVX(PL_linestr);
2655 PL_bufend += SvCUR(PL_linestr);
2656 PL_expect = XOPERATOR;
2657 PL_sublex_info.sub_inwhat = 0;
2662 PERL_STATIC_INLINE SV*
2663 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2665 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2666 * interior, hence to the "}". Finds what the name resolves to, returning
2667 * an SV* containing it; NULL if no valid one found */
2669 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2676 const U8* first_bad_char_loc;
2677 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2679 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2681 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2683 &first_bad_char_loc))
2685 /* If warnings are on, this will print a more detailed analysis of what
2686 * is wrong than the error message below */
2687 utf8n_to_uvuni(first_bad_char_loc,
2688 e - ((char *) first_bad_char_loc),
2691 /* We deliberately don't try to print the malformed character, which
2692 * might not print very well; it also may be just the first of many
2693 * malformations, so don't print what comes after it */
2694 yyerror(Perl_form(aTHX_
2695 "Malformed UTF-8 character immediately after '%.*s'",
2696 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2700 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2701 /* include the <}> */
2702 e - backslash_ptr + 1);
2704 SvREFCNT_dec_NN(res);
2708 /* See if the charnames handler is the Perl core's, and if so, we can skip
2709 * the validation needed for a user-supplied one, as Perl's does its own
2711 table = GvHV(PL_hintgv); /* ^H */
2712 cvp = hv_fetchs(table, "charnames", FALSE);
2713 if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
2714 && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
2716 const char * const name = HvNAME(stash);
2717 if strEQ(name, "_charnames") {
2722 /* Here, it isn't Perl's charname handler. We can't rely on a
2723 * user-supplied handler to validate the input name. For non-ut8 input,
2724 * look to see that the first character is legal. Then loop through the
2725 * rest checking that each is a continuation */
2727 /* This code needs to be sync'ed with a regex in _charnames.pm which does
2731 if (! isALPHAU(*s)) {
2736 if (! isCHARNAME_CONT(*s)) {
2739 if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2740 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2741 "A sequence of multiple spaces in a charnames "
2742 "alias definition is deprecated");
2746 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2747 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2748 "Trailing white-space in a charnames alias "
2749 "definition is deprecated");
2753 /* Similarly for utf8. For invariants can check directly; for other
2754 * Latin1, can calculate their code point and check; otherwise use a
2756 if (UTF8_IS_INVARIANT(*s)) {
2757 if (! isALPHAU(*s)) {
2761 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2762 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
2768 if (! PL_utf8_charname_begin) {
2769 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2770 PL_utf8_charname_begin = _core_swash_init("utf8",
2771 "_Perl_Charname_Begin",
2773 1, 0, NULL, &flags);
2775 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2782 if (UTF8_IS_INVARIANT(*s)) {
2783 if (! isCHARNAME_CONT(*s)) {
2786 if (*s == ' ' && *(s-1) == ' '
2787 && ckWARN_d(WARN_DEPRECATED)) {
2788 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2789 "A sequence of multiple spaces in a charnam"
2790 "es alias definition is deprecated");
2794 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2795 if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
2803 if (! PL_utf8_charname_continue) {
2804 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2805 PL_utf8_charname_continue = _core_swash_init("utf8",
2806 "_Perl_Charname_Continue",
2808 1, 0, NULL, &flags);
2810 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2816 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2817 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2818 "Trailing white-space in a charnames alias "
2819 "definition is deprecated");
2823 if (SvUTF8(res)) { /* Don't accept malformed input */
2824 const U8* first_bad_char_loc;
2826 const char* const str = SvPV_const(res, len);
2827 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2828 /* If warnings are on, this will print a more detailed analysis of
2829 * what is wrong than the error message below */
2830 utf8n_to_uvuni(first_bad_char_loc,
2831 (char *) first_bad_char_loc - str,
2834 /* We deliberately don't try to print the malformed character,
2835 * which might not print very well; it also may be just the first
2836 * of many malformations, so don't print what comes after it */
2839 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2840 (int) (e - backslash_ptr + 1), backslash_ptr,
2841 (int) ((char *) first_bad_char_loc - str), str
2851 int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
2853 /* The final %.*s makes sure that should the trailing NUL be missing
2854 * that this print won't run off the end of the string */
2857 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2858 (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2859 (int)(e - s + bad_char_size), s + bad_char_size
2861 UTF ? SVf_UTF8 : 0);
2869 Extracts the next constant part of a pattern, double-quoted string,
2870 or transliteration. This is terrifying code.
2872 For example, in parsing the double-quoted string "ab\x63$d", it would
2873 stop at the '$' and return an OP_CONST containing 'abc'.
2875 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2876 processing a pattern (PL_lex_inpat is true), a transliteration
2877 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2879 Returns a pointer to the character scanned up to. If this is
2880 advanced from the start pointer supplied (i.e. if anything was
2881 successfully parsed), will leave an OP_CONST for the substring scanned
2882 in pl_yylval. Caller must intuit reason for not parsing further
2883 by looking at the next characters herself.
2887 \N{FOO} => \N{U+hex_for_character_FOO}
2888 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2891 all other \-char, including \N and \N{ apart from \N{ABC}
2894 @ and $ where it appears to be a var, but not for $ as tail anchor
2899 In transliterations:
2900 characters are VERY literal, except for - not at the start or end
2901 of the string, which indicates a range. If the range is in bytes,
2902 scan_const expands the range to the full set of intermediate
2903 characters. If the range is in utf8, the hyphen is replaced with
2904 a certain range mark which will be handled by pmtrans() in op.c.
2906 In double-quoted strings:
2908 double-quoted style: \r and \n
2909 constants: \x31, etc.
2910 deprecated backrefs: \1 (in substitution replacements)
2911 case and quoting: \U \Q \E
2914 scan_const does *not* construct ops to handle interpolated strings.
2915 It stops processing as soon as it finds an embedded $ or @ variable
2916 and leaves it to the caller to work out what's going on.
2918 embedded arrays (whether in pattern or not) could be:
2919 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2921 $ in double-quoted strings must be the symbol of an embedded scalar.
2923 $ in pattern could be $foo or could be tail anchor. Assumption:
2924 it's a tail anchor if $ is the last thing in the string, or if it's
2925 followed by one of "()| \r\n\t"
2927 \1 (backreferences) are turned into $1 in substitutions
2929 The structure of the code is
2930 while (there's a character to process) {
2931 handle transliteration ranges
2932 skip regexp comments /(?#comment)/ and codes /(?{code})/
2933 skip #-initiated comments in //x patterns
2934 check for embedded arrays
2935 check for embedded scalars
2937 deprecate \1 in substitution replacements
2938 handle string-changing backslashes \l \U \Q \E, etc.
2939 switch (what was escaped) {
2940 handle \- in a transliteration (becomes a literal -)
2941 if a pattern and not \N{, go treat as regular character
2942 handle \132 (octal characters)
2943 handle \x15 and \x{1234} (hex characters)
2944 handle \N{name} (named characters, also \N{3,5} in a pattern)
2945 handle \cV (control characters)
2946 handle printf-style backslashes (\f, \r, \n, etc)
2949 } (end if backslash)
2950 handle regular character
2951 } (end while character to read)
2956 S_scan_const(pTHX_ char *start)
2959 char *send = PL_bufend; /* end of the constant */
2960 SV *sv = newSV(send - start); /* sv for the constant. See
2961 note below on sizing. */
2962 char *s = start; /* start of the constant */
2963 char *d = SvPVX(sv); /* destination for copies */
2964 bool dorange = FALSE; /* are we in a translit range? */
2965 bool didrange = FALSE; /* did we just finish a range? */
2966 bool in_charclass = FALSE; /* within /[...]/ */
2967 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2968 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2969 to be UTF8? But, this can
2970 show as true when the source
2971 isn't utf8, as for example
2972 when it is entirely composed
2974 SV *res; /* result from charnames */
2976 /* Note on sizing: The scanned constant is placed into sv, which is
2977 * initialized by newSV() assuming one byte of output for every byte of
2978 * input. This routine expects newSV() to allocate an extra byte for a
2979 * trailing NUL, which this routine will append if it gets to the end of
2980 * the input. There may be more bytes of input than output (eg., \N{LATIN
2981 * CAPITAL LETTER A}), or more output than input if the constant ends up
2982 * recoded to utf8, but each time a construct is found that might increase
2983 * the needed size, SvGROW() is called. Its size parameter each time is
2984 * based on the best guess estimate at the time, namely the length used so
2985 * far, plus the length the current construct will occupy, plus room for
2986 * the trailing NUL, plus one byte for every input byte still unscanned */
2988 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2991 UV literal_endpoint = 0;
2992 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2995 PERL_ARGS_ASSERT_SCAN_CONST;
2997 assert(PL_lex_inwhat != OP_TRANSR);
2998 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2999 /* If we are doing a trans and we know we want UTF8 set expectation */
3000 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
3001 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3004 /* Protect sv from errors and fatal warnings. */
3005 ENTER_with_name("scan_const");
3008 while (s < send || dorange) {
3010 /* get transliterations out of the way (they're most literal) */
3011 if (PL_lex_inwhat == OP_TRANS) {
3012 /* expand a range A-Z to the full set of characters. AIE! */
3014 I32 i; /* current expanded character */
3015 I32 min; /* first character in range */
3016 I32 max; /* last character in range */
3027 char * const c = (char*)utf8_hop((U8*)d, -1);
3031 *c = (char)UTF_TO_NATIVE(0xff);
3032 /* mark the range as done, and continue */
3038 i = d - SvPVX_const(sv); /* remember current offset */
3041 SvLEN(sv) + (has_utf8 ?
3042 (512 - UTF_CONTINUATION_MARK +
3045 /* How many two-byte within 0..255: 128 in UTF-8,
3046 * 96 in UTF-8-mod. */
3048 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
3050 d = SvPVX(sv) + i; /* refresh d after realloc */
3054 for (j = 0; j <= 1; j++) {
3055 char * const c = (char*)utf8_hop((U8*)d, -1);
3056 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3062 max = (U8)0xff; /* only to \xff */
3063 uvmax = uv; /* \x{100} to uvmax */
3065 d = c; /* eat endpoint chars */
3070 d -= 2; /* eat the first char and the - */
3071 min = (U8)*d; /* first char in range */
3072 max = (U8)d[1]; /* last char in range */
3079 "Invalid range \"%c-%c\" in transliteration operator",
3080 (char)min, (char)max);
3084 if (literal_endpoint == 2 &&
3085 ((isLOWER(min) && isLOWER(max)) ||
3086 (isUPPER(min) && isUPPER(max)))) {
3088 for (i = min; i <= max; i++)
3090 *d++ = NATIVE_TO_NEED(has_utf8,i);
3092 for (i = min; i <= max; i++)
3094 *d++ = NATIVE_TO_NEED(has_utf8,i);
3099 for (i = min; i <= max; i++)
3102 const U8 ch = (U8)NATIVE_TO_UTF(i);
3103 if (UNI_IS_INVARIANT(ch))
3106 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
3107 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
3116 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3118 *d++ = (char)UTF_TO_NATIVE(0xff);
3120 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3124 /* mark the range as done, and continue */
3128 literal_endpoint = 0;
3133 /* range begins (ignore - as first or last char) */
3134 else if (*s == '-' && s+1 < send && s != start) {
3136 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3143 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
3153 literal_endpoint = 0;
3154 native_range = TRUE;
3159 /* if we get here, we're not doing a transliteration */
3161 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3164 while (s1 >= start && *s1-- == '\\')
3167 in_charclass = TRUE;
3170 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3173 while (s1 >= start && *s1-- == '\\')
3176 in_charclass = FALSE;
3179 /* skip for regexp comments /(?#comment)/, except for the last
3180 * char, which will be done separately.
3181 * Stop on (?{..}) and friends */
3183 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
3185 while (s+1 < send && *s != ')')
3186 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3188 else if (!PL_lex_casemods && !in_charclass &&
3189 ( s[2] == '{' /* This should match regcomp.c */
3190 || (s[2] == '?' && s[3] == '{')))
3196 /* likewise skip #-initiated comments in //x patterns */
3197 else if (*s == '#' && PL_lex_inpat &&
3198 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3199 while (s+1 < send && *s != '\n')
3200 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3203 /* no further processing of single-quoted regex */
3204 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3205 goto default_action;
3207 /* check for embedded arrays
3208 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3210 else if (*s == '@' && s[1]) {
3211 if (isWORDCHAR_lazy_if(s+1,UTF))
3213 if (strchr(":'{$", s[1]))
3215 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3216 break; /* in regexp, neither @+ nor @- are interpolated */
3219 /* check for embedded scalars. only stop if we're sure it's a
3222 else if (*s == '$') {
3223 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3225 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3227 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3228 "Possible unintended interpolation of $\\ in regex");
3230 break; /* in regexp, $ might be tail anchor */
3234 /* End of else if chain - OP_TRANS rejoin rest */
3237 if (*s == '\\' && s+1 < send) {
3238 char* e; /* Can be used for ending '}', etc. */
3242 /* warn on \1 - \9 in substitution replacements, but note that \11
3243 * is an octal; and \19 is \1 followed by '9' */
3244 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3245 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3247 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3252 /* string-change backslash escapes */
3253 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3257 /* In a pattern, process \N, but skip any other backslash escapes.
3258 * This is because we don't want to translate an escape sequence
3259 * into a meta symbol and have the regex compiler use the meta
3260 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3261 * in spite of this, we do have to process \N here while the proper
3262 * charnames handler is in scope. See bugs #56444 and #62056.
3263 * There is a complication because \N in a pattern may also stand
3264 * for 'match a non-nl', and not mean a charname, in which case its
3265 * processing should be deferred to the regex compiler. To be a
3266 * charname it must be followed immediately by a '{', and not look
3267 * like \N followed by a curly quantifier, i.e., not something like
3268 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3270 else if (PL_lex_inpat
3273 || regcurly(s + 1, FALSE)))
3275 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
3276 goto default_action;
3281 /* quoted - in transliterations */
3283 if (PL_lex_inwhat == OP_TRANS) {
3290 if ((isALPHANUMERIC(*s)))
3291 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3292 "Unrecognized escape \\%c passed through",
3294 /* default action is to copy the quoted character */
3295 goto default_action;
3298 /* eg. \132 indicates the octal constant 0132 */
3299 case '0': case '1': case '2': case '3':
3300 case '4': case '5': case '6': case '7':
3302 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3304 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
3306 if (len < 3 && s < send && isDIGIT(*s)
3307 && ckWARN(WARN_MISC))
3309 Perl_warner(aTHX_ packWARN(WARN_MISC),
3310 "%s", form_short_octal_warning(s, len));
3313 goto NUM_ESCAPE_INSERT;
3315 /* eg. \o{24} indicates the octal constant \024 */
3320 bool valid = grok_bslash_o(&s, &uv, &error,
3321 TRUE, /* Output warning */
3322 FALSE, /* Not strict */
3323 TRUE, /* Output warnings for
3330 goto NUM_ESCAPE_INSERT;
3333 /* eg. \x24 indicates the hex constant 0x24 */
3338 bool valid = grok_bslash_x(&s, &uv, &error,
3339 TRUE, /* Output warning */
3340 FALSE, /* Not strict */
3341 TRUE, /* Output warnings for
3351 /* Insert oct or hex escaped character. There will always be
3352 * enough room in sv since such escapes will be longer than any
3353 * UTF-8 sequence they can end up as, except if they force us
3354 * to recode the rest of the string into utf8 */
3356 /* Here uv is the ordinal of the next character being added in
3357 * unicode (converted from native). */
3358 if (!UNI_IS_INVARIANT(uv)) {
3359 if (!has_utf8 && uv > 255) {
3360 /* Might need to recode whatever we have accumulated so
3361 * far if it contains any chars variant in utf8 or
3364 SvCUR_set(sv, d - SvPVX_const(sv));
3367 /* See Note on sizing above. */
3368 sv_utf8_upgrade_flags_grow(sv,
3369 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3370 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3371 d = SvPVX(sv) + SvCUR(sv);
3376 d = (char*)uvuni_to_utf8((U8*)d, uv);
3377 if (PL_lex_inwhat == OP_TRANS &&
3378 PL_sublex_info.sub_op) {
3379 PL_sublex_info.sub_op->op_private |=
3380 (PL_lex_repl ? OPpTRANS_FROM_UTF
3384 if (uv > 255 && !dorange)
3385 native_range = FALSE;
3398 /* In a non-pattern \N must be a named character, like \N{LATIN
3399 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3400 * mean to match a non-newline. For non-patterns, named
3401 * characters are converted to their string equivalents. In
3402 * patterns, named characters are not converted to their
3403 * ultimate forms for the same reasons that other escapes
3404 * aren't. Instead, they are converted to the \N{U+...} form
3405 * to get the value from the charnames that is in effect right
3406 * now, while preserving the fact that it was a named character
3407 * so that the regex compiler knows this */
3409 /* This section of code doesn't generally use the
3410 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3411 * a close examination of this macro and determined it is a
3412 * no-op except on utfebcdic variant characters. Every
3413 * character generated by this that would normally need to be
3414 * enclosed by this macro is invariant, so the macro is not
3415 * needed, and would complicate use of copy(). XXX There are
3416 * other parts of this file where the macro is used
3417 * inconsistently, but are saved by it being a no-op */
3419 /* The structure of this section of code (besides checking for
3420 * errors and upgrading to utf8) is:
3421 * Further disambiguate between the two meanings of \N, and if
3422 * not a charname, go process it elsewhere
3423 * If of form \N{U+...}, pass it through if a pattern;
3424 * otherwise convert to utf8
3425 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3426 * pattern; otherwise convert to utf8 */
3428 /* Here, s points to the 'N'; the test below is guaranteed to
3429 * succeed if we are being called on a pattern as we already
3430 * know from a test above that the next character is a '{'.
3431 * On a non-pattern \N must mean 'named sequence, which
3432 * requires braces */
3435 yyerror("Missing braces on \\N{}");
3440 /* If there is no matching '}', it is an error. */
3441 if (! (e = strchr(s, '}'))) {
3442 if (! PL_lex_inpat) {
3443 yyerror("Missing right brace on \\N{}");
3445 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3450 /* Here it looks like a named character */
3452 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3453 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3454 | PERL_SCAN_DISALLOW_PREFIX;
3457 /* For \N{U+...}, the '...' is a unicode value even on
3458 * EBCDIC machines */
3459 s += 2; /* Skip to next char after the 'U+' */
3461 uv = grok_hex(s, &len, &flags, NULL);
3462 if (len == 0 || len != (STRLEN)(e - s)) {
3463 yyerror("Invalid hexadecimal number in \\N{U+...}");
3470 /* On non-EBCDIC platforms, pass through to the regex
3471 * compiler unchanged. The reason we evaluated the
3472 * number above is to make sure there wasn't a syntax
3473 * error. But on EBCDIC we convert to native so
3474 * downstream code can continue to assume it's native
3476 s -= 5; /* Include the '\N{U+' */
3478 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3481 (unsigned int) UNI_TO_NATIVE(uv));
3483 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3487 else { /* Not a pattern: convert the hex to string */
3489 /* If destination is not in utf8, unconditionally
3490 * recode it to be so. This is because \N{} implies
3491 * Unicode semantics, and scalars have to be in utf8
3492 * to guarantee those semantics */
3494 SvCUR_set(sv, d - SvPVX_const(sv));
3497 /* See Note on sizing above. */
3498 sv_utf8_upgrade_flags_grow(
3500 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3501 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3502 d = SvPVX(sv) + SvCUR(sv);
3506 /* Add the string to the output */
3507 if (UNI_IS_INVARIANT(uv)) {
3510 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3513 else /* Here is \N{NAME} but not \N{U+...}. */
3514 if ((res = get_and_check_backslash_N_name(s, e)))
3517 const char *str = SvPV_const(res, len);
3520 if (! len) { /* The name resolved to an empty string */
3521 Copy("\\N{}", d, 4, char);
3525 /* In order to not lose information for the regex
3526 * compiler, pass the result in the specially made
3527 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3528 * the code points in hex of each character
3529 * returned by charnames */
3531 const char *str_end = str + len;
3532 const STRLEN off = d - SvPVX_const(sv);
3534 if (! SvUTF8(res)) {
3535 /* For the non-UTF-8 case, we can determine the
3536 * exact length needed without having to parse
3537 * through the string. Each character takes up
3538 * 2 hex digits plus either a trailing dot or
3540 d = off + SvGROW(sv, off
3542 + 6 /* For the "\N{U+", and
3544 + (STRLEN)(send - e));
3545 Copy("\\N{U+", d, 5, char);
3547 while (str < str_end) {
3549 my_snprintf(hex_string, sizeof(hex_string),
3550 "%02X.", (U8) *str);
3551 Copy(hex_string, d, 3, char);
3555 d--; /* We will overwrite below the final
3556 dot with a right brace */
3559 STRLEN char_length; /* cur char's byte length */
3561 /* and the number of bytes after this is
3562 * translated into hex digits */
3563 STRLEN output_length;
3565 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3566 * for max('U+', '.'); and 1 for NUL */
3567 char hex_string[2 * UTF8_MAXBYTES + 5];
3569 /* Get the first character of the result. */
3570 U32 uv = utf8n_to_uvuni((U8 *) str,
3574 /* Convert first code point to hex, including
3575 * the boiler plate before it. For all these,
3576 * we convert to native format so that
3577 * downstream code can continue to assume the
3578 * input is native */
3580 my_snprintf(hex_string, sizeof(hex_string),
3582 (unsigned int) UNI_TO_NATIVE(uv));
3584 /* Make sure there is enough space to hold it */
3585 d = off + SvGROW(sv, off
3587 + (STRLEN)(send - e)
3588 + 2); /* '}' + NUL */
3590 Copy(hex_string, d, output_length, char);
3593 /* For each subsequent character, append dot and
3594 * its ordinal in hex */
3595 while ((str += char_length) < str_end) {
3596 const STRLEN off = d - SvPVX_const(sv);
3597 U32 uv = utf8n_to_uvuni((U8 *) str,
3602 my_snprintf(hex_string,
3605 (unsigned int) UNI_TO_NATIVE(uv));
3607 d = off + SvGROW(sv, off
3609 + (STRLEN)(send - e)
3610 + 2); /* '}' + NUL */
3611 Copy(hex_string, d, output_length, char);
3616 *d++ = '}'; /* Done. Add the trailing brace */
3619 else { /* Here, not in a pattern. Convert the name to a
3622 /* If destination is not in utf8, unconditionally
3623 * recode it to be so. This is because \N{} implies
3624 * Unicode semantics, and scalars have to be in utf8
3625 * to guarantee those semantics */
3627 SvCUR_set(sv, d - SvPVX_const(sv));
3630 /* See Note on sizing above. */
3631 sv_utf8_upgrade_flags_grow(sv,
3632 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3633 len + (STRLEN)(send - s) + 1);
3634 d = SvPVX(sv) + SvCUR(sv);
3636 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3638 /* See Note on sizing above. (NOTE: SvCUR() is not
3639 * set correctly here). */
3640 const STRLEN off = d - SvPVX_const(sv);
3641 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3643 Copy(str, d, len, char);
3649 } /* End \N{NAME} */
3652 native_range = FALSE; /* \N{} is defined to be Unicode */
3654 s = e + 1; /* Point to just after the '}' */
3657 /* \c is a control character */
3661 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3664 yyerror("Missing control char name in \\c");
3668 /* printf-style backslashes, formfeeds, newlines, etc */
3670 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3673 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3676 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3679 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3682 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3685 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3688 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3694 } /* end if (backslash) */
3701 /* If we started with encoded form, or already know we want it,
3702 then encode the next character */
3703 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3707 /* One might think that it is wasted effort in the case of the
3708 * source being utf8 (this_utf8 == TRUE) to take the next character
3709 * in the source, convert it to an unsigned value, and then convert
3710 * it back again. But the source has not been validated here. The
3711 * routine that does the conversion checks for errors like
3714 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3715 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3717 SvCUR_set(sv, d - SvPVX_const(sv));
3720 /* See Note on sizing above. */
3721 sv_utf8_upgrade_flags_grow(sv,
3722 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3723 need + (STRLEN)(send - s) + 1);
3724 d = SvPVX(sv) + SvCUR(sv);
3726 } else if (need > len) {
3727 /* encoded value larger than old, may need extra space (NOTE:
3728 * SvCUR() is not set correctly here). See Note on sizing
3730 const STRLEN off = d - SvPVX_const(sv);
3731 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3735 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3737 if (uv > 255 && !dorange)
3738 native_range = FALSE;
3742 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3744 } /* while loop to process each character */
3746 /* terminate the string and set up the sv */
3748 SvCUR_set(sv, d - SvPVX_const(sv));
3749 if (SvCUR(sv) >= SvLEN(sv))
3750 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3751 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3754 if (PL_encoding && !has_utf8) {
3755 sv_recode_to_utf8(sv, PL_encoding);
3761 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3762 PL_sublex_info.sub_op->op_private |=
3763 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3767 /* shrink the sv if we allocated more than we used */
3768 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3769 SvPV_shrink_to_cur(sv);
3772 /* return the substring (via pl_yylval) only if we parsed anything */
3773 if (s > PL_bufptr) {
3774 SvREFCNT_inc_simple_void_NN(sv);
3775 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3776 && ! PL_parser->lex_re_reparsing)
3778 const char *const key = PL_lex_inpat ? "qr" : "q";
3779 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3783 if (PL_lex_inwhat == OP_TRANS) {
3786 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3789 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3797 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3800 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3802 LEAVE_with_name("scan_const");
3807 * Returns TRUE if there's more to the expression (e.g., a subscript),
3810 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3812 * ->[ and ->{ return TRUE
3813 * { and [ outside a pattern are always subscripts, so return TRUE
3814 * if we're outside a pattern and it's not { or [, then return FALSE
3815 * if we're in a pattern and the first char is a {
3816 * {4,5} (any digits around the comma) returns FALSE
3817 * if we're in a pattern and the first char is a [
3819 * [SOMETHING] has a funky algorithm to decide whether it's a
3820 * character class or not. It has to deal with things like
3821 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3822 * anything else returns TRUE
3825 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3828 S_intuit_more(pTHX_ char *s)
3832 PERL_ARGS_ASSERT_INTUIT_MORE;
3834 if (PL_lex_brackets)
3836 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3838 if (*s != '{' && *s != '[')
3843 /* In a pattern, so maybe we have {n,m}. */
3845 if (regcurly(s, FALSE)) {
3851 /* On the other hand, maybe we have a character class */
3854 if (*s == ']' || *s == '^')
3857 /* this is terrifying, and it works */
3860 const char * const send = strchr(s,']');
3861 unsigned char un_char, last_un_char;
3862 char tmpbuf[sizeof PL_tokenbuf * 4];
3864 if (!send) /* has to be an expression */
3866 weight = 2; /* let's weigh the evidence */
3870 else if (isDIGIT(*s)) {
3872 if (isDIGIT(s[1]) && s[2] == ']')
3878 Zero(seen,256,char);
3880 for (; s < send; s++) {
3881 last_un_char = un_char;
3882 un_char = (unsigned char)*s;
3887 weight -= seen[un_char] * 10;
3888 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3890 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3891 len = (int)strlen(tmpbuf);
3892 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3893 UTF ? SVf_UTF8 : 0, SVt_PV))
3898 else if (*s == '$' && s[1] &&
3899 strchr("[#!%*<>()-=",s[1])) {
3900 if (/*{*/ strchr("])} =",s[2]))
3909 if (strchr("wds]",s[1]))
3911 else if (seen[(U8)'\''] || seen[(U8)'"'])
3913 else if (strchr("rnftbxcav",s[1]))
3915 else if (isDIGIT(s[1])) {
3917 while (s[1] && isDIGIT(s[1]))
3927 if (strchr("aA01! ",last_un_char))
3929 if (strchr("zZ79~",s[1]))
3931 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3932 weight -= 5; /* cope with negative subscript */
3935 if (!isWORDCHAR(last_un_char)
3936 && !(last_un_char == '$' || last_un_char == '@'
3937 || last_un_char == '&')
3938 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3943 if (keyword(tmpbuf, d - tmpbuf, 0))
3946 if (un_char == last_un_char + 1)
3948 weight -= seen[un_char];
3953 if (weight >= 0) /* probably a character class */
3963 * Does all the checking to disambiguate
3965 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3966 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3968 * First argument is the stuff after the first token, e.g. "bar".
3970 * Not a method if foo is a filehandle.
3971 * Not a method if foo is a subroutine prototyped to take a filehandle.
3972 * Not a method if it's really "Foo $bar"
3973 * Method if it's "foo $bar"
3974 * Not a method if it's really "print foo $bar"
3975 * Method if it's really "foo package::" (interpreted as package->foo)
3976 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3977 * Not a method if bar is a filehandle or package, but is quoted with
3982 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3985 char *s = start + (*start == '$');
3986 char tmpbuf[sizeof PL_tokenbuf];
3993 PERL_ARGS_ASSERT_INTUIT_METHOD;
3995 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3997 if (cv && SvPOK(cv)) {
3998 const char *proto = CvPROTO(cv);
4000 while (*proto && (isSPACE(*proto) || *proto == ';'))
4007 if (*start == '$') {
4008 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
4009 isUPPER(*PL_tokenbuf))
4012 len = start - SvPVX(PL_linestr);
4016 start = SvPVX(PL_linestr) + len;
4020 return *s == '(' ? FUNCMETH : METHOD;
4023 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4024 /* start is the beginning of the possible filehandle/object,
4025 * and s is the end of it
4026 * tmpbuf is a copy of it (but with single quotes as double colons)
4029 if (!keyword(tmpbuf, len, 0)) {
4030 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4034 soff = s - SvPVX(PL_linestr);
4038 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4039 if (indirgv && GvCVu(indirgv))
4041 /* filehandle or package name makes it a method */
4042 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4044 soff = s - SvPVX(PL_linestr);
4047 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4048 return 0; /* no assumptions -- "=>" quotes bareword */
4050 start_force(PL_curforce);
4051 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4052 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4053 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4055 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4056 ( UTF ? SVf_UTF8 : 0 )));
4061 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4063 return *s == '(' ? FUNCMETH : METHOD;
4069 /* Encoded script support. filter_add() effectively inserts a
4070 * 'pre-processing' function into the current source input stream.
4071 * Note that the filter function only applies to the current source file
4072 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4074 * The datasv parameter (which may be NULL) can be used to pass
4075 * private data to this instance of the filter. The filter function
4076 * can recover the SV using the FILTER_DATA macro and use it to
4077 * store private buffers and state information.
4079 * The supplied datasv parameter is upgraded to a PVIO type
4080 * and the IoDIRP/IoANY field is used to store the function pointer,
4081 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4082 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4083 * private use must be set using malloc'd pointers.
4087 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4096 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4097 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4099 if (!PL_rsfp_filters)
4100 PL_rsfp_filters = newAV();
4103 SvUPGRADE(datasv, SVt_PVIO);
4104 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4105 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4106 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4107 FPTR2DPTR(void *, IoANY(datasv)),
4108 SvPV_nolen(datasv)));
4109 av_unshift(PL_rsfp_filters, 1);
4110 av_store(PL_rsfp_filters, 0, datasv) ;
4112 !PL_parser->filtered
4113 && PL_parser->lex_flags & LEX_EVALBYTES
4114 && PL_bufptr < PL_bufend
4116 const char *s = PL_bufptr;
4117 while (s < PL_bufend) {
4119 SV *linestr = PL_parser->linestr;
4120 char *buf = SvPVX(linestr);
4121 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4122 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4123 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4124 STRLEN const linestart_pos = PL_parser->linestart - buf;
4125 STRLEN const last_uni_pos =
4126 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4127 STRLEN const last_lop_pos =
4128 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4129 av_push(PL_rsfp_filters, linestr);
4130 PL_parser->linestr =
4131 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4132 buf = SvPVX(PL_parser->linestr);
4133 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4134 PL_parser->bufptr = buf + bufptr_pos;
4135 PL_parser->oldbufptr = buf + oldbufptr_pos;
4136 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4137 PL_parser->linestart = buf + linestart_pos;
4138 if (PL_parser->last_uni)
4139 PL_parser->last_uni = buf + last_uni_pos;
4140 if (PL_parser->last_lop)
4141 PL_parser->last_lop = buf + last_lop_pos;
4142 SvLEN(linestr) = SvCUR(linestr);
4143 SvCUR(linestr) = s-SvPVX(linestr);
4144 PL_parser->filtered = 1;
4154 /* Delete most recently added instance of this filter function. */
4156 Perl_filter_del(pTHX_ filter_t funcp)
4161 PERL_ARGS_ASSERT_FILTER_DEL;
4164 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4165 FPTR2DPTR(void*, funcp)));
4167 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4169 /* if filter is on top of stack (usual case) just pop it off */
4170 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4171 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4172 sv_free(av_pop(PL_rsfp_filters));
4176 /* we need to search for the correct entry and clear it */
4177 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4181 /* Invoke the idxth filter function for the current rsfp. */
4182 /* maxlen 0 = read one text line */
4184 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4189 /* This API is bad. It should have been using unsigned int for maxlen.
4190 Not sure if we want to change the API, but if not we should sanity
4191 check the value here. */
4192 unsigned int correct_length
4201 PERL_ARGS_ASSERT_FILTER_READ;
4203 if (!PL_parser || !PL_rsfp_filters)
4205 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4206 /* Provide a default input filter to make life easy. */
4207 /* Note that we append to the line. This is handy. */
4208 DEBUG_P(PerlIO_printf(Perl_debug_log,
4209 "filter_read %d: from rsfp\n", idx));
4210 if (correct_length) {
4213 const int old_len = SvCUR(buf_sv);
4215 /* ensure buf_sv is large enough */
4216 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4217 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4218 correct_length)) <= 0) {
4219 if (PerlIO_error(PL_rsfp))
4220 return -1; /* error */
4222 return 0 ; /* end of file */
4224 SvCUR_set(buf_sv, old_len + len) ;
4225 SvPVX(buf_sv)[old_len + len] = '\0';
4228 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4229 if (PerlIO_error(PL_rsfp))
4230 return -1; /* error */
4232 return 0 ; /* end of file */
4235 return SvCUR(buf_sv);
4237 /* Skip this filter slot if filter has been deleted */
4238 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4239 DEBUG_P(PerlIO_printf(Perl_debug_log,
4240 "filter_read %d: skipped (filter deleted)\n",
4242 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4244 if (SvTYPE(datasv) != SVt_PVIO) {
4245 if (correct_length) {
4247 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4248 if (!remainder) return 0; /* eof */
4249 if (correct_length > remainder) correct_length = remainder;
4250 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4251 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4254 const char *s = SvEND(datasv);
4255 const char *send = SvPVX(datasv) + SvLEN(datasv);
4263 if (s == send) return 0; /* eof */
4264 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4265 SvCUR_set(datasv, s-SvPVX(datasv));
4267 return SvCUR(buf_sv);
4269 /* Get function pointer hidden within datasv */
4270 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4271 DEBUG_P(PerlIO_printf(Perl_debug_log,
4272 "filter_read %d: via function %p (%s)\n",
4273 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4274 /* Call function. The function is expected to */
4275 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4276 /* Return: <0:error, =0:eof, >0:not eof */
4277 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4281 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4285 PERL_ARGS_ASSERT_FILTER_GETS;
4287 #ifdef PERL_CR_FILTER
4288 if (!PL_rsfp_filters) {
4289 filter_add(S_cr_textfilter,NULL);
4292 if (PL_rsfp_filters) {
4294 SvCUR_set(sv, 0); /* start with empty line */
4295 if (FILTER_READ(0, sv, 0) > 0)
4296 return ( SvPVX(sv) ) ;
4301 return (sv_gets(sv, PL_rsfp, append));
4305 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4310 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4312 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4316 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4317 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4319 return GvHV(gv); /* Foo:: */
4322 /* use constant CLASS => 'MyClass' */
4323 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4324 if (gv && GvCV(gv)) {
4325 SV * const sv = cv_const_sv(GvCV(gv));
4327 pkgname = SvPV_const(sv, len);
4330 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4334 * S_readpipe_override
4335 * Check whether readpipe() is overridden, and generates the appropriate
4336 * optree, provided sublex_start() is called afterwards.
4339 S_readpipe_override(pTHX)
4342 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4343 pl_yylval.ival = OP_BACKTICK;
4345 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4347 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4348 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4349 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4351 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4352 op_append_elem(OP_LIST,
4353 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4354 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4361 * The intent of this yylex wrapper is to minimize the changes to the
4362 * tokener when we aren't interested in collecting madprops. It remains
4363 * to be seen how successful this strategy will be...
4370 char *s = PL_bufptr;
4372 /* make sure PL_thiswhite is initialized */
4376 /* previous token ate up our whitespace? */
4377 if (!PL_lasttoke && PL_nextwhite) {
4378 PL_thiswhite = PL_nextwhite;
4382 /* isolate the token, and figure out where it is without whitespace */
4383 PL_realtokenstart = -1;
4387 assert(PL_curforce < 0);
4389 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4390 if (!PL_thistoken) {
4391 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4392 PL_thistoken = newSVpvs("");
4394 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4395 PL_thistoken = newSVpvn(tstart, s - tstart);
4398 if (PL_thismad) /* install head */
4399 CURMAD('X', PL_thistoken);
4402 /* last whitespace of a sublex? */
4403 if (optype == ')' && PL_endwhite) {
4404 CURMAD('X', PL_endwhite);
4409 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4410 if (!PL_thiswhite && !PL_endwhite && !optype) {
4411 sv_free(PL_thistoken);
4416 /* put off final whitespace till peg */
4417 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4418 PL_nextwhite = PL_thiswhite;
4421 else if (PL_thisopen) {
4422 CURMAD('q', PL_thisopen);
4424 sv_free(PL_thistoken);
4428 /* Store actual token text as madprop X */
4429 CURMAD('X', PL_thistoken);
4433 /* add preceding whitespace as madprop _ */
4434 CURMAD('_', PL_thiswhite);
4438 /* add quoted material as madprop = */
4439 CURMAD('=', PL_thisstuff);
4443 /* add terminating quote as madprop Q */
4444 CURMAD('Q', PL_thisclose);
4448 /* special processing based on optype */
4452 /* opval doesn't need a TOKEN since it can already store mp */
4462 if (pl_yylval.opval)
4463 append_madprops(PL_thismad, pl_yylval.opval, 0);