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_pending_ident (PL_parser->pending_ident)
70 #define PL_preambled (PL_parser->preambled)
71 #define PL_sublex_info (PL_parser->sublex_info)
72 #define PL_linestr (PL_parser->linestr)
73 #define PL_expect (PL_parser->expect)
74 #define PL_copline (PL_parser->copline)
75 #define PL_bufptr (PL_parser->bufptr)
76 #define PL_oldbufptr (PL_parser->oldbufptr)
77 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
78 #define PL_linestart (PL_parser->linestart)
79 #define PL_bufend (PL_parser->bufend)
80 #define PL_last_uni (PL_parser->last_uni)
81 #define PL_last_lop (PL_parser->last_lop)
82 #define PL_last_lop_op (PL_parser->last_lop_op)
83 #define PL_lex_state (PL_parser->lex_state)
84 #define PL_rsfp (PL_parser->rsfp)
85 #define PL_rsfp_filters (PL_parser->rsfp_filters)
86 #define PL_in_my (PL_parser->in_my)
87 #define PL_in_my_stash (PL_parser->in_my_stash)
88 #define PL_tokenbuf (PL_parser->tokenbuf)
89 #define PL_multi_end (PL_parser->multi_end)
90 #define PL_error_count (PL_parser->error_count)
93 # define PL_endwhite (PL_parser->endwhite)
94 # define PL_faketokens (PL_parser->faketokens)
95 # define PL_lasttoke (PL_parser->lasttoke)
96 # define PL_nextwhite (PL_parser->nextwhite)
97 # define PL_realtokenstart (PL_parser->realtokenstart)
98 # define PL_skipwhite (PL_parser->skipwhite)
99 # define PL_thisclose (PL_parser->thisclose)
100 # define PL_thismad (PL_parser->thismad)
101 # define PL_thisopen (PL_parser->thisopen)
102 # define PL_thisstuff (PL_parser->thisstuff)
103 # define PL_thistoken (PL_parser->thistoken)
104 # define PL_thiswhite (PL_parser->thiswhite)
105 # define PL_thiswhite (PL_parser->thiswhite)
106 # define PL_nexttoke (PL_parser->nexttoke)
107 # define PL_curforce (PL_parser->curforce)
109 # define PL_nexttoke (PL_parser->nexttoke)
110 # define PL_nexttype (PL_parser->nexttype)
111 # define PL_nextval (PL_parser->nextval)
114 /* This can't be done with embed.fnc, because struct yy_parser contains a
115 member named pending_ident, which clashes with the generated #define */
117 S_pending_ident(pTHX);
119 static const char ident_too_long[] = "Identifier too long";
122 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
123 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
125 # define CURMAD(slot,sv)
126 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
129 #define XENUMMASK 0x3f
130 #define XFAKEEOF 0x40
131 #define XFAKEBRACK 0x80
133 #ifdef USE_UTF8_SCRIPTS
134 # define UTF (!IN_BYTES)
136 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
139 /* The maximum number of characters preceding the unrecognized one to display */
140 #define UNRECOGNIZED_PRECEDE_COUNT 10
142 /* In variables named $^X, these are the legal values for X.
143 * 1999-02-27 mjd-perl-patch@plover.com */
144 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
146 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
148 /* LEX_* are values for PL_lex_state, the state of the lexer.
149 * They are arranged oddly so that the guard on the switch statement
150 * can get by with a single comparison (if the compiler is smart enough).
153 /* #define LEX_NOTPARSING 11 is done in perl.h. */
155 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
156 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
157 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
158 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
159 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
161 /* at end of code, eg "$x" followed by: */
162 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
163 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
165 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
166 string or after \E, $foo, etc */
167 #define LEX_INTERPCONST 2 /* NOT USED */
168 #define LEX_FORMLINE 1 /* expecting a format line */
169 #define LEX_KNOWNEXT 0 /* next token known; just return it */
173 static const char* const lex_state_names[] = {
192 #include "keywords.h"
194 /* CLINE is a macro that ensures PL_copline has a sane value */
199 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
202 # define SKIPSPACE0(s) skipspace0(s)
203 # define SKIPSPACE1(s) skipspace1(s)
204 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
205 # define PEEKSPACE(s) skipspace2(s,0)
207 # define SKIPSPACE0(s) skipspace(s)
208 # define SKIPSPACE1(s) skipspace(s)
209 # define SKIPSPACE2(s,tsv) skipspace(s)
210 # define PEEKSPACE(s) skipspace(s)
214 * Convenience functions to return different tokens and prime the
215 * lexer for the next token. They all take an argument.
217 * TOKEN : generic token (used for '(', DOLSHARP, etc)
218 * OPERATOR : generic operator
219 * AOPERATOR : assignment operator
220 * PREBLOCK : beginning the block after an if, while, foreach, ...
221 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
222 * PREREF : *EXPR where EXPR is not a simple identifier
223 * TERM : expression term
224 * LOOPX : loop exiting command (goto, last, dump, etc)
225 * FTST : file test operator
226 * FUN0 : zero-argument function
227 * FUN0OP : zero-argument function, with its op created in this file
228 * FUN1 : not used, except for not, which isn't a UNIOP
229 * BOop : bitwise or or xor
231 * SHop : shift operator
232 * PWop : power operator
233 * PMop : pattern-matching operator
234 * Aop : addition-level operator
235 * Mop : multiplication-level operator
236 * Eop : equality-testing operator
237 * Rop : relational operator <= != gt
239 * Also see LOP and lop() below.
242 #ifdef DEBUGGING /* Serve -DT. */
243 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
245 # define REPORT(retval) (retval)
248 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
249 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
250 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
251 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
252 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
253 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
254 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
255 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
256 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
257 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
258 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
259 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
260 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
261 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
262 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
263 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
264 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
265 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
266 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
267 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
268 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
270 /* This bit of chicanery makes a unary function followed by
271 * a parenthesis into a function with one argument, highest precedence.
272 * The UNIDOR macro is for unary functions that can be followed by the //
273 * operator (such as C<shift // 0>).
275 #define UNI2(f,x) { \
276 pl_yylval.ival = f; \
279 PL_last_uni = PL_oldbufptr; \
280 PL_last_lop_op = f; \
282 return REPORT( (int)FUNC1 ); \
284 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
286 #define UNI(f) UNI2(f,XTERM)
287 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
289 #define UNIBRACK(f) { \
290 pl_yylval.ival = f; \
292 PL_last_uni = PL_oldbufptr; \
294 return REPORT( (int)FUNC1 ); \
296 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
299 /* grandfather return to old style */
302 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
303 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
304 pl_yylval.ival = (f); \
312 /* how to interpret the pl_yylval associated with the token */
316 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
322 static struct debug_tokens {
324 enum token_type type;
326 } const debug_tokens[] =
328 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
329 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
330 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
331 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
332 { ARROW, TOKENTYPE_NONE, "ARROW" },
333 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
334 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
335 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
336 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
337 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
338 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
339 { DO, TOKENTYPE_NONE, "DO" },
340 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
341 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
342 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
343 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
344 { ELSE, TOKENTYPE_NONE, "ELSE" },
345 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
346 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
347 { FOR, TOKENTYPE_IVAL, "FOR" },
348 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
349 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
350 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
351 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
352 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
353 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
354 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
355 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
356 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
357 { IF, TOKENTYPE_IVAL, "IF" },
358 { LABEL, TOKENTYPE_PVAL, "LABEL" },
359 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
360 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
361 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
362 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
363 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
364 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
365 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
366 { MY, TOKENTYPE_IVAL, "MY" },
367 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
368 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
369 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
370 { OROP, TOKENTYPE_IVAL, "OROP" },
371 { OROR, TOKENTYPE_NONE, "OROR" },
372 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
373 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
374 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
375 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
376 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
377 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
378 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
379 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
380 { PREINC, TOKENTYPE_NONE, "PREINC" },
381 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
382 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
383 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
384 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
385 { SUB, TOKENTYPE_NONE, "SUB" },
386 { THING, TOKENTYPE_OPVAL, "THING" },
387 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
388 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
389 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
390 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
391 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
392 { USE, TOKENTYPE_IVAL, "USE" },
393 { WHEN, TOKENTYPE_IVAL, "WHEN" },
394 { WHILE, TOKENTYPE_IVAL, "WHILE" },
395 { WORD, TOKENTYPE_OPVAL, "WORD" },
396 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
397 { 0, TOKENTYPE_NONE, NULL }
400 /* dump the returned token in rv, plus any optional arg in pl_yylval */
403 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
407 PERL_ARGS_ASSERT_TOKEREPORT;
410 const char *name = NULL;
411 enum token_type type = TOKENTYPE_NONE;
412 const struct debug_tokens *p;
413 SV* const report = newSVpvs("<== ");
415 for (p = debug_tokens; p->token; p++) {
416 if (p->token == (int)rv) {
423 Perl_sv_catpv(aTHX_ report, name);
424 else if ((char)rv > ' ' && (char)rv < '~')
425 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
427 sv_catpvs(report, "EOF");
429 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
432 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
435 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
437 case TOKENTYPE_OPNUM:
438 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
439 PL_op_name[lvalp->ival]);
442 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
444 case TOKENTYPE_OPVAL:
446 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
447 PL_op_name[lvalp->opval->op_type]);
448 if (lvalp->opval->op_type == OP_CONST) {
449 Perl_sv_catpvf(aTHX_ report, " %s",
450 SvPEEK(cSVOPx_sv(lvalp->opval)));
455 sv_catpvs(report, "(opval=null)");
458 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
464 /* print the buffer with suitable escapes */
467 S_printbuf(pTHX_ const char *const fmt, const char *const s)
469 SV* const tmp = newSVpvs("");
471 PERL_ARGS_ASSERT_PRINTBUF;
473 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
480 S_deprecate_commaless_var_list(pTHX) {
482 deprecate("comma-less variable list");
483 return REPORT(','); /* grandfather non-comma-format format */
489 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
490 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
494 S_ao(pTHX_ int toketype)
497 if (*PL_bufptr == '=') {
499 if (toketype == ANDAND)
500 pl_yylval.ival = OP_ANDASSIGN;
501 else if (toketype == OROR)
502 pl_yylval.ival = OP_ORASSIGN;
503 else if (toketype == DORDOR)
504 pl_yylval.ival = OP_DORASSIGN;
512 * When Perl expects an operator and finds something else, no_op
513 * prints the warning. It always prints "<something> found where
514 * operator expected. It prints "Missing semicolon on previous line?"
515 * if the surprise occurs at the start of the line. "do you need to
516 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
517 * where the compiler doesn't know if foo is a method call or a function.
518 * It prints "Missing operator before end of line" if there's nothing
519 * after the missing operator, or "... before <...>" if there is something
520 * after the missing operator.
524 S_no_op(pTHX_ const char *const what, char *s)
527 char * const oldbp = PL_bufptr;
528 const bool is_first = (PL_oldbufptr == PL_linestart);
530 PERL_ARGS_ASSERT_NO_OP;
536 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
537 if (ckWARN_d(WARN_SYNTAX)) {
539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
540 "\t(Missing semicolon on previous line?)\n");
541 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
543 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
545 if (t < PL_bufptr && isSPACE(*t))
546 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
547 "\t(Do you need to predeclare %.*s?)\n",
548 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
552 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
553 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
561 * Complain about missing quote/regexp/heredoc terminator.
562 * If it's called with NULL then it cauterizes the line buffer.
563 * If we're in a delimited string and the delimiter is a control
564 * character, it's reformatted into a two-char sequence like ^C.
569 S_missingterm(pTHX_ char *s)
575 char * const nl = strrchr(s,'\n');
579 else if (isCNTRL(PL_multi_close)) {
581 tmpbuf[1] = (char)toCTRL(PL_multi_close);
586 *tmpbuf = (char)PL_multi_close;
590 q = strchr(s,'"') ? '\'' : '"';
591 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
595 * Check whether the named feature is enabled.
598 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
601 HV * const hinthv = GvHV(PL_hintgv);
602 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
604 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
606 if (namelen > MAX_FEATURE_LEN)
608 memcpy(&he_name[8], name, namelen);
610 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
614 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
615 * utf16-to-utf8-reversed.
618 #ifdef PERL_CR_FILTER
622 register const char *s = SvPVX_const(sv);
623 register const char * const e = s + SvCUR(sv);
625 PERL_ARGS_ASSERT_STRIP_RETURN;
627 /* outer loop optimized to do nothing if there are no CR-LFs */
629 if (*s++ == '\r' && *s == '\n') {
630 /* hit a CR-LF, need to copy the rest */
631 register char *d = s - 1;
634 if (*s == '\r' && s[1] == '\n')
645 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
647 const I32 count = FILTER_READ(idx+1, sv, maxlen);
648 if (count > 0 && !maxlen)
655 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
657 Creates and initialises a new lexer/parser state object, supplying
658 a context in which to lex and parse from a new source of Perl code.
659 A pointer to the new state object is placed in L</PL_parser>. An entry
660 is made on the save stack so that upon unwinding the new state object
661 will be destroyed and the former value of L</PL_parser> will be restored.
662 Nothing else need be done to clean up the parsing context.
664 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
665 non-null, provides a string (in SV form) containing code to be parsed.
666 A copy of the string is made, so subsequent modification of I<line>
667 does not affect parsing. I<rsfp>, if non-null, provides an input stream
668 from which code will be read to be parsed. If both are non-null, the
669 code in I<line> comes first and must consist of complete lines of input,
670 and I<rsfp> supplies the remainder of the source.
672 The I<flags> parameter is reserved for future use, and must always
673 be zero, except for one flag that is currently reserved for perl's internal
679 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
680 can share filters with the current parser. */
683 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
686 const char *s = NULL;
688 yy_parser *parser, *oparser;
689 if (flags && flags & ~LEX_START_FLAGS)
690 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
692 /* create and initialise a parser */
694 Newxz(parser, 1, yy_parser);
695 parser->old_parser = oparser = PL_parser;
698 parser->stack = NULL;
700 parser->stack_size = 0;
702 /* on scope exit, free this parser and restore any outer one */
704 parser->saved_curcop = PL_curcop;
706 /* initialise lexer state */
709 parser->curforce = -1;
711 parser->nexttoke = 0;
713 parser->error_count = oparser ? oparser->error_count : 0;
714 parser->copline = NOLINE;
715 parser->lex_state = LEX_NORMAL;
716 parser->expect = XSTATE;
718 parser->rsfp_filters =
719 !(flags & LEX_START_SAME_FILTER) || !oparser
721 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
723 Newx(parser->lex_brackstack, 120, char);
724 Newx(parser->lex_casestack, 12, char);
725 *parser->lex_casestack = '\0';
728 s = SvPV_const(line, len);
734 parser->linestr = newSVpvs("\n;");
736 parser->linestr = newSVpvn_flags(s, len, SvUTF8(line));
738 sv_catpvs(parser->linestr, "\n;");
740 parser->oldoldbufptr =
743 parser->linestart = SvPVX(parser->linestr);
744 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
745 parser->last_lop = parser->last_uni = NULL;
746 parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES);
748 parser->in_pod = parser->filtered = 0;
752 /* delete a parser object */
755 Perl_parser_free(pTHX_ const yy_parser *parser)
757 PERL_ARGS_ASSERT_PARSER_FREE;
759 PL_curcop = parser->saved_curcop;
760 SvREFCNT_dec(parser->linestr);
762 if (parser->rsfp == PerlIO_stdin())
763 PerlIO_clearerr(parser->rsfp);
764 else if (parser->rsfp && (!parser->old_parser ||
765 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
766 PerlIO_close(parser->rsfp);
767 SvREFCNT_dec(parser->rsfp_filters);
769 Safefree(parser->lex_brackstack);
770 Safefree(parser->lex_casestack);
771 PL_parser = parser->old_parser;
777 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
779 Buffer scalar containing the chunk currently under consideration of the
780 text currently being lexed. This is always a plain string scalar (for
781 which C<SvPOK> is true). It is not intended to be used as a scalar by
782 normal scalar means; instead refer to the buffer directly by the pointer
783 variables described below.
785 The lexer maintains various C<char*> pointers to things in the
786 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
787 reallocated, all of these pointers must be updated. Don't attempt to
788 do this manually, but rather use L</lex_grow_linestr> if you need to
789 reallocate the buffer.
791 The content of the text chunk in the buffer is commonly exactly one
792 complete line of input, up to and including a newline terminator,
793 but there are situations where it is otherwise. The octets of the
794 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
795 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
796 flag on this scalar, which may disagree with it.
798 For direct examination of the buffer, the variable
799 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
800 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
801 of these pointers is usually preferable to examination of the scalar
802 through normal scalar means.
804 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
806 Direct pointer to the end of the chunk of text currently being lexed, the
807 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
808 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
809 always located at the end of the buffer, and does not count as part of
810 the buffer's contents.
812 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
814 Points to the current position of lexing inside the lexer buffer.
815 Characters around this point may be freely examined, within
816 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
817 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
818 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
820 Lexing code (whether in the Perl core or not) moves this pointer past
821 the characters that it consumes. It is also expected to perform some
822 bookkeeping whenever a newline character is consumed. This movement
823 can be more conveniently performed by the function L</lex_read_to>,
824 which handles newlines appropriately.
826 Interpretation of the buffer's octets can be abstracted out by
827 using the slightly higher-level functions L</lex_peek_unichar> and
828 L</lex_read_unichar>.
830 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
832 Points to the start of the current line inside the lexer buffer.
833 This is useful for indicating at which column an error occurred, and
834 not much else. This must be updated by any lexing code that consumes
835 a newline; the function L</lex_read_to> handles this detail.
841 =for apidoc Amx|bool|lex_bufutf8
843 Indicates whether the octets in the lexer buffer
844 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
845 of Unicode characters. If not, they should be interpreted as Latin-1
846 characters. This is analogous to the C<SvUTF8> flag for scalars.
848 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
849 contains valid UTF-8. Lexing code must be robust in the face of invalid
852 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
853 is significant, but not the whole story regarding the input character
854 encoding. Normally, when a file is being read, the scalar contains octets
855 and its C<SvUTF8> flag is off, but the octets should be interpreted as
856 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
857 however, the scalar may have the C<SvUTF8> flag on, and in this case its
858 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
859 is in effect. This logic may change in the future; use this function
860 instead of implementing the logic yourself.
866 Perl_lex_bufutf8(pTHX)
872 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
874 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
875 at least I<len> octets (including terminating NUL). Returns a
876 pointer to the reallocated buffer. This is necessary before making
877 any direct modification of the buffer that would increase its length.
878 L</lex_stuff_pvn> provides a more convenient way to insert text into
881 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
882 this function updates all of the lexer's variables that point directly
889 Perl_lex_grow_linestr(pTHX_ STRLEN len)
893 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
894 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
895 linestr = PL_parser->linestr;
896 buf = SvPVX(linestr);
897 if (len <= SvLEN(linestr))
899 bufend_pos = PL_parser->bufend - buf;
900 bufptr_pos = PL_parser->bufptr - buf;
901 oldbufptr_pos = PL_parser->oldbufptr - buf;
902 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
903 linestart_pos = PL_parser->linestart - buf;
904 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
905 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
906 buf = sv_grow(linestr, len);
907 PL_parser->bufend = buf + bufend_pos;
908 PL_parser->bufptr = buf + bufptr_pos;
909 PL_parser->oldbufptr = buf + oldbufptr_pos;
910 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
911 PL_parser->linestart = buf + linestart_pos;
912 if (PL_parser->last_uni)
913 PL_parser->last_uni = buf + last_uni_pos;
914 if (PL_parser->last_lop)
915 PL_parser->last_lop = buf + last_lop_pos;
920 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
922 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
923 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
924 reallocating the buffer if necessary. This means that lexing code that
925 runs later will see the characters as if they had appeared in the input.
926 It is not recommended to do this as part of normal parsing, and most
927 uses of this facility run the risk of the inserted characters being
928 interpreted in an unintended manner.
930 The string to be inserted is represented by I<len> octets starting
931 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
932 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
933 The characters are recoded for the lexer buffer, according to how the
934 buffer is currently being interpreted (L</lex_bufutf8>). If a string
935 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
936 function is more convenient.
942 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
946 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
947 if (flags & ~(LEX_STUFF_UTF8))
948 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
950 if (flags & LEX_STUFF_UTF8) {
954 const char *p, *e = pv+len;
955 for (p = pv; p != e; p++)
956 highhalf += !!(((U8)*p) & 0x80);
959 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
960 bufptr = PL_parser->bufptr;
961 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
962 SvCUR_set(PL_parser->linestr,
963 SvCUR(PL_parser->linestr) + len+highhalf);
964 PL_parser->bufend += len+highhalf;
965 for (p = pv; p != e; p++) {
968 *bufptr++ = (char)(0xc0 | (c >> 6));
969 *bufptr++ = (char)(0x80 | (c & 0x3f));
976 if (flags & LEX_STUFF_UTF8) {
978 const char *p, *e = pv+len;
979 for (p = pv; p != e; p++) {
982 Perl_croak(aTHX_ "Lexing code attempted to stuff "
983 "non-Latin-1 character into Latin-1 input");
984 } else if (c >= 0xc2 && p+1 != e &&
985 (((U8)p[1]) & 0xc0) == 0x80) {
988 } else if (c >= 0x80) {
989 /* malformed UTF-8 */
991 SAVESPTR(PL_warnhook);
992 PL_warnhook = PERL_WARNHOOK_FATAL;
993 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
999 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1000 bufptr = PL_parser->bufptr;
1001 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1002 SvCUR_set(PL_parser->linestr,
1003 SvCUR(PL_parser->linestr) + len-highhalf);
1004 PL_parser->bufend += len-highhalf;
1005 for (p = pv; p != e; p++) {
1008 *bufptr++ = (char)(((c & 0x3) << 6) | (p[1] & 0x3f));
1011 *bufptr++ = (char)c;
1016 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1017 bufptr = PL_parser->bufptr;
1018 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1019 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1020 PL_parser->bufend += len;
1021 Copy(pv, bufptr, len, char);
1027 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1029 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1030 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1031 reallocating the buffer if necessary. This means that lexing code that
1032 runs later will see the characters as if they had appeared in the input.
1033 It is not recommended to do this as part of normal parsing, and most
1034 uses of this facility run the risk of the inserted characters being
1035 interpreted in an unintended manner.
1037 The string to be inserted is represented by octets starting at I<pv>
1038 and continuing to the first nul. These octets are interpreted as either
1039 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1040 in I<flags>. The characters are recoded for the lexer buffer, according
1041 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1042 If it is not convenient to nul-terminate a string to be inserted, the
1043 L</lex_stuff_pvn> function is more appropriate.
1049 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1051 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1052 lex_stuff_pvn(pv, strlen(pv), flags);
1056 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1058 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1059 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1060 reallocating the buffer if necessary. This means that lexing code that
1061 runs later will see the characters as if they had appeared in the input.
1062 It is not recommended to do this as part of normal parsing, and most
1063 uses of this facility run the risk of the inserted characters being
1064 interpreted in an unintended manner.
1066 The string to be inserted is the string value of I<sv>. The characters
1067 are recoded for the lexer buffer, according to how the buffer is currently
1068 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1069 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1070 need to construct a scalar.
1076 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1080 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1082 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1084 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1088 =for apidoc Amx|void|lex_unstuff|char *ptr
1090 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1091 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1092 This hides the discarded text from any lexing code that runs later,
1093 as if the text had never appeared.
1095 This is not the normal way to consume lexed text. For that, use
1102 Perl_lex_unstuff(pTHX_ char *ptr)
1106 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1107 buf = PL_parser->bufptr;
1109 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1112 bufend = PL_parser->bufend;
1114 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1115 unstuff_len = ptr - buf;
1116 Move(ptr, buf, bufend+1-ptr, char);
1117 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1118 PL_parser->bufend = bufend - unstuff_len;
1122 =for apidoc Amx|void|lex_read_to|char *ptr
1124 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1125 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1126 performing the correct bookkeeping whenever a newline character is passed.
1127 This is the normal way to consume lexed text.
1129 Interpretation of the buffer's octets can be abstracted out by
1130 using the slightly higher-level functions L</lex_peek_unichar> and
1131 L</lex_read_unichar>.
1137 Perl_lex_read_to(pTHX_ char *ptr)
1140 PERL_ARGS_ASSERT_LEX_READ_TO;
1141 s = PL_parser->bufptr;
1142 if (ptr < s || ptr > PL_parser->bufend)
1143 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1144 for (; s != ptr; s++)
1146 CopLINE_inc(PL_curcop);
1147 PL_parser->linestart = s+1;
1149 PL_parser->bufptr = ptr;
1153 =for apidoc Amx|void|lex_discard_to|char *ptr
1155 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1156 up to I<ptr>. The remaining content of the buffer will be moved, and
1157 all pointers into the buffer updated appropriately. I<ptr> must not
1158 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1159 it is not permitted to discard text that has yet to be lexed.
1161 Normally it is not necessarily to do this directly, because it suffices to
1162 use the implicit discarding behaviour of L</lex_next_chunk> and things
1163 based on it. However, if a token stretches across multiple lines,
1164 and the lexing code has kept multiple lines of text in the buffer for
1165 that purpose, then after completion of the token it would be wise to
1166 explicitly discard the now-unneeded earlier lines, to avoid future
1167 multi-line tokens growing the buffer without bound.
1173 Perl_lex_discard_to(pTHX_ char *ptr)
1177 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1178 buf = SvPVX(PL_parser->linestr);
1180 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1183 if (ptr > PL_parser->bufptr)
1184 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1185 discard_len = ptr - buf;
1186 if (PL_parser->oldbufptr < ptr)
1187 PL_parser->oldbufptr = ptr;
1188 if (PL_parser->oldoldbufptr < ptr)
1189 PL_parser->oldoldbufptr = ptr;
1190 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1191 PL_parser->last_uni = NULL;
1192 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1193 PL_parser->last_lop = NULL;
1194 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1195 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1196 PL_parser->bufend -= discard_len;
1197 PL_parser->bufptr -= discard_len;
1198 PL_parser->oldbufptr -= discard_len;
1199 PL_parser->oldoldbufptr -= discard_len;
1200 if (PL_parser->last_uni)
1201 PL_parser->last_uni -= discard_len;
1202 if (PL_parser->last_lop)
1203 PL_parser->last_lop -= discard_len;
1207 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1209 Reads in the next chunk of text to be lexed, appending it to
1210 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1211 looked to the end of the current chunk and wants to know more. It is
1212 usual, but not necessary, for lexing to have consumed the entirety of
1213 the current chunk at this time.
1215 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1216 chunk (i.e., the current chunk has been entirely consumed), normally the
1217 current chunk will be discarded at the same time that the new chunk is
1218 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1219 will not be discarded. If the current chunk has not been entirely
1220 consumed, then it will not be discarded regardless of the flag.
1222 Returns true if some new text was added to the buffer, or false if the
1223 buffer has reached the end of the input text.
1228 #define LEX_FAKE_EOF 0x80000000
1231 Perl_lex_next_chunk(pTHX_ U32 flags)
1235 STRLEN old_bufend_pos, new_bufend_pos;
1236 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1237 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1238 bool got_some_for_debugger = 0;
1240 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF))
1241 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1242 linestr = PL_parser->linestr;
1243 buf = SvPVX(linestr);
1244 if (!(flags & LEX_KEEP_PREVIOUS) &&
1245 PL_parser->bufptr == PL_parser->bufend) {
1246 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1248 if (PL_parser->last_uni != PL_parser->bufend)
1249 PL_parser->last_uni = NULL;
1250 if (PL_parser->last_lop != PL_parser->bufend)
1251 PL_parser->last_lop = NULL;
1252 last_uni_pos = last_lop_pos = 0;
1256 old_bufend_pos = PL_parser->bufend - buf;
1257 bufptr_pos = PL_parser->bufptr - buf;
1258 oldbufptr_pos = PL_parser->oldbufptr - buf;
1259 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1260 linestart_pos = PL_parser->linestart - buf;
1261 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1262 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1264 if (flags & LEX_FAKE_EOF) {
1266 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1268 } else if (filter_gets(linestr, old_bufend_pos)) {
1270 got_some_for_debugger = 1;
1272 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1273 sv_setpvs(linestr, "");
1275 /* End of real input. Close filehandle (unless it was STDIN),
1276 * then add implicit termination.
1278 if ((PerlIO*)PL_parser->rsfp == PerlIO_stdin())
1279 PerlIO_clearerr(PL_parser->rsfp);
1280 else if (PL_parser->rsfp)
1281 (void)PerlIO_close(PL_parser->rsfp);
1282 PL_parser->rsfp = NULL;
1283 PL_parser->in_pod = PL_parser->filtered = 0;
1285 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1288 if (!PL_in_eval && PL_minus_p) {
1290 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1291 PL_minus_n = PL_minus_p = 0;
1292 } else if (!PL_in_eval && PL_minus_n) {
1293 sv_catpvs(linestr, /*{*/";}");
1296 sv_catpvs(linestr, ";");
1299 buf = SvPVX(linestr);
1300 new_bufend_pos = SvCUR(linestr);
1301 PL_parser->bufend = buf + new_bufend_pos;
1302 PL_parser->bufptr = buf + bufptr_pos;
1303 PL_parser->oldbufptr = buf + oldbufptr_pos;
1304 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1305 PL_parser->linestart = buf + linestart_pos;
1306 if (PL_parser->last_uni)
1307 PL_parser->last_uni = buf + last_uni_pos;
1308 if (PL_parser->last_lop)
1309 PL_parser->last_lop = buf + last_lop_pos;
1310 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1311 PL_curstash != PL_debstash) {
1312 /* debugger active and we're not compiling the debugger code,
1313 * so store the line into the debugger's array of lines
1315 update_debugger_info(NULL, buf+old_bufend_pos,
1316 new_bufend_pos-old_bufend_pos);
1322 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1324 Looks ahead one (Unicode) character in the text currently being lexed.
1325 Returns the codepoint (unsigned integer value) of the next character,
1326 or -1 if lexing has reached the end of the input text. To consume the
1327 peeked character, use L</lex_read_unichar>.
1329 If the next character is in (or extends into) the next chunk of input
1330 text, the next chunk will be read in. Normally the current chunk will be
1331 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1332 then the current chunk will not be discarded.
1334 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1335 is encountered, an exception is generated.
1341 Perl_lex_peek_unichar(pTHX_ U32 flags)
1345 if (flags & ~(LEX_KEEP_PREVIOUS))
1346 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1347 s = PL_parser->bufptr;
1348 bufend = PL_parser->bufend;
1354 if (!lex_next_chunk(flags))
1356 s = PL_parser->bufptr;
1357 bufend = PL_parser->bufend;
1363 len = PL_utf8skip[head];
1364 while ((STRLEN)(bufend-s) < len) {
1365 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1367 s = PL_parser->bufptr;
1368 bufend = PL_parser->bufend;
1371 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1372 if (retlen == (STRLEN)-1) {
1373 /* malformed UTF-8 */
1375 SAVESPTR(PL_warnhook);
1376 PL_warnhook = PERL_WARNHOOK_FATAL;
1377 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1383 if (!lex_next_chunk(flags))
1385 s = PL_parser->bufptr;
1392 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1394 Reads the next (Unicode) character in the text currently being lexed.
1395 Returns the codepoint (unsigned integer value) of the character read,
1396 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1397 if lexing has reached the end of the input text. To non-destructively
1398 examine the next character, use L</lex_peek_unichar> instead.
1400 If the next character is in (or extends into) the next chunk of input
1401 text, the next chunk will be read in. Normally the current chunk will be
1402 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1403 then the current chunk will not be discarded.
1405 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1406 is encountered, an exception is generated.
1412 Perl_lex_read_unichar(pTHX_ U32 flags)
1415 if (flags & ~(LEX_KEEP_PREVIOUS))
1416 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1417 c = lex_peek_unichar(flags);
1420 CopLINE_inc(PL_curcop);
1422 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1424 ++(PL_parser->bufptr);
1430 =for apidoc Amx|void|lex_read_space|U32 flags
1432 Reads optional spaces, in Perl style, in the text currently being
1433 lexed. The spaces may include ordinary whitespace characters and
1434 Perl-style comments. C<#line> directives are processed if encountered.
1435 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1436 at a non-space character (or the end of the input text).
1438 If spaces extend into the next chunk of input text, the next chunk will
1439 be read in. Normally the current chunk will be discarded at the same
1440 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1441 chunk will not be discarded.
1446 #define LEX_NO_NEXT_CHUNK 0x80000000
1449 Perl_lex_read_space(pTHX_ U32 flags)
1452 bool need_incline = 0;
1453 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
1454 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1457 sv_free(PL_skipwhite);
1458 PL_skipwhite = NULL;
1461 PL_skipwhite = newSVpvs("");
1462 #endif /* PERL_MAD */
1463 s = PL_parser->bufptr;
1464 bufend = PL_parser->bufend;
1470 } while (!(c == '\n' || (c == 0 && s == bufend)));
1471 } else if (c == '\n') {
1473 PL_parser->linestart = s;
1478 } else if (isSPACE(c)) {
1480 } else if (c == 0 && s == bufend) {
1484 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1485 #endif /* PERL_MAD */
1486 if (flags & LEX_NO_NEXT_CHUNK)
1488 PL_parser->bufptr = s;
1489 CopLINE_inc(PL_curcop);
1490 got_more = lex_next_chunk(flags);
1491 CopLINE_dec(PL_curcop);
1492 s = PL_parser->bufptr;
1493 bufend = PL_parser->bufend;
1496 if (need_incline && PL_parser->rsfp) {
1506 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1507 #endif /* PERL_MAD */
1508 PL_parser->bufptr = s;
1513 * This subroutine has nothing to do with tilting, whether at windmills
1514 * or pinball tables. Its name is short for "increment line". It
1515 * increments the current line number in CopLINE(PL_curcop) and checks
1516 * to see whether the line starts with a comment of the form
1517 * # line 500 "foo.pm"
1518 * If so, it sets the current line number and file to the values in the comment.
1522 S_incline(pTHX_ const char *s)
1530 PERL_ARGS_ASSERT_INCLINE;
1532 CopLINE_inc(PL_curcop);
1535 while (SPACE_OR_TAB(*s))
1537 if (strnEQ(s, "line", 4))
1541 if (SPACE_OR_TAB(*s))
1545 while (SPACE_OR_TAB(*s))
1553 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1555 while (SPACE_OR_TAB(*s))
1557 if (*s == '"' && (t = strchr(s+1, '"'))) {
1563 while (!isSPACE(*t))
1567 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1569 if (*e != '\n' && *e != '\0')
1570 return; /* false alarm */
1572 line_num = atoi(n)-1;
1575 const STRLEN len = t - s;
1576 SV *const temp_sv = CopFILESV(PL_curcop);
1581 cf = SvPVX(temp_sv);
1582 tmplen = SvCUR(temp_sv);
1588 if (!PL_rsfp && !PL_parser->filtered) {
1589 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1590 * to *{"::_<newfilename"} */
1591 /* However, the long form of evals is only turned on by the
1592 debugger - usually they're "(eval %lu)" */
1596 STRLEN tmplen2 = len;
1597 if (tmplen + 2 <= sizeof smallbuf)
1600 Newx(tmpbuf, tmplen + 2, char);
1603 memcpy(tmpbuf + 2, cf, tmplen);
1605 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1610 if (tmplen2 + 2 <= sizeof smallbuf)
1613 Newx(tmpbuf2, tmplen2 + 2, char);
1615 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1616 /* Either they malloc'd it, or we malloc'd it,
1617 so no prefix is present in ours. */
1622 memcpy(tmpbuf2 + 2, s, tmplen2);
1625 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1627 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1628 /* adjust ${"::_<newfilename"} to store the new file name */
1629 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1630 /* The line number may differ. If that is the case,
1631 alias the saved lines that are in the array.
1632 Otherwise alias the whole array. */
1633 if (CopLINE(PL_curcop) == line_num) {
1634 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1635 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1637 else if (GvAV(*gvp)) {
1638 AV * const av = GvAV(*gvp);
1639 const I32 start = CopLINE(PL_curcop)+1;
1640 I32 items = AvFILLp(av) - start;
1642 AV * const av2 = GvAVn(gv2);
1643 SV **svp = AvARRAY(av) + start;
1644 I32 l = (I32)line_num+1;
1646 av_store(av2, l++, SvREFCNT_inc(*svp++));
1651 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1653 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1655 CopFILE_free(PL_curcop);
1656 CopFILE_setn(PL_curcop, s, len);
1658 CopLINE_set(PL_curcop, line_num);
1662 /* skip space before PL_thistoken */
1665 S_skipspace0(pTHX_ register char *s)
1667 PERL_ARGS_ASSERT_SKIPSPACE0;
1674 PL_thiswhite = newSVpvs("");
1675 sv_catsv(PL_thiswhite, PL_skipwhite);
1676 sv_free(PL_skipwhite);
1679 PL_realtokenstart = s - SvPVX(PL_linestr);
1683 /* skip space after PL_thistoken */
1686 S_skipspace1(pTHX_ register char *s)
1688 const char *start = s;
1689 I32 startoff = start - SvPVX(PL_linestr);
1691 PERL_ARGS_ASSERT_SKIPSPACE1;
1696 start = SvPVX(PL_linestr) + startoff;
1697 if (!PL_thistoken && PL_realtokenstart >= 0) {
1698 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1699 PL_thistoken = newSVpvn(tstart, start - tstart);
1701 PL_realtokenstart = -1;
1704 PL_nextwhite = newSVpvs("");
1705 sv_catsv(PL_nextwhite, PL_skipwhite);
1706 sv_free(PL_skipwhite);
1713 S_skipspace2(pTHX_ register char *s, SV **svp)
1716 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1717 const I32 startoff = s - SvPVX(PL_linestr);
1719 PERL_ARGS_ASSERT_SKIPSPACE2;
1722 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1723 if (!PL_madskills || !svp)
1725 start = SvPVX(PL_linestr) + startoff;
1726 if (!PL_thistoken && PL_realtokenstart >= 0) {
1727 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1728 PL_thistoken = newSVpvn(tstart, start - tstart);
1729 PL_realtokenstart = -1;
1733 *svp = newSVpvs("");
1734 sv_setsv(*svp, PL_skipwhite);
1735 sv_free(PL_skipwhite);
1744 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1746 AV *av = CopFILEAVx(PL_curcop);
1748 SV * const sv = newSV_type(SVt_PVMG);
1750 sv_setsv(sv, orig_sv);
1752 sv_setpvn(sv, buf, len);
1755 av_store(av, (I32)CopLINE(PL_curcop), sv);
1761 * Called to gobble the appropriate amount and type of whitespace.
1762 * Skips comments as well.
1766 S_skipspace(pTHX_ register char *s)
1770 #endif /* PERL_MAD */
1771 PERL_ARGS_ASSERT_SKIPSPACE;
1774 sv_free(PL_skipwhite);
1775 PL_skipwhite = NULL;
1777 #endif /* PERL_MAD */
1778 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1779 while (s < PL_bufend && SPACE_OR_TAB(*s))
1782 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1784 lex_read_space(LEX_KEEP_PREVIOUS |
1785 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1786 LEX_NO_NEXT_CHUNK : 0));
1788 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1789 if (PL_linestart > PL_bufptr)
1790 PL_bufptr = PL_linestart;
1795 PL_skipwhite = newSVpvn(start, s-start);
1796 #endif /* PERL_MAD */
1802 * Check the unary operators to ensure there's no ambiguity in how they're
1803 * used. An ambiguous piece of code would be:
1805 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1806 * the +5 is its argument.
1816 if (PL_oldoldbufptr != PL_last_uni)
1818 while (isSPACE(*PL_last_uni))
1821 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1823 if ((t = strchr(s, '(')) && t < PL_bufptr)
1826 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1827 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1828 (int)(s - PL_last_uni), PL_last_uni);
1832 * LOP : macro to build a list operator. Its behaviour has been replaced
1833 * with a subroutine, S_lop() for which LOP is just another name.
1836 #define LOP(f,x) return lop(f,x,s)
1840 * Build a list operator (or something that might be one). The rules:
1841 * - if we have a next token, then it's a list operator [why?]
1842 * - if the next thing is an opening paren, then it's a function
1843 * - else it's a list operator
1847 S_lop(pTHX_ I32 f, int x, char *s)
1851 PERL_ARGS_ASSERT_LOP;
1857 PL_last_lop = PL_oldbufptr;
1858 PL_last_lop_op = (OPCODE)f;
1867 return REPORT(FUNC);
1870 return REPORT(FUNC);
1873 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1874 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1875 return REPORT(LSTOP);
1882 * Sets up for an eventual force_next(). start_force(0) basically does
1883 * an unshift, while start_force(-1) does a push. yylex removes items
1888 S_start_force(pTHX_ int where)
1892 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1893 where = PL_lasttoke;
1894 assert(PL_curforce < 0 || PL_curforce == where);
1895 if (PL_curforce != where) {
1896 for (i = PL_lasttoke; i > where; --i) {
1897 PL_nexttoke[i] = PL_nexttoke[i-1];
1901 if (PL_curforce < 0) /* in case of duplicate start_force() */
1902 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1903 PL_curforce = where;
1906 curmad('^', newSVpvs(""));
1907 CURMAD('_', PL_nextwhite);
1912 S_curmad(pTHX_ char slot, SV *sv)
1918 if (PL_curforce < 0)
1919 where = &PL_thismad;
1921 where = &PL_nexttoke[PL_curforce].next_mad;
1927 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1929 else if (PL_encoding) {
1930 sv_recode_to_utf8(sv, PL_encoding);
1935 /* keep a slot open for the head of the list? */
1936 if (slot != '_' && *where && (*where)->mad_key == '^') {
1937 (*where)->mad_key = slot;
1938 sv_free(MUTABLE_SV(((*where)->mad_val)));
1939 (*where)->mad_val = (void*)sv;
1942 addmad(newMADsv(slot, sv), where, 0);
1945 # define start_force(where) NOOP
1946 # define curmad(slot, sv) NOOP
1951 * When the lexer realizes it knows the next token (for instance,
1952 * it is reordering tokens for the parser) then it can call S_force_next
1953 * to know what token to return the next time the lexer is called. Caller
1954 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1955 * and possibly PL_expect to ensure the lexer handles the token correctly.
1959 S_force_next(pTHX_ I32 type)
1964 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1965 tokereport(type, &NEXTVAL_NEXTTOKE);
1969 if (PL_curforce < 0)
1970 start_force(PL_lasttoke);
1971 PL_nexttoke[PL_curforce].next_type = type;
1972 if (PL_lex_state != LEX_KNOWNEXT)
1973 PL_lex_defer = PL_lex_state;
1974 PL_lex_state = LEX_KNOWNEXT;
1975 PL_lex_expect = PL_expect;
1978 PL_nexttype[PL_nexttoke] = type;
1980 if (PL_lex_state != LEX_KNOWNEXT) {
1981 PL_lex_defer = PL_lex_state;
1982 PL_lex_expect = PL_expect;
1983 PL_lex_state = LEX_KNOWNEXT;
1991 int yyc = PL_parser->yychar;
1992 if (yyc != YYEMPTY) {
1995 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1996 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1997 PL_lex_allbrackets--;
1999 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2000 } else if (yyc == '('/*)*/) {
2001 PL_lex_allbrackets--;
2006 PL_parser->yychar = YYEMPTY;
2011 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2014 SV * const sv = newSVpvn_utf8(start, len,
2017 && !is_ascii_string((const U8*)start, len)
2018 && is_utf8_string((const U8*)start, len));
2024 * When the lexer knows the next thing is a word (for instance, it has
2025 * just seen -> and it knows that the next char is a word char, then
2026 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2030 * char *start : buffer position (must be within PL_linestr)
2031 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2032 * int check_keyword : if true, Perl checks to make sure the word isn't
2033 * a keyword (do this if the word is a label, e.g. goto FOO)
2034 * int allow_pack : if true, : characters will also be allowed (require,
2035 * use, etc. do this)
2036 * int allow_initial_tick : used by the "sub" lexer only.
2040 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
2046 PERL_ARGS_ASSERT_FORCE_WORD;
2048 start = SKIPSPACE1(start);
2050 if (isIDFIRST_lazy_if(s,UTF) ||
2051 (allow_pack && *s == ':') ||
2052 (allow_initial_tick && *s == '\'') )
2054 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2055 if (check_keyword && keyword(PL_tokenbuf, len, 0))
2057 start_force(PL_curforce);
2059 curmad('X', newSVpvn(start,s-start));
2060 if (token == METHOD) {
2065 PL_expect = XOPERATOR;
2069 curmad('g', newSVpvs( "forced" ));
2070 NEXTVAL_NEXTTOKE.opval
2071 = (OP*)newSVOP(OP_CONST,0,
2072 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2073 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2081 * Called when the lexer wants $foo *foo &foo etc, but the program
2082 * text only contains the "foo" portion. The first argument is a pointer
2083 * to the "foo", and the second argument is the type symbol to prefix.
2084 * Forces the next token to be a "WORD".
2085 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2089 S_force_ident(pTHX_ register const char *s, int kind)
2093 PERL_ARGS_ASSERT_FORCE_IDENT;
2096 const STRLEN len = strlen(s);
2097 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2098 UTF ? SVf_UTF8 : 0));
2099 start_force(PL_curforce);
2100 NEXTVAL_NEXTTOKE.opval = o;
2103 o->op_private = OPpCONST_ENTERED;
2104 /* XXX see note in pp_entereval() for why we forgo typo
2105 warnings if the symbol must be introduced in an eval.
2107 gv_fetchpvn_flags(s, len,
2108 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2109 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2110 kind == '$' ? SVt_PV :
2111 kind == '@' ? SVt_PVAV :
2112 kind == '%' ? SVt_PVHV :
2120 Perl_str_to_version(pTHX_ SV *sv)
2125 const char *start = SvPV_const(sv,len);
2126 const char * const end = start + len;
2127 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2129 PERL_ARGS_ASSERT_STR_TO_VERSION;
2131 while (start < end) {
2135 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2140 retval += ((NV)n)/nshift;
2149 * Forces the next token to be a version number.
2150 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2151 * and if "guessing" is TRUE, then no new token is created (and the caller
2152 * must use an alternative parsing method).
2156 S_force_version(pTHX_ char *s, int guessing)
2162 I32 startoff = s - SvPVX(PL_linestr);
2165 PERL_ARGS_ASSERT_FORCE_VERSION;
2173 while (isDIGIT(*d) || *d == '_' || *d == '.')
2177 start_force(PL_curforce);
2178 curmad('X', newSVpvn(s,d-s));
2181 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2183 #ifdef USE_LOCALE_NUMERIC
2184 char *loc = setlocale(LC_NUMERIC, "C");
2186 s = scan_num(s, &pl_yylval);
2187 #ifdef USE_LOCALE_NUMERIC
2188 setlocale(LC_NUMERIC, loc);
2190 version = pl_yylval.opval;
2191 ver = cSVOPx(version)->op_sv;
2192 if (SvPOK(ver) && !SvNIOK(ver)) {
2193 SvUPGRADE(ver, SVt_PVNV);
2194 SvNV_set(ver, str_to_version(ver));
2195 SvNOK_on(ver); /* hint that it is a version */
2198 else if (guessing) {
2201 sv_free(PL_nextwhite); /* let next token collect whitespace */
2203 s = SvPVX(PL_linestr) + startoff;
2211 if (PL_madskills && !version) {
2212 sv_free(PL_nextwhite); /* let next token collect whitespace */
2214 s = SvPVX(PL_linestr) + startoff;
2217 /* NOTE: The parser sees the package name and the VERSION swapped */
2218 start_force(PL_curforce);
2219 NEXTVAL_NEXTTOKE.opval = version;
2226 * S_force_strict_version
2227 * Forces the next token to be a version number using strict syntax rules.
2231 S_force_strict_version(pTHX_ char *s)
2236 I32 startoff = s - SvPVX(PL_linestr);
2238 const char *errstr = NULL;
2240 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2242 while (isSPACE(*s)) /* leading whitespace */
2245 if (is_STRICT_VERSION(s,&errstr)) {
2247 s = (char *)scan_version(s, ver, 0);
2248 version = newSVOP(OP_CONST, 0, ver);
2250 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2251 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2255 yyerror(errstr); /* version required */
2260 if (PL_madskills && !version) {
2261 sv_free(PL_nextwhite); /* let next token collect whitespace */
2263 s = SvPVX(PL_linestr) + startoff;
2266 /* NOTE: The parser sees the package name and the VERSION swapped */
2267 start_force(PL_curforce);
2268 NEXTVAL_NEXTTOKE.opval = version;
2276 * Tokenize a quoted string passed in as an SV. It finds the next
2277 * chunk, up to end of string or a backslash. It may make a new
2278 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2283 S_tokeq(pTHX_ SV *sv)
2287 register char *send;
2292 PERL_ARGS_ASSERT_TOKEQ;
2297 s = SvPV_force(sv, len);
2298 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2301 /* This is relying on the SV being "well formed" with a trailing '\0' */
2302 while (s < send && !(*s == '\\' && s[1] == '\\'))
2307 if ( PL_hints & HINT_NEW_STRING ) {
2308 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2312 if (s + 1 < send && (s[1] == '\\'))
2313 s++; /* all that, just for this */
2318 SvCUR_set(sv, d - SvPVX_const(sv));
2320 if ( PL_hints & HINT_NEW_STRING )
2321 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2326 * Now come three functions related to double-quote context,
2327 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2328 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2329 * interact with PL_lex_state, and create fake ( ... ) argument lists
2330 * to handle functions and concatenation.
2331 * They assume that whoever calls them will be setting up a fake
2332 * join call, because each subthing puts a ',' after it. This lets
2335 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
2337 * (I'm not sure whether the spurious commas at the end of lcfirst's
2338 * arguments and join's arguments are created or not).
2343 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2345 * Pattern matching will set PL_lex_op to the pattern-matching op to
2346 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2348 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2350 * Everything else becomes a FUNC.
2352 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2353 * had an OP_CONST or OP_READLINE). This just sets us up for a
2354 * call to S_sublex_push().
2358 S_sublex_start(pTHX)
2361 register const I32 op_type = pl_yylval.ival;
2363 if (op_type == OP_NULL) {
2364 pl_yylval.opval = PL_lex_op;
2368 if (op_type == OP_CONST || op_type == OP_READLINE) {
2369 SV *sv = tokeq(PL_lex_stuff);
2371 if (SvTYPE(sv) == SVt_PVIV) {
2372 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2374 const char * const p = SvPV_const(sv, len);
2375 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2379 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2380 PL_lex_stuff = NULL;
2381 /* Allow <FH> // "foo" */
2382 if (op_type == OP_READLINE)
2383 PL_expect = XTERMORDORDOR;
2386 else if (op_type == OP_BACKTICK && PL_lex_op) {
2387 /* readpipe() vas overriden */
2388 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2389 pl_yylval.opval = PL_lex_op;
2391 PL_lex_stuff = NULL;
2395 PL_sublex_info.super_state = PL_lex_state;
2396 PL_sublex_info.sub_inwhat = (U16)op_type;
2397 PL_sublex_info.sub_op = PL_lex_op;
2398 PL_lex_state = LEX_INTERPPUSH;
2402 pl_yylval.opval = PL_lex_op;
2412 * Create a new scope to save the lexing state. The scope will be
2413 * ended in S_sublex_done. Returns a '(', starting the function arguments
2414 * to the uc, lc, etc. found before.
2415 * Sets PL_lex_state to LEX_INTERPCONCAT.
2424 PL_lex_state = PL_sublex_info.super_state;
2425 SAVEBOOL(PL_lex_dojoin);
2426 SAVEI32(PL_lex_brackets);
2427 SAVEI32(PL_lex_allbrackets);
2428 SAVEI8(PL_lex_fakeeof);
2429 SAVEI32(PL_lex_casemods);
2430 SAVEI32(PL_lex_starts);
2431 SAVEI8(PL_lex_state);
2432 SAVEVPTR(PL_lex_inpat);
2433 SAVEI16(PL_lex_inwhat);
2434 SAVECOPLINE(PL_curcop);
2435 SAVEPPTR(PL_bufptr);
2436 SAVEPPTR(PL_bufend);
2437 SAVEPPTR(PL_oldbufptr);
2438 SAVEPPTR(PL_oldoldbufptr);
2439 SAVEPPTR(PL_last_lop);
2440 SAVEPPTR(PL_last_uni);
2441 SAVEPPTR(PL_linestart);
2442 SAVESPTR(PL_linestr);
2443 SAVEGENERICPV(PL_lex_brackstack);
2444 SAVEGENERICPV(PL_lex_casestack);
2446 PL_linestr = PL_lex_stuff;
2447 PL_lex_stuff = NULL;
2449 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2450 = SvPVX(PL_linestr);
2451 PL_bufend += SvCUR(PL_linestr);
2452 PL_last_lop = PL_last_uni = NULL;
2453 SAVEFREESV(PL_linestr);
2455 PL_lex_dojoin = FALSE;
2456 PL_lex_brackets = 0;
2457 PL_lex_allbrackets = 0;
2458 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2459 Newx(PL_lex_brackstack, 120, char);
2460 Newx(PL_lex_casestack, 12, char);
2461 PL_lex_casemods = 0;
2462 *PL_lex_casestack = '\0';
2464 PL_lex_state = LEX_INTERPCONCAT;
2465 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2467 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2468 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2469 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2470 PL_lex_inpat = PL_sublex_info.sub_op;
2472 PL_lex_inpat = NULL;
2479 * Restores lexer state after a S_sublex_push.
2486 if (!PL_lex_starts++) {
2487 SV * const sv = newSVpvs("");
2488 if (SvUTF8(PL_linestr))
2490 PL_expect = XOPERATOR;
2491 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2495 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2496 PL_lex_state = LEX_INTERPCASEMOD;
2500 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2501 assert(PL_lex_inwhat != OP_TRANSR);
2502 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2503 PL_linestr = PL_lex_repl;
2505 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2506 PL_bufend += SvCUR(PL_linestr);
2507 PL_last_lop = PL_last_uni = NULL;
2508 SAVEFREESV(PL_linestr);
2509 PL_lex_dojoin = FALSE;
2510 PL_lex_brackets = 0;
2511 PL_lex_allbrackets = 0;
2512 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2513 PL_lex_casemods = 0;
2514 *PL_lex_casestack = '\0';
2516 if (SvEVALED(PL_lex_repl)) {
2517 PL_lex_state = LEX_INTERPNORMAL;
2519 /* we don't clear PL_lex_repl here, so that we can check later
2520 whether this is an evalled subst; that means we rely on the
2521 logic to ensure sublex_done() is called again only via the
2522 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2525 PL_lex_state = LEX_INTERPCONCAT;
2535 PL_endwhite = newSVpvs("");
2536 sv_catsv(PL_endwhite, PL_thiswhite);
2540 sv_setpvs(PL_thistoken,"");
2542 PL_realtokenstart = -1;
2546 PL_bufend = SvPVX(PL_linestr);
2547 PL_bufend += SvCUR(PL_linestr);
2548 PL_expect = XOPERATOR;
2549 PL_sublex_info.sub_inwhat = 0;
2557 Extracts a pattern, double-quoted string, or transliteration. This
2560 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2561 processing a pattern (PL_lex_inpat is true), a transliteration
2562 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2564 Returns a pointer to the character scanned up to. If this is
2565 advanced from the start pointer supplied (i.e. if anything was
2566 successfully parsed), will leave an OP for the substring scanned
2567 in pl_yylval. Caller must intuit reason for not parsing further
2568 by looking at the next characters herself.
2572 constants: \N{NAME} only
2573 case and quoting: \U \Q \E
2574 stops on @ and $, but not for $ as tail anchor
2576 In transliterations:
2577 characters are VERY literal, except for - not at the start or end
2578 of the string, which indicates a range. If the range is in bytes,
2579 scan_const expands the range to the full set of intermediate
2580 characters. If the range is in utf8, the hyphen is replaced with
2581 a certain range mark which will be handled by pmtrans() in op.c.
2583 In double-quoted strings:
2585 double-quoted style: \r and \n
2586 constants: \x31, etc.
2587 deprecated backrefs: \1 (in substitution replacements)
2588 case and quoting: \U \Q \E
2591 scan_const does *not* construct ops to handle interpolated strings.
2592 It stops processing as soon as it finds an embedded $ or @ variable
2593 and leaves it to the caller to work out what's going on.
2595 embedded arrays (whether in pattern or not) could be:
2596 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2598 $ in double-quoted strings must be the symbol of an embedded scalar.
2600 $ in pattern could be $foo or could be tail anchor. Assumption:
2601 it's a tail anchor if $ is the last thing in the string, or if it's
2602 followed by one of "()| \r\n\t"
2604 \1 (backreferences) are turned into $1
2606 The structure of the code is
2607 while (there's a character to process) {
2608 handle transliteration ranges
2609 skip regexp comments /(?#comment)/ and codes /(?{code})/
2610 skip #-initiated comments in //x patterns
2611 check for embedded arrays
2612 check for embedded scalars
2614 deprecate \1 in substitution replacements
2615 handle string-changing backslashes \l \U \Q \E, etc.
2616 switch (what was escaped) {
2617 handle \- in a transliteration (becomes a literal -)
2618 if a pattern and not \N{, go treat as regular character
2619 handle \132 (octal characters)
2620 handle \x15 and \x{1234} (hex characters)
2621 handle \N{name} (named characters, also \N{3,5} in a pattern)
2622 handle \cV (control characters)
2623 handle printf-style backslashes (\f, \r, \n, etc)
2626 } (end if backslash)
2627 handle regular character
2628 } (end while character to read)
2633 S_scan_const(pTHX_ char *start)
2636 register char *send = PL_bufend; /* end of the constant */
2637 SV *sv = newSV(send - start); /* sv for the constant. See
2638 note below on sizing. */
2639 register char *s = start; /* start of the constant */
2640 register char *d = SvPVX(sv); /* destination for copies */
2641 bool dorange = FALSE; /* are we in a translit range? */
2642 bool didrange = FALSE; /* did we just finish a range? */
2643 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2644 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2645 to be UTF8? But, this can
2646 show as true when the source
2647 isn't utf8, as for example
2648 when it is entirely composed
2651 /* Note on sizing: The scanned constant is placed into sv, which is
2652 * initialized by newSV() assuming one byte of output for every byte of
2653 * input. This routine expects newSV() to allocate an extra byte for a
2654 * trailing NUL, which this routine will append if it gets to the end of
2655 * the input. There may be more bytes of input than output (eg., \N{LATIN
2656 * CAPITAL LETTER A}), or more output than input if the constant ends up
2657 * recoded to utf8, but each time a construct is found that might increase
2658 * the needed size, SvGROW() is called. Its size parameter each time is
2659 * based on the best guess estimate at the time, namely the length used so
2660 * far, plus the length the current construct will occupy, plus room for
2661 * the trailing NUL, plus one byte for every input byte still unscanned */
2665 UV literal_endpoint = 0;
2666 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2669 PERL_ARGS_ASSERT_SCAN_CONST;
2671 assert(PL_lex_inwhat != OP_TRANSR);
2672 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2673 /* If we are doing a trans and we know we want UTF8 set expectation */
2674 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2675 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2679 while (s < send || dorange) {
2681 /* get transliterations out of the way (they're most literal) */
2682 if (PL_lex_inwhat == OP_TRANS) {
2683 /* expand a range A-Z to the full set of characters. AIE! */
2685 I32 i; /* current expanded character */
2686 I32 min; /* first character in range */
2687 I32 max; /* last character in range */
2698 char * const c = (char*)utf8_hop((U8*)d, -1);
2702 *c = (char)UTF_TO_NATIVE(0xff);
2703 /* mark the range as done, and continue */
2709 i = d - SvPVX_const(sv); /* remember current offset */
2712 SvLEN(sv) + (has_utf8 ?
2713 (512 - UTF_CONTINUATION_MARK +
2716 /* How many two-byte within 0..255: 128 in UTF-8,
2717 * 96 in UTF-8-mod. */
2719 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2721 d = SvPVX(sv) + i; /* refresh d after realloc */
2725 for (j = 0; j <= 1; j++) {
2726 char * const c = (char*)utf8_hop((U8*)d, -1);
2727 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2733 max = (U8)0xff; /* only to \xff */
2734 uvmax = uv; /* \x{100} to uvmax */
2736 d = c; /* eat endpoint chars */
2741 d -= 2; /* eat the first char and the - */
2742 min = (U8)*d; /* first char in range */
2743 max = (U8)d[1]; /* last char in range */
2750 "Invalid range \"%c-%c\" in transliteration operator",
2751 (char)min, (char)max);
2755 if (literal_endpoint == 2 &&
2756 ((isLOWER(min) && isLOWER(max)) ||
2757 (isUPPER(min) && isUPPER(max)))) {
2759 for (i = min; i <= max; i++)
2761 *d++ = NATIVE_TO_NEED(has_utf8,i);
2763 for (i = min; i <= max; i++)
2765 *d++ = NATIVE_TO_NEED(has_utf8,i);
2770 for (i = min; i <= max; i++)
2773 const U8 ch = (U8)NATIVE_TO_UTF(i);
2774 if (UNI_IS_INVARIANT(ch))
2777 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2778 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2787 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2789 *d++ = (char)UTF_TO_NATIVE(0xff);
2791 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2795 /* mark the range as done, and continue */
2799 literal_endpoint = 0;
2804 /* range begins (ignore - as first or last char) */
2805 else if (*s == '-' && s+1 < send && s != start) {
2807 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2814 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2824 literal_endpoint = 0;
2825 native_range = TRUE;
2830 /* if we get here, we're not doing a transliteration */
2832 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2833 except for the last char, which will be done separately. */
2834 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2836 while (s+1 < send && *s != ')')
2837 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2839 else if (s[2] == '{' /* This should match regcomp.c */
2840 || (s[2] == '?' && s[3] == '{'))
2843 char *regparse = s + (s[2] == '{' ? 3 : 4);
2846 while (count && (c = *regparse)) {
2847 if (c == '\\' && regparse[1])
2855 if (*regparse != ')')
2856 regparse--; /* Leave one char for continuation. */
2857 while (s < regparse)
2858 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2862 /* likewise skip #-initiated comments in //x patterns */
2863 else if (*s == '#' && PL_lex_inpat &&
2864 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
2865 while (s+1 < send && *s != '\n')
2866 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2869 /* check for embedded arrays
2870 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2872 else if (*s == '@' && s[1]) {
2873 if (isALNUM_lazy_if(s+1,UTF))
2875 if (strchr(":'{$", s[1]))
2877 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2878 break; /* in regexp, neither @+ nor @- are interpolated */
2881 /* check for embedded scalars. only stop if we're sure it's a
2884 else if (*s == '$') {
2885 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2887 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2889 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2890 "Possible unintended interpolation of $\\ in regex");
2892 break; /* in regexp, $ might be tail anchor */
2896 /* End of else if chain - OP_TRANS rejoin rest */
2899 if (*s == '\\' && s+1 < send) {
2900 char* e; /* Can be used for ending '}', etc. */
2904 /* warn on \1 - \9 in substitution replacements, but note that \11
2905 * is an octal; and \19 is \1 followed by '9' */
2906 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2907 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2909 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2914 /* string-change backslash escapes */
2915 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2919 /* In a pattern, process \N, but skip any other backslash escapes.
2920 * This is because we don't want to translate an escape sequence
2921 * into a meta symbol and have the regex compiler use the meta
2922 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
2923 * in spite of this, we do have to process \N here while the proper
2924 * charnames handler is in scope. See bugs #56444 and #62056.
2925 * There is a complication because \N in a pattern may also stand
2926 * for 'match a non-nl', and not mean a charname, in which case its
2927 * processing should be deferred to the regex compiler. To be a
2928 * charname it must be followed immediately by a '{', and not look
2929 * like \N followed by a curly quantifier, i.e., not something like
2930 * \N{3,}. regcurly returns a boolean indicating if it is a legal
2932 else if (PL_lex_inpat
2935 || regcurly(s + 1)))
2937 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2938 goto default_action;
2943 /* quoted - in transliterations */
2945 if (PL_lex_inwhat == OP_TRANS) {
2952 if ((isALPHA(*s) || isDIGIT(*s)))
2953 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2954 "Unrecognized escape \\%c passed through",
2956 /* default action is to copy the quoted character */
2957 goto default_action;
2960 /* eg. \132 indicates the octal constant 0132 */
2961 case '0': case '1': case '2': case '3':
2962 case '4': case '5': case '6': case '7':
2966 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2969 goto NUM_ESCAPE_INSERT;
2971 /* eg. \o{24} indicates the octal constant \024 */
2977 bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
2983 goto NUM_ESCAPE_INSERT;
2986 /* eg. \x24 indicates the hex constant 0x24 */
2990 char* const e = strchr(s, '}');
2991 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2992 PERL_SCAN_DISALLOW_PREFIX;
2997 yyerror("Missing right brace on \\x{}");
3001 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
3007 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3008 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
3014 /* Insert oct or hex escaped character. There will always be
3015 * enough room in sv since such escapes will be longer than any
3016 * UTF-8 sequence they can end up as, except if they force us
3017 * to recode the rest of the string into utf8 */
3019 /* Here uv is the ordinal of the next character being added in
3020 * unicode (converted from native). */
3021 if (!UNI_IS_INVARIANT(uv)) {
3022 if (!has_utf8 && uv > 255) {
3023 /* Might need to recode whatever we have accumulated so
3024 * far if it contains any chars variant in utf8 or
3027 SvCUR_set(sv, d - SvPVX_const(sv));
3030 /* See Note on sizing above. */
3031 sv_utf8_upgrade_flags_grow(sv,
3032 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3033 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3034 d = SvPVX(sv) + SvCUR(sv);
3039 d = (char*)uvuni_to_utf8((U8*)d, uv);
3040 if (PL_lex_inwhat == OP_TRANS &&
3041 PL_sublex_info.sub_op) {
3042 PL_sublex_info.sub_op->op_private |=
3043 (PL_lex_repl ? OPpTRANS_FROM_UTF
3047 if (uv > 255 && !dorange)
3048 native_range = FALSE;
3061 /* In a non-pattern \N must be a named character, like \N{LATIN
3062 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3063 * mean to match a non-newline. For non-patterns, named
3064 * characters are converted to their string equivalents. In
3065 * patterns, named characters are not converted to their
3066 * ultimate forms for the same reasons that other escapes
3067 * aren't. Instead, they are converted to the \N{U+...} form
3068 * to get the value from the charnames that is in effect right
3069 * now, while preserving the fact that it was a named character
3070 * so that the regex compiler knows this */
3072 /* This section of code doesn't generally use the
3073 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3074 * a close examination of this macro and determined it is a
3075 * no-op except on utfebcdic variant characters. Every
3076 * character generated by this that would normally need to be
3077 * enclosed by this macro is invariant, so the macro is not
3078 * needed, and would complicate use of copy(). XXX There are
3079 * other parts of this file where the macro is used
3080 * inconsistently, but are saved by it being a no-op */
3082 /* The structure of this section of code (besides checking for
3083 * errors and upgrading to utf8) is:
3084 * Further disambiguate between the two meanings of \N, and if
3085 * not a charname, go process it elsewhere
3086 * If of form \N{U+...}, pass it through if a pattern;
3087 * otherwise convert to utf8
3088 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3089 * pattern; otherwise convert to utf8 */
3091 /* Here, s points to the 'N'; the test below is guaranteed to
3092 * succeed if we are being called on a pattern as we already
3093 * know from a test above that the next character is a '{'.
3094 * On a non-pattern \N must mean 'named sequence, which
3095 * requires braces */
3098 yyerror("Missing braces on \\N{}");
3103 /* If there is no matching '}', it is an error. */
3104 if (! (e = strchr(s, '}'))) {
3105 if (! PL_lex_inpat) {
3106 yyerror("Missing right brace on \\N{}");
3108 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3113 /* Here it looks like a named character */
3117 /* XXX This block is temporary code. \N{} implies that the
3118 * pattern is to have Unicode semantics, and therefore
3119 * currently has to be encoded in utf8. By putting it in
3120 * utf8 now, we save a whole pass in the regular expression
3121 * compiler. Once that code is changed so Unicode
3122 * semantics doesn't necessarily have to be in utf8, this
3123 * block should be removed. However, the code that parses
3124 * the output of this would have to be changed to not
3125 * necessarily expect utf8 */
3127 SvCUR_set(sv, d - SvPVX_const(sv));
3130 /* See Note on sizing above. */
3131 sv_utf8_upgrade_flags_grow(sv,
3132 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3133 /* 5 = '\N{' + cur char + NUL */
3134 (STRLEN)(send - s) + 5);
3135 d = SvPVX(sv) + SvCUR(sv);
3140 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3141 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3142 | PERL_SCAN_DISALLOW_PREFIX;
3145 /* For \N{U+...}, the '...' is a unicode value even on
3146 * EBCDIC machines */
3147 s += 2; /* Skip to next char after the 'U+' */
3149 uv = grok_hex(s, &len, &flags, NULL);
3150 if (len == 0 || len != (STRLEN)(e - s)) {
3151 yyerror("Invalid hexadecimal number in \\N{U+...}");
3158 /* On non-EBCDIC platforms, pass through to the regex
3159 * compiler unchanged. The reason we evaluated the
3160 * number above is to make sure there wasn't a syntax
3161 * error. But on EBCDIC we convert to native so
3162 * downstream code can continue to assume it's native
3164 s -= 5; /* Include the '\N{U+' */
3166 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3169 (unsigned int) UNI_TO_NATIVE(uv));
3171 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3175 else { /* Not a pattern: convert the hex to string */
3177 /* If destination is not in utf8, unconditionally
3178 * recode it to be so. This is because \N{} implies
3179 * Unicode semantics, and scalars have to be in utf8
3180 * to guarantee those semantics */
3182 SvCUR_set(sv, d - SvPVX_const(sv));
3185 /* See Note on sizing above. */
3186 sv_utf8_upgrade_flags_grow(
3188 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3189 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3190 d = SvPVX(sv) + SvCUR(sv);
3194 /* Add the string to the output */
3195 if (UNI_IS_INVARIANT(uv)) {
3198 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3201 else { /* Here is \N{NAME} but not \N{U+...}. */
3203 SV *res; /* result from charnames */
3204 const char *str; /* the string in 'res' */
3205 STRLEN len; /* its length */
3207 /* Get the value for NAME */
3208 res = newSVpvn(s, e - s);
3209 res = new_constant( NULL, 0, "charnames",
3210 /* includes all of: \N{...} */
3211 res, NULL, s - 3, e - s + 4 );
3213 /* Most likely res will be in utf8 already since the
3214 * standard charnames uses pack U, but a custom translator
3215 * can leave it otherwise, so make sure. XXX This can be
3216 * revisited to not have charnames use utf8 for characters
3217 * that don't need it when regexes don't have to be in utf8
3218 * for Unicode semantics. If doing so, remember EBCDIC */
3219 sv_utf8_upgrade(res);
3220 str = SvPV_const(res, len);
3222 /* Don't accept malformed input */
3223 if (! is_utf8_string((U8 *) str, len)) {
3224 yyerror("Malformed UTF-8 returned by \\N");
3226 else if (PL_lex_inpat) {
3228 if (! len) { /* The name resolved to an empty string */
3229 Copy("\\N{}", d, 4, char);
3233 /* In order to not lose information for the regex
3234 * compiler, pass the result in the specially made
3235 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3236 * the code points in hex of each character
3237 * returned by charnames */
3239 const char *str_end = str + len;
3240 STRLEN char_length; /* cur char's byte length */
3241 STRLEN output_length; /* and the number of bytes
3242 after this is translated
3244 const STRLEN off = d - SvPVX_const(sv);
3246 /* 2 hex per byte; 2 chars for '\N'; 2 chars for
3247 * max('U+', '.'); and 1 for NUL */
3248 char hex_string[2 * UTF8_MAXBYTES + 5];
3250 /* Get the first character of the result. */
3251 U32 uv = utf8n_to_uvuni((U8 *) str,
3256 /* The call to is_utf8_string() above hopefully
3257 * guarantees that there won't be an error. But
3258 * it's easy here to make sure. The function just
3259 * above warns and returns 0 if invalid utf8, but
3260 * it can also return 0 if the input is validly a
3261 * NUL. Disambiguate */
3262 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3263 uv = UNICODE_REPLACEMENT;
3266 /* Convert first code point to hex, including the
3267 * boiler plate before it. For all these, we
3268 * convert to native format so that downstream code
3269 * can continue to assume the input is native */
3271 my_snprintf(hex_string, sizeof(hex_string),
3273 (unsigned int) UNI_TO_NATIVE(uv));
3275 /* Make sure there is enough space to hold it */
3276 d = off + SvGROW(sv, off
3278 + (STRLEN)(send - e)
3279 + 2); /* '}' + NUL */
3281 Copy(hex_string, d, output_length, char);
3284 /* For each subsequent character, append dot and
3285 * its ordinal in hex */
3286 while ((str += char_length) < str_end) {
3287 const STRLEN off = d - SvPVX_const(sv);
3288 U32 uv = utf8n_to_uvuni((U8 *) str,
3292 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3293 uv = UNICODE_REPLACEMENT;
3297 my_snprintf(hex_string, sizeof(hex_string),
3299 (unsigned int) UNI_TO_NATIVE(uv));
3301 d = off + SvGROW(sv, off
3303 + (STRLEN)(send - e)
3304 + 2); /* '}' + NUL */
3305 Copy(hex_string, d, output_length, char);
3309 *d++ = '}'; /* Done. Add the trailing brace */
3312 else { /* Here, not in a pattern. Convert the name to a
3315 /* If destination is not in utf8, unconditionally
3316 * recode it to be so. This is because \N{} implies
3317 * Unicode semantics, and scalars have to be in utf8
3318 * to guarantee those semantics */
3320 SvCUR_set(sv, d - SvPVX_const(sv));
3323 /* See Note on sizing above. */
3324 sv_utf8_upgrade_flags_grow(sv,
3325 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3326 len + (STRLEN)(send - s) + 1);
3327 d = SvPVX(sv) + SvCUR(sv);
3329 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3331 /* See Note on sizing above. (NOTE: SvCUR() is not
3332 * set correctly here). */
3333 const STRLEN off = d - SvPVX_const(sv);
3334 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3336 Copy(str, d, len, char);
3341 /* Deprecate non-approved name syntax */
3342 if (ckWARN_d(WARN_DEPRECATED)) {
3343 bool problematic = FALSE;
3346 /* For non-ut8 input, look to see that the first
3347 * character is an alpha, then loop through the rest
3348 * checking that each is a continuation */
3350 if (! isALPHAU(*i)) problematic = TRUE;
3351 else for (i = s + 1; i < e; i++) {
3352 if (isCHARNAME_CONT(*i)) continue;
3358 /* Similarly for utf8. For invariants can check
3359 * directly. We accept anything above the latin1
3360 * range because it is immaterial to Perl if it is
3361 * correct or not, and is expensive to check. But
3362 * it is fairly easy in the latin1 range to convert
3363 * the variants into a single character and check
3365 if (UTF8_IS_INVARIANT(*i)) {
3366 if (! isALPHAU(*i)) problematic = TRUE;
3367 } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
3368 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
3374 if (! problematic) for (i = s + UTF8SKIP(s);
3378 if (UTF8_IS_INVARIANT(*i)) {
3379 if (isCHARNAME_CONT(*i)) continue;
3380 } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
3382 } else if (isCHARNAME_CONT(
3384 TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
3393 /* The e-i passed to the final %.*s makes sure that
3394 * should the trailing NUL be missing that this
3395 * print won't run off the end of the string */
3396 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3397 "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
3398 (int)(i - s + 1), s, (int)(e - i), i + 1);
3401 } /* End \N{NAME} */
3404 native_range = FALSE; /* \N{} is defined to be Unicode */
3406 s = e + 1; /* Point to just after the '}' */
3409 /* \c is a control character */
3413 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3416 yyerror("Missing control char name in \\c");
3420 /* printf-style backslashes, formfeeds, newlines, etc */
3422 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3425 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3428 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3431 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3434 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3437 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3440 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3446 } /* end if (backslash) */
3453 /* If we started with encoded form, or already know we want it,
3454 then encode the next character */
3455 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3459 /* One might think that it is wasted effort in the case of the
3460 * source being utf8 (this_utf8 == TRUE) to take the next character
3461 * in the source, convert it to an unsigned value, and then convert
3462 * it back again. But the source has not been validated here. The
3463 * routine that does the conversion checks for errors like
3466 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3467 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3469 SvCUR_set(sv, d - SvPVX_const(sv));
3472 /* See Note on sizing above. */
3473 sv_utf8_upgrade_flags_grow(sv,
3474 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3475 need + (STRLEN)(send - s) + 1);
3476 d = SvPVX(sv) + SvCUR(sv);
3478 } else if (need > len) {
3479 /* encoded value larger than old, may need extra space (NOTE:
3480 * SvCUR() is not set correctly here). See Note on sizing
3482 const STRLEN off = d - SvPVX_const(sv);
3483 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3487 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3489 if (uv > 255 && !dorange)
3490 native_range = FALSE;
3494 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3496 } /* while loop to process each character */
3498 /* terminate the string and set up the sv */
3500 SvCUR_set(sv, d - SvPVX_const(sv));
3501 if (SvCUR(sv) >= SvLEN(sv))
3502 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
3505 if (PL_encoding && !has_utf8) {
3506 sv_recode_to_utf8(sv, PL_encoding);
3512 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3513 PL_sublex_info.sub_op->op_private |=
3514 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3518 /* shrink the sv if we allocated more than we used */
3519 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3520 SvPV_shrink_to_cur(sv);
3523 /* return the substring (via pl_yylval) only if we parsed anything */
3524 if (s > PL_bufptr) {
3525 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
3526 const char *const key = PL_lex_inpat ? "qr" : "q";
3527 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3531 if (PL_lex_inwhat == OP_TRANS) {
3534 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3542 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3545 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3552 * Returns TRUE if there's more to the expression (e.g., a subscript),
3555 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3557 * ->[ and ->{ return TRUE
3558 * { and [ outside a pattern are always subscripts, so return TRUE
3559 * if we're outside a pattern and it's not { or [, then return FALSE
3560 * if we're in a pattern and the first char is a {
3561 * {4,5} (any digits around the comma) returns FALSE
3562 * if we're in a pattern and the first char is a [
3564 * [SOMETHING] has a funky algorithm to decide whether it's a
3565 * character class or not. It has to deal with things like
3566 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3567 * anything else returns TRUE
3570 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3573 S_intuit_more(pTHX_ register char *s)
3577 PERL_ARGS_ASSERT_INTUIT_MORE;
3579 if (PL_lex_brackets)
3581 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3583 if (*s != '{' && *s != '[')
3588 /* In a pattern, so maybe we have {n,m}. */
3596 /* On the other hand, maybe we have a character class */
3599 if (*s == ']' || *s == '^')
3602 /* this is terrifying, and it works */
3603 int weight = 2; /* let's weigh the evidence */
3605 unsigned char un_char = 255, last_un_char;
3606 const char * const send = strchr(s,']');
3607 char tmpbuf[sizeof PL_tokenbuf * 4];
3609 if (!send) /* has to be an expression */
3612 Zero(seen,256,char);
3615 else if (isDIGIT(*s)) {
3617 if (isDIGIT(s[1]) && s[2] == ']')
3623 for (; s < send; s++) {
3624 last_un_char = un_char;
3625 un_char = (unsigned char)*s;
3630 weight -= seen[un_char] * 10;
3631 if (isALNUM_lazy_if(s+1,UTF)) {
3633 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3634 len = (int)strlen(tmpbuf);
3635 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3636 UTF ? SVf_UTF8 : 0, SVt_PV))
3641 else if (*s == '$' && s[1] &&
3642 strchr("[#!%*<>()-=",s[1])) {
3643 if (/*{*/ strchr("])} =",s[2]))
3652 if (strchr("wds]",s[1]))
3654 else if (seen[(U8)'\''] || seen[(U8)'"'])
3656 else if (strchr("rnftbxcav",s[1]))
3658 else if (isDIGIT(s[1])) {
3660 while (s[1] && isDIGIT(s[1]))
3670 if (strchr("aA01! ",last_un_char))
3672 if (strchr("zZ79~",s[1]))
3674 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3675 weight -= 5; /* cope with negative subscript */
3678 if (!isALNUM(last_un_char)
3679 && !(last_un_char == '$' || last_un_char == '@'
3680 || last_un_char == '&')
3681 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3686 if (keyword(tmpbuf, d - tmpbuf, 0))
3689 if (un_char == last_un_char + 1)
3691 weight -= seen[un_char];
3696 if (weight >= 0) /* probably a character class */
3706 * Does all the checking to disambiguate
3708 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3709 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3711 * First argument is the stuff after the first token, e.g. "bar".
3713 * Not a method if bar is a filehandle.
3714 * Not a method if foo is a subroutine prototyped to take a filehandle.
3715 * Not a method if it's really "Foo $bar"
3716 * Method if it's "foo $bar"
3717 * Not a method if it's really "print foo $bar"
3718 * Method if it's really "foo package::" (interpreted as package->foo)
3719 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3720 * Not a method if bar is a filehandle or package, but is quoted with
3725 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3728 char *s = start + (*start == '$');
3729 char tmpbuf[sizeof PL_tokenbuf];
3736 PERL_ARGS_ASSERT_INTUIT_METHOD;
3739 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3743 const char *proto = CvPROTO(cv);
3754 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3755 /* start is the beginning of the possible filehandle/object,
3756 * and s is the end of it
3757 * tmpbuf is a copy of it
3760 if (*start == '$') {
3761 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3762 isUPPER(*PL_tokenbuf))
3765 len = start - SvPVX(PL_linestr);
3769 start = SvPVX(PL_linestr) + len;
3773 return *s == '(' ? FUNCMETH : METHOD;
3775 if (!keyword(tmpbuf, len, 0)) {
3776 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3780 soff = s - SvPVX(PL_linestr);
3784 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3785 if (indirgv && GvCVu(indirgv))
3787 /* filehandle or package name makes it a method */
3788 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3790 soff = s - SvPVX(PL_linestr);
3793 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3794 return 0; /* no assumptions -- "=>" quotes bareword */
3796 start_force(PL_curforce);
3797 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3798 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3799 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3801 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
3802 ( UTF ? SVf_UTF8 : 0 )));
3807 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
3809 return *s == '(' ? FUNCMETH : METHOD;
3815 /* Encoded script support. filter_add() effectively inserts a
3816 * 'pre-processing' function into the current source input stream.
3817 * Note that the filter function only applies to the current source file
3818 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3820 * The datasv parameter (which may be NULL) can be used to pass
3821 * private data to this instance of the filter. The filter function
3822 * can recover the SV using the FILTER_DATA macro and use it to
3823 * store private buffers and state information.
3825 * The supplied datasv parameter is upgraded to a PVIO type
3826 * and the IoDIRP/IoANY field is used to store the function pointer,
3827 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3828 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3829 * private use must be set using malloc'd pointers.
3833 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3842 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3843 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3845 if (!PL_rsfp_filters)
3846 PL_rsfp_filters = newAV();
3849 SvUPGRADE(datasv, SVt_PVIO);
3850 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3851 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3852 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3853 FPTR2DPTR(void *, IoANY(datasv)),
3854 SvPV_nolen(datasv)));
3855 av_unshift(PL_rsfp_filters, 1);
3856 av_store(PL_rsfp_filters, 0, datasv) ;
3858 !PL_parser->filtered
3859 && PL_parser->lex_flags & LEX_EVALBYTES
3860 && PL_bufptr < PL_bufend
3862 const char *s = PL_bufptr;
3863 while (s < PL_bufend) {
3865 SV *linestr = PL_parser->linestr;
3866 char *buf = SvPVX(linestr);
3867 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3868 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3869 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3870 STRLEN const linestart_pos = PL_parser->linestart - buf;
3871 STRLEN const last_uni_pos =
3872 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3873 STRLEN const last_lop_pos =
3874 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3875 av_push(PL_rsfp_filters, linestr);
3876 PL_parser->linestr =
3877 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3878 buf = SvPVX(PL_parser->linestr);
3879 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3880 PL_parser->bufptr = buf + bufptr_pos;
3881 PL_parser->oldbufptr = buf + oldbufptr_pos;
3882 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3883 PL_parser->linestart = buf + linestart_pos;
3884 if (PL_parser->last_uni)
3885 PL_parser->last_uni = buf + last_uni_pos;
3886 if (PL_parser->last_lop)
3887 PL_parser->last_lop = buf + last_lop_pos;
3888 SvLEN(linestr) = SvCUR(linestr);
3889 SvCUR(linestr) = s-SvPVX(linestr);
3890 PL_parser->filtered = 1;
3900 /* Delete most recently added instance of this filter function. */
3902 Perl_filter_del(pTHX_ filter_t funcp)
3907 PERL_ARGS_ASSERT_FILTER_DEL;
3910 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3911 FPTR2DPTR(void*, funcp)));
3913 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3915 /* if filter is on top of stack (usual case) just pop it off */
3916 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3917 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3918 sv_free(av_pop(PL_rsfp_filters));
3922 /* we need to search for the correct entry and clear it */
3923 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3927 /* Invoke the idxth filter function for the current rsfp. */
3928 /* maxlen 0 = read one text line */
3930 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
3935 /* This API is bad. It should have been using unsigned int for maxlen.
3936 Not sure if we want to change the API, but if not we should sanity
3937 check the value here. */
3938 unsigned int correct_length
3947 PERL_ARGS_ASSERT_FILTER_READ;
3949 if (!PL_parser || !PL_rsfp_filters)
3951 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
3952 /* Provide a default input filter to make life easy. */
3953 /* Note that we append to the line. This is handy. */
3954 DEBUG_P(PerlIO_printf(Perl_debug_log,
3955 "filter_read %d: from rsfp\n", idx));
3956 if (correct_length) {
3959 const int old_len = SvCUR(buf_sv);
3961 /* ensure buf_sv is large enough */
3962 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
3963 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
3964 correct_length)) <= 0) {
3965 if (PerlIO_error(PL_rsfp))
3966 return -1; /* error */
3968 return 0 ; /* end of file */
3970 SvCUR_set(buf_sv, old_len + len) ;
3971 SvPVX(buf_sv)[old_len + len] = '\0';
3974 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
3975 if (PerlIO_error(PL_rsfp))
3976 return -1; /* error */
3978 return 0 ; /* end of file */
3981 return SvCUR(buf_sv);
3983 /* Skip this filter slot if filter has been deleted */
3984 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
3985 DEBUG_P(PerlIO_printf(Perl_debug_log,
3986 "filter_read %d: skipped (filter deleted)\n",
3988 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
3990 if (SvTYPE(datasv) != SVt_PVIO) {
3991 if (correct_length) {
3993 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
3994 if (!remainder) return 0; /* eof */
3995 if (correct_length > remainder) correct_length = remainder;
3996 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
3997 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4000 const char *s = SvEND(datasv);
4001 const char *send = SvPVX(datasv) + SvLEN(datasv);
4009 if (s == send) return 0; /* eof */
4010 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4011 SvCUR_set(datasv, s-SvPVX(datasv));
4013 return SvCUR(buf_sv);
4015 /* Get function pointer hidden within datasv */
4016 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4017 DEBUG_P(PerlIO_printf(Perl_debug_log,
4018 "filter_read %d: via function %p (%s)\n",
4019 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4020 /* Call function. The function is expected to */
4021 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4022 /* Return: <0:error, =0:eof, >0:not eof */
4023 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4027 S_filter_gets(pTHX_ register SV *sv, STRLEN append)
4031 PERL_ARGS_ASSERT_FILTER_GETS;
4033 #ifdef PERL_CR_FILTER
4034 if (!PL_rsfp_filters) {
4035 filter_add(S_cr_textfilter,NULL);
4038 if (PL_rsfp_filters) {
4040 SvCUR_set(sv, 0); /* start with empty line */
4041 if (FILTER_READ(0, sv, 0) > 0)
4042 return ( SvPVX(sv) ) ;
4047 return (sv_gets(sv, PL_rsfp, append));
4051 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4056 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4058 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4062 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4063 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4065 return GvHV(gv); /* Foo:: */
4068 /* use constant CLASS => 'MyClass' */
4069 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4070 if (gv && GvCV(gv)) {
4071 SV * const sv = cv_const_sv(GvCV(gv));
4073 pkgname = SvPV_const(sv, len);
4076 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4080 * S_readpipe_override
4081 * Check whether readpipe() is overridden, and generates the appropriate
4082 * optree, provided sublex_start() is called afterwards.
4085 S_readpipe_override(pTHX)
4088 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4089 pl_yylval.ival = OP_BACKTICK;
4091 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4093 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4094 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4095 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4097 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4098 op_append_elem(OP_LIST,
4099 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4100 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4107 * The intent of this yylex wrapper is to minimize the changes to the
4108 * tokener when we aren't interested in collecting madprops. It remains
4109 * to be seen how successful this strategy will be...
4116 char *s = PL_bufptr;
4118 /* make sure PL_thiswhite is initialized */
4122 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
4123 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4124 return S_pending_ident(aTHX);
4126 /* previous token ate up our whitespace? */
4127 if (!PL_lasttoke && PL_nextwhite) {
4128 PL_thiswhite = PL_nextwhite;
4132 /* isolate the token, and figure out where it is without whitespace */
4133 PL_realtokenstart = -1;
4137 assert(PL_curforce < 0);
4139 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4140 if (!PL_thistoken) {
4141 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4142 PL_thistoken = newSVpvs("");
4144 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4145 PL_thistoken = newSVpvn(tstart, s - tstart);
4148 if (PL_thismad) /* install head */
4149 CURMAD('X', PL_thistoken);
4152 /* last whitespace of a sublex? */
4153 if (optype == ')' && PL_endwhite) {
4154 CURMAD('X', PL_endwhite);
4159 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4160 if (!PL_thiswhite && !PL_endwhite && !optype) {
4161 sv_free(PL_thistoken);
4166 /* put off final whitespace till peg */
4167 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4168 PL_nextwhite = PL_thiswhite;
4171 else if (PL_thisopen) {
4172 CURMAD('q', PL_thisopen);
4174 sv_free(PL_thistoken);
4178 /* Store actual token text as madprop X */
4179 CURMAD('X', PL_thistoken);
4183 /* add preceding whitespace as madprop _ */
4184 CURMAD('_', PL_thiswhite);
4188 /* add quoted material as madprop = */
4189 CURMAD('=', PL_thisstuff);
4193 /* add terminating quote as madprop Q */
4194 CURMAD('Q', PL_thisclose);
4198 /* special processing based on optype */
4202 /* opval doesn't need a TOKEN since it can already store mp */
4212 if (pl_yylval.opval)
4213 append_madprops(PL_thismad, pl_yylval.opval, 0);
4221 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4230 /* remember any fake bracket that lexer is about to discard */
4231 if (PL_lex_brackets == 1 &&
4232 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4235 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4238 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4239 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4242 break; /* don't bother looking for trailing comment */
4251 /* attach a trailing comment to its statement instead of next token */
4255 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4257 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4259 if (*s == '\n' || *s == '#') {
4260 while (s < PL_bufend && *s != '\n')
4264 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4265 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4282 /* Create new token struct. Note: opvals return early above. */
4283 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4290 S_tokenize_use(pTHX_ int is_use, char *s) {
4293 PERL_ARGS_ASSERT_TOKENIZE_USE;
4295 if (PL_expect != XSTATE)
4296 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4297 is_use ? "use" : "no"));
4299 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4300 s = force_version(s, TRUE);
4301 if (*s == ';' || *s == '}'
4302 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4303 start_force(PL_curforce);
4304 NEXTVAL_NEXTTOKE.opval = NULL;
4307 else if (*s == 'v') {
4308 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4309 s = force_version(s, FALSE);
4313 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4314 s = force_version(s, FALSE);
4316 pl_yylval.ival = is_use;
4320 static const char* const exp_name[] =
4321 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4322 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4326 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4328 S_word_takes_any_delimeter(char *p, STRLEN len)
4330 return (len == 1 && strchr("msyq", p[0])) ||
4332 (p[0] == 't' && p[1] == 'r') ||
4333 (p[0] == 'q' && strchr("qwxr", p[1]))));
4339 Works out what to call the token just pulled out of the input
4340 stream. The yacc parser takes care of taking the ops we return and
4341 stitching them into a tree.
4347 if read an identifier
4348 if we're in a my declaration
4349 croak if they tried to say my($foo::bar)
4350 build the ops for a my() declaration
4351 if it's an access to a my() variable
4352 are we in a sort block?
4353 croak if my($a); $a <=> $b
4354 build ops for access to a my() variable
4355 if in a dq string, and they've said @foo and we can't find @foo
4357 build ops for a bareword
4358 if we already built the token before, use it.
4363 #pragma segment Perl_yylex
4369 register char *s = PL_bufptr;
4375 /* orig_keyword, gvp, and gv are initialized here because
4376 * jump to the label just_a_word_zero can bypass their
4377 * initialization later. */
4378 I32 orig_keyword = 0;
4383 SV* tmp = newSVpvs("");
4384 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4385 (IV)CopLINE(PL_curcop),
4386 lex_state_names[PL_lex_state],
4387 exp_name[PL_expect],
4388 pv_display(tmp, s, strlen(s), 0, 60));
4391 /* check if there's an identifier for us to look at */
4392 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4393 return REPORT(S_pending_ident(aTHX));
4395 /* no identifier pending identification */
4397 switch (PL_lex_state) {
4399 case LEX_NORMAL: /* Some compilers will produce faster */
4400 case LEX_INTERPNORMAL: /* code if we comment these out. */
4404 /* when we've already built the next token, just pull it out of the queue */
4408 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4410 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4411 PL_nexttoke[PL_lasttoke].next_mad = 0;
4412 if (PL_thismad && PL_thismad->mad_key == '_') {
4413 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4414 PL_thismad->mad_val = 0;
4415 mad_free(PL_thismad);
4420 PL_lex_state = PL_lex_defer;
4421 PL_expect = PL_lex_expect;
4422 PL_lex_defer = LEX_NORMAL;
4423 if (!PL_nexttoke[PL_lasttoke].next_type)
4428 pl_yylval = PL_nextval[PL_nexttoke];
4430 PL_lex_state = PL_lex_defer;
4431 PL_expect = PL_lex_expect;
4432 PL_lex_defer = LEX_NORMAL;
4438 next_type = PL_nexttoke[PL_lasttoke].next_type;
4440 next_type = PL_nexttype[PL_nexttoke];
4442 if (next_type & (7<<24)) {
4443 if (next_type & (1<<24)) {
4444 if (PL_lex_brackets > 100)
4445 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4446 PL_lex_brackstack[PL_lex_brackets++] =
4447 (char) ((next_type >> 16) & 0xff);
4449 if (next_type & (2<<24))
4450 PL_lex_allbrackets++;
4451 if (next_type & (4<<24))
4452 PL_lex_allbrackets--;