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 %"UTF8f"?)\n",
557 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
561 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
562 "\t(Missing operator before %"UTF8f"?)\n",
563 UTF8fARG(UTF, s - oldbp, oldbp));
571 * Complain about missing quote/regexp/heredoc terminator.
572 * If it's called with NULL then it cauterizes the line buffer.
573 * If we're in a delimited string and the delimiter is a control
574 * character, it's reformatted into a two-char sequence like ^C.
579 S_missingterm(pTHX_ char *s)
585 char * const nl = strrchr(s,'\n');
589 else if (isCNTRL(PL_multi_close)) {
591 tmpbuf[1] = (char)toCTRL(PL_multi_close);
596 *tmpbuf = (char)PL_multi_close;
600 q = strchr(s,'"') ? '\'' : '"';
601 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
607 * Check whether the named feature is enabled.
610 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
613 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
615 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
617 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
619 if (namelen > MAX_FEATURE_LEN)
621 memcpy(&he_name[8], name, namelen);
623 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
624 REFCOUNTED_HE_EXISTS));
628 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
629 * utf16-to-utf8-reversed.
632 #ifdef PERL_CR_FILTER
636 const char *s = SvPVX_const(sv);
637 const char * const e = s + SvCUR(sv);
639 PERL_ARGS_ASSERT_STRIP_RETURN;
641 /* outer loop optimized to do nothing if there are no CR-LFs */
643 if (*s++ == '\r' && *s == '\n') {
644 /* hit a CR-LF, need to copy the rest */
648 if (*s == '\r' && s[1] == '\n')
659 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
661 const I32 count = FILTER_READ(idx+1, sv, maxlen);
662 if (count > 0 && !maxlen)
669 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
671 Creates and initialises a new lexer/parser state object, supplying
672 a context in which to lex and parse from a new source of Perl code.
673 A pointer to the new state object is placed in L</PL_parser>. An entry
674 is made on the save stack so that upon unwinding the new state object
675 will be destroyed and the former value of L</PL_parser> will be restored.
676 Nothing else need be done to clean up the parsing context.
678 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
679 non-null, provides a string (in SV form) containing code to be parsed.
680 A copy of the string is made, so subsequent modification of I<line>
681 does not affect parsing. I<rsfp>, if non-null, provides an input stream
682 from which code will be read to be parsed. If both are non-null, the
683 code in I<line> comes first and must consist of complete lines of input,
684 and I<rsfp> supplies the remainder of the source.
686 The I<flags> parameter is reserved for future use. Currently it is only
687 used by perl internally, so extensions should always pass zero.
692 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
693 can share filters with the current parser.
694 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
695 caller, hence isn't owned by the parser, so shouldn't be closed on parser
696 destruction. This is used to handle the case of defaulting to reading the
697 script from the standard input because no filename was given on the command
698 line (without getting confused by situation where STDIN has been closed, so
699 the script handle is opened on fd 0) */
702 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
705 const char *s = NULL;
706 yy_parser *parser, *oparser;
707 if (flags && flags & ~LEX_START_FLAGS)
708 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
710 /* create and initialise a parser */
712 Newxz(parser, 1, yy_parser);
713 parser->old_parser = oparser = PL_parser;
716 parser->stack = NULL;
718 parser->stack_size = 0;
720 /* on scope exit, free this parser and restore any outer one */
722 parser->saved_curcop = PL_curcop;
724 /* initialise lexer state */
727 parser->curforce = -1;
729 parser->nexttoke = 0;
731 parser->error_count = oparser ? oparser->error_count : 0;
732 parser->copline = NOLINE;
733 parser->lex_state = LEX_NORMAL;
734 parser->expect = XSTATE;
736 parser->rsfp_filters =
737 !(flags & LEX_START_SAME_FILTER) || !oparser
739 : MUTABLE_AV(SvREFCNT_inc(
740 oparser->rsfp_filters
741 ? oparser->rsfp_filters
742 : (oparser->rsfp_filters = newAV())
745 Newx(parser->lex_brackstack, 120, char);
746 Newx(parser->lex_casestack, 12, char);
747 *parser->lex_casestack = '\0';
748 Newxz(parser->lex_shared, 1, LEXSHARED);
752 s = SvPV_const(line, len);
753 parser->linestr = flags & LEX_START_COPIED
754 ? SvREFCNT_inc_simple_NN(line)
755 : newSVpvn_flags(s, len, SvUTF8(line));
756 sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
758 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
760 parser->oldoldbufptr =
763 parser->linestart = SvPVX(parser->linestr);
764 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
765 parser->last_lop = parser->last_uni = NULL;
766 parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
767 |LEX_DONT_CLOSE_RSFP);
769 parser->in_pod = parser->filtered = 0;
773 /* delete a parser object */
776 Perl_parser_free(pTHX_ const yy_parser *parser)
778 PERL_ARGS_ASSERT_PARSER_FREE;
780 PL_curcop = parser->saved_curcop;
781 SvREFCNT_dec(parser->linestr);
783 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
784 PerlIO_clearerr(parser->rsfp);
785 else if (parser->rsfp && (!parser->old_parser ||
786 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
787 PerlIO_close(parser->rsfp);
788 SvREFCNT_dec(parser->rsfp_filters);
789 SvREFCNT_dec(parser->lex_stuff);
790 SvREFCNT_dec(parser->sublex_info.repl);
792 Safefree(parser->lex_brackstack);
793 Safefree(parser->lex_casestack);
794 Safefree(parser->lex_shared);
795 PL_parser = parser->old_parser;
800 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
803 I32 nexttoke = parser->lasttoke;
805 I32 nexttoke = parser->nexttoke;
807 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
810 if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
812 && parser->nexttoke[nexttoke].next_val.opval
813 && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
814 && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
815 op_free(parser->nexttoke[nexttoke].next_val.opval);
816 parser->nexttoke[nexttoke].next_val.opval = NULL;
819 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
820 && parser->nextval[nexttoke].opval
821 && parser->nextval[nexttoke].opval->op_slabbed
822 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
823 op_free(parser->nextval[nexttoke].opval);
824 parser->nextval[nexttoke].opval = NULL;
832 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
834 Buffer scalar containing the chunk currently under consideration of the
835 text currently being lexed. This is always a plain string scalar (for
836 which C<SvPOK> is true). It is not intended to be used as a scalar by
837 normal scalar means; instead refer to the buffer directly by the pointer
838 variables described below.
840 The lexer maintains various C<char*> pointers to things in the
841 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
842 reallocated, all of these pointers must be updated. Don't attempt to
843 do this manually, but rather use L</lex_grow_linestr> if you need to
844 reallocate the buffer.
846 The content of the text chunk in the buffer is commonly exactly one
847 complete line of input, up to and including a newline terminator,
848 but there are situations where it is otherwise. The octets of the
849 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
850 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
851 flag on this scalar, which may disagree with it.
853 For direct examination of the buffer, the variable
854 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
855 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
856 of these pointers is usually preferable to examination of the scalar
857 through normal scalar means.
859 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
861 Direct pointer to the end of the chunk of text currently being lexed, the
862 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
863 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
864 always located at the end of the buffer, and does not count as part of
865 the buffer's contents.
867 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
869 Points to the current position of lexing inside the lexer buffer.
870 Characters around this point may be freely examined, within
871 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
872 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
873 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
875 Lexing code (whether in the Perl core or not) moves this pointer past
876 the characters that it consumes. It is also expected to perform some
877 bookkeeping whenever a newline character is consumed. This movement
878 can be more conveniently performed by the function L</lex_read_to>,
879 which handles newlines appropriately.
881 Interpretation of the buffer's octets can be abstracted out by
882 using the slightly higher-level functions L</lex_peek_unichar> and
883 L</lex_read_unichar>.
885 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
887 Points to the start of the current line inside the lexer buffer.
888 This is useful for indicating at which column an error occurred, and
889 not much else. This must be updated by any lexing code that consumes
890 a newline; the function L</lex_read_to> handles this detail.
896 =for apidoc Amx|bool|lex_bufutf8
898 Indicates whether the octets in the lexer buffer
899 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
900 of Unicode characters. If not, they should be interpreted as Latin-1
901 characters. This is analogous to the C<SvUTF8> flag for scalars.
903 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
904 contains valid UTF-8. Lexing code must be robust in the face of invalid
907 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
908 is significant, but not the whole story regarding the input character
909 encoding. Normally, when a file is being read, the scalar contains octets
910 and its C<SvUTF8> flag is off, but the octets should be interpreted as
911 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
912 however, the scalar may have the C<SvUTF8> flag on, and in this case its
913 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
914 is in effect. This logic may change in the future; use this function
915 instead of implementing the logic yourself.
921 Perl_lex_bufutf8(pTHX)
927 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
929 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
930 at least I<len> octets (including terminating NUL). Returns a
931 pointer to the reallocated buffer. This is necessary before making
932 any direct modification of the buffer that would increase its length.
933 L</lex_stuff_pvn> provides a more convenient way to insert text into
936 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
937 this function updates all of the lexer's variables that point directly
944 Perl_lex_grow_linestr(pTHX_ STRLEN len)
948 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
949 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
950 linestr = PL_parser->linestr;
951 buf = SvPVX(linestr);
952 if (len <= SvLEN(linestr))
954 bufend_pos = PL_parser->bufend - buf;
955 bufptr_pos = PL_parser->bufptr - buf;
956 oldbufptr_pos = PL_parser->oldbufptr - buf;
957 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
958 linestart_pos = PL_parser->linestart - buf;
959 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
960 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
961 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
962 PL_parser->lex_shared->re_eval_start - buf : 0;
964 buf = sv_grow(linestr, len);
966 PL_parser->bufend = buf + bufend_pos;
967 PL_parser->bufptr = buf + bufptr_pos;
968 PL_parser->oldbufptr = buf + oldbufptr_pos;
969 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
970 PL_parser->linestart = buf + linestart_pos;
971 if (PL_parser->last_uni)
972 PL_parser->last_uni = buf + last_uni_pos;
973 if (PL_parser->last_lop)
974 PL_parser->last_lop = buf + last_lop_pos;
975 if (PL_parser->lex_shared->re_eval_start)
976 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
981 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
983 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
984 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
985 reallocating the buffer if necessary. This means that lexing code that
986 runs later will see the characters as if they had appeared in the input.
987 It is not recommended to do this as part of normal parsing, and most
988 uses of this facility run the risk of the inserted characters being
989 interpreted in an unintended manner.
991 The string to be inserted is represented by I<len> octets starting
992 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
993 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
994 The characters are recoded for the lexer buffer, according to how the
995 buffer is currently being interpreted (L</lex_bufutf8>). If a string
996 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
997 function is more convenient.
1003 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1007 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1008 if (flags & ~(LEX_STUFF_UTF8))
1009 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1011 if (flags & LEX_STUFF_UTF8) {
1014 STRLEN highhalf = 0; /* Count of variants */
1015 const char *p, *e = pv+len;
1016 for (p = pv; p != e; p++) {
1017 if (! UTF8_IS_INVARIANT(*p)) {
1023 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1024 bufptr = PL_parser->bufptr;
1025 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1026 SvCUR_set(PL_parser->linestr,
1027 SvCUR(PL_parser->linestr) + len+highhalf);
1028 PL_parser->bufend += len+highhalf;
1029 for (p = pv; p != e; p++) {
1031 if (! UTF8_IS_INVARIANT(c)) {
1032 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1033 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1035 *bufptr++ = (char)c;
1040 if (flags & LEX_STUFF_UTF8) {
1041 STRLEN highhalf = 0;
1042 const char *p, *e = pv+len;
1043 for (p = pv; p != e; p++) {
1045 if (UTF8_IS_ABOVE_LATIN1(c)) {
1046 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1047 "non-Latin-1 character into Latin-1 input");
1048 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1051 } else if (! UTF8_IS_INVARIANT(c)) {
1052 /* malformed UTF-8 */
1054 SAVESPTR(PL_warnhook);
1055 PL_warnhook = PERL_WARNHOOK_FATAL;
1056 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
1062 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1063 bufptr = PL_parser->bufptr;
1064 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1065 SvCUR_set(PL_parser->linestr,
1066 SvCUR(PL_parser->linestr) + len-highhalf);
1067 PL_parser->bufend += len-highhalf;
1070 if (UTF8_IS_INVARIANT(*p)) {
1076 *bufptr++ = TWO_BYTE_UTF8_TO_UNI(*p, *(p+1));
1082 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1083 bufptr = PL_parser->bufptr;
1084 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1085 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1086 PL_parser->bufend += len;
1087 Copy(pv, bufptr, len, char);
1093 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1095 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1096 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1097 reallocating the buffer if necessary. This means that lexing code that
1098 runs later will see the characters as if they had appeared in the input.
1099 It is not recommended to do this as part of normal parsing, and most
1100 uses of this facility run the risk of the inserted characters being
1101 interpreted in an unintended manner.
1103 The string to be inserted is represented by octets starting at I<pv>
1104 and continuing to the first nul. These octets are interpreted as either
1105 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1106 in I<flags>. The characters are recoded for the lexer buffer, according
1107 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1108 If it is not convenient to nul-terminate a string to be inserted, the
1109 L</lex_stuff_pvn> function is more appropriate.
1115 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1117 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1118 lex_stuff_pvn(pv, strlen(pv), flags);
1122 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1124 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1125 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1126 reallocating the buffer if necessary. This means that lexing code that
1127 runs later will see the characters as if they had appeared in the input.
1128 It is not recommended to do this as part of normal parsing, and most
1129 uses of this facility run the risk of the inserted characters being
1130 interpreted in an unintended manner.
1132 The string to be inserted is the string value of I<sv>. The characters
1133 are recoded for the lexer buffer, according to how the buffer is currently
1134 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1135 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1136 need to construct a scalar.
1142 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1146 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1148 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1150 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1154 =for apidoc Amx|void|lex_unstuff|char *ptr
1156 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1157 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1158 This hides the discarded text from any lexing code that runs later,
1159 as if the text had never appeared.
1161 This is not the normal way to consume lexed text. For that, use
1168 Perl_lex_unstuff(pTHX_ char *ptr)
1172 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1173 buf = PL_parser->bufptr;
1175 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1178 bufend = PL_parser->bufend;
1180 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1181 unstuff_len = ptr - buf;
1182 Move(ptr, buf, bufend+1-ptr, char);
1183 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1184 PL_parser->bufend = bufend - unstuff_len;
1188 =for apidoc Amx|void|lex_read_to|char *ptr
1190 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1191 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1192 performing the correct bookkeeping whenever a newline character is passed.
1193 This is the normal way to consume lexed text.
1195 Interpretation of the buffer's octets can be abstracted out by
1196 using the slightly higher-level functions L</lex_peek_unichar> and
1197 L</lex_read_unichar>.
1203 Perl_lex_read_to(pTHX_ char *ptr)
1206 PERL_ARGS_ASSERT_LEX_READ_TO;
1207 s = PL_parser->bufptr;
1208 if (ptr < s || ptr > PL_parser->bufend)
1209 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1210 for (; s != ptr; s++)
1212 COPLINE_INC_WITH_HERELINES;
1213 PL_parser->linestart = s+1;
1215 PL_parser->bufptr = ptr;
1219 =for apidoc Amx|void|lex_discard_to|char *ptr
1221 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1222 up to I<ptr>. The remaining content of the buffer will be moved, and
1223 all pointers into the buffer updated appropriately. I<ptr> must not
1224 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1225 it is not permitted to discard text that has yet to be lexed.
1227 Normally it is not necessarily to do this directly, because it suffices to
1228 use the implicit discarding behaviour of L</lex_next_chunk> and things
1229 based on it. However, if a token stretches across multiple lines,
1230 and the lexing code has kept multiple lines of text in the buffer for
1231 that purpose, then after completion of the token it would be wise to
1232 explicitly discard the now-unneeded earlier lines, to avoid future
1233 multi-line tokens growing the buffer without bound.
1239 Perl_lex_discard_to(pTHX_ char *ptr)
1243 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1244 buf = SvPVX(PL_parser->linestr);
1246 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1249 if (ptr > PL_parser->bufptr)
1250 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1251 discard_len = ptr - buf;
1252 if (PL_parser->oldbufptr < ptr)
1253 PL_parser->oldbufptr = ptr;
1254 if (PL_parser->oldoldbufptr < ptr)
1255 PL_parser->oldoldbufptr = ptr;
1256 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1257 PL_parser->last_uni = NULL;
1258 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1259 PL_parser->last_lop = NULL;
1260 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1261 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1262 PL_parser->bufend -= discard_len;
1263 PL_parser->bufptr -= discard_len;
1264 PL_parser->oldbufptr -= discard_len;
1265 PL_parser->oldoldbufptr -= discard_len;
1266 if (PL_parser->last_uni)
1267 PL_parser->last_uni -= discard_len;
1268 if (PL_parser->last_lop)
1269 PL_parser->last_lop -= discard_len;
1273 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1275 Reads in the next chunk of text to be lexed, appending it to
1276 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1277 looked to the end of the current chunk and wants to know more. It is
1278 usual, but not necessary, for lexing to have consumed the entirety of
1279 the current chunk at this time.
1281 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1282 chunk (i.e., the current chunk has been entirely consumed), normally the
1283 current chunk will be discarded at the same time that the new chunk is
1284 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1285 will not be discarded. If the current chunk has not been entirely
1286 consumed, then it will not be discarded regardless of the flag.
1288 Returns true if some new text was added to the buffer, or false if the
1289 buffer has reached the end of the input text.
1294 #define LEX_FAKE_EOF 0x80000000
1295 #define LEX_NO_TERM 0x40000000
1298 Perl_lex_next_chunk(pTHX_ U32 flags)
1302 STRLEN old_bufend_pos, new_bufend_pos;
1303 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1304 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1305 bool got_some_for_debugger = 0;
1307 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1308 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1309 linestr = PL_parser->linestr;
1310 buf = SvPVX(linestr);
1311 if (!(flags & LEX_KEEP_PREVIOUS) &&
1312 PL_parser->bufptr == PL_parser->bufend) {
1313 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1315 if (PL_parser->last_uni != PL_parser->bufend)
1316 PL_parser->last_uni = NULL;
1317 if (PL_parser->last_lop != PL_parser->bufend)
1318 PL_parser->last_lop = NULL;
1319 last_uni_pos = last_lop_pos = 0;
1323 old_bufend_pos = PL_parser->bufend - buf;
1324 bufptr_pos = PL_parser->bufptr - buf;
1325 oldbufptr_pos = PL_parser->oldbufptr - buf;
1326 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1327 linestart_pos = PL_parser->linestart - buf;
1328 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1329 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1331 if (flags & LEX_FAKE_EOF) {
1333 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1335 } else if (filter_gets(linestr, old_bufend_pos)) {
1337 got_some_for_debugger = 1;
1338 } else if (flags & LEX_NO_TERM) {
1341 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1342 sv_setpvs(linestr, "");
1344 /* End of real input. Close filehandle (unless it was STDIN),
1345 * then add implicit termination.
1347 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1348 PerlIO_clearerr(PL_parser->rsfp);
1349 else if (PL_parser->rsfp)
1350 (void)PerlIO_close(PL_parser->rsfp);
1351 PL_parser->rsfp = NULL;
1352 PL_parser->in_pod = PL_parser->filtered = 0;
1354 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1357 if (!PL_in_eval && PL_minus_p) {
1359 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1360 PL_minus_n = PL_minus_p = 0;
1361 } else if (!PL_in_eval && PL_minus_n) {
1362 sv_catpvs(linestr, /*{*/";}");
1365 sv_catpvs(linestr, ";");
1368 buf = SvPVX(linestr);
1369 new_bufend_pos = SvCUR(linestr);
1370 PL_parser->bufend = buf + new_bufend_pos;
1371 PL_parser->bufptr = buf + bufptr_pos;
1372 PL_parser->oldbufptr = buf + oldbufptr_pos;
1373 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1374 PL_parser->linestart = buf + linestart_pos;
1375 if (PL_parser->last_uni)
1376 PL_parser->last_uni = buf + last_uni_pos;
1377 if (PL_parser->last_lop)
1378 PL_parser->last_lop = buf + last_lop_pos;
1379 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1380 PL_curstash != PL_debstash) {
1381 /* debugger active and we're not compiling the debugger code,
1382 * so store the line into the debugger's array of lines
1384 update_debugger_info(NULL, buf+old_bufend_pos,
1385 new_bufend_pos-old_bufend_pos);
1391 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1393 Looks ahead one (Unicode) character in the text currently being lexed.
1394 Returns the codepoint (unsigned integer value) of the next character,
1395 or -1 if lexing has reached the end of the input text. To consume the
1396 peeked character, use L</lex_read_unichar>.
1398 If the next character is in (or extends into) the next chunk of input
1399 text, the next chunk will be read in. Normally the current chunk will be
1400 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1401 then the current chunk will not be discarded.
1403 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1404 is encountered, an exception is generated.
1410 Perl_lex_peek_unichar(pTHX_ U32 flags)
1414 if (flags & ~(LEX_KEEP_PREVIOUS))
1415 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1416 s = PL_parser->bufptr;
1417 bufend = PL_parser->bufend;
1423 if (!lex_next_chunk(flags))
1425 s = PL_parser->bufptr;
1426 bufend = PL_parser->bufend;
1429 if (UTF8_IS_INVARIANT(head))
1431 if (UTF8_IS_START(head)) {
1432 len = UTF8SKIP(&head);
1433 while ((STRLEN)(bufend-s) < len) {
1434 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1436 s = PL_parser->bufptr;
1437 bufend = PL_parser->bufend;
1440 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1441 if (retlen == (STRLEN)-1) {
1442 /* malformed UTF-8 */
1444 SAVESPTR(PL_warnhook);
1445 PL_warnhook = PERL_WARNHOOK_FATAL;
1446 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1452 if (!lex_next_chunk(flags))
1454 s = PL_parser->bufptr;
1461 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1463 Reads the next (Unicode) character in the text currently being lexed.
1464 Returns the codepoint (unsigned integer value) of the character read,
1465 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1466 if lexing has reached the end of the input text. To non-destructively
1467 examine the next character, use L</lex_peek_unichar> instead.
1469 If the next character is in (or extends into) the next chunk of input
1470 text, the next chunk will be read in. Normally the current chunk will be
1471 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1472 then the current chunk will not be discarded.
1474 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1475 is encountered, an exception is generated.
1481 Perl_lex_read_unichar(pTHX_ U32 flags)
1484 if (flags & ~(LEX_KEEP_PREVIOUS))
1485 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1486 c = lex_peek_unichar(flags);
1489 COPLINE_INC_WITH_HERELINES;
1491 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1493 ++(PL_parser->bufptr);
1499 =for apidoc Amx|void|lex_read_space|U32 flags
1501 Reads optional spaces, in Perl style, in the text currently being
1502 lexed. The spaces may include ordinary whitespace characters and
1503 Perl-style comments. C<#line> directives are processed if encountered.
1504 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1505 at a non-space character (or the end of the input text).
1507 If spaces extend into the next chunk of input text, the next chunk will
1508 be read in. Normally the current chunk will be discarded at the same
1509 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1510 chunk will not be discarded.
1515 #define LEX_NO_INCLINE 0x40000000
1516 #define LEX_NO_NEXT_CHUNK 0x80000000
1519 Perl_lex_read_space(pTHX_ U32 flags)
1522 const bool can_incline = !(flags & LEX_NO_INCLINE);
1523 bool need_incline = 0;
1524 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
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') {
1545 PL_parser->linestart = s;
1551 } else if (isSPACE(c)) {
1553 } else if (c == 0 && s == bufend) {
1557 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1558 #endif /* PERL_MAD */
1559 if (flags & LEX_NO_NEXT_CHUNK)
1561 PL_parser->bufptr = s;
1562 if (can_incline) COPLINE_INC_WITH_HERELINES;
1563 got_more = lex_next_chunk(flags);
1564 if (can_incline) CopLINE_dec(PL_curcop);
1565 s = PL_parser->bufptr;
1566 bufend = PL_parser->bufend;
1569 if (can_incline && need_incline && PL_parser->rsfp) {
1579 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1580 #endif /* PERL_MAD */
1581 PL_parser->bufptr = s;
1586 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1588 This function performs syntax checking on a prototype, C<proto>.
1589 If C<warn> is true, any illegal characters or mismatched brackets
1590 will trigger illegalproto warnings, declaring that they were
1591 detected in the prototype for C<name>.
1593 The return value is C<true> if this is a valid prototype, and
1594 C<false> if it is not, regardless of whether C<warn> was C<true> or
1597 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1604 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1606 STRLEN len, origlen;
1607 char *p = proto ? SvPV(proto, len) : NULL;
1608 bool bad_proto = FALSE;
1609 bool in_brackets = FALSE;
1610 bool after_slash = FALSE;
1611 char greedy_proto = ' ';
1612 bool proto_after_greedy_proto = FALSE;
1613 bool must_be_last = FALSE;
1614 bool underscore = FALSE;
1615 bool bad_proto_after_underscore = FALSE;
1617 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1623 for (; len--; p++) {
1626 proto_after_greedy_proto = TRUE;
1628 if (!strchr(";@%", *p))
1629 bad_proto_after_underscore = TRUE;
1632 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1639 in_brackets = FALSE;
1640 else if ((*p == '@' || *p == '%') &&
1643 must_be_last = TRUE;
1652 after_slash = FALSE;
1657 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1660 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1661 origlen, UNI_DISPLAY_ISPRINT)
1662 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1664 if (proto_after_greedy_proto)
1665 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1666 "Prototype after '%c' for %"SVf" : %s",
1667 greedy_proto, SVfARG(name), p);
1669 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1670 "Missing ']' in prototype for %"SVf" : %s",
1673 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1674 "Illegal character in prototype for %"SVf" : %s",
1676 if (bad_proto_after_underscore)
1677 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1678 "Illegal character after '_' in prototype for %"SVf" : %s",
1682 return (! (proto_after_greedy_proto || bad_proto) );
1687 * This subroutine has nothing to do with tilting, whether at windmills
1688 * or pinball tables. Its name is short for "increment line". It
1689 * increments the current line number in CopLINE(PL_curcop) and checks
1690 * to see whether the line starts with a comment of the form
1691 * # line 500 "foo.pm"
1692 * If so, it sets the current line number and file to the values in the comment.
1696 S_incline(pTHX_ const char *s)
1704 PERL_ARGS_ASSERT_INCLINE;
1706 COPLINE_INC_WITH_HERELINES;
1707 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1708 && s+1 == PL_bufend && *s == ';') {
1709 /* fake newline in string eval */
1710 CopLINE_dec(PL_curcop);
1715 while (SPACE_OR_TAB(*s))
1717 if (strnEQ(s, "line", 4))
1721 if (SPACE_OR_TAB(*s))
1725 while (SPACE_OR_TAB(*s))
1733 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1735 while (SPACE_OR_TAB(*s))
1737 if (*s == '"' && (t = strchr(s+1, '"'))) {
1743 while (!isSPACE(*t))
1747 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1749 if (*e != '\n' && *e != '\0')
1750 return; /* false alarm */
1752 line_num = atoi(n)-1;
1755 const STRLEN len = t - s;
1757 if (!PL_rsfp && !PL_parser->filtered) {
1758 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1759 * to *{"::_<newfilename"} */
1760 /* However, the long form of evals is only turned on by the
1761 debugger - usually they're "(eval %lu)" */
1762 GV * const cfgv = CopFILEGV(PL_curcop);
1765 STRLEN tmplen2 = len;
1769 if (tmplen2 + 2 <= sizeof smallbuf)
1772 Newx(tmpbuf2, tmplen2 + 2, char);
1777 memcpy(tmpbuf2 + 2, s, tmplen2);
1780 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1782 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1783 /* adjust ${"::_<newfilename"} to store the new file name */
1784 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1785 /* The line number may differ. If that is the case,
1786 alias the saved lines that are in the array.
1787 Otherwise alias the whole array. */
1788 if (CopLINE(PL_curcop) == line_num) {
1789 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1790 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1792 else if (GvAV(cfgv)) {
1793 AV * const av = GvAV(cfgv);
1794 const I32 start = CopLINE(PL_curcop)+1;
1795 I32 items = AvFILLp(av) - start;
1797 AV * const av2 = GvAVn(gv2);
1798 SV **svp = AvARRAY(av) + start;
1799 I32 l = (I32)line_num+1;
1801 av_store(av2, l++, SvREFCNT_inc(*svp++));
1806 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1809 CopFILE_free(PL_curcop);
1810 CopFILE_setn(PL_curcop, s, len);
1812 CopLINE_set(PL_curcop, line_num);
1815 #define skipspace(s) skipspace_flags(s, 0)
1818 /* skip space before PL_thistoken */
1821 S_skipspace0(pTHX_ char *s)
1823 PERL_ARGS_ASSERT_SKIPSPACE0;
1830 PL_thiswhite = newSVpvs("");
1831 sv_catsv(PL_thiswhite, PL_skipwhite);
1832 sv_free(PL_skipwhite);
1835 PL_realtokenstart = s - SvPVX(PL_linestr);
1839 /* skip space after PL_thistoken */
1842 S_skipspace1(pTHX_ char *s)
1844 const char *start = s;
1845 I32 startoff = start - SvPVX(PL_linestr);
1847 PERL_ARGS_ASSERT_SKIPSPACE1;
1852 start = SvPVX(PL_linestr) + startoff;
1853 if (!PL_thistoken && PL_realtokenstart >= 0) {
1854 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1855 PL_thistoken = newSVpvn(tstart, start - tstart);
1857 PL_realtokenstart = -1;
1860 PL_nextwhite = newSVpvs("");
1861 sv_catsv(PL_nextwhite, PL_skipwhite);
1862 sv_free(PL_skipwhite);
1869 S_skipspace2(pTHX_ char *s, SV **svp)
1872 const I32 startoff = s - SvPVX(PL_linestr);
1874 PERL_ARGS_ASSERT_SKIPSPACE2;
1877 if (!PL_madskills || !svp)
1879 start = SvPVX(PL_linestr) + startoff;
1880 if (!PL_thistoken && PL_realtokenstart >= 0) {
1881 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1882 PL_thistoken = newSVpvn(tstart, start - tstart);
1883 PL_realtokenstart = -1;
1887 *svp = newSVpvs("");
1888 sv_setsv(*svp, PL_skipwhite);
1889 sv_free(PL_skipwhite);
1898 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1900 AV *av = CopFILEAVx(PL_curcop);
1902 SV * const sv = newSV_type(SVt_PVMG);
1904 sv_setsv_flags(sv, orig_sv, 0); /* no cow */
1906 sv_setpvn(sv, buf, len);
1909 av_store(av, CopLINE(PL_curcop), sv);
1915 * Called to gobble the appropriate amount and type of whitespace.
1916 * Skips comments as well.
1920 S_skipspace_flags(pTHX_ char *s, U32 flags)
1924 #endif /* PERL_MAD */
1925 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1928 sv_free(PL_skipwhite);
1929 PL_skipwhite = NULL;
1931 #endif /* PERL_MAD */
1932 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1933 while (s < PL_bufend && SPACE_OR_TAB(*s))
1936 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1938 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1939 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1940 LEX_NO_NEXT_CHUNK : 0));
1942 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1943 if (PL_linestart > PL_bufptr)
1944 PL_bufptr = PL_linestart;
1949 PL_skipwhite = newSVpvn(start, s-start);
1950 #endif /* PERL_MAD */
1956 * Check the unary operators to ensure there's no ambiguity in how they're
1957 * used. An ambiguous piece of code would be:
1959 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1960 * the +5 is its argument.
1970 if (PL_oldoldbufptr != PL_last_uni)
1972 while (isSPACE(*PL_last_uni))
1975 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1977 if ((t = strchr(s, '(')) && t < PL_bufptr)
1980 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1981 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1982 (int)(s - PL_last_uni), PL_last_uni);
1986 * LOP : macro to build a list operator. Its behaviour has been replaced
1987 * with a subroutine, S_lop() for which LOP is just another name.
1990 #define LOP(f,x) return lop(f,x,s)
1994 * Build a list operator (or something that might be one). The rules:
1995 * - if we have a next token, then it's a list operator [why?]
1996 * - if the next thing is an opening paren, then it's a function
1997 * - else it's a list operator
2001 S_lop(pTHX_ I32 f, int x, char *s)
2005 PERL_ARGS_ASSERT_LOP;
2011 PL_last_lop = PL_oldbufptr;
2012 PL_last_lop_op = (OPCODE)f;
2021 return REPORT(FUNC);
2024 return REPORT(FUNC);
2027 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
2028 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
2029 return REPORT(LSTOP);
2036 * Sets up for an eventual force_next(). start_force(0) basically does
2037 * an unshift, while start_force(-1) does a push. yylex removes items
2042 S_start_force(pTHX_ int where)
2046 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
2047 where = PL_lasttoke;
2048 assert(PL_curforce < 0 || PL_curforce == where);
2049 if (PL_curforce != where) {
2050 for (i = PL_lasttoke; i > where; --i) {
2051 PL_nexttoke[i] = PL_nexttoke[i-1];
2055 if (PL_curforce < 0) /* in case of duplicate start_force() */
2056 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
2057 PL_curforce = where;
2060 curmad('^', newSVpvs(""));
2061 CURMAD('_', PL_nextwhite);
2066 S_curmad(pTHX_ char slot, SV *sv)
2072 if (PL_curforce < 0)
2073 where = &PL_thismad;
2075 where = &PL_nexttoke[PL_curforce].next_mad;
2081 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2083 else if (PL_encoding) {
2084 sv_recode_to_utf8(sv, PL_encoding);
2089 /* keep a slot open for the head of the list? */
2090 if (slot != '_' && *where && (*where)->mad_key == '^') {
2091 (*where)->mad_key = slot;
2092 sv_free(MUTABLE_SV(((*where)->mad_val)));
2093 (*where)->mad_val = (void*)sv;
2096 addmad(newMADsv(slot, sv), where, 0);
2099 # define start_force(where) NOOP
2100 # define curmad(slot, sv) NOOP
2105 * When the lexer realizes it knows the next token (for instance,
2106 * it is reordering tokens for the parser) then it can call S_force_next
2107 * to know what token to return the next time the lexer is called. Caller
2108 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2109 * and possibly PL_expect to ensure the lexer handles the token correctly.
2113 S_force_next(pTHX_ I32 type)
2118 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2119 tokereport(type, &NEXTVAL_NEXTTOKE);
2123 if (PL_curforce < 0)
2124 start_force(PL_lasttoke);
2125 PL_nexttoke[PL_curforce].next_type = type;
2126 if (PL_lex_state != LEX_KNOWNEXT)
2127 PL_lex_defer = PL_lex_state;
2128 PL_lex_state = LEX_KNOWNEXT;
2129 PL_lex_expect = PL_expect;
2132 PL_nexttype[PL_nexttoke] = type;
2134 if (PL_lex_state != LEX_KNOWNEXT) {
2135 PL_lex_defer = PL_lex_state;
2136 PL_lex_expect = PL_expect;
2137 PL_lex_state = LEX_KNOWNEXT;
2145 int yyc = PL_parser->yychar;
2146 if (yyc != YYEMPTY) {
2149 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2150 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2151 PL_lex_allbrackets--;
2153 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2154 } else if (yyc == '('/*)*/) {
2155 PL_lex_allbrackets--;
2160 PL_parser->yychar = YYEMPTY;
2165 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2168 SV * const sv = newSVpvn_utf8(start, len,
2171 && !is_ascii_string((const U8*)start, len)
2172 && is_utf8_string((const U8*)start, len));
2178 * When the lexer knows the next thing is a word (for instance, it has
2179 * just seen -> and it knows that the next char is a word char, then
2180 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2184 * char *start : buffer position (must be within PL_linestr)
2185 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2186 * int check_keyword : if true, Perl checks to make sure the word isn't
2187 * a keyword (do this if the word is a label, e.g. goto FOO)
2188 * int allow_pack : if true, : characters will also be allowed (require,
2189 * use, etc. do this)
2190 * int allow_initial_tick : used by the "sub" lexer only.
2194 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2200 PERL_ARGS_ASSERT_FORCE_WORD;
2202 start = SKIPSPACE1(start);
2204 if (isIDFIRST_lazy_if(s,UTF) ||
2205 (allow_pack && *s == ':') )
2207 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2208 if (check_keyword) {
2209 char *s2 = PL_tokenbuf;
2210 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2212 if (keyword(s2, len, 0))
2215 start_force(PL_curforce);
2217 curmad('X', newSVpvn(start,s-start));
2218 if (token == METHOD) {
2223 PL_expect = XOPERATOR;
2227 curmad('g', newSVpvs( "forced" ));
2228 NEXTVAL_NEXTTOKE.opval
2229 = (OP*)newSVOP(OP_CONST,0,
2230 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2231 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2239 * Called when the lexer wants $foo *foo &foo etc, but the program
2240 * text only contains the "foo" portion. The first argument is a pointer
2241 * to the "foo", and the second argument is the type symbol to prefix.
2242 * Forces the next token to be a "WORD".
2243 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2247 S_force_ident(pTHX_ const char *s, int kind)
2251 PERL_ARGS_ASSERT_FORCE_IDENT;
2254 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2255 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2256 UTF ? SVf_UTF8 : 0));
2257 start_force(PL_curforce);
2258 NEXTVAL_NEXTTOKE.opval = o;
2261 o->op_private = OPpCONST_ENTERED;
2262 /* XXX see note in pp_entereval() for why we forgo typo
2263 warnings if the symbol must be introduced in an eval.
2265 gv_fetchpvn_flags(s, len,
2266 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2267 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2268 kind == '$' ? SVt_PV :
2269 kind == '@' ? SVt_PVAV :
2270 kind == '%' ? SVt_PVHV :
2278 S_force_ident_maybe_lex(pTHX_ char pit)
2280 start_force(PL_curforce);
2281 NEXTVAL_NEXTTOKE.ival = pit;
2286 Perl_str_to_version(pTHX_ SV *sv)
2291 const char *start = SvPV_const(sv,len);
2292 const char * const end = start + len;
2293 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2295 PERL_ARGS_ASSERT_STR_TO_VERSION;
2297 while (start < end) {
2301 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2306 retval += ((NV)n)/nshift;
2315 * Forces the next token to be a version number.
2316 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2317 * and if "guessing" is TRUE, then no new token is created (and the caller
2318 * must use an alternative parsing method).
2322 S_force_version(pTHX_ char *s, int guessing)
2328 I32 startoff = s - SvPVX(PL_linestr);
2331 PERL_ARGS_ASSERT_FORCE_VERSION;
2339 while (isDIGIT(*d) || *d == '_' || *d == '.')
2343 start_force(PL_curforce);
2344 curmad('X', newSVpvn(s,d-s));
2347 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2349 #ifdef USE_LOCALE_NUMERIC
2350 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2351 setlocale(LC_NUMERIC, "C");
2353 s = scan_num(s, &pl_yylval);
2354 #ifdef USE_LOCALE_NUMERIC
2355 setlocale(LC_NUMERIC, loc);
2358 version = pl_yylval.opval;
2359 ver = cSVOPx(version)->op_sv;
2360 if (SvPOK(ver) && !SvNIOK(ver)) {
2361 SvUPGRADE(ver, SVt_PVNV);
2362 SvNV_set(ver, str_to_version(ver));
2363 SvNOK_on(ver); /* hint that it is a version */
2366 else if (guessing) {
2369 sv_free(PL_nextwhite); /* let next token collect whitespace */
2371 s = SvPVX(PL_linestr) + startoff;
2379 if (PL_madskills && !version) {
2380 sv_free(PL_nextwhite); /* let next token collect whitespace */
2382 s = SvPVX(PL_linestr) + startoff;
2385 /* NOTE: The parser sees the package name and the VERSION swapped */
2386 start_force(PL_curforce);
2387 NEXTVAL_NEXTTOKE.opval = version;
2394 * S_force_strict_version
2395 * Forces the next token to be a version number using strict syntax rules.
2399 S_force_strict_version(pTHX_ char *s)
2404 I32 startoff = s - SvPVX(PL_linestr);
2406 const char *errstr = NULL;
2408 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2410 while (isSPACE(*s)) /* leading whitespace */
2413 if (is_STRICT_VERSION(s,&errstr)) {
2415 s = (char *)scan_version(s, ver, 0);
2416 version = newSVOP(OP_CONST, 0, ver);
2418 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2419 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2423 yyerror(errstr); /* version required */
2428 if (PL_madskills && !version) {
2429 sv_free(PL_nextwhite); /* let next token collect whitespace */
2431 s = SvPVX(PL_linestr) + startoff;
2434 /* NOTE: The parser sees the package name and the VERSION swapped */
2435 start_force(PL_curforce);
2436 NEXTVAL_NEXTTOKE.opval = version;
2444 * Tokenize a quoted string passed in as an SV. It finds the next
2445 * chunk, up to end of string or a backslash. It may make a new
2446 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2451 S_tokeq(pTHX_ SV *sv)
2460 PERL_ARGS_ASSERT_TOKEQ;
2465 s = SvPV_force(sv, len);
2466 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2469 /* This is relying on the SV being "well formed" with a trailing '\0' */
2470 while (s < send && !(*s == '\\' && s[1] == '\\'))
2475 if ( PL_hints & HINT_NEW_STRING ) {
2476 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2480 if (s + 1 < send && (s[1] == '\\'))
2481 s++; /* all that, just for this */
2486 SvCUR_set(sv, d - SvPVX_const(sv));
2488 if ( PL_hints & HINT_NEW_STRING )
2489 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2494 * Now come three functions related to double-quote context,
2495 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2496 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2497 * interact with PL_lex_state, and create fake ( ... ) argument lists
2498 * to handle functions and concatenation.
2502 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2507 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2509 * Pattern matching will set PL_lex_op to the pattern-matching op to
2510 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2512 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2514 * Everything else becomes a FUNC.
2516 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2517 * had an OP_CONST or OP_READLINE). This just sets us up for a
2518 * call to S_sublex_push().
2522 S_sublex_start(pTHX)
2525 const I32 op_type = pl_yylval.ival;
2527 if (op_type == OP_NULL) {
2528 pl_yylval.opval = PL_lex_op;
2532 if (op_type == OP_CONST || op_type == OP_READLINE) {
2533 SV *sv = tokeq(PL_lex_stuff);
2535 if (SvTYPE(sv) == SVt_PVIV) {
2536 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2538 const char * const p = SvPV_const(sv, len);
2539 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2543 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2544 PL_lex_stuff = NULL;
2545 /* Allow <FH> // "foo" */
2546 if (op_type == OP_READLINE)
2547 PL_expect = XTERMORDORDOR;
2550 else if (op_type == OP_BACKTICK && PL_lex_op) {
2551 /* readpipe() was overridden */
2552 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2553 pl_yylval.opval = PL_lex_op;
2555 PL_lex_stuff = NULL;
2559 PL_sublex_info.super_state = PL_lex_state;
2560 PL_sublex_info.sub_inwhat = (U16)op_type;
2561 PL_sublex_info.sub_op = PL_lex_op;
2562 PL_lex_state = LEX_INTERPPUSH;
2566 pl_yylval.opval = PL_lex_op;
2576 * Create a new scope to save the lexing state. The scope will be
2577 * ended in S_sublex_done. Returns a '(', starting the function arguments
2578 * to the uc, lc, etc. found before.
2579 * Sets PL_lex_state to LEX_INTERPCONCAT.
2589 PL_lex_state = PL_sublex_info.super_state;
2590 SAVEBOOL(PL_lex_dojoin);
2591 SAVEI32(PL_lex_brackets);
2592 SAVEI32(PL_lex_allbrackets);
2593 SAVEI32(PL_lex_formbrack);
2594 SAVEI8(PL_lex_fakeeof);
2595 SAVEI32(PL_lex_casemods);
2596 SAVEI32(PL_lex_starts);
2597 SAVEI8(PL_lex_state);
2598 SAVESPTR(PL_lex_repl);
2599 SAVEVPTR(PL_lex_inpat);
2600 SAVEI16(PL_lex_inwhat);
2601 SAVECOPLINE(PL_curcop);
2602 SAVEPPTR(PL_bufptr);
2603 SAVEPPTR(PL_bufend);
2604 SAVEPPTR(PL_oldbufptr);
2605 SAVEPPTR(PL_oldoldbufptr);
2606 SAVEPPTR(PL_last_lop);
2607 SAVEPPTR(PL_last_uni);
2608 SAVEPPTR(PL_linestart);
2609 SAVESPTR(PL_linestr);
2610 SAVEGENERICPV(PL_lex_brackstack);
2611 SAVEGENERICPV(PL_lex_casestack);
2612 SAVEGENERICPV(PL_parser->lex_shared);
2613 SAVEBOOL(PL_parser->lex_re_reparsing);
2615 /* The here-doc parser needs to be able to peek into outer lexing
2616 scopes to find the body of the here-doc. So we put PL_linestr and
2617 PL_bufptr into lex_shared, to ‘share’ those values.
2619 PL_parser->lex_shared->ls_linestr = PL_linestr;
2620 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2622 PL_linestr = PL_lex_stuff;
2623 PL_lex_repl = PL_sublex_info.repl;
2624 PL_lex_stuff = NULL;
2625 PL_sublex_info.repl = NULL;
2627 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2628 = SvPVX(PL_linestr);
2629 PL_bufend += SvCUR(PL_linestr);
2630 PL_last_lop = PL_last_uni = NULL;
2631 SAVEFREESV(PL_linestr);
2632 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2634 PL_lex_dojoin = FALSE;
2635 PL_lex_brackets = PL_lex_formbrack = 0;
2636 PL_lex_allbrackets = 0;
2637 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2638 Newx(PL_lex_brackstack, 120, char);
2639 Newx(PL_lex_casestack, 12, char);
2640 PL_lex_casemods = 0;
2641 *PL_lex_casestack = '\0';
2643 PL_lex_state = LEX_INTERPCONCAT;
2644 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2646 Newxz(shared, 1, LEXSHARED);
2647 shared->ls_prev = PL_parser->lex_shared;
2648 PL_parser->lex_shared = shared;
2650 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2651 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2652 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2653 PL_lex_inpat = PL_sublex_info.sub_op;
2655 PL_lex_inpat = NULL;
2657 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2658 PL_in_eval &= ~EVAL_RE_REPARSING;
2665 * Restores lexer state after a S_sublex_push.
2672 if (!PL_lex_starts++) {
2673 SV * const sv = newSVpvs("");
2674 if (SvUTF8(PL_linestr))
2676 PL_expect = XOPERATOR;
2677 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2681 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2682 PL_lex_state = LEX_INTERPCASEMOD;
2686 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2687 assert(PL_lex_inwhat != OP_TRANSR);
2688 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2689 PL_linestr = PL_lex_repl;
2691 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2692 PL_bufend += SvCUR(PL_linestr);
2693 PL_last_lop = PL_last_uni = NULL;
2694 PL_lex_dojoin = FALSE;
2695 PL_lex_brackets = 0;
2696 PL_lex_allbrackets = 0;
2697 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2698 PL_lex_casemods = 0;
2699 *PL_lex_casestack = '\0';
2701 if (SvEVALED(PL_lex_repl)) {
2702 PL_lex_state = LEX_INTERPNORMAL;
2704 /* we don't clear PL_lex_repl here, so that we can check later
2705 whether this is an evalled subst; that means we rely on the
2706 logic to ensure sublex_done() is called again only via the
2707 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2710 PL_lex_state = LEX_INTERPCONCAT;
2720 PL_endwhite = newSVpvs("");
2721 sv_catsv(PL_endwhite, PL_thiswhite);
2725 sv_setpvs(PL_thistoken,"");
2727 PL_realtokenstart = -1;
2731 PL_bufend = SvPVX(PL_linestr);
2732 PL_bufend += SvCUR(PL_linestr);
2733 PL_expect = XOPERATOR;
2734 PL_sublex_info.sub_inwhat = 0;
2739 PERL_STATIC_INLINE SV*
2740 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2742 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2743 * interior, hence to the "}". Finds what the name resolves to, returning
2744 * an SV* containing it; NULL if no valid one found */
2746 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2753 const U8* first_bad_char_loc;
2754 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2756 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2758 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2760 &first_bad_char_loc))
2762 /* If warnings are on, this will print a more detailed analysis of what
2763 * is wrong than the error message below */
2764 utf8n_to_uvuni(first_bad_char_loc,
2765 e - ((char *) first_bad_char_loc),
2768 /* We deliberately don't try to print the malformed character, which
2769 * might not print very well; it also may be just the first of many
2770 * malformations, so don't print what comes after it */
2771 yyerror(Perl_form(aTHX_
2772 "Malformed UTF-8 character immediately after '%.*s'",
2773 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2777 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2778 /* include the <}> */
2779 e - backslash_ptr + 1);
2781 SvREFCNT_dec_NN(res);
2785 /* See if the charnames handler is the Perl core's, and if so, we can skip
2786 * the validation needed for a user-supplied one, as Perl's does its own
2788 table = GvHV(PL_hintgv); /* ^H */
2789 cvp = hv_fetchs(table, "charnames", FALSE);
2790 if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
2791 && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
2793 const char * const name = HvNAME(stash);
2794 if strEQ(name, "_charnames") {
2799 /* Here, it isn't Perl's charname handler. We can't rely on a
2800 * user-supplied handler to validate the input name. For non-ut8 input,
2801 * look to see that the first character is legal. Then loop through the
2802 * rest checking that each is a continuation */
2804 /* This code needs to be sync'ed with a regex in _charnames.pm which does
2808 if (! isALPHAU(*s)) {
2813 if (! isCHARNAME_CONT(*s)) {
2816 if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2817 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2818 "A sequence of multiple spaces in a charnames "
2819 "alias definition is deprecated");
2823 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2824 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2825 "Trailing white-space in a charnames alias "
2826 "definition is deprecated");
2830 /* Similarly for utf8. For invariants can check directly; for other
2831 * Latin1, can calculate their code point and check; otherwise use a
2833 if (UTF8_IS_INVARIANT(*s)) {
2834 if (! isALPHAU(*s)) {
2838 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2839 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
2845 if (! PL_utf8_charname_begin) {
2846 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2847 PL_utf8_charname_begin = _core_swash_init("utf8",
2848 "_Perl_Charname_Begin",
2850 1, 0, NULL, &flags);
2852 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2859 if (UTF8_IS_INVARIANT(*s)) {
2860 if (! isCHARNAME_CONT(*s)) {
2863 if (*s == ' ' && *(s-1) == ' '
2864 && ckWARN_d(WARN_DEPRECATED)) {
2865 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2866 "A sequence of multiple spaces in a charnam"
2867 "es alias definition is deprecated");
2871 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2872 if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
2880 if (! PL_utf8_charname_continue) {
2881 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2882 PL_utf8_charname_continue = _core_swash_init("utf8",
2883 "_Perl_Charname_Continue",
2885 1, 0, NULL, &flags);
2887 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2893 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2894 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2895 "Trailing white-space in a charnames alias "
2896 "definition is deprecated");
2900 if (SvUTF8(res)) { /* Don't accept malformed input */
2901 const U8* first_bad_char_loc;
2903 const char* const str = SvPV_const(res, len);
2904 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2905 /* If warnings are on, this will print a more detailed analysis of
2906 * what is wrong than the error message below */
2907 utf8n_to_uvuni(first_bad_char_loc,
2908 (char *) first_bad_char_loc - str,
2911 /* We deliberately don't try to print the malformed character,
2912 * which might not print very well; it also may be just the first
2913 * of many malformations, so don't print what comes after it */
2916 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2917 (int) (e - backslash_ptr + 1), backslash_ptr,
2918 (int) ((char *) first_bad_char_loc - str), str
2928 int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
2930 /* The final %.*s makes sure that should the trailing NUL be missing
2931 * that this print won't run off the end of the string */
2934 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2935 (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2936 (int)(e - s + bad_char_size), s + bad_char_size
2938 UTF ? SVf_UTF8 : 0);
2946 Extracts the next constant part of a pattern, double-quoted string,
2947 or transliteration. This is terrifying code.
2949 For example, in parsing the double-quoted string "ab\x63$d", it would
2950 stop at the '$' and return an OP_CONST containing 'abc'.
2952 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2953 processing a pattern (PL_lex_inpat is true), a transliteration
2954 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2956 Returns a pointer to the character scanned up to. If this is
2957 advanced from the start pointer supplied (i.e. if anything was
2958 successfully parsed), will leave an OP_CONST for the substring scanned
2959 in pl_yylval. Caller must intuit reason for not parsing further
2960 by looking at the next characters herself.
2964 \N{FOO} => \N{U+hex_for_character_FOO}
2965 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2968 all other \-char, including \N and \N{ apart from \N{ABC}
2971 @ and $ where it appears to be a var, but not for $ as tail anchor
2976 In transliterations:
2977 characters are VERY literal, except for - not at the start or end
2978 of the string, which indicates a range. If the range is in bytes,
2979 scan_const expands the range to the full set of intermediate
2980 characters. If the range is in utf8, the hyphen is replaced with
2981 a certain range mark which will be handled by pmtrans() in op.c.
2983 In double-quoted strings:
2985 double-quoted style: \r and \n
2986 constants: \x31, etc.
2987 deprecated backrefs: \1 (in substitution replacements)
2988 case and quoting: \U \Q \E
2991 scan_const does *not* construct ops to handle interpolated strings.
2992 It stops processing as soon as it finds an embedded $ or @ variable
2993 and leaves it to the caller to work out what's going on.
2995 embedded arrays (whether in pattern or not) could be:
2996 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2998 $ in double-quoted strings must be the symbol of an embedded scalar.
3000 $ in pattern could be $foo or could be tail anchor. Assumption:
3001 it's a tail anchor if $ is the last thing in the string, or if it's
3002 followed by one of "()| \r\n\t"
3004 \1 (backreferences) are turned into $1 in substitutions
3006 The structure of the code is
3007 while (there's a character to process) {
3008 handle transliteration ranges
3009 skip regexp comments /(?#comment)/ and codes /(?{code})/
3010 skip #-initiated comments in //x patterns
3011 check for embedded arrays
3012 check for embedded scalars
3014 deprecate \1 in substitution replacements
3015 handle string-changing backslashes \l \U \Q \E, etc.
3016 switch (what was escaped) {
3017 handle \- in a transliteration (becomes a literal -)
3018 if a pattern and not \N{, go treat as regular character
3019 handle \132 (octal characters)
3020 handle \x15 and \x{1234} (hex characters)
3021 handle \N{name} (named characters, also \N{3,5} in a pattern)
3022 handle \cV (control characters)
3023 handle printf-style backslashes (\f, \r, \n, etc)
3026 } (end if backslash)
3027 handle regular character
3028 } (end while character to read)
3033 S_scan_const(pTHX_ char *start)
3036 char *send = PL_bufend; /* end of the constant */
3037 SV *sv = newSV(send - start); /* sv for the constant. See
3038 note below on sizing. */
3039 char *s = start; /* start of the constant */
3040 char *d = SvPVX(sv); /* destination for copies */
3041 bool dorange = FALSE; /* are we in a translit range? */
3042 bool didrange = FALSE; /* did we just finish a range? */
3043 bool in_charclass = FALSE; /* within /[...]/ */
3044 bool has_utf8 = FALSE; /* Output constant is UTF8 */
3045 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
3046 to be UTF8? But, this can
3047 show as true when the source
3048 isn't utf8, as for example
3049 when it is entirely composed
3051 SV *res; /* result from charnames */
3053 /* Note on sizing: The scanned constant is placed into sv, which is
3054 * initialized by newSV() assuming one byte of output for every byte of
3055 * input. This routine expects newSV() to allocate an extra byte for a
3056 * trailing NUL, which this routine will append if it gets to the end of
3057 * the input. There may be more bytes of input than output (eg., \N{LATIN
3058 * CAPITAL LETTER A}), or more output than input if the constant ends up
3059 * recoded to utf8, but each time a construct is found that might increase
3060 * the needed size, SvGROW() is called. Its size parameter each time is
3061 * based on the best guess estimate at the time, namely the length used so
3062 * far, plus the length the current construct will occupy, plus room for
3063 * the trailing NUL, plus one byte for every input byte still unscanned */
3065 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
3068 UV literal_endpoint = 0;
3069 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
3072 PERL_ARGS_ASSERT_SCAN_CONST;
3074 assert(PL_lex_inwhat != OP_TRANSR);
3075 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3076 /* If we are doing a trans and we know we want UTF8 set expectation */
3077 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
3078 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3081 /* Protect sv from errors and fatal warnings. */
3082 ENTER_with_name("scan_const");
3085 while (s < send || dorange) {
3087 /* get transliterations out of the way (they're most literal) */
3088 if (PL_lex_inwhat == OP_TRANS) {
3089 /* expand a range A-Z to the full set of characters. AIE! */
3091 I32 i; /* current expanded character */
3092 I32 min; /* first character in range */
3093 I32 max; /* last character in range */
3104 char * const c = (char*)utf8_hop((U8*)d, -1);
3108 *c = (char)I8_TO_NATIVE_UTF8(0xff);
3109 /* mark the range as done, and continue */
3115 i = d - SvPVX_const(sv); /* remember current offset */
3118 SvLEN(sv) + (has_utf8 ?
3119 (512 - UTF_CONTINUATION_MARK +
3122 /* How many two-byte within 0..255: 128 in UTF-8,
3123 * 96 in UTF-8-mod. */
3125 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
3127 d = SvPVX(sv) + i; /* refresh d after realloc */
3131 for (j = 0; j <= 1; j++) {
3132 char * const c = (char*)utf8_hop((U8*)d, -1);
3133 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3139 max = (U8)0xff; /* only to \xff */
3140 uvmax = uv; /* \x{100} to uvmax */
3142 d = c; /* eat endpoint chars */
3147 d -= 2; /* eat the first char and the - */
3148 min = (U8)*d; /* first char in range */
3149 max = (U8)d[1]; /* last char in range */
3156 "Invalid range \"%c-%c\" in transliteration operator",
3157 (char)min, (char)max);
3161 if (literal_endpoint == 2 &&
3162 ((isLOWER(min) && isLOWER(max)) ||
3163 (isUPPER(min) && isUPPER(max)))) {
3165 for (i = min; i <= max; i++)
3167 *d++ = NATIVE_TO_NEED(has_utf8,i);
3169 for (i = min; i <= max; i++)
3171 *d++ = NATIVE_TO_NEED(has_utf8,i);
3176 for (i = min; i <= max; i++)
3179 append_utf8_from_native_byte(i, &d);
3187 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3189 *d++ = (char)UTF_TO_NATIVE(0xff);
3191 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3195 /* mark the range as done, and continue */
3199 literal_endpoint = 0;
3204 /* range begins (ignore - as first or last char) */
3205 else if (*s == '-' && s+1 < send && s != start) {
3207 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3214 *d++ = (char)I8_TO_NATIVE_UTF8(0xff); /* use illegal utf8 byte--see pmtrans */
3224 literal_endpoint = 0;
3225 native_range = TRUE;
3230 /* if we get here, we're not doing a transliteration */
3232 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3235 while (s1 >= start && *s1-- == '\\')
3238 in_charclass = TRUE;
3241 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3244 while (s1 >= start && *s1-- == '\\')
3247 in_charclass = FALSE;
3250 /* skip for regexp comments /(?#comment)/, except for the last
3251 * char, which will be done separately.
3252 * Stop on (?{..}) and friends */
3254 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3256 while (s+1 < send && *s != ')')
3257 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3259 else if (!PL_lex_casemods &&
3260 ( s[2] == '{' /* This should match regcomp.c */
3261 || (s[2] == '?' && s[3] == '{')))
3267 /* likewise skip #-initiated comments in //x patterns */
3268 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3269 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3270 while (s+1 < send && *s != '\n')
3271 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3274 /* no further processing of single-quoted regex */
3275 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3276 goto default_action;
3278 /* check for embedded arrays
3279 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3281 else if (*s == '@' && s[1]) {
3282 if (isWORDCHAR_lazy_if(s+1,UTF))
3284 if (strchr(":'{$", s[1]))
3286 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3287 break; /* in regexp, neither @+ nor @- are interpolated */
3290 /* check for embedded scalars. only stop if we're sure it's a
3293 else if (*s == '$') {
3294 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3296 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3298 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3299 "Possible unintended interpolation of $\\ in regex");
3301 break; /* in regexp, $ might be tail anchor */
3305 /* End of else if chain - OP_TRANS rejoin rest */
3308 if (*s == '\\' && s+1 < send) {
3309 char* e; /* Can be used for ending '}', etc. */
3313 /* warn on \1 - \9 in substitution replacements, but note that \11
3314 * is an octal; and \19 is \1 followed by '9' */
3315 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3316 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3318 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3323 /* string-change backslash escapes */
3324 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3328 /* In a pattern, process \N, but skip any other backslash escapes.
3329 * This is because we don't want to translate an escape sequence
3330 * into a meta symbol and have the regex compiler use the meta
3331 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3332 * in spite of this, we do have to process \N here while the proper
3333 * charnames handler is in scope. See bugs #56444 and #62056.
3334 * There is a complication because \N in a pattern may also stand
3335 * for 'match a non-nl', and not mean a charname, in which case its
3336 * processing should be deferred to the regex compiler. To be a
3337 * charname it must be followed immediately by a '{', and not look
3338 * like \N followed by a curly quantifier, i.e., not something like
3339 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3341 else if (PL_lex_inpat
3344 || regcurly(s + 1, FALSE)))
3346 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
3347 goto default_action;
3352 /* quoted - in transliterations */
3354 if (PL_lex_inwhat == OP_TRANS) {
3361 if ((isALPHANUMERIC(*s)))
3362 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3363 "Unrecognized escape \\%c passed through",
3365 /* default action is to copy the quoted character */
3366 goto default_action;
3369 /* eg. \132 indicates the octal constant 0132 */
3370 case '0': case '1': case '2': case '3':
3371 case '4': case '5': case '6': case '7':
3373 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3375 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
3377 if (len < 3 && s < send && isDIGIT(*s)
3378 && ckWARN(WARN_MISC))
3380 Perl_warner(aTHX_ packWARN(WARN_MISC),
3381 "%s", form_short_octal_warning(s, len));
3384 goto NUM_ESCAPE_INSERT;
3386 /* eg. \o{24} indicates the octal constant \024 */
3391 bool valid = grok_bslash_o(&s, &uv, &error,
3392 TRUE, /* Output warning */
3393 FALSE, /* Not strict */
3394 TRUE, /* Output warnings for
3401 goto NUM_ESCAPE_INSERT;
3404 /* eg. \x24 indicates the hex constant 0x24 */
3409 bool valid = grok_bslash_x(&s, &uv, &error,
3410 TRUE, /* Output warning */
3411 FALSE, /* Not strict */
3412 TRUE, /* Output warnings for
3422 /* Insert oct or hex escaped character. There will always be
3423 * enough room in sv since such escapes will be longer than any
3424 * UTF-8 sequence they can end up as, except if they force us
3425 * to recode the rest of the string into utf8 */
3427 /* Here uv is the ordinal of the next character being added in
3428 * unicode (converted from native). */
3429 if (!UNI_IS_INVARIANT(uv)) {
3430 if (!has_utf8 && uv > 255) {
3431 /* Might need to recode whatever we have accumulated so
3432 * far if it contains any chars variant in utf8 or
3435 SvCUR_set(sv, d - SvPVX_const(sv));
3438 /* See Note on sizing above. */
3439 sv_utf8_upgrade_flags_grow(sv,
3440 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3441 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3442 d = SvPVX(sv) + SvCUR(sv);
3447 d = (char*)uvuni_to_utf8((U8*)d, uv);
3448 if (PL_lex_inwhat == OP_TRANS &&
3449 PL_sublex_info.sub_op) {
3450 PL_sublex_info.sub_op->op_private |=
3451 (PL_lex_repl ? OPpTRANS_FROM_UTF
3455 if (uv > 255 && !dorange)
3456 native_range = FALSE;
3469 /* In a non-pattern \N must be a named character, like \N{LATIN
3470 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3471 * mean to match a non-newline. For non-patterns, named
3472 * characters are converted to their string equivalents. In
3473 * patterns, named characters are not converted to their
3474 * ultimate forms for the same reasons that other escapes
3475 * aren't. Instead, they are converted to the \N{U+...} form
3476 * to get the value from the charnames that is in effect right
3477 * now, while preserving the fact that it was a named character
3478 * so that the regex compiler knows this */
3480 /* This section of code doesn't generally use the
3481 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3482 * a close examination of this macro and determined it is a
3483 * no-op except on utfebcdic variant characters. Every
3484 * character generated by this that would normally need to be
3485 * enclosed by this macro is invariant, so the macro is not
3486 * needed, and would complicate use of copy(). XXX There are
3487 * other parts of this file where the macro is used
3488 * inconsistently, but are saved by it being a no-op */
3490 /* The structure of this section of code (besides checking for
3491 * errors and upgrading to utf8) is:
3492 * Further disambiguate between the two meanings of \N, and if
3493 * not a charname, go process it elsewhere
3494 * If of form \N{U+...}, pass it through if a pattern;
3495 * otherwise convert to utf8
3496 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3497 * pattern; otherwise convert to utf8 */
3499 /* Here, s points to the 'N'; the test below is guaranteed to
3500 * succeed if we are being called on a pattern as we already
3501 * know from a test above that the next character is a '{'.
3502 * On a non-pattern \N must mean 'named sequence, which
3503 * requires braces */
3506 yyerror("Missing braces on \\N{}");
3511 /* If there is no matching '}', it is an error. */
3512 if (! (e = strchr(s, '}'))) {
3513 if (! PL_lex_inpat) {
3514 yyerror("Missing right brace on \\N{}");
3516 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3521 /* Here it looks like a named character */
3523 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3524 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3525 | PERL_SCAN_DISALLOW_PREFIX;
3528 /* For \N{U+...}, the '...' is a unicode value even on
3529 * EBCDIC machines */
3530 s += 2; /* Skip to next char after the 'U+' */
3532 uv = grok_hex(s, &len, &flags, NULL);
3533 if (len == 0 || len != (STRLEN)(e - s)) {
3534 yyerror("Invalid hexadecimal number in \\N{U+...}");
3541 /* On non-EBCDIC platforms, pass through to the regex
3542 * compiler unchanged. The reason we evaluated the
3543 * number above is to make sure there wasn't a syntax
3544 * error. But on EBCDIC we convert to native so
3545 * downstream code can continue to assume it's native
3547 s -= 5; /* Include the '\N{U+' */
3549 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3552 (unsigned int) UNI_TO_NATIVE(uv));
3554 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3558 else { /* Not a pattern: convert the hex to string */
3560 /* If destination is not in utf8, unconditionally
3561 * recode it to be so. This is because \N{} implies
3562 * Unicode semantics, and scalars have to be in utf8
3563 * to guarantee those semantics */
3565 SvCUR_set(sv, d - SvPVX_const(sv));
3568 /* See Note on sizing above. */
3569 sv_utf8_upgrade_flags_grow(
3571 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3572 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3573 d = SvPVX(sv) + SvCUR(sv);
3577 /* Add the string to the output */
3578 if (UNI_IS_INVARIANT(uv)) {
3581 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3584 else /* Here is \N{NAME} but not \N{U+...}. */
3585 if ((res = get_and_check_backslash_N_name(s, e)))
3588 const char *str = SvPV_const(res, len);
3591 if (! len) { /* The name resolved to an empty string */
3592 Copy("\\N{}", d, 4, char);
3596 /* In order to not lose information for the regex
3597 * compiler, pass the result in the specially made
3598 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3599 * the code points in hex of each character
3600 * returned by charnames */
3602 const char *str_end = str + len;
3603 const STRLEN off = d - SvPVX_const(sv);
3605 if (! SvUTF8(res)) {
3606 /* For the non-UTF-8 case, we can determine the
3607 * exact length needed without having to parse
3608 * through the string. Each character takes up
3609 * 2 hex digits plus either a trailing dot or
3611 d = off + SvGROW(sv, off
3613 + 6 /* For the "\N{U+", and
3615 + (STRLEN)(send - e));
3616 Copy("\\N{U+", d, 5, char);
3618 while (str < str_end) {
3620 my_snprintf(hex_string, sizeof(hex_string),
3621 "%02X.", (U8) *str);
3622 Copy(hex_string, d, 3, char);
3626 d--; /* We will overwrite below the final
3627 dot with a right brace */
3630 STRLEN char_length; /* cur char's byte length */
3632 /* and the number of bytes after this is
3633 * translated into hex digits */
3634 STRLEN output_length;
3636 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3637 * for max('U+', '.'); and 1 for NUL */
3638 char hex_string[2 * UTF8_MAXBYTES + 5];
3640 /* Get the first character of the result. */
3641 U32 uv = utf8n_to_uvuni((U8 *) str,
3645 /* Convert first code point to hex, including
3646 * the boiler plate before it. For all these,
3647 * we convert to native format so that
3648 * downstream code can continue to assume the
3649 * input is native */
3651 my_snprintf(hex_string, sizeof(hex_string),
3653 (unsigned int) UNI_TO_NATIVE(uv));
3655 /* Make sure there is enough space to hold it */
3656 d = off + SvGROW(sv, off
3658 + (STRLEN)(send - e)
3659 + 2); /* '}' + NUL */
3661 Copy(hex_string, d, output_length, char);
3664 /* For each subsequent character, append dot and
3665 * its ordinal in hex */
3666 while ((str += char_length) < str_end) {
3667 const STRLEN off = d - SvPVX_const(sv);
3668 U32 uv = utf8n_to_uvuni((U8 *) str,
3673 my_snprintf(hex_string,
3676 (unsigned int) UNI_TO_NATIVE(uv));
3678 d = off + SvGROW(sv, off
3680 + (STRLEN)(send - e)
3681 + 2); /* '}' + NUL */
3682 Copy(hex_string, d, output_length, char);
3687 *d++ = '}'; /* Done. Add the trailing brace */
3690 else { /* Here, not in a pattern. Convert the name to a
3693 /* If destination is not in utf8, unconditionally
3694 * recode it to be so. This is because \N{} implies
3695 * Unicode semantics, and scalars have to be in utf8
3696 * to guarantee those semantics */
3698 SvCUR_set(sv, d - SvPVX_const(sv));
3701 /* See Note on sizing above. */
3702 sv_utf8_upgrade_flags_grow(sv,
3703 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3704 len + (STRLEN)(send - s) + 1);
3705 d = SvPVX(sv) + SvCUR(sv);
3707 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3709 /* See Note on sizing above. (NOTE: SvCUR() is not
3710 * set correctly here). */
3711 const STRLEN off = d - SvPVX_const(sv);
3712 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3714 Copy(str, d, len, char);
3720 } /* End \N{NAME} */
3723 native_range = FALSE; /* \N{} is defined to be Unicode */
3725 s = e + 1; /* Point to just after the '}' */
3728 /* \c is a control character */
3732 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3735 yyerror("Missing control char name in \\c");
3739 /* printf-style backslashes, formfeeds, newlines, etc */
3741 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3744 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3747 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3750 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3753 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3756 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3759 *d++ = NATIVE_TO_NEED(has_utf8,'\a');
3765 } /* end if (backslash) */
3772 /* If we started with encoded form, or already know we want it,
3773 then encode the next character */
3774 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3778 /* One might think that it is wasted effort in the case of the
3779 * source being utf8 (this_utf8 == TRUE) to take the next character
3780 * in the source, convert it to an unsigned value, and then convert
3781 * it back again. But the source has not been validated here. The
3782 * routine that does the conversion checks for errors like
3785 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3786 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3788 SvCUR_set(sv, d - SvPVX_const(sv));
3791 /* See Note on sizing above. */
3792 sv_utf8_upgrade_flags_grow(sv,
3793 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3794 need + (STRLEN)(send - s) + 1);
3795 d = SvPVX(sv) + SvCUR(sv);
3797 } else if (need > len) {
3798 /* encoded value larger than old, may need extra space (NOTE:
3799 * SvCUR() is not set correctly here). See Note on sizing
3801 const STRLEN off = d - SvPVX_const(sv);
3802 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3806 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3808 if (uv > 255 && !dorange)
3809 native_range = FALSE;
3813 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3815 } /* while loop to process each character */
3817 /* terminate the string and set up the sv */
3819 SvCUR_set(sv, d - SvPVX_const(sv));
3820 if (SvCUR(sv) >= SvLEN(sv))
3821 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3822 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3825 if (PL_encoding && !has_utf8) {
3826 sv_recode_to_utf8(sv, PL_encoding);
3832 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3833 PL_sublex_info.sub_op->op_private |=
3834 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3838 /* shrink the sv if we allocated more than we used */
3839 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3840 SvPV_shrink_to_cur(sv);
3843 /* return the substring (via pl_yylval) only if we parsed anything */
3844 if (s > PL_bufptr) {
3845 SvREFCNT_inc_simple_void_NN(sv);
3846 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3847 && ! PL_parser->lex_re_reparsing)
3849 const char *const key = PL_lex_inpat ? "qr" : "q";
3850 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3854 if (PL_lex_inwhat == OP_TRANS) {
3857 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3860 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3868 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3871 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3873 LEAVE_with_name("scan_const");
3878 * Returns TRUE if there's more to the expression (e.g., a subscript),
3881 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3883 * ->[ and ->{ return TRUE
3884 * { and [ outside a pattern are always subscripts, so return TRUE
3885 * if we're outside a pattern and it's not { or [, then return FALSE
3886 * if we're in a pattern and the first char is a {
3887 * {4,5} (any digits around the comma) returns FALSE
3888 * if we're in a pattern and the first char is a [
3890 * [SOMETHING] has a funky algorithm to decide whether it's a
3891 * character class or not. It has to deal with things like
3892 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3893 * anything else returns TRUE
3896 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3899 S_intuit_more(pTHX_ char *s)
3903 PERL_ARGS_ASSERT_INTUIT_MORE;
3905 if (PL_lex_brackets)
3907 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3909 if (*s != '{' && *s != '[')
3914 /* In a pattern, so maybe we have {n,m}. */
3916 if (regcurly(s, FALSE)) {
3922 /* On the other hand, maybe we have a character class */
3925 if (*s == ']' || *s == '^')
3928 /* this is terrifying, and it works */
3931 const char * const send = strchr(s,']');
3932 unsigned char un_char, last_un_char;
3933 char tmpbuf[sizeof PL_tokenbuf * 4];
3935 if (!send) /* has to be an expression */
3937 weight = 2; /* let's weigh the evidence */
3941 else if (isDIGIT(*s)) {
3943 if (isDIGIT(s[1]) && s[2] == ']')
3949 Zero(seen,256,char);
3951 for (; s < send; s++) {
3952 last_un_char = un_char;
3953 un_char = (unsigned char)*s;
3958 weight -= seen[un_char] * 10;
3959 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3961 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3962 len = (int)strlen(tmpbuf);
3963 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3964 UTF ? SVf_UTF8 : 0, SVt_PV))
3969 else if (*s == '$' && s[1] &&
3970 strchr("[#!%*<>()-=",s[1])) {
3971 if (/*{*/ strchr("])} =",s[2]))
3980 if (strchr("wds]",s[1]))
3982 else if (seen[(U8)'\''] || seen[(U8)'"'])
3984 else if (strchr("rnftbxcav",s[1]))
3986 else if (isDIGIT(s[1])) {
3988 while (s[1] && isDIGIT(s[1]))
3998 if (strchr("aA01! ",last_un_char))
4000 if (strchr("zZ79~",s[1]))
4002 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4003 weight -= 5; /* cope with negative subscript */
4006 if (!isWORDCHAR(last_un_char)
4007 && !(last_un_char == '$' || last_un_char == '@'
4008 || last_un_char == '&')
4009 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4014 if (keyword(tmpbuf, d - tmpbuf, 0))
4017 if (un_char == last_un_char + 1)
4019 weight -= seen[un_char];
4024 if (weight >= 0) /* probably a character class */
4034 * Does all the checking to disambiguate
4036 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4037 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4039 * First argument is the stuff after the first token, e.g. "bar".
4041 * Not a method if foo is a filehandle.
4042 * Not a method if foo is a subroutine prototyped to take a filehandle.
4043 * Not a method if it's really "Foo $bar"
4044 * Method if it's "foo $bar"
4045 * Not a method if it's really "print foo $bar"
4046 * Method if it's really "foo package::" (interpreted as package->foo)
4047 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4048 * Not a method if bar is a filehandle or package, but is quoted with
4053 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
4056 char *s = start + (*start == '$');
4057 char tmpbuf[sizeof PL_tokenbuf];
4064 PERL_ARGS_ASSERT_INTUIT_METHOD;
4066 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4068 if (cv && SvPOK(cv)) {
4069 const char *proto = CvPROTO(cv);
4071 while (*proto && (isSPACE(*proto) || *proto == ';'))
4078 if (*start == '$') {
4079 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
4080 isUPPER(*PL_tokenbuf))
4083 len = start - SvPVX(PL_linestr);
4087 start = SvPVX(PL_linestr) + len;
4091 return *s == '(' ? FUNCMETH : METHOD;
4094 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4095 /* start is the beginning of the possible filehandle/object,
4096 * and s is the end of it
4097 * tmpbuf is a copy of it (but with single quotes as double colons)
4100 if (!keyword(tmpbuf, len, 0)) {
4101 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4105 soff = s - SvPVX(PL_linestr);
4109 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4110 if (indirgv && GvCVu(indirgv))
4112 /* filehandle or package name makes it a method */
4113 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4115 soff = s - SvPVX(PL_linestr);
4118 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4119 return 0; /* no assumptions -- "=>" quotes bareword */
4121 start_force(PL_curforce);
4122 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4123 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4124 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4126 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4127 ( UTF ? SVf_UTF8 : 0 )));
4132 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4134 return *s == '(' ? FUNCMETH : METHOD;
4140 /* Encoded script support. filter_add() effectively inserts a
4141 * 'pre-processing' function into the current source input stream.
4142 * Note that the filter function only applies to the current source file
4143 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4145 * The datasv parameter (which may be NULL) can be used to pass
4146 * private data to this instance of the filter. The filter function
4147 * can recover the SV using the FILTER_DATA macro and use it to
4148 * store private buffers and state information.
4150 * The supplied datasv parameter is upgraded to a PVIO type
4151 * and the IoDIRP/IoANY field is used to store the function pointer,
4152 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4153 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4154 * private use must be set using malloc'd pointers.
4158 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4167 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4168 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4170 if (!PL_rsfp_filters)
4171 PL_rsfp_filters = newAV();
4174 SvUPGRADE(datasv, SVt_PVIO);
4175 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4176 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4177 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4178 FPTR2DPTR(void *, IoANY(datasv)),
4179 SvPV_nolen(datasv)));
4180 av_unshift(PL_rsfp_filters, 1);
4181 av_store(PL_rsfp_filters, 0, datasv) ;
4183 !PL_parser->filtered
4184 && PL_parser->lex_flags & LEX_EVALBYTES
4185 && PL_bufptr < PL_bufend
4187 const char *s = PL_bufptr;
4188 while (s < PL_bufend) {
4190 SV *linestr = PL_parser->linestr;
4191 char *buf = SvPVX(linestr);
4192 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4193 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4194 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4195 STRLEN const linestart_pos = PL_parser->linestart - buf;
4196 STRLEN const last_uni_pos =
4197 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4198 STRLEN const last_lop_pos =
4199 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4200 av_push(PL_rsfp_filters, linestr);
4201 PL_parser->linestr =
4202 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4203 buf = SvPVX(PL_parser->linestr);
4204 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4205 PL_parser->bufptr = buf + bufptr_pos;
4206 PL_parser->oldbufptr = buf + oldbufptr_pos;
4207 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4208 PL_parser->linestart = buf + linestart_pos;
4209 if (PL_parser->last_uni)
4210 PL_parser->last_uni = buf + last_uni_pos;
4211 if (PL_parser->last_lop)
4212 PL_parser->last_lop = buf + last_lop_pos;
4213 SvLEN(linestr) = SvCUR(linestr);
4214 SvCUR(linestr) = s-SvPVX(linestr);
4215 PL_parser->filtered = 1;
4225 /* Delete most recently added instance of this filter function. */
4227 Perl_filter_del(pTHX_ filter_t funcp)
4232 PERL_ARGS_ASSERT_FILTER_DEL;
4235 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4236 FPTR2DPTR(void*, funcp)));
4238 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4240 /* if filter is on top of stack (usual case) just pop it off */
4241 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4242 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4243 sv_free(av_pop(PL_rsfp_filters));
4247 /* we need to search for the correct entry and clear it */
4248 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4252 /* Invoke the idxth filter function for the current rsfp. */
4253 /* maxlen 0 = read one text line */
4255 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4260 /* This API is bad. It should have been using unsigned int for maxlen.
4261 Not sure if we want to change the API, but if not we should sanity
4262 check the value here. */
4263 unsigned int correct_length
4272 PERL_ARGS_ASSERT_FILTER_READ;
4274 if (!PL_parser || !PL_rsfp_filters)
4276 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4277 /* Provide a default input filter to make life easy. */
4278 /* Note that we append to the line. This is handy. */
4279 DEBUG_P(PerlIO_printf(Perl_debug_log,
4280 "filter_read %d: from rsfp\n", idx));
4281 if (correct_length) {
4284 const int old_len = SvCUR(buf_sv);
4286 /* ensure buf_sv is large enough */
4287 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4288 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4289 correct_length)) <= 0) {
4290 if (PerlIO_error(PL_rsfp))
4291 return -1; /* error */
4293 return 0 ; /* end of file */
4295 SvCUR_set(buf_sv, old_len + len) ;
4296 SvPVX(buf_sv)[old_len + len] = '\0';
4299 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4300 if (PerlIO_error(PL_rsfp))
4301 return -1; /* error */
4303 return 0 ; /* end of file */
4306 return SvCUR(buf_sv);
4308 /* Skip this filter slot if filter has been deleted */
4309 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4310 DEBUG_P(PerlIO_printf(Perl_debug_log,
4311 "filter_read %d: skipped (filter deleted)\n",
4313 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4315 if (SvTYPE(datasv) != SVt_PVIO) {
4316 if (correct_length) {
4318 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4319 if (!remainder) return 0; /* eof */
4320 if (correct_length > remainder) correct_length = remainder;
4321 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4322 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4325 const char *s = SvEND(datasv);
4326 const char *send = SvPVX(datasv) + SvLEN(datasv);
4334 if (s == send) return 0; /* eof */
4335 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4336 SvCUR_set(datasv, s-SvPVX(datasv));
4338 return SvCUR(buf_sv);
4340 /* Get function pointer hidden within datasv */
4341 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4342 DEBUG_P(PerlIO_printf(Perl_debug_log,
4343 "filter_read %d: via function %p (%s)\n",
4344 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4345 /* Call function. The function is expected to */
4346 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4347 /* Return: <0:error, =0:eof, >0:not eof */
4348 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4352 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4356 PERL_ARGS_ASSERT_FILTER_GETS;
4358 #ifdef PERL_CR_FILTER
4359 if (!PL_rsfp_filters) {
4360 filter_add(S_cr_textfilter,NULL);
4363 if (PL_rsfp_filters) {
4365 SvCUR_set(sv, 0); /* start with empty line */
4366 if (FILTER_READ(0, sv, 0) > 0)
4367 return ( SvPVX(sv) ) ;
4372 return (sv_gets(sv, PL_rsfp, append));
4376 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4381 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4383 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4387 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4388 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4390 return GvHV(gv); /* Foo:: */
4393 /* use constant CLASS => 'MyClass' */
4394 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4395 if (gv && GvCV(gv)) {
4396 SV * const sv = cv_const_sv(GvCV(gv));
4398 pkgname = SvPV_const(sv, len);
4401 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4405 * S_readpipe_override
4406 * Check whether readpipe() is overridden, and generates the appropriate
4407 * optree, provided sublex_start() is called afterwards.
4410 S_readpipe_override(pTHX)
4413 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4414 pl_yylval.ival = OP_BACKTICK;
4416 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4418 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4419 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4420 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4422 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4423 op_append_elem(OP_LIST,
4424 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4425 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4432 * The intent of this yylex wrapper is to minimize the changes to the
4433 * tokener when we aren't interested in collecting madprops. It remains
4434 * to be seen how successful this strategy will be...
4441 char *s = PL_bufptr;
4443 /* make sure PL_thiswhite is initialized */
4447 /* previous token ate up our whitespace? */
4448 if (!PL_lasttoke && PL_nextwhite) {
4449 PL_thiswhite = PL_nextwhite;
4453 /* isolate the token, and figure out where it is without whitespace */
4454 PL_realtokenstart = -1;
4458 assert(PL_curforce < 0);
4460 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4461 if (!PL_thistoken) {
4462 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4463 PL_thistoken = newSVpvs("");
4465 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;