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).
152 * These values refer to the various states within a sublex parse,
153 * i.e. within a double quotish string
156 /* #define LEX_NOTPARSING 11 is done in perl.h. */
158 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
159 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
160 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
161 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
162 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
164 /* at end of code, eg "$x" followed by: */
165 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
166 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
168 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
169 string or after \E, $foo, etc */
170 #define LEX_INTERPCONST 2 /* NOT USED */
171 #define LEX_FORMLINE 1 /* expecting a format line */
172 #define LEX_KNOWNEXT 0 /* next token known; just return it */
176 static const char* const lex_state_names[] = {
195 #include "keywords.h"
197 /* CLINE is a macro that ensures PL_copline has a sane value */
202 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
205 # define SKIPSPACE0(s) skipspace0(s)
206 # define SKIPSPACE1(s) skipspace1(s)
207 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
208 # define PEEKSPACE(s) skipspace2(s,0)
210 # define SKIPSPACE0(s) skipspace(s)
211 # define SKIPSPACE1(s) skipspace(s)
212 # define SKIPSPACE2(s,tsv) skipspace(s)
213 # define PEEKSPACE(s) skipspace(s)
217 * Convenience functions to return different tokens and prime the
218 * lexer for the next token. They all take an argument.
220 * TOKEN : generic token (used for '(', DOLSHARP, etc)
221 * OPERATOR : generic operator
222 * AOPERATOR : assignment operator
223 * PREBLOCK : beginning the block after an if, while, foreach, ...
224 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
225 * PREREF : *EXPR where EXPR is not a simple identifier
226 * TERM : expression term
227 * LOOPX : loop exiting command (goto, last, dump, etc)
228 * FTST : file test operator
229 * FUN0 : zero-argument function
230 * FUN0OP : zero-argument function, with its op created in this file
231 * FUN1 : not used, except for not, which isn't a UNIOP
232 * BOop : bitwise or or xor
234 * SHop : shift operator
235 * PWop : power operator
236 * PMop : pattern-matching operator
237 * Aop : addition-level operator
238 * Mop : multiplication-level operator
239 * Eop : equality-testing operator
240 * Rop : relational operator <= != gt
242 * Also see LOP and lop() below.
245 #ifdef DEBUGGING /* Serve -DT. */
246 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
248 # define REPORT(retval) (retval)
251 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
252 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
253 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
254 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
255 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
256 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
257 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
258 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
259 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
260 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
261 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
262 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
263 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
264 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
265 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
266 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
267 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
268 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
269 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
270 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
271 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
273 /* This bit of chicanery makes a unary function followed by
274 * a parenthesis into a function with one argument, highest precedence.
275 * The UNIDOR macro is for unary functions that can be followed by the //
276 * operator (such as C<shift // 0>).
278 #define UNI3(f,x,have_x) { \
279 pl_yylval.ival = f; \
280 if (have_x) PL_expect = x; \
282 PL_last_uni = PL_oldbufptr; \
283 PL_last_lop_op = f; \
285 return REPORT( (int)FUNC1 ); \
287 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
289 #define UNI(f) UNI3(f,XTERM,1)
290 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
291 #define UNIPROTO(f,optional) { \
292 if (optional) PL_last_uni = PL_oldbufptr; \
296 #define UNIBRACK(f) UNI3(f,0,0)
298 /* grandfather return to old style */
301 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
302 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
303 pl_yylval.ival = (f); \
309 #define COPLINE_INC_WITH_HERELINES \
311 CopLINE_inc(PL_curcop); \
312 if (PL_parser->lex_shared->herelines) \
313 CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \
314 PL_parser->lex_shared->herelines = 0; \
320 /* how to interpret the pl_yylval associated with the token */
324 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
329 static struct debug_tokens {
331 enum token_type type;
333 } const debug_tokens[] =
335 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
336 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
337 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
338 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
339 { ARROW, TOKENTYPE_NONE, "ARROW" },
340 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
341 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
342 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
343 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
344 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
345 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
346 { DO, TOKENTYPE_NONE, "DO" },
347 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
348 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
349 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
350 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
351 { ELSE, TOKENTYPE_NONE, "ELSE" },
352 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
353 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
354 { FOR, TOKENTYPE_IVAL, "FOR" },
355 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
356 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
357 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
358 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
359 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
360 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
361 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
362 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
363 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
364 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
365 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
366 { IF, TOKENTYPE_IVAL, "IF" },
367 { LABEL, TOKENTYPE_OPVAL, "LABEL" },
368 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
369 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
370 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
371 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
372 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
373 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
374 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
375 { MY, TOKENTYPE_IVAL, "MY" },
376 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
377 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
378 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
379 { OROP, TOKENTYPE_IVAL, "OROP" },
380 { OROR, TOKENTYPE_NONE, "OROR" },
381 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
382 { PEG, TOKENTYPE_NONE, "PEG" },
383 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
384 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
385 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
386 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
387 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
388 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
389 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
390 { PREINC, TOKENTYPE_NONE, "PREINC" },
391 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
392 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
393 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
394 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
395 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
396 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
397 { SUB, TOKENTYPE_NONE, "SUB" },
398 { THING, TOKENTYPE_OPVAL, "THING" },
399 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
400 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
401 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
402 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
403 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
404 { USE, TOKENTYPE_IVAL, "USE" },
405 { WHEN, TOKENTYPE_IVAL, "WHEN" },
406 { WHILE, TOKENTYPE_IVAL, "WHILE" },
407 { WORD, TOKENTYPE_OPVAL, "WORD" },
408 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
409 { 0, TOKENTYPE_NONE, NULL }
412 /* dump the returned token in rv, plus any optional arg in pl_yylval */
415 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
419 PERL_ARGS_ASSERT_TOKEREPORT;
422 const char *name = NULL;
423 enum token_type type = TOKENTYPE_NONE;
424 const struct debug_tokens *p;
425 SV* const report = newSVpvs("<== ");
427 for (p = debug_tokens; p->token; p++) {
428 if (p->token == (int)rv) {
435 Perl_sv_catpv(aTHX_ report, name);
436 else if ((char)rv > ' ' && (char)rv < '~')
437 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
439 sv_catpvs(report, "EOF");
441 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
446 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
448 case TOKENTYPE_OPNUM:
449 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
450 PL_op_name[lvalp->ival]);
453 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
455 case TOKENTYPE_OPVAL:
457 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
458 PL_op_name[lvalp->opval->op_type]);
459 if (lvalp->opval->op_type == OP_CONST) {
460 Perl_sv_catpvf(aTHX_ report, " %s",
461 SvPEEK(cSVOPx_sv(lvalp->opval)));
466 sv_catpvs(report, "(opval=null)");
469 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
475 /* print the buffer with suitable escapes */
478 S_printbuf(pTHX_ const char *const fmt, const char *const s)
480 SV* const tmp = newSVpvs("");
482 PERL_ARGS_ASSERT_PRINTBUF;
484 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
491 S_deprecate_commaless_var_list(pTHX) {
493 deprecate("comma-less variable list");
494 return REPORT(','); /* grandfather non-comma-format format */
500 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
501 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
505 S_ao(pTHX_ int toketype)
508 if (*PL_bufptr == '=') {
510 if (toketype == ANDAND)
511 pl_yylval.ival = OP_ANDASSIGN;
512 else if (toketype == OROR)
513 pl_yylval.ival = OP_ORASSIGN;
514 else if (toketype == DORDOR)
515 pl_yylval.ival = OP_DORASSIGN;
523 * When Perl expects an operator and finds something else, no_op
524 * prints the warning. It always prints "<something> found where
525 * operator expected. It prints "Missing semicolon on previous line?"
526 * if the surprise occurs at the start of the line. "do you need to
527 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
528 * where the compiler doesn't know if foo is a method call or a function.
529 * It prints "Missing operator before end of line" if there's nothing
530 * after the missing operator, or "... before <...>" if there is something
531 * after the missing operator.
535 S_no_op(pTHX_ const char *const what, char *s)
538 char * const oldbp = PL_bufptr;
539 const bool is_first = (PL_oldbufptr == PL_linestart);
541 PERL_ARGS_ASSERT_NO_OP;
547 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
548 if (ckWARN_d(WARN_SYNTAX)) {
550 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
551 "\t(Missing semicolon on previous line?)\n");
552 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
554 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':');
555 t += UTF ? UTF8SKIP(t) : 1)
557 if (t < PL_bufptr && isSPACE(*t))
558 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
559 "\t(Do you need to predeclare %"SVf"?)\n",
560 SVfARG(newSVpvn_flags(PL_oldoldbufptr, (STRLEN)(t - PL_oldoldbufptr),
561 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
565 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
566 "\t(Missing operator before %"SVf"?)\n",
567 SVfARG(newSVpvn_flags(oldbp, (STRLEN)(s - oldbp),
568 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
576 * Complain about missing quote/regexp/heredoc terminator.
577 * If it's called with NULL then it cauterizes the line buffer.
578 * If we're in a delimited string and the delimiter is a control
579 * character, it's reformatted into a two-char sequence like ^C.
584 S_missingterm(pTHX_ char *s)
590 char * const nl = strrchr(s,'\n');
594 else if (isCNTRL(PL_multi_close)) {
596 tmpbuf[1] = (char)toCTRL(PL_multi_close);
601 *tmpbuf = (char)PL_multi_close;
605 q = strchr(s,'"') ? '\'' : '"';
606 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
612 * Check whether the named feature is enabled.
615 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
618 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
620 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
622 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
624 if (namelen > MAX_FEATURE_LEN)
626 memcpy(&he_name[8], name, namelen);
628 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
629 REFCOUNTED_HE_EXISTS));
633 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
634 * utf16-to-utf8-reversed.
637 #ifdef PERL_CR_FILTER
641 const char *s = SvPVX_const(sv);
642 const char * const e = s + SvCUR(sv);
644 PERL_ARGS_ASSERT_STRIP_RETURN;
646 /* outer loop optimized to do nothing if there are no CR-LFs */
648 if (*s++ == '\r' && *s == '\n') {
649 /* hit a CR-LF, need to copy the rest */
653 if (*s == '\r' && s[1] == '\n')
664 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
666 const I32 count = FILTER_READ(idx+1, sv, maxlen);
667 if (count > 0 && !maxlen)
674 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
676 Creates and initialises a new lexer/parser state object, supplying
677 a context in which to lex and parse from a new source of Perl code.
678 A pointer to the new state object is placed in L</PL_parser>. An entry
679 is made on the save stack so that upon unwinding the new state object
680 will be destroyed and the former value of L</PL_parser> will be restored.
681 Nothing else need be done to clean up the parsing context.
683 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
684 non-null, provides a string (in SV form) containing code to be parsed.
685 A copy of the string is made, so subsequent modification of I<line>
686 does not affect parsing. I<rsfp>, if non-null, provides an input stream
687 from which code will be read to be parsed. If both are non-null, the
688 code in I<line> comes first and must consist of complete lines of input,
689 and I<rsfp> supplies the remainder of the source.
691 The I<flags> parameter is reserved for future use. Currently it is only
692 used by perl internally, so extensions should always pass zero.
697 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
698 can share filters with the current parser.
699 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
700 caller, hence isn't owned by the parser, so shouldn't be closed on parser
701 destruction. This is used to handle the case of defaulting to reading the
702 script from the standard input because no filename was given on the command
703 line (without getting confused by situation where STDIN has been closed, so
704 the script handle is opened on fd 0) */
707 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
710 const char *s = NULL;
711 yy_parser *parser, *oparser;
712 if (flags && flags & ~LEX_START_FLAGS)
713 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
715 /* create and initialise a parser */
717 Newxz(parser, 1, yy_parser);
718 parser->old_parser = oparser = PL_parser;
721 parser->stack = NULL;
723 parser->stack_size = 0;
725 /* on scope exit, free this parser and restore any outer one */
727 parser->saved_curcop = PL_curcop;
729 /* initialise lexer state */
732 parser->curforce = -1;
734 parser->nexttoke = 0;
736 parser->error_count = oparser ? oparser->error_count : 0;
737 parser->copline = NOLINE;
738 parser->lex_state = LEX_NORMAL;
739 parser->expect = XSTATE;
741 parser->rsfp_filters =
742 !(flags & LEX_START_SAME_FILTER) || !oparser
744 : MUTABLE_AV(SvREFCNT_inc(
745 oparser->rsfp_filters
746 ? oparser->rsfp_filters
747 : (oparser->rsfp_filters = newAV())
750 Newx(parser->lex_brackstack, 120, char);
751 Newx(parser->lex_casestack, 12, char);
752 *parser->lex_casestack = '\0';
753 Newxz(parser->lex_shared, 1, LEXSHARED);
757 s = SvPV_const(line, len);
758 parser->linestr = flags & LEX_START_COPIED
759 ? SvREFCNT_inc_simple_NN(line)
760 : newSVpvn_flags(s, len, SvUTF8(line));
761 sv_catpvs(parser->linestr, "\n;");
763 parser->linestr = newSVpvs("\n;");
765 parser->oldoldbufptr =
768 parser->linestart = SvPVX(parser->linestr);
769 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
770 parser->last_lop = parser->last_uni = NULL;
771 parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
772 |LEX_DONT_CLOSE_RSFP);
774 parser->in_pod = parser->filtered = 0;
778 /* delete a parser object */
781 Perl_parser_free(pTHX_ const yy_parser *parser)
783 PERL_ARGS_ASSERT_PARSER_FREE;
785 PL_curcop = parser->saved_curcop;
786 SvREFCNT_dec(parser->linestr);
788 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
789 PerlIO_clearerr(parser->rsfp);
790 else if (parser->rsfp && (!parser->old_parser ||
791 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
792 PerlIO_close(parser->rsfp);
793 SvREFCNT_dec(parser->rsfp_filters);
795 Safefree(parser->lex_brackstack);
796 Safefree(parser->lex_casestack);
797 Safefree(parser->lex_shared);
798 PL_parser = parser->old_parser;
804 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
806 Buffer scalar containing the chunk currently under consideration of the
807 text currently being lexed. This is always a plain string scalar (for
808 which C<SvPOK> is true). It is not intended to be used as a scalar by
809 normal scalar means; instead refer to the buffer directly by the pointer
810 variables described below.
812 The lexer maintains various C<char*> pointers to things in the
813 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
814 reallocated, all of these pointers must be updated. Don't attempt to
815 do this manually, but rather use L</lex_grow_linestr> if you need to
816 reallocate the buffer.
818 The content of the text chunk in the buffer is commonly exactly one
819 complete line of input, up to and including a newline terminator,
820 but there are situations where it is otherwise. The octets of the
821 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
822 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
823 flag on this scalar, which may disagree with it.
825 For direct examination of the buffer, the variable
826 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
827 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
828 of these pointers is usually preferable to examination of the scalar
829 through normal scalar means.
831 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
833 Direct pointer to the end of the chunk of text currently being lexed, the
834 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
835 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
836 always located at the end of the buffer, and does not count as part of
837 the buffer's contents.
839 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
841 Points to the current position of lexing inside the lexer buffer.
842 Characters around this point may be freely examined, within
843 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
844 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
845 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
847 Lexing code (whether in the Perl core or not) moves this pointer past
848 the characters that it consumes. It is also expected to perform some
849 bookkeeping whenever a newline character is consumed. This movement
850 can be more conveniently performed by the function L</lex_read_to>,
851 which handles newlines appropriately.
853 Interpretation of the buffer's octets can be abstracted out by
854 using the slightly higher-level functions L</lex_peek_unichar> and
855 L</lex_read_unichar>.
857 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
859 Points to the start of the current line inside the lexer buffer.
860 This is useful for indicating at which column an error occurred, and
861 not much else. This must be updated by any lexing code that consumes
862 a newline; the function L</lex_read_to> handles this detail.
868 =for apidoc Amx|bool|lex_bufutf8
870 Indicates whether the octets in the lexer buffer
871 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
872 of Unicode characters. If not, they should be interpreted as Latin-1
873 characters. This is analogous to the C<SvUTF8> flag for scalars.
875 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
876 contains valid UTF-8. Lexing code must be robust in the face of invalid
879 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
880 is significant, but not the whole story regarding the input character
881 encoding. Normally, when a file is being read, the scalar contains octets
882 and its C<SvUTF8> flag is off, but the octets should be interpreted as
883 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
884 however, the scalar may have the C<SvUTF8> flag on, and in this case its
885 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
886 is in effect. This logic may change in the future; use this function
887 instead of implementing the logic yourself.
893 Perl_lex_bufutf8(pTHX)
899 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
901 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
902 at least I<len> octets (including terminating NUL). Returns a
903 pointer to the reallocated buffer. This is necessary before making
904 any direct modification of the buffer that would increase its length.
905 L</lex_stuff_pvn> provides a more convenient way to insert text into
908 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
909 this function updates all of the lexer's variables that point directly
916 Perl_lex_grow_linestr(pTHX_ STRLEN len)
920 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
921 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
922 linestr = PL_parser->linestr;
923 buf = SvPVX(linestr);
924 if (len <= SvLEN(linestr))
926 bufend_pos = PL_parser->bufend - buf;
927 bufptr_pos = PL_parser->bufptr - buf;
928 oldbufptr_pos = PL_parser->oldbufptr - buf;
929 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
930 linestart_pos = PL_parser->linestart - buf;
931 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
932 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
933 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
934 PL_parser->lex_shared->re_eval_start - buf : 0;
936 buf = sv_grow(linestr, len);
938 PL_parser->bufend = buf + bufend_pos;
939 PL_parser->bufptr = buf + bufptr_pos;
940 PL_parser->oldbufptr = buf + oldbufptr_pos;
941 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
942 PL_parser->linestart = buf + linestart_pos;
943 if (PL_parser->last_uni)
944 PL_parser->last_uni = buf + last_uni_pos;
945 if (PL_parser->last_lop)
946 PL_parser->last_lop = buf + last_lop_pos;
947 if (PL_parser->lex_shared->re_eval_start)
948 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
953 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
955 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
956 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
957 reallocating the buffer if necessary. This means that lexing code that
958 runs later will see the characters as if they had appeared in the input.
959 It is not recommended to do this as part of normal parsing, and most
960 uses of this facility run the risk of the inserted characters being
961 interpreted in an unintended manner.
963 The string to be inserted is represented by I<len> octets starting
964 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
965 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
966 The characters are recoded for the lexer buffer, according to how the
967 buffer is currently being interpreted (L</lex_bufutf8>). If a string
968 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
969 function is more convenient.
975 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
979 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
980 if (flags & ~(LEX_STUFF_UTF8))
981 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
983 if (flags & LEX_STUFF_UTF8) {
987 const char *p, *e = pv+len;
988 for (p = pv; p != e; p++)
989 highhalf += !!(((U8)*p) & 0x80);
992 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
993 bufptr = PL_parser->bufptr;
994 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
995 SvCUR_set(PL_parser->linestr,
996 SvCUR(PL_parser->linestr) + len+highhalf);
997 PL_parser->bufend += len+highhalf;
998 for (p = pv; p != e; p++) {
1001 *bufptr++ = (char)(0xc0 | (c >> 6));
1002 *bufptr++ = (char)(0x80 | (c & 0x3f));
1004 *bufptr++ = (char)c;
1009 if (flags & LEX_STUFF_UTF8) {
1010 STRLEN highhalf = 0;
1011 const char *p, *e = pv+len;
1012 for (p = pv; p != e; p++) {
1015 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1016 "non-Latin-1 character into Latin-1 input");
1017 } else if (c >= 0xc2 && p+1 != e &&
1018 (((U8)p[1]) & 0xc0) == 0x80) {
1021 } else if (c >= 0x80) {
1022 /* malformed UTF-8 */
1024 SAVESPTR(PL_warnhook);
1025 PL_warnhook = PERL_WARNHOOK_FATAL;
1026 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
1032 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1033 bufptr = PL_parser->bufptr;
1034 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1035 SvCUR_set(PL_parser->linestr,
1036 SvCUR(PL_parser->linestr) + len-highhalf);
1037 PL_parser->bufend += len-highhalf;
1038 for (p = pv; p != e; p++) {
1041 *bufptr++ = (char)(((c & 0x3) << 6) | (p[1] & 0x3f));
1044 *bufptr++ = (char)c;
1049 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1050 bufptr = PL_parser->bufptr;
1051 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1052 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1053 PL_parser->bufend += len;
1054 Copy(pv, bufptr, len, char);
1060 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1062 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1063 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1064 reallocating the buffer if necessary. This means that lexing code that
1065 runs later will see the characters as if they had appeared in the input.
1066 It is not recommended to do this as part of normal parsing, and most
1067 uses of this facility run the risk of the inserted characters being
1068 interpreted in an unintended manner.
1070 The string to be inserted is represented by octets starting at I<pv>
1071 and continuing to the first nul. These octets are interpreted as either
1072 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1073 in I<flags>. The characters are recoded for the lexer buffer, according
1074 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1075 If it is not convenient to nul-terminate a string to be inserted, the
1076 L</lex_stuff_pvn> function is more appropriate.
1082 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1084 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1085 lex_stuff_pvn(pv, strlen(pv), flags);
1089 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1091 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1092 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1093 reallocating the buffer if necessary. This means that lexing code that
1094 runs later will see the characters as if they had appeared in the input.
1095 It is not recommended to do this as part of normal parsing, and most
1096 uses of this facility run the risk of the inserted characters being
1097 interpreted in an unintended manner.
1099 The string to be inserted is the string value of I<sv>. The characters
1100 are recoded for the lexer buffer, according to how the buffer is currently
1101 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1102 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1103 need to construct a scalar.
1109 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1113 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1115 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1117 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1121 =for apidoc Amx|void|lex_unstuff|char *ptr
1123 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1124 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1125 This hides the discarded text from any lexing code that runs later,
1126 as if the text had never appeared.
1128 This is not the normal way to consume lexed text. For that, use
1135 Perl_lex_unstuff(pTHX_ char *ptr)
1139 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1140 buf = PL_parser->bufptr;
1142 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1145 bufend = PL_parser->bufend;
1147 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1148 unstuff_len = ptr - buf;
1149 Move(ptr, buf, bufend+1-ptr, char);
1150 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1151 PL_parser->bufend = bufend - unstuff_len;
1155 =for apidoc Amx|void|lex_read_to|char *ptr
1157 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1158 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1159 performing the correct bookkeeping whenever a newline character is passed.
1160 This is the normal way to consume lexed text.
1162 Interpretation of the buffer's octets can be abstracted out by
1163 using the slightly higher-level functions L</lex_peek_unichar> and
1164 L</lex_read_unichar>.
1170 Perl_lex_read_to(pTHX_ char *ptr)
1173 PERL_ARGS_ASSERT_LEX_READ_TO;
1174 s = PL_parser->bufptr;
1175 if (ptr < s || ptr > PL_parser->bufend)
1176 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1177 for (; s != ptr; s++)
1179 COPLINE_INC_WITH_HERELINES;
1180 PL_parser->linestart = s+1;
1182 PL_parser->bufptr = ptr;
1186 =for apidoc Amx|void|lex_discard_to|char *ptr
1188 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1189 up to I<ptr>. The remaining content of the buffer will be moved, and
1190 all pointers into the buffer updated appropriately. I<ptr> must not
1191 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1192 it is not permitted to discard text that has yet to be lexed.
1194 Normally it is not necessarily to do this directly, because it suffices to
1195 use the implicit discarding behaviour of L</lex_next_chunk> and things
1196 based on it. However, if a token stretches across multiple lines,
1197 and the lexing code has kept multiple lines of text in the buffer for
1198 that purpose, then after completion of the token it would be wise to
1199 explicitly discard the now-unneeded earlier lines, to avoid future
1200 multi-line tokens growing the buffer without bound.
1206 Perl_lex_discard_to(pTHX_ char *ptr)
1210 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1211 buf = SvPVX(PL_parser->linestr);
1213 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1216 if (ptr > PL_parser->bufptr)
1217 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1218 discard_len = ptr - buf;
1219 if (PL_parser->oldbufptr < ptr)
1220 PL_parser->oldbufptr = ptr;
1221 if (PL_parser->oldoldbufptr < ptr)
1222 PL_parser->oldoldbufptr = ptr;
1223 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1224 PL_parser->last_uni = NULL;
1225 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1226 PL_parser->last_lop = NULL;
1227 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1228 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1229 PL_parser->bufend -= discard_len;
1230 PL_parser->bufptr -= discard_len;
1231 PL_parser->oldbufptr -= discard_len;
1232 PL_parser->oldoldbufptr -= discard_len;
1233 if (PL_parser->last_uni)
1234 PL_parser->last_uni -= discard_len;
1235 if (PL_parser->last_lop)
1236 PL_parser->last_lop -= discard_len;
1240 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1242 Reads in the next chunk of text to be lexed, appending it to
1243 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1244 looked to the end of the current chunk and wants to know more. It is
1245 usual, but not necessary, for lexing to have consumed the entirety of
1246 the current chunk at this time.
1248 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1249 chunk (i.e., the current chunk has been entirely consumed), normally the
1250 current chunk will be discarded at the same time that the new chunk is
1251 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1252 will not be discarded. If the current chunk has not been entirely
1253 consumed, then it will not be discarded regardless of the flag.
1255 Returns true if some new text was added to the buffer, or false if the
1256 buffer has reached the end of the input text.
1261 #define LEX_FAKE_EOF 0x80000000
1262 #define LEX_NO_TERM 0x40000000
1265 Perl_lex_next_chunk(pTHX_ U32 flags)
1269 STRLEN old_bufend_pos, new_bufend_pos;
1270 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1271 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1272 bool got_some_for_debugger = 0;
1274 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1275 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1276 linestr = PL_parser->linestr;
1277 buf = SvPVX(linestr);
1278 if (!(flags & LEX_KEEP_PREVIOUS) &&
1279 PL_parser->bufptr == PL_parser->bufend) {
1280 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1282 if (PL_parser->last_uni != PL_parser->bufend)
1283 PL_parser->last_uni = NULL;
1284 if (PL_parser->last_lop != PL_parser->bufend)
1285 PL_parser->last_lop = NULL;
1286 last_uni_pos = last_lop_pos = 0;
1290 old_bufend_pos = PL_parser->bufend - buf;
1291 bufptr_pos = PL_parser->bufptr - buf;
1292 oldbufptr_pos = PL_parser->oldbufptr - buf;
1293 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1294 linestart_pos = PL_parser->linestart - buf;
1295 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1296 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1298 if (flags & LEX_FAKE_EOF) {
1300 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1302 } else if (filter_gets(linestr, old_bufend_pos)) {
1304 got_some_for_debugger = 1;
1305 } else if (flags & LEX_NO_TERM) {
1308 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1309 sv_setpvs(linestr, "");
1311 /* End of real input. Close filehandle (unless it was STDIN),
1312 * then add implicit termination.
1314 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1315 PerlIO_clearerr(PL_parser->rsfp);
1316 else if (PL_parser->rsfp)
1317 (void)PerlIO_close(PL_parser->rsfp);
1318 PL_parser->rsfp = NULL;
1319 PL_parser->in_pod = PL_parser->filtered = 0;
1321 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1324 if (!PL_in_eval && PL_minus_p) {
1326 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1327 PL_minus_n = PL_minus_p = 0;
1328 } else if (!PL_in_eval && PL_minus_n) {
1329 sv_catpvs(linestr, /*{*/";}");
1332 sv_catpvs(linestr, ";");
1335 buf = SvPVX(linestr);
1336 new_bufend_pos = SvCUR(linestr);
1337 PL_parser->bufend = buf + new_bufend_pos;
1338 PL_parser->bufptr = buf + bufptr_pos;
1339 PL_parser->oldbufptr = buf + oldbufptr_pos;
1340 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1341 PL_parser->linestart = buf + linestart_pos;
1342 if (PL_parser->last_uni)
1343 PL_parser->last_uni = buf + last_uni_pos;
1344 if (PL_parser->last_lop)
1345 PL_parser->last_lop = buf + last_lop_pos;
1346 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1347 PL_curstash != PL_debstash) {
1348 /* debugger active and we're not compiling the debugger code,
1349 * so store the line into the debugger's array of lines
1351 update_debugger_info(NULL, buf+old_bufend_pos,
1352 new_bufend_pos-old_bufend_pos);
1358 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1360 Looks ahead one (Unicode) character in the text currently being lexed.
1361 Returns the codepoint (unsigned integer value) of the next character,
1362 or -1 if lexing has reached the end of the input text. To consume the
1363 peeked character, use L</lex_read_unichar>.
1365 If the next character is in (or extends into) the next chunk of input
1366 text, the next chunk will be read in. Normally the current chunk will be
1367 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1368 then the current chunk will not be discarded.
1370 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1371 is encountered, an exception is generated.
1377 Perl_lex_peek_unichar(pTHX_ U32 flags)
1381 if (flags & ~(LEX_KEEP_PREVIOUS))
1382 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1383 s = PL_parser->bufptr;
1384 bufend = PL_parser->bufend;
1390 if (!lex_next_chunk(flags))
1392 s = PL_parser->bufptr;
1393 bufend = PL_parser->bufend;
1399 len = PL_utf8skip[head];
1400 while ((STRLEN)(bufend-s) < len) {
1401 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1403 s = PL_parser->bufptr;
1404 bufend = PL_parser->bufend;
1407 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1408 if (retlen == (STRLEN)-1) {
1409 /* malformed UTF-8 */
1411 SAVESPTR(PL_warnhook);
1412 PL_warnhook = PERL_WARNHOOK_FATAL;
1413 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1419 if (!lex_next_chunk(flags))
1421 s = PL_parser->bufptr;
1428 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1430 Reads the next (Unicode) character in the text currently being lexed.
1431 Returns the codepoint (unsigned integer value) of the character read,
1432 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1433 if lexing has reached the end of the input text. To non-destructively
1434 examine the next character, use L</lex_peek_unichar> instead.
1436 If the next character is in (or extends into) the next chunk of input
1437 text, the next chunk will be read in. Normally the current chunk will be
1438 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1439 then the current chunk will not be discarded.
1441 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1442 is encountered, an exception is generated.
1448 Perl_lex_read_unichar(pTHX_ U32 flags)
1451 if (flags & ~(LEX_KEEP_PREVIOUS))
1452 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1453 c = lex_peek_unichar(flags);
1456 COPLINE_INC_WITH_HERELINES;
1458 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1460 ++(PL_parser->bufptr);
1466 =for apidoc Amx|void|lex_read_space|U32 flags
1468 Reads optional spaces, in Perl style, in the text currently being
1469 lexed. The spaces may include ordinary whitespace characters and
1470 Perl-style comments. C<#line> directives are processed if encountered.
1471 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1472 at a non-space character (or the end of the input text).
1474 If spaces extend into the next chunk of input text, the next chunk will
1475 be read in. Normally the current chunk will be discarded at the same
1476 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1477 chunk will not be discarded.
1482 #define LEX_NO_NEXT_CHUNK 0x80000000
1485 Perl_lex_read_space(pTHX_ U32 flags)
1488 bool need_incline = 0;
1489 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
1490 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1493 sv_free(PL_skipwhite);
1494 PL_skipwhite = NULL;
1497 PL_skipwhite = newSVpvs("");
1498 #endif /* PERL_MAD */
1499 s = PL_parser->bufptr;
1500 bufend = PL_parser->bufend;
1506 } while (!(c == '\n' || (c == 0 && s == bufend)));
1507 } else if (c == '\n') {
1509 PL_parser->linestart = s;
1514 } else if (isSPACE(c)) {
1516 } else if (c == 0 && s == bufend) {
1520 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1521 #endif /* PERL_MAD */
1522 if (flags & LEX_NO_NEXT_CHUNK)
1524 PL_parser->bufptr = s;
1525 COPLINE_INC_WITH_HERELINES;
1526 got_more = lex_next_chunk(flags);
1527 CopLINE_dec(PL_curcop);
1528 s = PL_parser->bufptr;
1529 bufend = PL_parser->bufend;
1532 if (need_incline && PL_parser->rsfp) {
1542 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1543 #endif /* PERL_MAD */
1544 PL_parser->bufptr = s;
1549 * This subroutine has nothing to do with tilting, whether at windmills
1550 * or pinball tables. Its name is short for "increment line". It
1551 * increments the current line number in CopLINE(PL_curcop) and checks
1552 * to see whether the line starts with a comment of the form
1553 * # line 500 "foo.pm"
1554 * If so, it sets the current line number and file to the values in the comment.
1558 S_incline(pTHX_ const char *s)
1566 PERL_ARGS_ASSERT_INCLINE;
1568 COPLINE_INC_WITH_HERELINES;
1571 while (SPACE_OR_TAB(*s))
1573 if (strnEQ(s, "line", 4))
1577 if (SPACE_OR_TAB(*s))
1581 while (SPACE_OR_TAB(*s))
1589 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1591 while (SPACE_OR_TAB(*s))
1593 if (*s == '"' && (t = strchr(s+1, '"'))) {
1599 while (!isSPACE(*t))
1603 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1605 if (*e != '\n' && *e != '\0')
1606 return; /* false alarm */
1608 line_num = atoi(n)-1;
1611 const STRLEN len = t - s;
1612 SV *const temp_sv = CopFILESV(PL_curcop);
1617 cf = SvPVX(temp_sv);
1618 tmplen = SvCUR(temp_sv);
1624 if (!PL_rsfp && !PL_parser->filtered) {
1625 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1626 * to *{"::_<newfilename"} */
1627 /* However, the long form of evals is only turned on by the
1628 debugger - usually they're "(eval %lu)" */
1632 STRLEN tmplen2 = len;
1633 if (tmplen + 2 <= sizeof smallbuf)
1636 Newx(tmpbuf, tmplen + 2, char);
1639 memcpy(tmpbuf + 2, cf, tmplen);
1641 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1646 if (tmplen2 + 2 <= sizeof smallbuf)
1649 Newx(tmpbuf2, tmplen2 + 2, char);
1651 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1652 /* Either they malloc'd it, or we malloc'd it,
1653 so no prefix is present in ours. */
1658 memcpy(tmpbuf2 + 2, s, tmplen2);
1661 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1663 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1664 /* adjust ${"::_<newfilename"} to store the new file name */
1665 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1666 /* The line number may differ. If that is the case,
1667 alias the saved lines that are in the array.
1668 Otherwise alias the whole array. */
1669 if (CopLINE(PL_curcop) == line_num) {
1670 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1671 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1673 else if (GvAV(*gvp)) {
1674 AV * const av = GvAV(*gvp);
1675 const I32 start = CopLINE(PL_curcop)+1;
1676 I32 items = AvFILLp(av) - start;
1678 AV * const av2 = GvAVn(gv2);
1679 SV **svp = AvARRAY(av) + start;
1680 I32 l = (I32)line_num+1;
1682 av_store(av2, l++, SvREFCNT_inc(*svp++));
1687 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1689 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1691 CopFILE_free(PL_curcop);
1692 CopFILE_setn(PL_curcop, s, len);
1694 CopLINE_set(PL_curcop, line_num);
1698 /* skip space before PL_thistoken */
1701 S_skipspace0(pTHX_ register char *s)
1703 PERL_ARGS_ASSERT_SKIPSPACE0;
1710 PL_thiswhite = newSVpvs("");
1711 sv_catsv(PL_thiswhite, PL_skipwhite);
1712 sv_free(PL_skipwhite);
1715 PL_realtokenstart = s - SvPVX(PL_linestr);
1719 /* skip space after PL_thistoken */
1722 S_skipspace1(pTHX_ register char *s)
1724 const char *start = s;
1725 I32 startoff = start - SvPVX(PL_linestr);
1727 PERL_ARGS_ASSERT_SKIPSPACE1;
1732 start = SvPVX(PL_linestr) + startoff;
1733 if (!PL_thistoken && PL_realtokenstart >= 0) {
1734 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1735 PL_thistoken = newSVpvn(tstart, start - tstart);
1737 PL_realtokenstart = -1;
1740 PL_nextwhite = newSVpvs("");
1741 sv_catsv(PL_nextwhite, PL_skipwhite);
1742 sv_free(PL_skipwhite);
1749 S_skipspace2(pTHX_ register char *s, SV **svp)
1752 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1753 const I32 startoff = s - SvPVX(PL_linestr);
1755 PERL_ARGS_ASSERT_SKIPSPACE2;
1758 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1759 if (!PL_madskills || !svp)
1761 start = SvPVX(PL_linestr) + startoff;
1762 if (!PL_thistoken && PL_realtokenstart >= 0) {
1763 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1764 PL_thistoken = newSVpvn(tstart, start - tstart);
1765 PL_realtokenstart = -1;
1769 *svp = newSVpvs("");
1770 sv_setsv(*svp, PL_skipwhite);
1771 sv_free(PL_skipwhite);
1780 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1782 AV *av = CopFILEAVx(PL_curcop);
1784 SV * const sv = newSV_type(SVt_PVMG);
1786 sv_setsv(sv, orig_sv);
1788 sv_setpvn(sv, buf, len);
1791 av_store(av, (I32)CopLINE(PL_curcop), sv);
1797 * Called to gobble the appropriate amount and type of whitespace.
1798 * Skips comments as well.
1802 S_skipspace(pTHX_ register char *s)
1806 #endif /* PERL_MAD */
1807 PERL_ARGS_ASSERT_SKIPSPACE;
1810 sv_free(PL_skipwhite);
1811 PL_skipwhite = NULL;
1813 #endif /* PERL_MAD */
1814 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1815 while (s < PL_bufend && SPACE_OR_TAB(*s))
1818 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1820 lex_read_space(LEX_KEEP_PREVIOUS |
1821 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1822 LEX_NO_NEXT_CHUNK : 0));
1824 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1825 if (PL_linestart > PL_bufptr)
1826 PL_bufptr = PL_linestart;
1831 PL_skipwhite = newSVpvn(start, s-start);
1832 #endif /* PERL_MAD */
1838 * Check the unary operators to ensure there's no ambiguity in how they're
1839 * used. An ambiguous piece of code would be:
1841 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1842 * the +5 is its argument.
1852 if (PL_oldoldbufptr != PL_last_uni)
1854 while (isSPACE(*PL_last_uni))
1857 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1859 if ((t = strchr(s, '(')) && t < PL_bufptr)
1862 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1863 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1864 (int)(s - PL_last_uni), PL_last_uni);
1868 * LOP : macro to build a list operator. Its behaviour has been replaced
1869 * with a subroutine, S_lop() for which LOP is just another name.
1872 #define LOP(f,x) return lop(f,x,s)
1876 * Build a list operator (or something that might be one). The rules:
1877 * - if we have a next token, then it's a list operator [why?]
1878 * - if the next thing is an opening paren, then it's a function
1879 * - else it's a list operator
1883 S_lop(pTHX_ I32 f, int x, char *s)
1887 PERL_ARGS_ASSERT_LOP;
1893 PL_last_lop = PL_oldbufptr;
1894 PL_last_lop_op = (OPCODE)f;
1903 return REPORT(FUNC);
1906 return REPORT(FUNC);
1909 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1910 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1911 return REPORT(LSTOP);
1918 * Sets up for an eventual force_next(). start_force(0) basically does
1919 * an unshift, while start_force(-1) does a push. yylex removes items
1924 S_start_force(pTHX_ int where)
1928 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1929 where = PL_lasttoke;
1930 assert(PL_curforce < 0 || PL_curforce == where);
1931 if (PL_curforce != where) {
1932 for (i = PL_lasttoke; i > where; --i) {
1933 PL_nexttoke[i] = PL_nexttoke[i-1];
1937 if (PL_curforce < 0) /* in case of duplicate start_force() */
1938 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1939 PL_curforce = where;
1942 curmad('^', newSVpvs(""));
1943 CURMAD('_', PL_nextwhite);
1948 S_curmad(pTHX_ char slot, SV *sv)
1954 if (PL_curforce < 0)
1955 where = &PL_thismad;
1957 where = &PL_nexttoke[PL_curforce].next_mad;
1963 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1965 else if (PL_encoding) {
1966 sv_recode_to_utf8(sv, PL_encoding);
1971 /* keep a slot open for the head of the list? */
1972 if (slot != '_' && *where && (*where)->mad_key == '^') {
1973 (*where)->mad_key = slot;
1974 sv_free(MUTABLE_SV(((*where)->mad_val)));
1975 (*where)->mad_val = (void*)sv;
1978 addmad(newMADsv(slot, sv), where, 0);
1981 # define start_force(where) NOOP
1982 # define curmad(slot, sv) NOOP
1987 * When the lexer realizes it knows the next token (for instance,
1988 * it is reordering tokens for the parser) then it can call S_force_next
1989 * to know what token to return the next time the lexer is called. Caller
1990 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1991 * and possibly PL_expect to ensure the lexer handles the token correctly.
1995 S_force_next(pTHX_ I32 type)
2000 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2001 tokereport(type, &NEXTVAL_NEXTTOKE);
2004 /* Don’t let opslab_force_free snatch it */
2005 if (S_is_opval_token(type & 0xffff) && NEXTVAL_NEXTTOKE.opval) {
2006 assert(!NEXTVAL_NEXTTOKE.opval->op_savefree);
2007 NEXTVAL_NEXTTOKE.opval->op_savefree = 1;
2010 if (PL_curforce < 0)
2011 start_force(PL_lasttoke);
2012 PL_nexttoke[PL_curforce].next_type = type;
2013 if (PL_lex_state != LEX_KNOWNEXT)
2014 PL_lex_defer = PL_lex_state;
2015 PL_lex_state = LEX_KNOWNEXT;
2016 PL_lex_expect = PL_expect;
2019 PL_nexttype[PL_nexttoke] = type;
2021 if (PL_lex_state != LEX_KNOWNEXT) {
2022 PL_lex_defer = PL_lex_state;
2023 PL_lex_expect = PL_expect;
2024 PL_lex_state = LEX_KNOWNEXT;
2032 int yyc = PL_parser->yychar;
2033 if (yyc != YYEMPTY) {
2036 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2037 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2038 PL_lex_allbrackets--;
2040 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2041 } else if (yyc == '('/*)*/) {
2042 PL_lex_allbrackets--;
2047 PL_parser->yychar = YYEMPTY;
2052 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2055 SV * const sv = newSVpvn_utf8(start, len,
2058 && !is_ascii_string((const U8*)start, len)
2059 && is_utf8_string((const U8*)start, len));
2065 * When the lexer knows the next thing is a word (for instance, it has
2066 * just seen -> and it knows that the next char is a word char, then
2067 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2071 * char *start : buffer position (must be within PL_linestr)
2072 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2073 * int check_keyword : if true, Perl checks to make sure the word isn't
2074 * a keyword (do this if the word is a label, e.g. goto FOO)
2075 * int allow_pack : if true, : characters will also be allowed (require,
2076 * use, etc. do this)
2077 * int allow_initial_tick : used by the "sub" lexer only.
2081 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
2087 PERL_ARGS_ASSERT_FORCE_WORD;
2089 start = SKIPSPACE1(start);
2091 if (isIDFIRST_lazy_if(s,UTF) ||
2092 (allow_pack && *s == ':') ||
2093 (allow_initial_tick && *s == '\'') )
2095 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2096 if (check_keyword && keyword(PL_tokenbuf, len, 0))
2098 start_force(PL_curforce);
2100 curmad('X', newSVpvn(start,s-start));
2101 if (token == METHOD) {
2106 PL_expect = XOPERATOR;
2110 curmad('g', newSVpvs( "forced" ));
2111 NEXTVAL_NEXTTOKE.opval
2112 = (OP*)newSVOP(OP_CONST,0,
2113 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2114 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2122 * Called when the lexer wants $foo *foo &foo etc, but the program
2123 * text only contains the "foo" portion. The first argument is a pointer
2124 * to the "foo", and the second argument is the type symbol to prefix.
2125 * Forces the next token to be a "WORD".
2126 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2130 S_force_ident(pTHX_ register const char *s, int kind)
2134 PERL_ARGS_ASSERT_FORCE_IDENT;
2137 const STRLEN len = strlen(s);
2138 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2139 UTF ? SVf_UTF8 : 0));
2140 start_force(PL_curforce);
2141 NEXTVAL_NEXTTOKE.opval = o;
2144 o->op_private = OPpCONST_ENTERED;
2145 /* XXX see note in pp_entereval() for why we forgo typo
2146 warnings if the symbol must be introduced in an eval.
2148 gv_fetchpvn_flags(s, len,
2149 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2150 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2151 kind == '$' ? SVt_PV :
2152 kind == '@' ? SVt_PVAV :
2153 kind == '%' ? SVt_PVHV :
2161 Perl_str_to_version(pTHX_ SV *sv)
2166 const char *start = SvPV_const(sv,len);
2167 const char * const end = start + len;
2168 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2170 PERL_ARGS_ASSERT_STR_TO_VERSION;
2172 while (start < end) {
2176 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2181 retval += ((NV)n)/nshift;
2190 * Forces the next token to be a version number.
2191 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2192 * and if "guessing" is TRUE, then no new token is created (and the caller
2193 * must use an alternative parsing method).
2197 S_force_version(pTHX_ char *s, int guessing)
2203 I32 startoff = s - SvPVX(PL_linestr);
2206 PERL_ARGS_ASSERT_FORCE_VERSION;
2214 while (isDIGIT(*d) || *d == '_' || *d == '.')
2218 start_force(PL_curforce);
2219 curmad('X', newSVpvn(s,d-s));
2222 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2224 #ifdef USE_LOCALE_NUMERIC
2225 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2226 setlocale(LC_NUMERIC, "C");
2228 s = scan_num(s, &pl_yylval);
2229 #ifdef USE_LOCALE_NUMERIC
2230 setlocale(LC_NUMERIC, loc);
2233 version = pl_yylval.opval;
2234 ver = cSVOPx(version)->op_sv;
2235 if (SvPOK(ver) && !SvNIOK(ver)) {
2236 SvUPGRADE(ver, SVt_PVNV);
2237 SvNV_set(ver, str_to_version(ver));
2238 SvNOK_on(ver); /* hint that it is a version */
2241 else if (guessing) {
2244 sv_free(PL_nextwhite); /* let next token collect whitespace */
2246 s = SvPVX(PL_linestr) + startoff;
2254 if (PL_madskills && !version) {
2255 sv_free(PL_nextwhite); /* let next token collect whitespace */
2257 s = SvPVX(PL_linestr) + startoff;
2260 /* NOTE: The parser sees the package name and the VERSION swapped */
2261 start_force(PL_curforce);
2262 NEXTVAL_NEXTTOKE.opval = version;
2269 * S_force_strict_version
2270 * Forces the next token to be a version number using strict syntax rules.
2274 S_force_strict_version(pTHX_ char *s)
2279 I32 startoff = s - SvPVX(PL_linestr);
2281 const char *errstr = NULL;
2283 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2285 while (isSPACE(*s)) /* leading whitespace */
2288 if (is_STRICT_VERSION(s,&errstr)) {
2290 s = (char *)scan_version(s, ver, 0);
2291 version = newSVOP(OP_CONST, 0, ver);
2293 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2294 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2298 yyerror(errstr); /* version required */
2303 if (PL_madskills && !version) {
2304 sv_free(PL_nextwhite); /* let next token collect whitespace */
2306 s = SvPVX(PL_linestr) + startoff;
2309 /* NOTE: The parser sees the package name and the VERSION swapped */
2310 start_force(PL_curforce);
2311 NEXTVAL_NEXTTOKE.opval = version;
2319 * Tokenize a quoted string passed in as an SV. It finds the next
2320 * chunk, up to end of string or a backslash. It may make a new
2321 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2326 S_tokeq(pTHX_ SV *sv)
2335 PERL_ARGS_ASSERT_TOKEQ;
2340 s = SvPV_force(sv, len);
2341 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2344 /* This is relying on the SV being "well formed" with a trailing '\0' */
2345 while (s < send && !(*s == '\\' && s[1] == '\\'))
2350 if ( PL_hints & HINT_NEW_STRING ) {
2351 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2355 if (s + 1 < send && (s[1] == '\\'))
2356 s++; /* all that, just for this */
2361 SvCUR_set(sv, d - SvPVX_const(sv));
2363 if ( PL_hints & HINT_NEW_STRING )
2364 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2369 * Now come three functions related to double-quote context,
2370 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2371 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2372 * interact with PL_lex_state, and create fake ( ... ) argument lists
2373 * to handle functions and concatenation.
2377 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2382 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2384 * Pattern matching will set PL_lex_op to the pattern-matching op to
2385 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2387 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2389 * Everything else becomes a FUNC.
2391 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2392 * had an OP_CONST or OP_READLINE). This just sets us up for a
2393 * call to S_sublex_push().
2397 S_sublex_start(pTHX)
2400 const I32 op_type = pl_yylval.ival;
2402 if (op_type == OP_NULL) {
2403 pl_yylval.opval = PL_lex_op;
2407 if (op_type == OP_CONST || op_type == OP_READLINE) {
2408 SV *sv = tokeq(PL_lex_stuff);
2410 if (SvTYPE(sv) == SVt_PVIV) {
2411 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2413 const char * const p = SvPV_const(sv, len);
2414 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2418 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2419 PL_lex_stuff = NULL;
2420 /* Allow <FH> // "foo" */
2421 if (op_type == OP_READLINE)
2422 PL_expect = XTERMORDORDOR;
2425 else if (op_type == OP_BACKTICK && PL_lex_op) {
2426 /* readpipe() vas overriden */
2427 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2428 pl_yylval.opval = PL_lex_op;
2430 PL_lex_stuff = NULL;
2434 PL_sublex_info.super_state = PL_lex_state;
2435 PL_sublex_info.sub_inwhat = (U16)op_type;
2436 PL_sublex_info.sub_op = PL_lex_op;
2437 PL_lex_state = LEX_INTERPPUSH;
2441 pl_yylval.opval = PL_lex_op;
2451 * Create a new scope to save the lexing state. The scope will be
2452 * ended in S_sublex_done. Returns a '(', starting the function arguments
2453 * to the uc, lc, etc. found before.
2454 * Sets PL_lex_state to LEX_INTERPCONCAT.
2464 PL_lex_state = PL_sublex_info.super_state;
2465 SAVEBOOL(PL_lex_dojoin);
2466 SAVEI32(PL_lex_brackets);
2467 SAVEI32(PL_lex_allbrackets);
2468 SAVEI32(PL_lex_formbrack);
2469 SAVEI8(PL_lex_fakeeof);
2470 SAVEI32(PL_lex_casemods);
2471 SAVEI32(PL_lex_starts);
2472 SAVEI8(PL_lex_state);
2473 SAVESPTR(PL_lex_repl);
2474 SAVEVPTR(PL_lex_inpat);
2475 SAVEI16(PL_lex_inwhat);
2476 SAVECOPLINE(PL_curcop);
2477 SAVEPPTR(PL_bufptr);
2478 SAVEPPTR(PL_bufend);
2479 SAVEPPTR(PL_oldbufptr);
2480 SAVEPPTR(PL_oldoldbufptr);
2481 SAVEPPTR(PL_last_lop);
2482 SAVEPPTR(PL_last_uni);
2483 SAVEPPTR(PL_linestart);
2484 SAVESPTR(PL_linestr);
2485 SAVEGENERICPV(PL_lex_brackstack);
2486 SAVEGENERICPV(PL_lex_casestack);
2487 SAVEGENERICPV(PL_parser->lex_shared);
2489 /* The here-doc parser needs to be able to peek into outer lexing
2490 scopes to find the body of the here-doc. So we put PL_linestr and
2491 PL_bufptr into lex_shared, to ‘share’ those values.
2493 PL_parser->lex_shared->ls_linestr = PL_linestr;
2494 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2496 PL_linestr = PL_lex_stuff;
2497 PL_lex_repl = PL_sublex_info.repl;
2498 PL_lex_stuff = NULL;
2499 PL_sublex_info.repl = NULL;
2501 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2502 = SvPVX(PL_linestr);
2503 PL_bufend += SvCUR(PL_linestr);
2504 PL_last_lop = PL_last_uni = NULL;
2505 SAVEFREESV(PL_linestr);
2506 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2508 PL_lex_dojoin = FALSE;
2509 PL_lex_brackets = PL_lex_formbrack = 0;
2510 PL_lex_allbrackets = 0;
2511 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2512 Newx(PL_lex_brackstack, 120, char);
2513 Newx(PL_lex_casestack, 12, char);
2514 PL_lex_casemods = 0;
2515 *PL_lex_casestack = '\0';
2517 PL_lex_state = LEX_INTERPCONCAT;
2518 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2520 Newxz(shared, 1, LEXSHARED);
2521 shared->ls_prev = PL_parser->lex_shared;
2522 PL_parser->lex_shared = shared;
2524 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2525 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2526 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2527 PL_lex_inpat = PL_sublex_info.sub_op;
2529 PL_lex_inpat = NULL;
2536 * Restores lexer state after a S_sublex_push.
2543 if (!PL_lex_starts++) {
2544 SV * const sv = newSVpvs("");
2545 if (SvUTF8(PL_linestr))
2547 PL_expect = XOPERATOR;
2548 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2552 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2553 PL_lex_state = LEX_INTERPCASEMOD;
2557 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2558 assert(PL_lex_inwhat != OP_TRANSR);
2559 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2560 PL_linestr = PL_lex_repl;
2562 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2563 PL_bufend += SvCUR(PL_linestr);
2564 PL_last_lop = PL_last_uni = NULL;
2565 PL_lex_dojoin = FALSE;
2566 PL_lex_brackets = 0;
2567 PL_lex_allbrackets = 0;
2568 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2569 PL_lex_casemods = 0;
2570 *PL_lex_casestack = '\0';
2572 if (SvEVALED(PL_lex_repl)) {
2573 PL_lex_state = LEX_INTERPNORMAL;
2575 /* we don't clear PL_lex_repl here, so that we can check later
2576 whether this is an evalled subst; that means we rely on the
2577 logic to ensure sublex_done() is called again only via the
2578 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2581 PL_lex_state = LEX_INTERPCONCAT;
2591 PL_endwhite = newSVpvs("");
2592 sv_catsv(PL_endwhite, PL_thiswhite);
2596 sv_setpvs(PL_thistoken,"");
2598 PL_realtokenstart = -1;
2602 PL_bufend = SvPVX(PL_linestr);
2603 PL_bufend += SvCUR(PL_linestr);
2604 PL_expect = XOPERATOR;
2605 PL_sublex_info.sub_inwhat = 0;
2613 Extracts the next constant part of a pattern, double-quoted string,
2614 or transliteration. This is terrifying code.
2616 For example, in parsing the double-quoted string "ab\x63$d", it would
2617 stop at the '$' and return an OP_CONST containing 'abc'.
2619 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2620 processing a pattern (PL_lex_inpat is true), a transliteration
2621 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2623 Returns a pointer to the character scanned up to. If this is
2624 advanced from the start pointer supplied (i.e. if anything was
2625 successfully parsed), will leave an OP_CONST for the substring scanned
2626 in pl_yylval. Caller must intuit reason for not parsing further
2627 by looking at the next characters herself.
2631 \N{ABC} => \N{U+41.42.43}
2634 all other \-char, including \N and \N{ apart from \N{ABC}
2637 @ and $ where it appears to be a var, but not for $ as tail anchor
2642 In transliterations:
2643 characters are VERY literal, except for - not at the start or end
2644 of the string, which indicates a range. If the range is in bytes,
2645 scan_const expands the range to the full set of intermediate
2646 characters. If the range is in utf8, the hyphen is replaced with
2647 a certain range mark which will be handled by pmtrans() in op.c.
2649 In double-quoted strings:
2651 double-quoted style: \r and \n
2652 constants: \x31, etc.
2653 deprecated backrefs: \1 (in substitution replacements)
2654 case and quoting: \U \Q \E
2657 scan_const does *not* construct ops to handle interpolated strings.
2658 It stops processing as soon as it finds an embedded $ or @ variable
2659 and leaves it to the caller to work out what's going on.
2661 embedded arrays (whether in pattern or not) could be:
2662 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2664 $ in double-quoted strings must be the symbol of an embedded scalar.
2666 $ in pattern could be $foo or could be tail anchor. Assumption:
2667 it's a tail anchor if $ is the last thing in the string, or if it's
2668 followed by one of "()| \r\n\t"
2670 \1 (backreferences) are turned into $1 in substitutions
2672 The structure of the code is
2673 while (there's a character to process) {
2674 handle transliteration ranges
2675 skip regexp comments /(?#comment)/ and codes /(?{code})/
2676 skip #-initiated comments in //x patterns
2677 check for embedded arrays
2678 check for embedded scalars
2680 deprecate \1 in substitution replacements
2681 handle string-changing backslashes \l \U \Q \E, etc.
2682 switch (what was escaped) {
2683 handle \- in a transliteration (becomes a literal -)
2684 if a pattern and not \N{, go treat as regular character
2685 handle \132 (octal characters)
2686 handle \x15 and \x{1234} (hex characters)
2687 handle \N{name} (named characters, also \N{3,5} in a pattern)
2688 handle \cV (control characters)
2689 handle printf-style backslashes (\f, \r, \n, etc)
2692 } (end if backslash)
2693 handle regular character
2694 } (end while character to read)
2699 S_scan_const(pTHX_ char *start)
2702 char *send = PL_bufend; /* end of the constant */
2703 SV *sv = newSV(send - start); /* sv for the constant. See
2704 note below on sizing. */
2705 char *s = start; /* start of the constant */
2706 char *d = SvPVX(sv); /* destination for copies */
2707 bool dorange = FALSE; /* are we in a translit range? */
2708 bool didrange = FALSE; /* did we just finish a range? */
2709 bool in_charclass = FALSE; /* within /[...]/ */
2710 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2711 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2712 to be UTF8? But, this can
2713 show as true when the source
2714 isn't utf8, as for example
2715 when it is entirely composed
2718 /* Note on sizing: The scanned constant is placed into sv, which is
2719 * initialized by newSV() assuming one byte of output for every byte of
2720 * input. This routine expects newSV() to allocate an extra byte for a
2721 * trailing NUL, which this routine will append if it gets to the end of
2722 * the input. There may be more bytes of input than output (eg., \N{LATIN
2723 * CAPITAL LETTER A}), or more output than input if the constant ends up
2724 * recoded to utf8, but each time a construct is found that might increase
2725 * the needed size, SvGROW() is called. Its size parameter each time is
2726 * based on the best guess estimate at the time, namely the length used so
2727 * far, plus the length the current construct will occupy, plus room for
2728 * the trailing NUL, plus one byte for every input byte still unscanned */
2732 UV literal_endpoint = 0;
2733 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2736 PERL_ARGS_ASSERT_SCAN_CONST;
2738 assert(PL_lex_inwhat != OP_TRANSR);
2739 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2740 /* If we are doing a trans and we know we want UTF8 set expectation */
2741 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2742 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2746 while (s < send || dorange) {
2748 /* get transliterations out of the way (they're most literal) */
2749 if (PL_lex_inwhat == OP_TRANS) {
2750 /* expand a range A-Z to the full set of characters. AIE! */
2752 I32 i; /* current expanded character */
2753 I32 min; /* first character in range */
2754 I32 max; /* last character in range */
2765 char * const c = (char*)utf8_hop((U8*)d, -1);
2769 *c = (char)UTF_TO_NATIVE(0xff);
2770 /* mark the range as done, and continue */
2776 i = d - SvPVX_const(sv); /* remember current offset */
2779 SvLEN(sv) + (has_utf8 ?
2780 (512 - UTF_CONTINUATION_MARK +
2783 /* How many two-byte within 0..255: 128 in UTF-8,
2784 * 96 in UTF-8-mod. */
2786 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2788 d = SvPVX(sv) + i; /* refresh d after realloc */
2792 for (j = 0; j <= 1; j++) {
2793 char * const c = (char*)utf8_hop((U8*)d, -1);
2794 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2800 max = (U8)0xff; /* only to \xff */
2801 uvmax = uv; /* \x{100} to uvmax */
2803 d = c; /* eat endpoint chars */
2808 d -= 2; /* eat the first char and the - */
2809 min = (U8)*d; /* first char in range */
2810 max = (U8)d[1]; /* last char in range */
2818 "Invalid range \"%c-%c\" in transliteration operator",
2819 (char)min, (char)max);
2823 if (literal_endpoint == 2 &&
2824 ((isLOWER(min) && isLOWER(max)) ||
2825 (isUPPER(min) && isUPPER(max)))) {
2827 for (i = min; i <= max; i++)
2829 *d++ = NATIVE_TO_NEED(has_utf8,i);
2831 for (i = min; i <= max; i++)
2833 *d++ = NATIVE_TO_NEED(has_utf8,i);
2838 for (i = min; i <= max; i++)
2841 const U8 ch = (U8)NATIVE_TO_UTF(i);
2842 if (UNI_IS_INVARIANT(ch))
2845 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2846 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2855 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2857 *d++ = (char)UTF_TO_NATIVE(0xff);
2859 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2863 /* mark the range as done, and continue */
2867 literal_endpoint = 0;
2872 /* range begins (ignore - as first or last char) */
2873 else if (*s == '-' && s+1 < send && s != start) {
2876 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2883 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2893 literal_endpoint = 0;
2894 native_range = TRUE;
2899 /* if we get here, we're not doing a transliteration */
2901 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
2904 while (s1 >= start && *s1-- == '\\')
2907 in_charclass = TRUE;
2910 else if (*s == ']' && PL_lex_inpat && in_charclass) {
2913 while (s1 >= start && *s1-- == '\\')
2916 in_charclass = FALSE;
2919 /* skip for regexp comments /(?#comment)/, except for the last
2920 * char, which will be done separately.
2921 * Stop on (?{..}) and friends */
2923 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2925 while (s+1 < send && *s != ')')
2926 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2928 else if (!PL_lex_casemods && !in_charclass &&
2929 ( s[2] == '{' /* This should match regcomp.c */
2930 || (s[2] == '?' && s[3] == '{')))
2936 /* likewise skip #-initiated comments in //x patterns */
2937 else if (*s == '#' && PL_lex_inpat &&
2938 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
2939 while (s+1 < send && *s != '\n')
2940 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2943 /* no further processing of single-quoted regex */
2944 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
2945 goto default_action;
2947 /* check for embedded arrays
2948 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2950 else if (*s == '@' && s[1]) {
2951 if (isALNUM_lazy_if(s+1,UTF))
2953 if (strchr(":'{$", s[1]))
2955 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2956 break; /* in regexp, neither @+ nor @- are interpolated */
2959 /* check for embedded scalars. only stop if we're sure it's a
2962 else if (*s == '$') {
2963 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2965 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2967 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2968 "Possible unintended interpolation of $\\ in regex");
2970 break; /* in regexp, $ might be tail anchor */
2974 /* End of else if chain - OP_TRANS rejoin rest */
2977 if (*s == '\\' && s+1 < send) {
2978 char* e; /* Can be used for ending '}', etc. */
2982 /* warn on \1 - \9 in substitution replacements, but note that \11
2983 * is an octal; and \19 is \1 followed by '9' */
2984 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2985 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2987 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2992 /* string-change backslash escapes */
2993 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
2997 /* In a pattern, process \N, but skip any other backslash escapes.
2998 * This is because we don't want to translate an escape sequence
2999 * into a meta symbol and have the regex compiler use the meta
3000 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3001 * in spite of this, we do have to process \N here while the proper
3002 * charnames handler is in scope. See bugs #56444 and #62056.
3003 * There is a complication because \N in a pattern may also stand
3004 * for 'match a non-nl', and not mean a charname, in which case its
3005 * processing should be deferred to the regex compiler. To be a
3006 * charname it must be followed immediately by a '{', and not look
3007 * like \N followed by a curly quantifier, i.e., not something like
3008 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3010 else if (PL_lex_inpat
3013 || regcurly(s + 1)))
3015 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
3016 goto default_action;
3021 /* quoted - in transliterations */
3023 if (PL_lex_inwhat == OP_TRANS) {
3031 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3032 "Unrecognized escape \\%c passed through",
3034 /* default action is to copy the quoted character */
3035 goto default_action;
3038 /* eg. \132 indicates the octal constant 0132 */
3039 case '0': case '1': case '2': case '3':
3040 case '4': case '5': case '6': case '7':
3044 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
3047 goto NUM_ESCAPE_INSERT;
3049 /* eg. \o{24} indicates the octal constant \024 */
3055 bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
3061 goto NUM_ESCAPE_INSERT;
3064 /* eg. \x24 indicates the hex constant 0x24 */
3070 bool valid = grok_bslash_x(s, &uv, &len, &error, 1);
3079 /* Insert oct or hex escaped character. There will always be
3080 * enough room in sv since such escapes will be longer than any
3081 * UTF-8 sequence they can end up as, except if they force us
3082 * to recode the rest of the string into utf8 */
3084 /* Here uv is the ordinal of the next character being added in
3085 * unicode (converted from native). */
3086 if (!UNI_IS_INVARIANT(uv)) {
3087 if (!has_utf8 && uv > 255) {
3088 /* Might need to recode whatever we have accumulated so
3089 * far if it contains any chars variant in utf8 or
3092 SvCUR_set(sv, d - SvPVX_const(sv));
3095 /* See Note on sizing above. */
3096 sv_utf8_upgrade_flags_grow(sv,
3097 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3098 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3099 d = SvPVX(sv) + SvCUR(sv);
3104 d = (char*)uvuni_to_utf8((U8*)d, uv);
3105 if (PL_lex_inwhat == OP_TRANS &&
3106 PL_sublex_info.sub_op) {
3107 PL_sublex_info.sub_op->op_private |=
3108 (PL_lex_repl ? OPpTRANS_FROM_UTF
3112 if (uv > 255 && !dorange)
3113 native_range = FALSE;
3126 /* In a non-pattern \N must be a named character, like \N{LATIN
3127 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3128 * mean to match a non-newline. For non-patterns, named
3129 * characters are converted to their string equivalents. In
3130 * patterns, named characters are not converted to their
3131 * ultimate forms for the same reasons that other escapes
3132 * aren't. Instead, they are converted to the \N{U+...} form
3133 * to get the value from the charnames that is in effect right
3134 * now, while preserving the fact that it was a named character
3135 * so that the regex compiler knows this */
3137 /* This section of code doesn't generally use the
3138 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3139 * a close examination of this macro and determined it is a
3140 * no-op except on utfebcdic variant characters. Every
3141 * character generated by this that would normally need to be
3142 * enclosed by this macro is invariant, so the macro is not
3143 * needed, and would complicate use of copy(). XXX There are
3144 * other parts of this file where the macro is used
3145 * inconsistently, but are saved by it being a no-op */
3147 /* The structure of this section of code (besides checking for
3148 * errors and upgrading to utf8) is:
3149 * Further disambiguate between the two meanings of \N, and if
3150 * not a charname, go process it elsewhere
3151 * If of form \N{U+...}, pass it through if a pattern;
3152 * otherwise convert to utf8
3153 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3154 * pattern; otherwise convert to utf8 */
3156 /* Here, s points to the 'N'; the test below is guaranteed to
3157 * succeed if we are being called on a pattern as we already
3158 * know from a test above that the next character is a '{'.
3159 * On a non-pattern \N must mean 'named sequence, which
3160 * requires braces */
3163 yyerror("Missing braces on \\N{}");
3168 /* If there is no matching '}', it is an error. */
3169 if (! (e = strchr(s, '}'))) {
3170 if (! PL_lex_inpat) {
3171 yyerror("Missing right brace on \\N{}");
3173 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3178 /* Here it looks like a named character */
3182 /* XXX This block is temporary code. \N{} implies that the
3183 * pattern is to have Unicode semantics, and therefore
3184 * currently has to be encoded in utf8. By putting it in
3185 * utf8 now, we save a whole pass in the regular expression
3186 * compiler. Once that code is changed so Unicode
3187 * semantics doesn't necessarily have to be in utf8, this
3188 * block should be removed. However, the code that parses
3189 * the output of this would have to be changed to not
3190 * necessarily expect utf8 */
3192 SvCUR_set(sv, d - SvPVX_const(sv));
3195 /* See Note on sizing above. */
3196 sv_utf8_upgrade_flags_grow(sv,
3197 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3198 /* 5 = '\N{' + cur char + NUL */
3199 (STRLEN)(send - s) + 5);
3200 d = SvPVX(sv) + SvCUR(sv);
3205 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3206 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3207 | PERL_SCAN_DISALLOW_PREFIX;
3210 /* For \N{U+...}, the '...' is a unicode value even on
3211 * EBCDIC machines */
3212 s += 2; /* Skip to next char after the 'U+' */
3214 uv = grok_hex(s, &len, &flags, NULL);
3215 if (len == 0 || len != (STRLEN)(e - s)) {
3216 yyerror("Invalid hexadecimal number in \\N{U+...}");
3223 /* On non-EBCDIC platforms, pass through to the regex
3224 * compiler unchanged. The reason we evaluated the
3225 * number above is to make sure there wasn't a syntax
3226 * error. But on EBCDIC we convert to native so
3227 * downstream code can continue to assume it's native
3229 s -= 5; /* Include the '\N{U+' */
3231 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3234 (unsigned int) UNI_TO_NATIVE(uv));
3236 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3240 else { /* Not a pattern: convert the hex to string */
3242 /* If destination is not in utf8, unconditionally
3243 * recode it to be so. This is because \N{} implies
3244 * Unicode semantics, and scalars have to be in utf8
3245 * to guarantee those semantics */
3247 SvCUR_set(sv, d - SvPVX_const(sv));
3250 /* See Note on sizing above. */
3251 sv_utf8_upgrade_flags_grow(
3253 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3254 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3255 d = SvPVX(sv) + SvCUR(sv);
3259 /* Add the string to the output */
3260 if (UNI_IS_INVARIANT(uv)) {
3263 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3266 else { /* Here is \N{NAME} but not \N{U+...}. */
3268 SV *res; /* result from charnames */
3269 const char *str; /* the string in 'res' */
3270 STRLEN len; /* its length */
3272 /* Get the value for NAME */
3273 res = newSVpvn(s, e - s);
3274 res = new_constant( NULL, 0, "charnames",
3275 /* includes all of: \N{...} */
3276 res, NULL, s - 3, e - s + 4 );
3278 /* Most likely res will be in utf8 already since the
3279 * standard charnames uses pack U, but a custom translator
3280 * can leave it otherwise, so make sure. XXX This can be
3281 * revisited to not have charnames use utf8 for characters
3282 * that don't need it when regexes don't have to be in utf8
3283 * for Unicode semantics. If doing so, remember EBCDIC */
3284 sv_utf8_upgrade(res);
3285 str = SvPV_const(res, len);
3287 /* Don't accept malformed input */
3288 if (! is_utf8_string((U8 *) str, len)) {
3289 yyerror("Malformed UTF-8 returned by \\N");
3291 else if (PL_lex_inpat) {
3293 if (! len) { /* The name resolved to an empty string */
3294 Copy("\\N{}", d, 4, char);
3298 /* In order to not lose information for the regex
3299 * compiler, pass the result in the specially made
3300 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3301 * the code points in hex of each character
3302 * returned by charnames */
3304 const char *str_end = str + len;
3305 STRLEN char_length; /* cur char's byte length */
3306 STRLEN output_length; /* and the number of bytes
3307 after this is translated
3309 const STRLEN off = d - SvPVX_const(sv);
3311 /* 2 hex per byte; 2 chars for '\N'; 2 chars for
3312 * max('U+', '.'); and 1 for NUL */
3313 char hex_string[2 * UTF8_MAXBYTES + 5];
3315 /* Get the first character of the result. */
3316 U32 uv = utf8n_to_uvuni((U8 *) str,
3321 /* The call to is_utf8_string() above hopefully
3322 * guarantees that there won't be an error. But
3323 * it's easy here to make sure. The function just
3324 * above warns and returns 0 if invalid utf8, but
3325 * it can also return 0 if the input is validly a
3326 * NUL. Disambiguate */
3327 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3328 uv = UNICODE_REPLACEMENT;
3331 /* Convert first code point to hex, including the
3332 * boiler plate before it. For all these, we
3333 * convert to native format so that downstream code
3334 * can continue to assume the input is native */
3336 my_snprintf(hex_string, sizeof(hex_string),
3338 (unsigned int) UNI_TO_NATIVE(uv));
3340 /* Make sure there is enough space to hold it */
3341 d = off + SvGROW(sv, off
3343 + (STRLEN)(send - e)
3344 + 2); /* '}' + NUL */
3346 Copy(hex_string, d, output_length, char);
3349 /* For each subsequent character, append dot and
3350 * its ordinal in hex */
3351 while ((str += char_length) < str_end) {
3352 const STRLEN off = d - SvPVX_const(sv);
3353 U32 uv = utf8n_to_uvuni((U8 *) str,
3357 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3358 uv = UNICODE_REPLACEMENT;
3362 my_snprintf(hex_string, sizeof(hex_string),
3364 (unsigned int) UNI_TO_NATIVE(uv));
3366 d = off + SvGROW(sv, off
3368 + (STRLEN)(send - e)
3369 + 2); /* '}' + NUL */
3370 Copy(hex_string, d, output_length, char);
3374 *d++ = '}'; /* Done. Add the trailing brace */
3377 else { /* Here, not in a pattern. Convert the name to a
3380 /* If destination is not in utf8, unconditionally
3381 * recode it to be so. This is because \N{} implies
3382 * Unicode semantics, and scalars have to be in utf8
3383 * to guarantee those semantics */
3385 SvCUR_set(sv, d - SvPVX_const(sv));
3388 /* See Note on sizing above. */
3389 sv_utf8_upgrade_flags_grow(sv,
3390 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3391 len + (STRLEN)(send - s) + 1);
3392 d = SvPVX(sv) + SvCUR(sv);
3394 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3396 /* See Note on sizing above. (NOTE: SvCUR() is not
3397 * set correctly here). */
3398 const STRLEN off = d - SvPVX_const(sv);
3399 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3401 Copy(str, d, len, char);
3406 /* Deprecate non-approved name syntax */
3407 if (ckWARN_d(WARN_DEPRECATED)) {
3408 bool problematic = FALSE;
3411 /* For non-ut8 input, look to see that the first
3412 * character is an alpha, then loop through the rest
3413 * checking that each is a continuation */
3415 if (! isALPHAU(*i)) problematic = TRUE;
3416 else for (i = s + 1; i < e; i++) {
3417 if (isCHARNAME_CONT(*i)) continue;
3423 /* Similarly for utf8. For invariants can check
3424 * directly. We accept anything above the latin1
3425 * range because it is immaterial to Perl if it is
3426 * correct or not, and is expensive to check. But
3427 * it is fairly easy in the latin1 range to convert
3428 * the variants into a single character and check
3430 if (UTF8_IS_INVARIANT(*i)) {
3431 if (! isALPHAU(*i)) problematic = TRUE;
3432 } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
3433 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
3439 if (! problematic) for (i = s + UTF8SKIP(s);
3443 if (UTF8_IS_INVARIANT(*i)) {
3444 if (isCHARNAME_CONT(*i)) continue;
3445 } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
3447 } else if (isCHARNAME_CONT(
3449 TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
3458 /* The e-i passed to the final %.*s makes sure that
3459 * should the trailing NUL be missing that this
3460 * print won't run off the end of the string */
3461 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3462 "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
3463 (int)(i - s + 1), s, (int)(e - i), i + 1);
3466 } /* End \N{NAME} */
3469 native_range = FALSE; /* \N{} is defined to be Unicode */
3471 s = e + 1; /* Point to just after the '}' */
3474 /* \c is a control character */
3478 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3481 yyerror("Missing control char name in \\c");
3485 /* printf-style backslashes, formfeeds, newlines, etc */
3487 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3490 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3493 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3496 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3499 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3502 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3505 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3511 } /* end if (backslash) */
3518 /* If we started with encoded form, or already know we want it,
3519 then encode the next character */
3520 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3524 /* One might think that it is wasted effort in the case of the
3525 * source being utf8 (this_utf8 == TRUE) to take the next character
3526 * in the source, convert it to an unsigned value, and then convert
3527 * it back again. But the source has not been validated here. The
3528 * routine that does the conversion checks for errors like
3531 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3532 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3534 SvCUR_set(sv, d - SvPVX_const(sv));
3537 /* See Note on sizing above. */
3538 sv_utf8_upgrade_flags_grow(sv,
3539 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3540 need + (STRLEN)(send - s) + 1);
3541 d = SvPVX(sv) + SvCUR(sv);
3543 } else if (need > len) {
3544 /* encoded value larger than old, may need extra space (NOTE:
3545 * SvCUR() is not set correctly here). See Note on sizing
3547 const STRLEN off = d - SvPVX_const(sv);
3548 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3552 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3554 if (uv > 255 && !dorange)
3555 native_range = FALSE;
3559 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3561 } /* while loop to process each character */
3563 /* terminate the string and set up the sv */
3565 SvCUR_set(sv, d - SvPVX_const(sv));
3566 if (SvCUR(sv) >= SvLEN(sv))
3567 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3568 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3571 if (PL_encoding && !has_utf8) {
3572 sv_recode_to_utf8(sv, PL_encoding);
3578 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3579 PL_sublex_info.sub_op->op_private |=
3580 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3584 /* shrink the sv if we allocated more than we used */
3585 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3586 SvPV_shrink_to_cur(sv);
3589 /* return the substring (via pl_yylval) only if we parsed anything */
3590 if (s > PL_bufptr) {
3591 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
3592 const char *const key = PL_lex_inpat ? "qr" : "q";
3593 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3597 if (PL_lex_inwhat == OP_TRANS) {
3600 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3603 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3611 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3614 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3621 * Returns TRUE if there's more to the expression (e.g., a subscript),
3624 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3626 * ->[ and ->{ return TRUE
3627 * { and [ outside a pattern are always subscripts, so return TRUE
3628 * if we're outside a pattern and it's not { or [, then return FALSE
3629 * if we're in a pattern and the first char is a {
3630 * {4,5} (any digits around the comma) returns FALSE
3631 * if we're in a pattern and the first char is a [
3633 * [SOMETHING] has a funky algorithm to decide whether it's a
3634 * character class or not. It has to deal with things like
3635 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3636 * anything else returns TRUE
3639 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3642 S_intuit_more(pTHX_ register char *s)
3646 PERL_ARGS_ASSERT_INTUIT_MORE;
3648 if (PL_lex_brackets)
3650 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3652 if (*s != '{' && *s != '[')
3657 /* In a pattern, so maybe we have {n,m}. */
3665 /* On the other hand, maybe we have a character class */
3668 if (*s == ']' || *s == '^')
3671 /* this is terrifying, and it works */
3672 int weight = 2; /* let's weigh the evidence */
3674 unsigned char un_char = 255, last_un_char;
3675 const char * const send = strchr(s,']');
3676 char tmpbuf[sizeof PL_tokenbuf * 4];
3678 if (!send) /* has to be an expression */
3681 Zero(seen,256,char);
3684 else if (isDIGIT(*s)) {
3686 if (isDIGIT(s[1]) && s[2] == ']')
3692 for (; s < send; s++) {
3693 last_un_char = un_char;
3694 un_char = (unsigned char)*s;
3699 weight -= seen[un_char] * 10;
3700 if (isALNUM_lazy_if(s+1,UTF)) {
3702 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3703 len = (int)strlen(tmpbuf);
3704 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3705 UTF ? SVf_UTF8 : 0, SVt_PV))
3710 else if (*s == '$' && s[1] &&
3711 strchr("[#!%*<>()-=",s[1])) {
3712 if (/*{*/ strchr("])} =",s[2]))
3721 if (strchr("wds]",s[1]))
3723 else if (seen[(U8)'\''] || seen[(U8)'"'])
3725 else if (strchr("rnftbxcav",s[1]))
3727 else if (isDIGIT(s[1])) {
3729 while (s[1] && isDIGIT(s[1]))
3739 if (strchr("aA01! ",last_un_char))
3741 if (strchr("zZ79~",s[1]))
3743 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3744 weight -= 5; /* cope with negative subscript */
3747 if (!isALNUM(last_un_char)
3748 && !(last_un_char == '$' || last_un_char == '@'
3749 || last_un_char == '&')
3750 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3755 if (keyword(tmpbuf, d - tmpbuf, 0))
3758 if (un_char == last_un_char + 1)
3760 weight -= seen[un_char];
3765 if (weight >= 0) /* probably a character class */
3775 * Does all the checking to disambiguate
3777 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3778 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3780 * First argument is the stuff after the first token, e.g. "bar".
3782 * Not a method if foo is a filehandle.
3783 * Not a method if foo is a subroutine prototyped to take a filehandle.
3784 * Not a method if it's really "Foo $bar"
3785 * Method if it's "foo $bar"
3786 * Not a method if it's really "print foo $bar"
3787 * Method if it's really "foo package::" (interpreted as package->foo)
3788 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3789 * Not a method if bar is a filehandle or package, but is quoted with
3794 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3797 char *s = start + (*start == '$');
3798 char tmpbuf[sizeof PL_tokenbuf];
3805 PERL_ARGS_ASSERT_INTUIT_METHOD;
3807 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3809 if (cv && SvPOK(cv)) {
3810 const char *proto = CvPROTO(cv);
3818 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3819 /* start is the beginning of the possible filehandle/object,
3820 * and s is the end of it
3821 * tmpbuf is a copy of it
3824 if (*start == '$') {
3825 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3826 isUPPER(*PL_tokenbuf))
3829 len = start - SvPVX(PL_linestr);
3833 start = SvPVX(PL_linestr) + len;
3837 return *s == '(' ? FUNCMETH : METHOD;
3839 if (!keyword(tmpbuf, len, 0)) {
3840 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3844 soff = s - SvPVX(PL_linestr);
3848 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3849 if (indirgv && GvCVu(indirgv))
3851 /* filehandle or package name makes it a method */
3852 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3854 soff = s - SvPVX(PL_linestr);
3857 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3858 return 0; /* no assumptions -- "=>" quotes bareword */
3860 start_force(PL_curforce);
3861 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3862 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3863 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3865 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
3866 ( UTF ? SVf_UTF8 : 0 )));
3871 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
3873 return *s == '(' ? FUNCMETH : METHOD;
3879 /* Encoded script support. filter_add() effectively inserts a
3880 * 'pre-processing' function into the current source input stream.
3881 * Note that the filter function only applies to the current source file
3882 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3884 * The datasv parameter (which may be NULL) can be used to pass
3885 * private data to this instance of the filter. The filter function
3886 * can recover the SV using the FILTER_DATA macro and use it to
3887 * store private buffers and state information.
3889 * The supplied datasv parameter is upgraded to a PVIO type
3890 * and the IoDIRP/IoANY field is used to store the function pointer,
3891 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3892 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3893 * private use must be set using malloc'd pointers.
3897 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3906 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3907 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3909 if (!PL_rsfp_filters)
3910 PL_rsfp_filters = newAV();
3913 SvUPGRADE(datasv, SVt_PVIO);
3914 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3915 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3916 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3917 FPTR2DPTR(void *, IoANY(datasv)),
3918 SvPV_nolen(datasv)));
3919 av_unshift(PL_rsfp_filters, 1);
3920 av_store(PL_rsfp_filters, 0, datasv) ;
3922 !PL_parser->filtered
3923 && PL_parser->lex_flags & LEX_EVALBYTES
3924 && PL_bufptr < PL_bufend
3926 const char *s = PL_bufptr;
3927 while (s < PL_bufend) {
3929 SV *linestr = PL_parser->linestr;
3930 char *buf = SvPVX(linestr);
3931 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3932 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3933 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3934 STRLEN const linestart_pos = PL_parser->linestart - buf;
3935 STRLEN const last_uni_pos =
3936 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3937 STRLEN const last_lop_pos =
3938 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3939 av_push(PL_rsfp_filters, linestr);
3940 PL_parser->linestr =
3941 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3942 buf = SvPVX(PL_parser->linestr);
3943 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3944 PL_parser->bufptr = buf + bufptr_pos;
3945 PL_parser->oldbufptr = buf + oldbufptr_pos;
3946 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3947 PL_parser->linestart = buf + linestart_pos;
3948 if (PL_parser->last_uni)
3949 PL_parser->last_uni = buf + last_uni_pos;
3950 if (PL_parser->last_lop)
3951 PL_parser->last_lop = buf + last_lop_pos;
3952 SvLEN(linestr) = SvCUR(linestr);
3953 SvCUR(linestr) = s-SvPVX(linestr);
3954 PL_parser->filtered = 1;
3964 /* Delete most recently added instance of this filter function. */
3966 Perl_filter_del(pTHX_ filter_t funcp)
3971 PERL_ARGS_ASSERT_FILTER_DEL;
3974 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3975 FPTR2DPTR(void*, funcp)));
3977 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3979 /* if filter is on top of stack (usual case) just pop it off */
3980 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3981 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3982 sv_free(av_pop(PL_rsfp_filters));
3986 /* we need to search for the correct entry and clear it */
3987 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3991 /* Invoke the idxth filter function for the current rsfp. */
3992 /* maxlen 0 = read one text line */
3994 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
3999 /* This API is bad. It should have been using unsigned int for maxlen.
4000 Not sure if we want to change the API, but if not we should sanity
4001 check the value here. */
4002 unsigned int correct_length
4011 PERL_ARGS_ASSERT_FILTER_READ;
4013 if (!PL_parser || !PL_rsfp_filters)
4015 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4016 /* Provide a default input filter to make life easy. */
4017 /* Note that we append to the line. This is handy. */
4018 DEBUG_P(PerlIO_printf(Perl_debug_log,
4019 "filter_read %d: from rsfp\n", idx));
4020 if (correct_length) {
4023 const int old_len = SvCUR(buf_sv);
4025 /* ensure buf_sv is large enough */
4026 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4027 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4028 correct_length)) <= 0) {
4029 if (PerlIO_error(PL_rsfp))
4030 return -1; /* error */
4032 return 0 ; /* end of file */
4034 SvCUR_set(buf_sv, old_len + len) ;
4035 SvPVX(buf_sv)[old_len + len] = '\0';
4038 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4039 if (PerlIO_error(PL_rsfp))
4040 return -1; /* error */
4042 return 0 ; /* end of file */
4045 return SvCUR(buf_sv);
4047 /* Skip this filter slot if filter has been deleted */
4048 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4049 DEBUG_P(PerlIO_printf(Perl_debug_log,
4050 "filter_read %d: skipped (filter deleted)\n",
4052 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4054 if (SvTYPE(datasv) != SVt_PVIO) {
4055 if (correct_length) {
4057 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4058 if (!remainder) return 0; /* eof */
4059 if (correct_length > remainder) correct_length = remainder;
4060 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4061 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4064 const char *s = SvEND(datasv);
4065 const char *send = SvPVX(datasv) + SvLEN(datasv);
4073 if (s == send) return 0; /* eof */
4074 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4075 SvCUR_set(datasv, s-SvPVX(datasv));
4077 return SvCUR(buf_sv);
4079 /* Get function pointer hidden within datasv */
4080 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4081 DEBUG_P(PerlIO_printf(Perl_debug_log,
4082 "filter_read %d: via function %p (%s)\n",
4083 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4084 /* Call function. The function is expected to */
4085 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4086 /* Return: <0:error, =0:eof, >0:not eof */
4087 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4091 S_filter_gets(pTHX_ register SV *sv, STRLEN append)
4095 PERL_ARGS_ASSERT_FILTER_GETS;
4097 #ifdef PERL_CR_FILTER
4098 if (!PL_rsfp_filters) {
4099 filter_add(S_cr_textfilter,NULL);
4102 if (PL_rsfp_filters) {
4104 SvCUR_set(sv, 0); /* start with empty line */
4105 if (FILTER_READ(0, sv, 0) > 0)
4106 return ( SvPVX(sv) ) ;
4111 return (sv_gets(sv, PL_rsfp, append));
4115 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4120 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4122 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4126 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4127 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4129 return GvHV(gv); /* Foo:: */
4132 /* use constant CLASS => 'MyClass' */
4133 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4134 if (gv && GvCV(gv)) {
4135 SV * const sv = cv_const_sv(GvCV(gv));
4137 pkgname = SvPV_const(sv, len);
4140 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4144 * S_readpipe_override
4145 * Check whether readpipe() is overridden, and generates the appropriate
4146 * optree, provided sublex_start() is called afterwards.
4149 S_readpipe_override(pTHX)
4152 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4153 pl_yylval.ival = OP_BACKTICK;
4155 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4157 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4158 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4159 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4161 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4162 op_append_elem(OP_LIST,
4163 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4164 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4171 * The intent of this yylex wrapper is to minimize the changes to the
4172 * tokener when we aren't interested in collecting madprops. It remains
4173 * to be seen how successful this strategy will be...
4180 char *s = PL_bufptr;
4182 /* make sure PL_thiswhite is initialized */
4186 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
4187 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4188 return S_pending_ident(aTHX);
4190 /* previous token ate up our whitespace? */
4191 if (!PL_lasttoke && PL_nextwhite) {
4192 PL_thiswhite = PL_nextwhite;
4196 /* isolate the token, and figure out where it is without whitespace */
4197 PL_realtokenstart = -1;
4201 assert(PL_curforce < 0);
4203 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4204 if (!PL_thistoken) {
4205 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4206 PL_thistoken = newSVpvs("");
4208 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4209 PL_thistoken = newSVpvn(tstart, s - tstart);
4212 if (PL_thismad) /* install head */
4213 CURMAD('X', PL_thistoken);
4216 /* last whitespace of a sublex? */
4217 if (optype == ')' && PL_endwhite) {
4218 CURMAD('X', PL_endwhite);
4223 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4224 if (!PL_thiswhite && !PL_endwhite && !optype) {
4225 sv_free(PL_thistoken);
4230 /* put off final whitespace till peg */
4231 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4232 PL_nextwhite = PL_thiswhite;
4235 else if (PL_thisopen) {
4236 CURMAD('q', PL_thisopen);
4238 sv_free(PL_thistoken);
4242 /* Store actual token text as madprop X */
4243 CURMAD('X', PL_thistoken);
4247 /* add preceding whitespace as madprop _ */
4248 CURMAD('_', PL_thiswhite);
4252 /* add quoted material as madprop = */
4253 CURMAD('=', PL_thisstuff);
4257 /* add terminating quote as madprop Q */
4258 CURMAD('Q', PL_thisclose);
4262 /* special processing based on optype */
4266 /* opval doesn't need a TOKEN since it can already store mp */
4277 if (pl_yylval.opval)
4278 append_madprops(PL_thismad, pl_yylval.opval, 0);
4286 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4295 /* remember any fake bracket that lexer is about to discard */
4296 if (PL_lex_brackets == 1 &&
4297 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4300 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4303 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4304 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4307 break; /* don't bother looking for trailing comment */
4316 /* attach a trailing comment to its statement instead of next token */
4320 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4322 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4324 if (*s == '\n' || *s == '#') {
4325 while (s < PL_bufend && *s != '\n')
4329 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4330 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4343 /* Create new token struct. Note: opvals return early above. */
4344 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4351 S_tokenize_use(pTHX_ int is_use, char *s) {
4354 PERL_ARGS_ASSERT_TOKENIZE_USE;
4356 if (PL_expect != XSTATE)
4357 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4358 is_use ? "use" : "no"));
4361 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4362 s = force_version(s, TRUE);
4363 if (*s == ';' || *s == '}'
4364 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4365 start_force(PL_curforce);
4366 NEXTVAL_NEXTTOKE.opval = NULL;
4369 else if (*s == 'v') {
4370 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4371 s = force_version(s, FALSE);
4375 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4376 s = force_version(s, FALSE);
4378 pl_yylval.ival = is_use;
4382 static const char* const exp_name[] =
4383 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4384 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4388 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4390 S_word_takes_any_delimeter(char *p, STRLEN len)
4392 return (len == 1 && strchr("msyq", p[0])) ||
4394 (p[0] == 't' && p[1] == 'r') ||
4395 (p[0] == 'q' && strchr("qwxr", p[1]))));
4401 Works out what to call the token just pulled out of the input
4402 stream. The yacc parser takes care of taking the ops we return and
4403 stitching them into a tree.
4409 if read an identifier
4410 if we're in a my declaration
4411 croak if they tried to say my($foo::bar)
4412 build the ops for a my() declaration
4413 if it's an access to a my() variable
4414 are we in a sort block?
4415 croak if my($a); $a <=> $b
4416 build ops for access to a my() variable
4417 if in a dq string, and they've said @foo and we can't find @foo
4419 build ops for a bareword
4420 if we already built the token before, use it.
4425 #pragma segment Perl_yylex
4431 char *s = PL_bufptr;
4438 /* orig_keyword, gvp, and gv are initialized here because
4439 * jump to the label just_a_word_zero can bypass their
4440 * initialization later. */
4441 I32 orig_keyword = 0;
4446 SV* tmp = newSVpvs("");
4447 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4448 (IV)CopLINE(PL_curcop),
4449 lex_state_names[PL_lex_state],
4450 exp_name[PL_expect],
4451 pv_display(tmp, s, strlen(s), 0, 60));
4454 /* check if there's an identifier for us to look at */
4455 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4456 return REPORT(S_pending_ident(aTHX));
4458 /* no identifier pending identification */
4460 switch (PL_lex_state) {
4462 case LEX_NORMAL: /* Some compilers will produce faster */
4463 case LEX_INTERPNORMAL: /* code if we comment these out. */
4467 /* when we've already built the next token, just pull it out of the queue */
4471 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4473 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4474 PL_nexttoke[PL_lasttoke].next_mad = 0;
4475 if (PL_thismad && PL_thismad->mad_key == '_') {
4476 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4477 PL_thismad->mad_val = 0;
4478 mad_free(PL_thismad);
4483 PL_lex_state = PL_lex_defer;
4484 PL_expect = PL_lex_expect;
4485 PL_lex_defer = LEX_NORMAL;
4486 if (!PL_nexttoke[PL_lasttoke].next_type)
4491 pl_yylval = PL_nextval[PL_nexttoke];
4493 PL_lex_state = PL_lex_defer;
4494 PL_expect = PL_lex_expect;
4495 PL_lex_defer = LEX_NORMAL;
4501 next_type = PL_nexttoke[PL_lasttoke].next_type;
4503 next_type = PL_nexttype[PL_nexttoke];
4505 if (next_type & (7<<24)) {
4506 if (next_type & (1<<24)) {
4507 if (PL_lex_brackets > 100)
4508 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4509 PL_lex_brackstack[PL_lex_brackets++] =
4510 (char) ((next_type >> 16) & 0xff);
4512 if (next_type & (2<<24))
4513 PL_lex_allbrackets++;
4514 if (next_type & (4<<24))
4515 PL_lex_allbrackets--;
4516 next_type &= 0xffff;
4518 if (S_is_opval_token(next_type) && pl_yylval.opval)
4519 pl_yylval.opval->op_savefree = 0; /* release */
4520 return REPORT(next_type);
4523 /* interpolated case modifiers like \L \U, including \Q and \E.
4524 when we get here, PL_bufptr is at the \
4526 case LEX_INTERPCASEMOD:
4528 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4530 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4531 PL_bufptr, PL_bufend, *PL_bufptr);
4533 /* handle \E or end of string */
4534 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4536 if (PL_lex_casemods) {
4537 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4538 PL_lex_casestack[PL_lex_casemods] = '\0';
4540 if (PL_bufptr != PL_bufend
4541 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4542 || oldmod == 'F')) {
4544 PL_lex_state = LEX_INTERPCONCAT;
4547 PL_thistoken = newSVpvs("\\E");
4550 PL_lex_allbrackets--;
4553 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4554 /* Got an unpaired \E */
4555 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4556 "Useless use of \\E");
4559 while (PL_bufptr != PL_bufend &&
4560 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4562 PL_thiswhite = newSVpvs("");
4563 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4567 if (PL_bufptr != PL_bufend)
4570 PL_lex_state = LEX_INTERPCONCAT;
4574 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4575 "### Saw case modifier\n"); });
4577 if (s[1] == '\\' && s[2] == 'E') {
4580 PL_thiswhite = newSVpvs("");
4581 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4584 PL_lex_state = LEX_INTERPCONCAT;
4589 if (!PL_madskills) /* when just compiling don't need correct */
4590 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4591 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4592 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4593 (strchr(PL_lex_casestack, 'L')
4594 || strchr(PL_lex_casestack, 'U')
4595 || strchr(PL_lex_casestack, 'F'))) {
4596 PL_lex_casestack[--PL_lex_casemods] = '\0';
4597 PL_lex_allbrackets--;
4600 if (PL_lex_casemods > 10)
4601 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4602 PL_lex_casestack[PL_lex_casemods++] = *s;
4603 PL_lex_casestack[PL_lex_casemods] = '\0';
4604 PL_lex_state = LEX_INTERPCONCAT;
4605 start_force(PL_curforce);
4606 NEXTVAL_NEXTTOKE.ival = 0;
4607 force_next((2<<24)|'(');
4608 start_force(PL_curforce);
4610 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4612 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4614 NEXTVAL_NEXTTOKE.ival = OP_LC;
4616 NEXTVAL_NEXTTOKE.ival = OP_UC;
4618 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4620 NEXTVAL_NEXTTOKE.ival = OP_FC;
4622 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4624 SV* const tmpsv = newSVpvs("\\ ");
4625 /* replace the space with the character we want to escape
4627 SvPVX(tmpsv)[1] = *s;
4633 if (PL_lex_starts) {
4639 sv_free(PL_thistoken);
4640 PL_thistoken = newSVpvs("");
4643 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4644 if (PL_lex_casemods == 1 && PL_lex_inpat)
4653 case LEX_INTERPPUSH:
4654 return REPORT(sublex_push());
4656 case LEX_INTERPSTART:
4657 if (PL_bufptr == PL_bufend)
4658 return REPORT(sublex_done());
4659 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4660 "### Interpolated variable\n"); });
4662 PL_lex_dojoin = (*PL_bufptr == '@');
4663 PL_lex_state = LEX_INTERPNORMAL;
4664 if (PL_lex_dojoin) {
4665 start_force(PL_curforce);
4666 NEXTVAL_NEXTTOKE.ival = 0;
4668 start_force(PL_curforce);
4669 force_ident("\"", '$');
4670 start_force(PL_curforce);
4671 NEXTVAL_NEXTTOKE.ival = 0;
4673 start_force(PL_curforce);
4674 NEXTVAL_NEXTTOKE.ival = 0;
4675 force_next((2<<24)|'(');
4676 start_force(PL_curforce);
4677 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4680 /* Convert (?{...}) and friends to 'do {...}' */
4681 if (PL_lex_inpat && *PL_bufptr == '(') {
4682 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4684 if (*PL_bufptr != '{')
4686 start_force(PL_curforce);
4687 /* XXX probably need a CURMAD(something) here */
4688 PL_expect = XTERMBLOCK;
4692 if (PL_lex_starts++) {
4697 sv_free(PL_thistoken);
4698 PL_thistoken = newSVpvs("");
4701 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4702 if (!PL_lex_casemods && PL_lex_inpat)
4709 case LEX_INTERPENDMAYBE:
4710 if (intuit_more(PL_bufptr)) {
4711 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4717 if (PL_lex_dojoin) {
4718 PL_lex_dojoin = FALSE;
4719 PL_lex_state = LEX_INTERPCONCAT;
4723 sv_free(PL_thistoken);
4724 PL_thistoken = newSVpvs("");
4727 PL_lex_allbrackets--;
4730 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4731 && SvEVALED(PL_lex_repl))
4733 if (PL_bufptr != PL_bufend)
4734 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4737 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4738 re_eval_str. If the here-doc body’s length equals the previous
4739 value of re_eval_start, re_eval_start will now be null. So
4740 check re_eval_str as well. */
4741 if (PL_parser->lex_shared->re_eval_start
4742 || PL_parser->lex_shared->re_eval_str) {
4744 if (*PL_bufptr != ')')
4745 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4747 /* having compiled a (?{..}) expression, return the original
4748 * text too, as a const */
4749 if (PL_parser->lex_shared->re_eval_str) {
4750 sv = PL_parser->lex_shared->re_eval_str;
4751 PL_parser->lex_shared->re_eval_str = NULL;
4753 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4754 SvPV_shrink_to_cur(sv);
4756 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4757 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4758 start_force(PL_curforce);
4759 /* XXX probably need a CURMAD(something) here */
4760 NEXTVAL_NEXTTOKE.opval =
4761 (OP*)newSVOP(OP_CONST, 0,
4764 PL_parser->lex_shared->re_eval_start = NULL;
4770 case LEX_INTERPCONCAT:
4772 if (PL_lex_brackets)
4773 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4774 (long) PL_lex_brackets);
4776 if (PL_bufptr == PL_bufend)
4777 return REPORT(sublex_done());
4779 /* m'foo' still needs to be parsed for possible (?{...}) */
4780 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4781 SV *sv = newSVsv(PL_linestr);
4783 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4787 s = scan_const(PL_bufptr);
4789 PL_lex_state = LEX_INTERPCASEMOD;
4791 PL_lex_state = LEX_INTERPSTART;
4794 if (s != PL_bufptr) {
4795 start_force(PL_curforce);
4797 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
4799 NEXTVAL_NEXTTOKE = pl_yylval;
4802 if (PL_lex_starts++) {
4806 sv_free(PL_thistoken);
4807 PL_thistoken = newSVpvs("");
4810 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4811 if (!PL_lex_casemods && PL_lex_inpat)
4824 s = scan_formline(PL_bufptr);
4825 if (!PL_lex_formbrack)
4835 PL_oldoldbufptr = PL_oldbufptr;
4841 sv_free(PL_thistoken);
4844 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
4848 if (isIDFIRST_lazy_if(s,UTF))
4851 SV *dsv = newSVpvs_flags("", SVs_TEMP);
4852 const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
4854 SVs_TEMP | SVf_UTF8),
4855 10, UNI_DISPLAY_ISPRINT))
4856 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
4857 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4858 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4859 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4867 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
4871 goto fake_eof; /* emulate EOF on ^D or ^Z */
4877 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
4880 if (PL_lex_brackets &&
4881 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4882 yyerror((const char *)
4884 ? "Format not terminated"
4885 : "Missing right curly or square bracket"));
4887 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4888 "### Tokener got EOF\n");
4892 if (s++ < PL_bufend)
4893 goto retry; /* ignore stray nulls */
4896 if (!PL_in_eval && !PL_preambled) {
4897 PL_preambled = TRUE;
4903 /* Generate a string of Perl code to load the debugger.
4904 * If PERL5DB is set, it will return the contents of that,
4905 * otherwise a compile-time require of perl5db.pl. */
4907 const char * const pdb = PerlEnv_getenv("PERL5DB");
4910 sv_setpv(PL_linestr, pdb);
4911 sv_catpvs(PL_linestr,";");
4913 SETERRNO(0,SS_NORMAL);
4914 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4917 sv_setpvs(PL_linestr,"");
4918 if (PL_preambleav) {
4919 SV **svp = AvARRAY(PL_preambleav);
4920 SV **const end = svp + AvFILLp(PL_preambleav);
4922 sv_catsv(PL_linestr, *svp);
4924 sv_catpvs(PL_linestr, ";");
4926 sv_free(MUTABLE_SV(PL_preambleav));
4927 PL_preambleav = NULL;
4930 sv_catpvs(PL_linestr,
4931 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4932 if (PL_minus_n || PL_minus_p) {
4933 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4935 sv_catpvs(PL_linestr,"chomp;");
4938 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4939 || *PL_splitstr == '"')
4940 && strchr(PL_splitstr + 1, *PL_splitstr))
4941 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4943 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4944 bytes can be used as quoting characters. :-) */
4945 const char *splits = PL_splitstr;
4946 sv_catpvs(PL_linestr, "our @F=split(q\0");
4949 if (*splits == '\\')
4950 sv_catpvn(PL_linestr, splits, 1);
4951 sv_catpvn(PL_linestr, splits, 1);
4952 } while (*splits++);
4953 /* This loop will embed the trailing NUL of
4954 PL_linestr as the last thing it does before
4956 sv_catpvs(PL_linestr, ");");
4960 sv_catpvs(PL_linestr,"our @F=split(' ');");
4963 sv_catpvs(PL_linestr, "\n");
4964 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4965 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4966 PL_last_lop = PL_last_uni = NULL;
4967 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4968 update_debugger_info(PL_linestr, NULL, 0);
4973 bof = PL_rsfp ? TRUE : FALSE;
4976 fake_eof = LEX_FAKE_EOF;
4978 PL_bufptr = PL_bufend;
4979 COPLINE_INC_WITH_HERELINES;
4980 if (!lex_next_chunk(fake_eof)) {
4981 CopLINE_dec(PL_curcop);
4983 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4985 CopLINE_dec(PL_curcop);
4988 PL_realtokenstart = -1;
4991 /* If it looks like the start of a BOM or raw UTF-16,
4992 * check if it in fact is. */
4993 if (bof && PL_rsfp &&
4998 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4999 bof = (offset == (Off_t)SvCUR(PL_linestr));
5000 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5001 /* offset may include swallowed CR */
5003 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5006 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5007 s = swallow_bom((U8*)s);
5010 if (PL_parser->in_pod) {
5011 /* Incest with pod. */
5014 sv_catsv(PL_thiswhite, PL_linestr);
5016 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
5017 sv_setpvs(PL_linestr, "");
5018 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5019 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5020 PL_last_lop = PL_last_uni = NULL;
5021 PL_parser->in_pod = 0;
5024 if (PL_rsfp || PL_parser->filtered)
5026 } while (PL_parser->in_pod);
5027 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5028 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5029 PL_last_lop = PL_last_uni = NULL;
5030 if (CopLINE(PL_curcop) == 1) {
5031 while (s < PL_bufend && isSPACE(*s))
5033 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5037 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
5041 if (*s == '#' && *(s+1) == '!')
5043 #ifdef ALTERNATE_SHEBANG
5045 static char const as[] = ALTERNATE_SHEBANG;
5046 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5047 d = s + (sizeof(as) - 1);
5049 #endif /* ALTERNATE_SHEBANG */
5058 while (*d && !isSPACE(*d))
5062 #ifdef ARG_ZERO_IS_SCRIPT
5063 if (ipathend > ipath) {
5065 * HP-UX (at least) sets argv[0] to the script name,
5066 * which makes $^X incorrect. And Digital UNIX and Linux,
5067 * at least, set argv[0] to the basename of the Perl
5068 * interpreter. So, having found "#!", we'll set it right.
5070 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5072 assert(SvPOK(x) || SvGMAGICAL(x));
5073 if (sv_eq(x, CopFILESV(PL_curcop))) {
5074 sv_setpvn(x, ipath, ipathend - ipath);
5080 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
5081 const char * const lstart = SvPV_const(x,llen);
5083 bstart += blen - llen;
5084 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5085 sv_setpvn(x, ipath, ipathend - ipath);
5090 TAINT_NOT; /* $^X is always tainted, but that's OK */
5092 #endif /* ARG_ZERO_IS_SCRIPT */
5097 d = instr(s,"perl -");
5099 d = instr(s,"perl");
5101 /* avoid getting into infinite loops when shebang
5102 * line contains "Perl" rather than "perl" */
5104 for (d = ipathend-4; d >= ipath; --d) {
5105 if ((*d == 'p' || *d == 'P')
5106 && !ibcmp(d, "perl", 4))
5116 #ifdef ALTERNATE_SHEBANG
5118 * If the ALTERNATE_SHEBANG on this system starts with a
5119 * character that can be part of a Perl expression, then if
5120 * we see it but not "perl", we're probably looking at the
5121 * start of Perl code, not a request to hand off to some
5122 * other interpreter. Similarly, if "perl" is there, but
5123 * not in the first 'word' of the line, we assume the line
5124 * contains the start of the Perl program.
5126 if (d && *s != '#') {
5127 const char *c = ipath;
5128 while (*c && !strchr("; \t\r\n\f\v#", *c))
5131 d = NULL; /* "perl" not in first word; ignore */
5133 *s = '#'; /* Don't try to parse shebang line */
5135 #endif /* ALTERNATE_SHEBANG */
5140 !instr(s,"indir") &&
5141 instr(PL_origargv[0],"perl"))
5148 while (s < PL_bufend && isSPACE(*s))
5150 if (s < PL_bufend) {
5151 Newx(newargv,PL_origargc+3,char*);
5153 while (s < PL_bufend && !isSPACE(*s))
5156 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5159 newargv = PL_origargv;
5162 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5164 Perl_croak(aTHX_ "Can't exec %s", ipath);
5167 while (*d && !isSPACE(*d))
5169 while (SPACE_OR_TAB(*d))
5173 const bool switches_done = PL_doswitches;
5174 const U32 oldpdb = PL_perldb;
5175 const bool oldn = PL_minus_n;
5176 const bool oldp = PL_minus_p;
5180 bool baduni = FALSE;
5182 const char *d2 = d1 + 1;
5183 if (parse_unicode_opts((const char **)&d2)
5187 if (baduni || *d1 == 'M' || *d1 == 'm') {
5188 const char * const m = d1;
5189 while (*d1 && !isSPACE(*d1))
5191 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5194 d1 = moreswitches(d1);
5196 if (PL_doswitches && !switches_done) {
5197 int argc = PL_origargc;
5198 char **argv = PL_origargv;
5201 } while (argc && argv[0][0] == '-' && argv[0][1]);
5202 init_argv_symbols(argc,argv);
5204 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5205 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5206 /* if we have already added "LINE: while (<>) {",
5207 we must not do it again */
5209 sv_setpvs(PL_linestr, "");
5210 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5211 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5212 PL_last_lop = PL_last_uni = NULL;
5213 PL_preambled = FALSE;
5214 if (PERLDB_LINE || PERLDB_SAVESRC)
5215 (void)gv_fetchfile(PL_origfilename);
5222 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5223 PL_lex_state = LEX_FORMLINE;
5224 start_force(PL_curforce);
5225 NEXTVAL_NEXTTOKE.ival = 0;
5226 force_next(FORMRBRACK);
5231 #ifdef PERL_STRICT_CR
5232 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5234 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5236 case ' ': case '\t': case '\f': case 013:
5238 PL_realtokenstart = -1;
5240 PL_thiswhite = newSVpvs("");
5241 sv_catpvn(PL_thiswhite, s, 1);
5248 PL_realtokenstart = -1;
5252 if (PL_lex_state != LEX_NORMAL ||
5253 (!PL_rsfp && !PL_parser->filtered)) {
5254 if (*s == '#' && s == PL_linestart
5255 && !PL_rsfp && !PL_parser->filtered) {
5256 /* handle eval qq[#line 1 "foo"\n ...] */
5257 CopLINE_dec(PL_curcop);
5260 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5262 if (PL_rsfp || PL_parser->filtered)
5266 const bool in_comment = *s == '#';
5268 while (d < PL_bufend && *d != '\n')
5272 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5273 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5277 PL_thiswhite = newSVpvn(s, d - s);
5280 if (in_comment && d == PL_bufend
5281 && PL_lex_state == LEX_INTERPNORMAL
5282 && PL_lex_inwhat == OP_SUBST && PL_lex_repl
5283 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5286 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5287 PL_lex_state = LEX_FORMLINE;
5288 start_force(PL_curforce);
5289 NEXTVAL_NEXTTOKE.ival = 0;
5290 force_next(FORMRBRACK);
5296 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5297 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5300 TOKEN(PEG); /* make sure any #! line is accessible */
5305 /* if (PL_madskills && PL_lex_formbrack) { */
5307 while (d < PL_bufend && *d != '\n')
5311 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5312 Perl_croak(aTHX_ "panic: input overflow");
5313 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5315 PL_thiswhite = newSVpvs("");
5316 if (CopLINE(PL_curcop) == 1) {
5317 sv_setpvs(PL_thiswhite, "");
5320 sv_catpvn(PL_thiswhite, s, d - s);
5334 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
5342 while (s < PL_bufend && SPACE_OR_TAB(*s))
5345 if (strnEQ(s,"=>",2)) {
5346 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
5347 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5348 OPERATOR('-'); /* unary minus */
5350 PL_last_uni = PL_oldbufptr;
5352 case 'r': ftst = OP_FTEREAD; break;
5353 case 'w': ftst = OP_FTEWRITE; break;
5354 case 'x': ftst = OP_FTEEXEC; break;
5355 case 'o': ftst = OP_FTEOWNED; break;
5356 case 'R': ftst = OP_FTRREAD; break;
5357 case 'W': ftst = OP_FTRWRITE; break;
5358 case 'X': ftst = OP_FTREXEC; break;
5359 case 'O': ftst = OP_FTROWNED; break;
5360 case 'e': ftst = OP_FTIS; break;
5361 case 'z': ftst = OP_FTZERO; break;
5362 case 's': ftst = OP_FTSIZE; break;
5363 case 'f': ftst = OP_FTFILE; break;
5364 case 'd': ftst = OP_FTDIR; break;
5365 case 'l': ftst = OP_FTLINK; break;
5366 case 'p': ftst = OP_FTPIPE; break;
5367 case 'S': ftst = OP_FTSOCK; break;
5368 case 'u': ftst = OP_FTSUID; break;
5369 case 'g': ftst = OP_FTSGID; break;
5370 case 'k': ftst = OP_FTSVTX; break;
5371 case 'b': ftst = OP_FTBLK; break;
5372 case 'c': ftst = OP_FTCHR; break;
5373 case 't': ftst = OP_FTTTY; break;
5374 case 'T': ftst = OP_FTTEXT; break;
5375 case 'B': ftst = OP_FTBINARY; break;
5376 case 'M': case 'A': case 'C':
5377 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5379 case 'M': ftst = OP_FTMTIME; break;
5380 case 'A': ftst = OP_FTATIME; break;
5381 case 'C': ftst = OP_FTCTIME; break;
5389 PL_last_lop_op = (OPCODE)ftst;
5390 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5391 "### Saw file test %c\n", (int)tmp);
5396 /* Assume it was a minus followed by a one-letter named
5397 * subroutine call (or a -bareword), then. */
5398 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5399 "### '-%c' looked like a file test but was not\n",
5406 const char tmp = *s++;
5409 if (PL_expect == XOPERATOR)
5414 else if (*s == '>') {
5417 if (isIDFIRST_lazy_if(s,UTF)) {
5418 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
5426 if (PL_expect == XOPERATOR) {
5427 if (*s == '=' && !PL_lex_allbrackets &&
5428 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5435 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5437 OPERATOR('-'); /* unary minus */
5443 const char tmp = *s++;
5446 if (PL_expect == XOPERATOR)
5451 if (PL_expect == XOPERATOR) {
5452 if (*s == '=' && !PL_lex_allbrackets &&
5453 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5460 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5467 if (PL_expect != XOPERATOR) {
5468 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5469 PL_expect = XOPERATOR;
5470 force_ident(PL_tokenbuf, '*');
5478 if (*s == '=' && !PL_lex_allbrackets &&
5479 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5485 if (*s == '=' && !PL_lex_allbrackets &&
5486 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5493 if (PL_expect == XOPERATOR) {
5494 if (s[1] == '=' && !PL_lex_allbrackets &&
5495 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5500 PL_tokenbuf[0] = '%';
5501 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5502 sizeof PL_tokenbuf - 1, FALSE);
5503 if (!PL_tokenbuf[1]) {
5506 PL_pending_ident = '%';
5510 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5511 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5516 if (PL_lex_brackets > 100)
5517 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5518 PL_lex_brackstack[PL_lex_brackets++] = 0;
5519 PL_lex_allbrackets++;
5521 const char tmp = *s++;
5526 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5528 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5536 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5543 goto just_a_word_zero_gv;
5546 switch (PL_expect) {
5552 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5554 PL_bufptr = s; /* update in case we back off */
5557 "Use of := for an empty attribute list is not allowed");
5564 PL_expect = XTERMBLOCK;
5567 stuffstart = s - SvPVX(PL_linestr) - 1;
5571 while (isIDFIRST_lazy_if(s,UTF)) {
5574 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5575 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5576 if (tmp < 0) tmp = -tmp;
5591 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5593 d = scan_str(d,TRUE,TRUE,FALSE);
5595 /* MUST advance bufptr here to avoid bogus
5596 "at end of line" context messages from yyerror().
5598 PL_bufptr = s + len;
5599 yyerror("Unterminated attribute parameter in attribute list");
5603 return REPORT(0); /* EOF indicator */
5607 sv_catsv(sv, PL_lex_stuff);
5608 attrs = op_append_elem(OP_LIST, attrs,
5609 newSVOP(OP_CONST, 0, sv));
5610 SvREFCNT_dec(PL_lex_stuff);
5611 PL_lex_stuff = NULL;
5614 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5616 if (PL_in_my == KEY_our) {
5617 deprecate(":unique");
5620 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5623 /* NOTE: any CV attrs applied here need to be part of
5624 the CVf_BUILTIN_ATTRS define in cv.h! */
5625 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5627 CvLVALUE_on(PL_compcv);
5629 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5631 deprecate(":locked");
5633 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5635 CvMETHOD_on(PL_compcv);
5637 /* After we've set the flags, it could be argued that
5638 we don't need to do the attributes.pm-based setting
5639 process, and shouldn't bother appending recognized
5640 flags. To experiment with that, uncomment the
5641 following "else". (Note that's already been
5642 uncommented. That keeps the above-applied built-in
5643 attributes from being intercepted (and possibly
5644 rejected) by a package's attribute routines, but is
5645 justified by the performance win for the common case
5646 of applying only built-in attributes.) */
5648 attrs = op_append_elem(OP_LIST, attrs,
5649 newSVOP(OP_CONST, 0,
5653 if (*s == ':' && s[1] != ':')
5656 break; /* require real whitespace or :'s */
5657 /* XXX losing whitespace on sequential attributes here */
5661 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5662 if (*s != ';' && *s != '}' && *s != tmp
5663 && (tmp != '=' || *s != ')')) {
5664 const char q = ((*s == '\'') ? '"' : '\'');
5665 /* If here for an expression, and parsed no attrs, back
5667 if (tmp == '=' && !attrs) {
5671 /* MUST advance bufptr here to avoid bogus "at end of line"
5672 context messages from yyerror().
5675 yyerror( (const char *)
5677 ? Perl_form(aTHX_ "Invalid separator character "
5678 "%c%c%c in attribute list", q, *s, q)
5679 : "Unterminated attribute list" ) );
5687 start_force(PL_curforce);
5688 NEXTVAL_NEXTTOKE.opval = attrs;
5689 CURMAD('_', PL_nextwhite);
5694 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
5695 (s - SvPVX(PL_linestr)) - stuffstart);
5700 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5704 PL_lex_allbrackets--;
5708 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5709 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5713 PL_lex_allbrackets++;
5716 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5722 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5725 PL_lex_allbrackets--;
5731 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5734 if (PL_lex_brackets <= 0)
5735 yyerror("Unmatched right square bracket");
5738 PL_lex_allbrackets--;
5739 if (PL_lex_state == LEX_INTERPNORMAL) {
5740 if (PL_lex_brackets == 0) {
5741 if (*s == '-' && s[1] == '>')
5742 PL_lex_state = LEX_INTERPENDMAYBE;
5743 else if (*s != '[' && *s != '{')
5744 PL_lex_state = LEX_INTERPEND;
5751 if (PL_lex_brackets > 100) {
5752 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5754 switch (PL_expect) {
5756 if (PL_oldoldbufptr == PL_last_lop)
5757 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5759 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5760 PL_lex_allbrackets++;
5761 OPERATOR(HASHBRACK);
5763 while (s < PL_bufend && SPACE_OR_TAB(*s))
5766 PL_tokenbuf[0] = '\0';
5767 if (d < PL_bufend && *d == '-') {
5768 PL_tokenbuf[0] = '-';
5770 while (d < PL_bufend && SPACE_OR_TAB(*d))
5773 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5774 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5776 while (d < PL_bufend && SPACE_OR_TAB(*d))
5779 const char minus = (PL_tokenbuf[0] == '-');
5780 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
5788 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5789 PL_lex_allbrackets++;
5794 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5795 PL_lex_allbrackets++;
5800 if (PL_oldoldbufptr == PL_last_lop)
5801 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5803 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5804 PL_lex_allbrackets++;
5807 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5809 /* This hack is to get the ${} in the message. */
5811 yyerror("syntax error");
5814 OPERATOR(HASHBRACK);
5816 /* This hack serves to disambiguate a pair of curlies
5817 * as being a block or an anon hash. Normally, expectation
5818 * determines that, but in cases where we're not in a
5819 * position to expect anything in particular (like inside
5820 * eval"") we have to resolve the ambiguity. This code
5821 * covers the case where the first term in the curlies is a
5822 * quoted string. Most other cases need to be explicitly
5823 * disambiguated by prepending a "+" before the opening
5824 * curly in order to force resolution as an anon hash.
5826 * XXX should probably propagate the outer expectation
5827 * into eval"" to rely less on this hack, but that could
5828 * potentially break current behavior of eval"".
5832 if (*s == '\'' || *s == '"' || *s == '`') {
5833 /* common case: get past first string, handling escapes */
5834 for (t++; t < PL_bufend && *t != *s;)
5835 if (*t++ == '\\' && (*t == '\\' || *t == *s))
5839 else if (*s == 'q') {
5842 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5845 /* skip q//-like construct */
5847 char open, close, term;
5850 while (t < PL_bufend && isSPACE(*t))
5852 /* check for q => */
5853 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5854 OPERATOR(HASHBRACK);
5858 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5862 for (t++; t < PL_bufend; t++) {
5863 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5865 else if (*t == open)
5869 for (t++; t < PL_bufend; t++) {
5870 if (*t == '\\' && t+1 < PL_bufend)
5872 else if (*t == close && --brackets <= 0)
5874 else if (*t == open)
5881 /* skip plain q word */
5882 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5885 else if (isALNUM_lazy_if(t,UTF)) {
5887 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5890 while (t < PL_bufend && isSPACE(*t))
5892 /* if comma follows first term, call it an anon hash */
5893 /* XXX it could be a comma expression with loop modifiers */
5894 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5895 || (*t == '=' && t[1] == '>')))
5896 OPERATOR(HASHBRACK);
5897 if (PL_expect == XREF)
5900 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5906 pl_yylval.ival = CopLINE(PL_curcop);
5907 if (isSPACE(*s) || *s == '#')
5908 PL_copline = NOLINE; /* invalidate current command line number */
5909 TOKEN(formbrack ? '=' : '{');
5911 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5915 if (PL_lex_brackets <= 0)
5916 yyerror("Unmatched right curly bracket");
5918 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5919 PL_lex_allbrackets--;
5920 if (PL_lex_state == LEX_INTERPNORMAL) {
5921 if (PL_lex_brackets == 0) {
5922 if (PL_expect & XFAKEBRACK) {
5923 PL_expect &= XENUMMASK;
5924 PL_lex_state = LEX_INTERPEND;
5929 PL_thiswhite = newSVpvs("");
5930 sv_catpvs(PL_thiswhite,"}");
5933 return yylex(); /* ignore fake brackets */
5935 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl
5936 && SvEVALED(PL_lex_repl))
5937 PL_lex_state = LEX_INTERPEND;
5938 else if (*s == '-' && s[1] == '>')
5939 PL_lex_state = LEX_INTERPENDMAYBE;
5940 else if (*s != '[' && *s != '{')
5941 PL_lex_state = LEX_INTERPEND;
5944 if (PL_expect & XFAKEBRACK) {
5945 PL_expect &= XENUMMASK;
5947 return yylex(); /* ignore fake brackets */
5949 start_force(PL_curforce);
5951 curmad('X', newSVpvn(s-1,1));
5952 CURMAD('_', PL_thiswhite);
5954 force_next(formbrack ? '.' : '}');
5955 if (formbrack) LEAVE;
5958 PL_thistoken = newSVpvs("");
5960 if (formbrack == 2) { /* means . where arguments were expected */
5961 start_force(PL_curforce);
5969 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5970 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5977 if (PL_expect == XOPERATOR) {
5978 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5979 && isIDFIRST_lazy_if(s,UTF))
5981 CopLINE_dec(PL_curcop);
5982 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5983 CopLINE_inc(PL_curcop);
5985 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5986 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5993 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5995 PL_expect = XOPERATOR;
5996 force_ident(PL_tokenbuf, '&');
6000 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6006 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6007 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6014 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6015 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6023 const char tmp = *s++;
6025 if (!PL_lex_allbrackets &&
6026 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6033 if (!PL_lex_allbrackets &&
6034 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
6042 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6043 && strchr("+-*/%.^&|<",tmp))
6044 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6045 "Reversed %c= operator",(int)tmp);
6047 if (PL_expect == XSTATE && isALPHA(tmp) &&
6048 (s == PL_linestart+1 || s[-2] == '\n') )
6050 if ((!PL_rsfp && !PL_parser->filtered)
6051 || PL_lex_state != LEX_NORMAL) {
6056 if (strnEQ(s,"=cut",4)) {
6072 PL_thiswhite = newSVpvs("");
6073 sv_catpvn(PL_thiswhite, PL_linestart,
6074 PL_bufend - PL_linestart);
6078 PL_parser->in_pod = 1;
6082 if (PL_expect == XBLOCK) {
6084 #ifdef PERL_STRICT_CR
6085 while (SPACE_OR_TAB(*t))
6087 while (SPACE_OR_TAB(*t) || *t == '\r')
6090 if (*t == '\n' || *t == '#') {
6093 SAVEI8(PL_parser->form_lex_state);
6094 SAVEI32(PL_lex_formbrack);
6095 PL_parser->form_lex_state = PL_lex_state;
6096 PL_lex_formbrack = PL_lex_brackets + 1;
6100 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6109 const char tmp = *s++;
6111 /* was this !=~ where !~ was meant?
6112 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6114 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6115 const char *t = s+1;
6117 while (t < PL_bufend && isSPACE(*t))
6120 if (*t == '/' || *t == '?' ||
6121 ((*t == 'm' || *t == 's' || *t == 'y')
6122 && !isALNUM(t[1])) ||
6123 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
6124 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6125 "!=~ should be !~");
6127 if (!PL_lex_allbrackets &&
6128 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6140 if (PL_expect != XOPERATOR) {
6141 if (s[1] != '<' && !strchr(s,'>'))
6144 s = scan_heredoc(s);
6146 s = scan_inputsymbol(s);
6147 PL_expect = XOPERATOR;
6148 TOKEN(sublex_start());
6154 if (*s == '=' && !PL_lex_allbrackets &&
6155 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6159 SHop(OP_LEFT_SHIFT);
6164 if (!PL_lex_allbrackets &&
6165 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6172 if (!PL_lex_allbrackets &&
6173 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6181 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6189 const char tmp = *s++;
6191 if (*s == '=' && !PL_lex_allbrackets &&
6192 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6196 SHop(OP_RIGHT_SHIFT);
6198 else if (tmp == '=') {
6199 if (!PL_lex_allbrackets &&
6200 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6208 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6217 if (PL_expect == XOPERATOR) {
6218 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6219 return deprecate_commaless_var_list();
6223 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6224 PL_tokenbuf[0] = '@';
6225 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6226 sizeof PL_tokenbuf - 1, FALSE);
6227 if (PL_expect == XOPERATOR)
6228 no_op("Array length", s);
6229 if (!PL_tokenbuf[1])
6231 PL_expect = XOPERATOR;
6232 PL_pending_ident = '#';
6236 PL_tokenbuf[0] = '$';
6237 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6238 sizeof PL_tokenbuf - 1, FALSE);
6239 if (PL_expect == XOPERATOR)
6241 if (!PL_tokenbuf[1]) {
6243 yyerror("Final $ should be \\$ or $name");
6249 const char tmp = *s;
6250 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6253 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6254 && intuit_more(s)) {
6256 PL_tokenbuf[0] = '@';
6257 if (ckWARN(WARN_SYNTAX)) {
6260 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
6263 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6264 while (t < PL_bufend && *t != ']')
6266 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6267 "Multidimensional syntax %.*s not supported",
6268 (int)((t - PL_bufptr) + 1), PL_bufptr);
6272 else if (*s == '{') {
6274 PL_tokenbuf[0] = '%';
6275 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6276 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6278 char tmpbuf[sizeof PL_tokenbuf];
6281 } while (isSPACE(*t));
6282 if (isIDFIRST_lazy_if(t,UTF)) {
6284 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6289 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6290 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6291 "You need to quote \"%"SVf"\"",
6292 SVfARG(newSVpvn_flags(tmpbuf, len,
6293 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
6299 PL_expect = XOPERATOR;
6300 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6301 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6302 if (!islop || PL_last_lop_op == OP_GREPSTART)
6303 PL_expect = XOPERATOR;
6304 else if (strchr("$@\"'`q", *s))
6305 PL_expect = XTERM; /* e.g. print $fh "foo" */
6306 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6307 PL_expect = XTERM; /* e.g. print $fh &sub */
6308 else if (isIDFIRST_lazy_if(s,UTF)) {
6309 char tmpbuf[sizeof PL_tokenbuf];
6311 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6312 if ((t2 = keyword(tmpbuf, len, 0))) {
6313 /* binary operators exclude handle interpretations */
6325 PL_expect = XTERM; /* e.g. print $fh length() */
6330 PL_expect = XTERM; /* e.g. print $fh subr() */
6333 else if (isDIGIT(*s))
6334 PL_expect = XTERM; /* e.g. print $fh 3 */
6335 else if (*s == '.' && isDIGIT(s[1]))
6336 PL_expect = XTERM; /* e.g. print $fh .3 */
6337 else if ((*s == '?' || *s == '-' || *s == '+')
6338 && !isSPACE(s[1]) && s[1] != '=')
6339 PL_expect = XTERM; /* e.g. print $fh -1 */
6340 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6342 PL_expect = XTERM; /* e.g. print $fh /.../
6343 XXX except DORDOR operator
6345 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6347 PL_expect = XTERM; /* print $fh <<"EOF" */
6350 PL_pending_ident = '$';
6354 if (PL_expect == XOPERATOR)
6356 PL_tokenbuf[0] = '@';
6357 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6358 if (!PL_tokenbuf[1]) {
6361 if (PL_lex_state == LEX_NORMAL)
6363 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6365 PL_tokenbuf[0] = '%';
6367 /* Warn about @ where they meant $. */
6368 if (*s == '[' || *s == '{') {
6369 if (ckWARN(WARN_SYNTAX)) {
6370 const char *t = s + 1;
6371 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6372 t += UTF ? UTF8SKIP(t) : 1;
6373 if (*t == '}' || *t == ']') {
6375 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6376 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
6377 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6378 "Scalar value %"SVf" better written as $%"SVf,
6379 SVfARG(newSVpvn_flags(PL_bufptr, (STRLEN)(t-PL_bufptr),
6380 SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))),
6381 SVfARG(newSVpvn_flags(PL_bufptr+1, (STRLEN)(t-PL_bufptr-1),
6382 SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))));
6387 PL_pending_ident = '@';
6390 case '/': /* may be division, defined-or, or pattern */
6391 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6392 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6393 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6398 case '?': /* may either be conditional or pattern */
6399 if (PL_expect == XOPERATOR) {
6402 if (!PL_lex_allbrackets &&
6403 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6407 PL_lex_allbrackets++;
6413 /* A // operator. */
6414 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6415 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6416 LEX_FAKEEOF_LOGIC)) {
6424 if (*s == '=' && !PL_lex_allbrackets &&
6425 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6434 /* Disable warning on "study /blah/" */
6435 if (PL_oldoldbufptr == PL_last_uni
6436 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6437 || memNE(PL_last_uni, "study", 5)
6438 || isALNUM_lazy_if(PL_last_uni+5,UTF)
6442 deprecate("?PATTERN? without explicit operator");
6443 s = scan_pat(s,OP_MATCH);
6444 TERM(sublex_start());
6448 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6449 #ifdef PERL_STRICT_CR
6452 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6454 && (s == PL_linestart || s[-1] == '\n') )
6457 formbrack = 2; /* dot seen where arguments expected */
6460 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6464 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6467 if (!PL_lex_allbrackets &&
6468 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6475 pl_yylval.ival = OPf_SPECIAL;
6481 if (*s == '=' && !PL_lex_allbrackets &&
6482 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6489 case '0': case '1': case '2': case '3': case '4':
6490 case '5': case '6': case '7': case '8': case '9':
6491 s = scan_num(s, &pl_yylval);
6492 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6493 if (PL_expect == XOPERATOR)
6498 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
6499 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6500 if (PL_expect == XOPERATOR) {
6501 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6502 return deprecate_commaless_var_list();
6509 pl_yylval.ival = OP_CONST;
6510 TERM(sublex_start());
6513 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
6514 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6515 if (PL_expect == XOPERATOR) {
6516 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6517 return deprecate_commaless_var_list();
6524 pl_yylval.ival = OP_CONST;
6525 /* FIXME. I think that this can be const if char *d is replaced by
6526 more localised variables. */
6527 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6528 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6529 pl_yylval.ival = OP_STRINGIFY;
6533 TERM(sublex_start());
6536 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
6537 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6538 if (PL_expect == XOPERATOR)
6539 no_op("Backticks",s);
6542 readpipe_override();
6543 TERM(sublex_start());
6547 if (PL_lex_inwhat && isDIGIT(*s))
6548 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6550 if (PL_expect == XOPERATOR)
6551 no_op("Backslash",s);
6555 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6556 char *start = s + 2;
6557 while (isDIGIT(*start) || *start == '_')
6559 if (*start == '.' && isDIGIT(start[1])) {
6560 s = scan_num(s, &pl_yylval);
6563 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6564 else if (!isALPHA(*start) && (PL_expect == XTERM
6565 || PL_expect == XREF || PL_expect == XSTATE
6566 || PL_expect == XTERMORDORDOR)) {
6567 GV *const gv = gv_fetchpvn_flags(s, start - s,
6568 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6570 s = scan_num(s, &pl_yylval);
6577 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6620 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6622 /* Some keywords can be followed by any delimiter, including ':' */
6623 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6625 /* x::* is just a word, unless x is "CORE" */
6626 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6630 while (d < PL_bufend && isSPACE(*d))
6631 d++; /* no comments skipped here, or s### is misparsed */
6633 /* Is this a word before a => operator? */
6634 if (*d == '=' && d[1] == '>') {
6637 = (OP*)newSVOP(OP_CONST, 0,
6638 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6639 pl_yylval.opval->op_private = OPpCONST_BARE;
6643 /* Check for plugged-in keyword */
6647 char *saved_bufptr = PL_bufptr;
6649 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6651 if (result == KEYWORD_PLUGIN_DECLINE) {
6652 /* not a plugged-in keyword */
6653 PL_bufptr = saved_bufptr;
6654 } else if (result == KEYWORD_PLUGIN_STMT) {
6655 pl_yylval.opval = o;
6658 return REPORT(PLUGSTMT);
6659 } else if (result == KEYWORD_PLUGIN_EXPR) {
6660 pl_yylval.opval = o;
6662 PL_expect = XOPERATOR;
6663 return REPORT(PLUGEXPR);
6665 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6670 /* Check for built-in keyword */
6671 tmp = keyword(PL_tokenbuf, len, 0);
6673 /* Is this a label? */
6674 if (!anydelim && PL_expect == XSTATE
6675 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6677 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
6678 newSVpvn_flags(PL_tokenbuf,
6679 len, UTF ? SVf_UTF8 : 0));
6684 if (tmp < 0) { /* second-class keyword? */
6685 GV *ogv = NULL; /* override (winner) */
6686 GV *hgv = NULL; /* hidden (loser) */
6687 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6689 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6690 UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
6693 if (GvIMPORTED_CV(gv))
6695 else if (! CvMETHOD(cv))
6699 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6700 UTF ? -(I32)len : (I32)len, FALSE)) &&
6701 (gv = *gvp) && isGV_with_GP(gv) &&
6702 GvCVu(gv) && GvIMPORTED_CV(gv))
6709 tmp = 0; /* overridden by import or by GLOBAL */
6712 && -tmp==KEY_lock /* XXX generalizable kludge */
6715 tmp = 0; /* any sub overrides "weak" keyword */
6717 else { /* no override */
6719 if (tmp == KEY_dump) {
6720 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6721 "dump() better written as CORE::dump()");
6725 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
6726 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6727 "Ambiguous call resolved as CORE::%s(), "
6728 "qualify as such or use &",
6736 default: /* not a keyword */
6737 /* Trade off - by using this evil construction we can pull the
6738 variable gv into the block labelled keylookup. If not, then
6739 we have to give it function scope so that the goto from the
6740 earlier ':' case doesn't bypass the initialisation. */
6742 just_a_word_zero_gv:
6750 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6754 SV *nextPL_nextwhite = 0;
6758 /* Get the rest if it looks like a package qualifier */
6760 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6762 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6765 Perl_croak(aTHX_ "Bad name after %"SVf"%s",
6766 SVfARG(newSVpvn_flags(PL_tokenbuf, len,
6767 (UTF ? SVf_UTF8 : 0) | SVs_TEMP )),
6768 *s == '\'' ? "'" : "::");
6773 if (PL_expect == XOPERATOR) {
6774 if (PL_bufptr == PL_linestart) {
6775 CopLINE_dec(PL_curcop);
6776 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6777 CopLINE_inc(PL_curcop);
6780 no_op("Bareword",s);
6783 /* Look for a subroutine with this name in current package,
6784 unless name is "Foo::", in which case Foo is a bareword
6785 (and a package name). */
6787 if (len > 2 && !PL_madskills &&
6788 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6790 if (ckWARN(WARN_BAREWORD)
6791 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6792 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6793 "Bareword \"%"SVf"\" refers to nonexistent package",
6794 SVfARG(newSVpvn_flags(PL_tokenbuf, len,
6795 (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
6797 PL_tokenbuf[len] = '\0';
6803 /* Mustn't actually add anything to a symbol table.
6804 But also don't want to "initialise" any placeholder
6805 constants that might already be there into full
6806 blown PVGVs with attached PVCV. */
6807 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6808 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
6814 /* if we saw a global override before, get the right name */
6816 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6817 len ? len : strlen(PL_tokenbuf));
6819 SV * const tmp_sv = sv;
6820 sv = newSVpvs("CORE::GLOBAL::");
6821 sv_catsv(sv, tmp_sv);
6822 SvREFCNT_dec(tmp_sv);
6826 if (PL_madskills && !PL_thistoken) {
6827 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
6828 PL_thistoken = newSVpvn(start,s - start);
6829 PL_realtokenstart = s - SvPVX(PL_linestr);
6833 /* Presume this is going to be a bareword of some sort. */
6835 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6836 pl_yylval.opval->op_private = OPpCONST_BARE;
6838 /* And if "Foo::", then that's what it certainly is. */
6843 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6844 const_op->op_private = OPpCONST_BARE;
6845 rv2cv_op = newCVREF(0, const_op);
6847 cv = rv2cv_op_cv(rv2cv_op, 0);
6849 /* See if it's the indirect object for a list operator. */
6851 if (PL_oldoldbufptr &&
6852 PL_oldoldbufptr < PL_bufptr &&
6853 (PL_oldoldbufptr == PL_last_lop
6854 || PL_oldoldbufptr == PL_last_uni) &&
6855 /* NO SKIPSPACE BEFORE HERE! */
6856 (PL_expect == XREF ||
6857 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6859 bool immediate_paren = *s == '(';
6861 /* (Now we can afford to cross potential line boundary.) */
6862 s = SKIPSPACE2(s,nextPL_nextwhite);
6864 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
6867 /* Two barewords in a row may indicate method call. */
6869 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6870 (tmp = intuit_method(s, gv, cv))) {
6872 if (tmp == METHOD && !PL_lex_allbrackets &&
6873 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6874 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6878 /* If not a declared subroutine, it's an indirect object. */
6879 /* (But it's an indir obj regardless for sort.) */
6880 /* Also, if "_" follows a filetest operator, it's a bareword */
6883 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6885 (PL_last_lop_op != OP_MAPSTART &&
6886 PL_last_lop_op != OP_GREPSTART))))
6887 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6888 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6891 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6896 PL_expect = XOPERATOR;
6899 s = SKIPSPACE2(s,nextPL_nextwhite);
6900 PL_nextwhite = nextPL_nextwhite;
6905 /* Is this a word before a => operator? */
6906 if (*s == '=' && s[1] == '>' && !pkgname) {
6909 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
6910 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
6911 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
6915 /* If followed by a paren, it's certainly a subroutine. */
6920 while (SPACE_OR_TAB(*d))
6922 if (*d == ')' && (sv = cv_const_sv(cv))) {
6929 PL_nextwhite = PL_thiswhite;
6932 start_force(PL_curforce);
6934 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6935 PL_expect = XOPERATOR;
6938 PL_nextwhite = nextPL_nextwhite;
6939 curmad('X', PL_thistoken);
6940 PL_thistoken = newSVpvs("");
6949 /* If followed by var or block, call it a method (unless sub) */
6951 if ((*s == '$' || *s == '{') && !cv) {
6953 PL_last_lop = PL_oldbufptr;
6954 PL_last_lop_op = OP_METHOD;
6955 if (!PL_lex_allbrackets &&
6956 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6957 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6961 /* If followed by a bareword, see if it looks like indir obj. */
6964 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6965 && (tmp = intuit_method(s, gv, cv))) {
6967 if (tmp == METHOD && !PL_lex_allbrackets &&
6968 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6969 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6973 /* Not a method, so call it a subroutine (if defined) */
6976 if (lastchar == '-') {
6977 const SV *tmpsv = newSVpvn_flags( PL_tokenbuf, len ? len : strlen(PL_tokenbuf), (UTF ? SVf_UTF8 : 0) | SVs_TEMP );
6978 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6979 "Ambiguous use of -%"SVf" resolved as -&%"SVf"()",
6980 SVfARG(tmpsv), SVfARG(tmpsv));
6982 /* Check for a constant sub */
6983 if ((sv = cv_const_sv(cv))) {
6986 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6987 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6988 pl_yylval.opval->op_private = OPpCONST_FOLDED;
6989 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6993 op_free(pl_yylval.opval);
6994 pl_yylval.opval = rv2cv_op;
6995 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6996 PL_last_lop = PL_oldbufptr;
6997 PL_last_lop_op = OP_ENTERSUB;
6998 /* Is there a prototype? */
7005 STRLEN protolen = CvPROTOLEN(cv);
7006 const char *proto = CvPROTO(cv);
7010 if ((optional = *proto == ';'))
7013 while (*proto == ';');
7017 *proto == '$' || *proto == '_'
7018 || *proto == '*' || *proto == '+'
7023 *proto == '\\' && proto[1] && proto[2] == '\0'
7026 UNIPROTO(UNIOPSUB,optional);
7027 if (*proto == '\\' && proto[1] == '[') {
7028 const char *p = proto + 2;
7029 while(*p && *p != ']')
7031 if(*p == ']' && !p[1])
7032 UNIPROTO(UNIOPSUB,optional);
7034 if (*proto == '&' && *s == '{') {
7036 sv_setpvs(PL_subname, "__ANON__");
7038 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7039 if (!PL_lex_allbrackets &&
7040 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7041 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7048 PL_nextwhite = PL_thiswhite;
7051 start_force(PL_curforce);
7052 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7055 PL_nextwhite = nextPL_nextwhite;
7056 curmad('X', PL_thistoken);
7057 PL_thistoken = newSVpvs("");
7060 if (!PL_lex_allbrackets &&
7061 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7062 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7067 /* Guess harder when madskills require "best effort". */
7068 if (PL_madskills && (!gv || !GvCVu(gv))) {
7069 int probable_sub = 0;
7070 if (strchr("\"'`$@%0123456789!*+{[<", *s))
7072 else if (isALPHA(*s)) {
7076 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
7077 if (!keyword(tmpbuf, tmplen, 0))
7080 while (d < PL_bufend && isSPACE(*d))
7082 if (*d == '=' && d[1] == '>')
7087 gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
7089 op_free(pl_yylval.opval);
7090 pl_yylval.opval = rv2cv_op;
7091 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7092 PL_last_lop = PL_oldbufptr;
7093 PL_last_lop_op = OP_ENTERSUB;
7094 PL_nextwhite = PL_thiswhite;
7096 start_force(PL_curforce);
7097 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7099 PL_nextwhite = nextPL_nextwhite;
7100 curmad('X', PL_thistoken);
7101 PL_thistoken = newSVpvs("");
7103 if (!PL_lex_allbrackets &&
7104 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7105 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7109 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7112 if (!PL_lex_allbrackets &&
7113 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7114 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7119 /* Call it a bare word */
7121 if (PL_hints & HINT_STRICT_SUBS)
7122 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7125 /* after "print" and similar functions (corresponding to
7126 * "F? L" in opcode.pl), whatever wasn't already parsed as
7127 * a filehandle should be subject to "strict subs".
7128 * Likewise for the optional indirect-object argument to system
7129 * or exec, which can't be a bareword */
7130 if ((PL_last_lop_op == OP_PRINT
7131 || PL_last_lop_op == OP_PRTF
7132 || PL_last_lop_op == OP_SAY
7133 || PL_last_lop_op == OP_SYSTEM
7134 || PL_last_lop_op == OP_EXEC)
7135 && (PL_hints & HINT_STRICT_SUBS))
7136 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7137 if (lastchar != '-') {
7138 if (ckWARN(WARN_RESERVED)) {
7142 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7143 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7151 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
7152 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7153 "Operator or semicolon missing before %c%"SVf,
7154 lastchar, SVfARG(newSVpvn_flags(PL_tokenbuf,
7155 strlen(PL_tokenbuf),
7156 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
7157 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7158 "Ambiguous use of %c resolved as operator %c",
7159 lastchar, lastchar);
7166 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7171 (OP*)newSVOP(OP_CONST, 0,
7172 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7175 case KEY___PACKAGE__:
7177 (OP*)newSVOP(OP_CONST, 0,
7179 ? newSVhek(HvNAME_HEK(PL_curstash))
7186 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7187 const char *pname = "main";
7190 if (PL_tokenbuf[2] == 'D')
7193 PL_curstash ? PL_curstash : PL_defstash;
7194 pname = HvNAME_get(stash);
7195 plen = HvNAMELEN (stash);
7196 if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
7198 gv = gv_fetchpvn_flags(
7199 Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
7200 plen+6, GV_ADD|putf8, SVt_PVIO
7204 GvIOp(gv) = newIO();
7205 IoIFP(GvIOp(gv)) = PL_rsfp;
7206 #if defined(HAS_FCNTL) && defined(F_SETFD)
7208 const int fd = PerlIO_fileno(PL_rsfp);
7209 fcntl(fd,F_SETFD,fd >= 3);
7212 /* Mark this internal pseudo-handle as clean */
7213 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7214 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7215 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7217 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7218 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7219 /* if the script was opened in binmode, we need to revert
7220 * it to text mode for compatibility; but only iff it has CRs
7221 * XXX this is a questionable hack at best. */
7222 if (PL_bufend-PL_bufptr > 2
7223 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7226 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7227 loc = PerlIO_tell(PL_rsfp);
7228 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7231 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7233 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7234 #endif /* NETWARE */
7236 PerlIO_seek(PL_rsfp, loc, 0);
7240 #ifdef PERLIO_LAYERS
7243 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7244 else if (PL_encoding) {
7251 XPUSHs(PL_encoding);
7253 call_method("name", G_SCALAR);
7257 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7258 Perl_form(aTHX_ ":encoding(%"SVf")",
7267 if (PL_realtokenstart >= 0) {
7268 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7270 PL_endwhite = newSVpvs("");
7271 sv_catsv(PL_endwhite, PL_thiswhite);
7273 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7274 PL_realtokenstart = -1;
7276 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7286 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
7295 if (PL_expect == XSTATE) {
7302 if (*s == ':' && s[1] == ':') {
7306 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7307 if ((*s == ':' && s[1] == ':')
7308 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7312 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7316 Perl_croak(aTHX_ "CORE::%"SVf" is not a keyword",
7317 SVfARG(newSVpvn_flags(PL_tokenbuf, len,
7318 (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
7321 else if (tmp == KEY_require || tmp == KEY_do
7323 /* that's a way to remember we saw "CORE::" */
7336 LOP(OP_ACCEPT,XTERM);
7339 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7344 LOP(OP_ATAN2,XTERM);
7350 LOP(OP_BINMODE,XTERM);
7353 LOP(OP_BLESS,XTERM);
7362 /* We have to disambiguate the two senses of
7363 "continue". If the next token is a '{' then
7364 treat it as the start of a continue block;
7365 otherwise treat it as a control operator.
7375 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7385 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7394 if (!PL_cryptseen) {
7395 PL_cryptseen = TRUE;
7399 LOP(OP_CRYPT,XTERM);
7402 LOP(OP_CHMOD,XTERM);
7405 LOP(OP_CHOWN,XTERM);
7408 LOP(OP_CONNECT,XTERM);
7427 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, 1, &len);
7430 if (*d == '(') s = force_word(s,WORD,TRUE,TRUE,FALSE);
7433 if (orig_keyword == KEY_do) {
7442 PL_hints |= HINT_BLOCK_SCOPE;
7452 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7453 STR_WITH_LEN("NDBM_File::"),
7454 STR_WITH_LEN("DB_File::"),
7455 STR_WITH_LEN("GDBM_File::"),
7456 STR_WITH_LEN("SDBM_File::"),
7457 STR_WITH_LEN("ODBM_File::"),
7459 LOP(OP_DBMOPEN,XTERM);
7465 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7472 pl_yylval.ival = CopLINE(PL_curcop);
7476 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7490 if (*s == '{') { /* block eval */
7491 PL_expect = XTERMBLOCK;
7492 UNIBRACK(OP_ENTERTRY);
7494 else { /* string eval */
7496 UNIBRACK(OP_ENTEREVAL);
7501 UNIBRACK(-OP_ENTEREVAL);
7515 case KEY_endhostent:
7521 case KEY_endservent:
7524 case KEY_endprotoent:
7535 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7537 pl_yylval.ival = CopLINE(PL_curcop);
7539 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7542 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7545 if ((PL_bufend - p) >= 3 &&
7546 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7548 else if ((PL_bufend - p) >= 4 &&
7549 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7552 if (isIDFIRST_lazy_if(p,UTF)) {
7553 p = scan_ident(p, PL_bufend,
7554 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7558 Perl_croak(aTHX_ "Missing $ on loop variable");
7560 s = SvPVX(PL_linestr) + soff;
7566 LOP(OP_FORMLINE,XTERM);
7575 LOP(OP_FCNTL,XTERM);
7581 LOP(OP_FLOCK,XTERM);
7584 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7589 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7594 LOP(OP_GREPSTART, XREF);
7597 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7612 case KEY_getpriority:
7613 LOP(OP_GETPRIORITY,XTERM);
7615 case KEY_getprotobyname:
7618 case KEY_getprotobynumber:
7619 LOP(OP_GPBYNUMBER,XTERM);
7621 case KEY_getprotoent:
7633 case KEY_getpeername:
7634 UNI(OP_GETPEERNAME);
7636 case KEY_gethostbyname:
7639 case KEY_gethostbyaddr:
7640 LOP(OP_GHBYADDR,XTERM);
7642 case KEY_gethostent:
7645 case KEY_getnetbyname:
7648 case KEY_getnetbyaddr:
7649 LOP(OP_GNBYADDR,XTERM);
7654 case KEY_getservbyname:
7655 LOP(OP_GSBYNAME,XTERM);
7657 case KEY_getservbyport:
7658 LOP(OP_GSBYPORT,XTERM);
7660 case KEY_getservent:
7663 case KEY_getsockname:
7664 UNI(OP_GETSOCKNAME);
7666 case KEY_getsockopt:
7667 LOP(OP_GSOCKOPT,XTERM);
7682 pl_yylval.ival = CopLINE(PL_curcop);
7687 orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
7695 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7697 pl_yylval.ival = CopLINE(PL_curcop);
7701 LOP(OP_INDEX,XTERM);
7707 LOP(OP_IOCTL,XTERM);
7719 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7736 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7741 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7755 LOP(OP_LISTEN,XTERM);
7764 s = scan_pat(s,OP_MATCH);
7765 TERM(sublex_start());
7768 LOP(OP_MAPSTART, XREF);
7771 LOP(OP_MKDIR,XTERM);
7774 LOP(OP_MSGCTL,XTERM);
7777 LOP(OP_MSGGET,XTERM);
7780 LOP(OP_MSGRCV,XTERM);
7783 LOP(OP_MSGSND,XTERM);
7788 PL_in_my = (U16)tmp;
7790 if (isIDFIRST_lazy_if(s,UTF)) {
7794 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7795 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7797 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7798 if (!PL_in_my_stash) {
7801 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7802 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
7805 if (PL_madskills) { /* just add type to declarator token */
7806 sv_catsv(PL_thistoken, PL_nextwhite);
7808 sv_catpvn(PL_thistoken, start, s - start);
7816 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7820 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7825 s = tokenize_use(0, s);
7829 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
7832 if (!PL_lex_allbrackets &&
7833 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7834 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7840 if (isIDFIRST_lazy_if(s,UTF)) {
7842 for (d = s; isALNUM_lazy_if(d,UTF);) {
7843 d += UTF ? UTF8SKIP(d) : 1;
7845 while (UTF8_IS_CONTINUED(*d) && is_utf8_mark((U8*)d)) {
7846 d += UTF ? UTF8SKIP(d) : 1;
7850 for (t=d; isSPACE(*t);)
7852 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7854 && !(t[0] == '=' && t[1] == '>')
7855 && !(t[0] == ':' && t[1] == ':')
7856 && !keyword(s, d-s, 0)
7858 SV *tmpsv = newSVpvn_flags(s, (STRLEN)(d-s),
7859 SVs_TEMP | (UTF ? SVf_UTF8 : 0));
7860 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7861 "Precedence problem: open %"SVf" should be open(%"SVf")",
7862 SVfARG(tmpsv), SVfARG(tmpsv));
7868 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7870 pl_yylval.ival = OP_OR;
7880 LOP(OP_OPEN_DIR,XTERM);
7883 checkcomma(s,PL_tokenbuf,"filehandle");
7887 checkcomma(s,PL_tokenbuf,"filehandle");
7906 s = force_word(s,WORD,FALSE,TRUE,FALSE);
7908 s = force_strict_version(s);
7909 PL_lex_expect = XBLOCK;
7913 LOP(OP_PIPE_OP,XTERM);
7916 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
7919 pl_yylval.ival = OP_CONST;
7920 TERM(sublex_start());
7927 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
7930 PL_expect = XOPERATOR;
7931 if (SvCUR(PL_lex_stuff)) {
7932 int warned_comma = !ckWARN(WARN_QW);
7933 int warned_comment = warned_comma;
7934 d = SvPV_force(PL_lex_stuff, len);
7936 for (; isSPACE(*d) && len; --len, ++d)
7941 if (!warned_comma || !warned_comment) {
7942 for (; !isSPACE(*d) && len; --len, ++d) {
7943 if (!warned_comma && *d == ',') {
7944 Perl_warner(aTHX_ packWARN(WARN_QW),
7945 "Possible attempt to separate words with commas");
7948 else if (!warned_comment && *d == '#') {
7949 Perl_warner(aTHX_ packWARN(WARN_QW),
7950 "Possible attempt to put comments in qw() list");
7956 for (; !isSPACE(*d) && len; --len, ++d)
7959 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7960 words = op_append_elem(OP_LIST, words,
7961 newSVOP(OP_CONST, 0, tokeq(sv)));
7966 words = newNULLLIST();
7968 SvREFCNT_dec(PL_lex_stuff);
7969 PL_lex_stuff = NULL;
7971 PL_expect = XOPERATOR;
7972 pl_yylval.opval = sawparens(words);
7977 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
7980 pl_yylval.ival = OP_STRINGIFY;
7981 if (SvIVX(PL_lex_stuff) == '\'')
7982 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7983 TERM(sublex_start());
7986 s = scan_pat(s,OP_QR);
7987 TERM(sublex_start());
7990 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
7993 readpipe_override();
7994 TERM(sublex_start());
8002 s = force_version(s, FALSE);
8004 else if (*s != 'v' || !isDIGIT(s[1])
8005 || (s = force_version(s, TRUE), *s == 'v'))
8007 *PL_tokenbuf = '\0';
8008 s = force_word(s,WORD,TRUE,TRUE,FALSE);
8009 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
8010 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8011 GV_ADD | (UTF ? SVf_UTF8 : 0));
8013 yyerror("<> should be quotes");
8015 if (orig_keyword == KEY_require) {
8023 PL_last_uni = PL_oldbufptr;
8024 PL_last_lop_op = OP_REQUIRE;
8026 return REPORT( (int)REQUIRE );
8032 s = force_word(s,WORD,TRUE,FALSE,FALSE);
8036 LOP(OP_RENAME,XTERM);
8045 LOP(OP_RINDEX,XTERM);
8054 UNIDOR(OP_READLINE);
8057 UNIDOR(OP_BACKTICK);
8066 LOP(OP_REVERSE,XTERM);
8069 UNIDOR(OP_READLINK);
8076 if (pl_yylval.opval)
8077 TERM(sublex_start());
8079 TOKEN(1); /* force error */
8082 checkcomma(s,PL_tokenbuf,"filehandle");
8092 LOP(OP_SELECT,XTERM);
8098 LOP(OP_SEMCTL,XTERM);
8101 LOP(OP_SEMGET,XTERM);
8104 LOP(OP_SEMOP,XTERM);
8110 LOP(OP_SETPGRP,XTERM);
8112 case KEY_setpriority:
8113 LOP(OP_SETPRIORITY,XTERM);
8115 case KEY_sethostent:
8121 case KEY_setservent:
8124 case KEY_setprotoent:
8134 LOP(OP_SEEKDIR,XTERM);
8136 case KEY_setsockopt:
8137 LOP(OP_SSOCKOPT,XTERM);
8143 LOP(OP_SHMCTL,XTERM);
8146 LOP(OP_SHMGET,XTERM);
8149 LOP(OP_SHMREAD,XTERM);
8152 LOP(OP_SHMWRITE,XTERM);
8155 LOP(OP_SHUTDOWN,XTERM);
8164 LOP(OP_SOCKET,XTERM);
8166 case KEY_socketpair:
8167 LOP(OP_SOCKPAIR,XTERM);
8170 checkcomma(s,PL_tokenbuf,"subroutine name");
8173 s = force_word(s,WORD,TRUE,TRUE,FALSE);
8177 LOP(OP_SPLIT,XTERM);
8180 LOP(OP_SPRINTF,XTERM);
8183 LOP(OP_SPLICE,XTERM);
8198 LOP(OP_SUBSTR,XTERM);
8204 char tmpbuf[sizeof PL_tokenbuf];
8205 SSize_t tboffset = 0;
8206 expectation attrful;
8207 bool have_name, have_proto;
8208 const int key = tmp;
8213 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
8214 SV *subtoken = newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr));
8218 s = SKIPSPACE2(s,tmpwhite);
8223 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
8224 (*s == ':' && s[1] == ':'))
8227 SV *nametoke = NULL;
8231 attrful = XATTRBLOCK;
8232 /* remember buffer pos'n for later force_word */
8233 tboffset = s - PL_oldbufptr;
8234 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
8237 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
8239 if (memchr(tmpbuf, ':', len))
8240 sv_setpvn(PL_subname, tmpbuf, len);
8242 sv_setsv(PL_subname,PL_curstname);
8243 sv_catpvs(PL_subname,"::");
8244 sv_catpvn(PL_subname,tmpbuf,len);
8246 if (SvUTF8(PL_linestr))
8247 SvUTF8_on(PL_subname);
8253 CURMAD('X', nametoke);
8254 CURMAD('_', tmpwhite);
8255 (void) force_word(PL_oldbufptr + tboffset, WORD,
8258 s = SKIPSPACE2(d,tmpwhite);
8265 Perl_croak(aTHX_ "Missing name in \"my sub\"");
8266 PL_expect = XTERMBLOCK;
8267 attrful = XATTRTERM;
8268 sv_setpvs(PL_subname,"?");
8272 if (key == KEY_format) {
8274 PL_thistoken = subtoken;
8278 (void) force_word(PL_oldbufptr + tboffset, WORD,
8284 /* Look for a prototype */
8287 bool bad_proto = FALSE;
8288 bool in_brackets = FALSE;
8289 char greedy_proto = ' ';
8290 bool proto_after_greedy_proto = FALSE;
8291 bool must_be_last = FALSE;
8292 bool underscore = FALSE;
8293 bool seen_underscore = FALSE;
8294 const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
8297 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
8299 Perl_croak(aTHX_ "Prototype not terminated");
8300 /* strip spaces and check for bad characters */
8301 d = SvPV(PL_lex_stuff, tmplen);
8303 for (p = d; tmplen; tmplen--, ++p) {
8307 if (warnillegalproto) {
8309 proto_after_greedy_proto = TRUE;
8310 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
8315 if ( !strchr(";@%", *p) )
8322 else if ( *p == ']' ) {
8323 in_brackets = FALSE;
8325 else if ( (*p == '@' || *p == '%') &&
8326 ( tmp < 2 || d[tmp-2] != '\\' ) &&
8328 must_be_last = TRUE;
8331 else if ( *p == '_' ) {
8332 underscore = seen_underscore = TRUE;
8339 if (proto_after_greedy_proto)
8340 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8341 "Prototype after '%c' for %"SVf" : %s",
8342 greedy_proto, SVfARG(PL_subname), d);
8344 SV *dsv = newSVpvs_flags("", SVs_TEMP);
8345 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8346 "Illegal character %sin prototype for %"SVf" : %s",
8347 seen_underscore ? "after '_' " : "",
8349 SvUTF8(PL_lex_stuff)
8350 ? sv_uni_display(dsv,
8351 newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8),
8353 UNI_DISPLAY_ISPRINT)
8354 : pv_pretty(dsv, d, tmp, 60, NULL, NULL,
8355 PERL_PV_ESCAPE_NONASCII));
8357 SvCUR_set(PL_lex_stuff, tmp);
8362 CURMAD('q', PL_thisopen);
8363 CURMAD('_', tmpwhite);
8364 CURMAD('=', PL_thisstuff);
8365 CURMAD('Q', PL_thisclose);
8366 NEXTVAL_NEXTTOKE.opval =
8367 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8368 PL_lex_stuff = NULL;
8371 s = SKIPSPACE2(s,tmpwhite);
8379 if (*s == ':' && s[1] != ':')
8380 PL_expect = attrful;
8381 else if (*s != '{' && key == KEY_sub) {
8383 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8384 else if (*s != ';' && *s != '}')
8385 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8392 curmad('^', newSVpvs(""));
8393 CURMAD('_', tmpwhite);
8397 PL_thistoken = subtoken;
8400 NEXTVAL_NEXTTOKE.opval =
8401 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8402 PL_lex_stuff = NULL;
8408 sv_setpvs(PL_subname, "__ANON__");
8410 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8414 (void) force_word(PL_oldbufptr + tboffset, WORD,
8423 LOP(OP_SYSTEM,XREF);
8426 LOP(OP_SYMLINK,XTERM);
8429 LOP(OP_SYSCALL,XTERM);
8432 LOP(OP_SYSOPEN,XTERM);
8435 LOP(OP_SYSSEEK,XTERM);
8438 LOP(OP_SYSREAD,XTERM);
8441 LOP(OP_SYSWRITE,XTERM);
8446 TERM(sublex_start());
8467 LOP(OP_TRUNCATE,XTERM);
8479 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8481 pl_yylval.ival = CopLINE(PL_curcop);
8485 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8487 pl_yylval.ival = CopLINE(PL_curcop);
8491 LOP(OP_UNLINK,XTERM);
8497 LOP(OP_UNPACK,XTERM);
8500 LOP(OP_UTIME,XTERM);
8506 LOP(OP_UNSHIFT,XTERM);
8509 s = tokenize_use(1, s);
8519 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8521 pl_yylval.ival = CopLINE(PL_curcop);
8525 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8527 pl_yylval.ival = CopLINE(PL_curcop);
8531 PL_hints |= HINT_BLOCK_SCOPE;
8538 LOP(OP_WAITPID,XTERM);
8547 ctl_l[0] = toCTRL('L');
8549 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8552 /* Make sure $^L is defined */
8553 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8558 if (PL_expect == XOPERATOR) {
8559 if (*s == '=' && !PL_lex_allbrackets &&
8560 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8568 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8570 pl_yylval.ival = OP_XOR;
8576 #pragma segment Main
8580 S_pending_ident(pTHX)
8584 /* pit holds the identifier we read and pending_ident is reset */
8585 char pit = PL_pending_ident;
8586 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8587 /* All routes through this function want to know if there is a colon. */
8588 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8589 PL_pending_ident = 0;
8591 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
8592 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8593 "### Pending identifier '%s'\n", PL_tokenbuf); });
8595 /* if we're in a my(), we can't allow dynamics here.
8596 $foo'bar has already been turned into $foo::bar, so
8597 just check for colons.
8599 if it's a legal name, the OP is a PADANY.
8602 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8604 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8605 "variable %s in \"our\"",
8606 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8607 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8611 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8612 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8613 UTF ? SVf_UTF8 : 0);
8615 pl_yylval.opval = newOP(OP_PADANY, 0);
8616 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8617 UTF ? SVf_UTF8 : 0);
8623 build the ops for accesses to a my() variable.
8628 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8629 UTF ? SVf_UTF8 : 0);
8630 if (tmp != NOT_IN_PAD) {
8631 /* might be an "our" variable" */
8632 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8633 /* build ops for a bareword */
8634 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8635 HEK * const stashname = HvNAME_HEK(stash);
8636 SV * const sym = newSVhek(stashname);
8637 sv_catpvs(sym, "::");
8638 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8639 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8640 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8643 ? (GV_ADDMULTI | GV_ADDINEVAL)
8646 ((PL_tokenbuf[0] == '$') ? SVt_PV
8647 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8652 pl_yylval.opval = newOP(OP_PADANY, 0);
8653 pl_yylval.opval->op_targ = tmp;
8659 Whine if they've said @foo in a doublequoted string,
8660 and @foo isn't a variable we can find in the symbol
8663 if (ckWARN(WARN_AMBIGUOUS) &&
8664 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8665 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8666 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8667 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8668 /* DO NOT warn for @- and @+ */
8669 && !( PL_tokenbuf[2] == '\0' &&
8670 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8673 /* Downgraded from fatal to warning 20000522 mjd */
8674 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8675 "Possible unintended interpolation of %"SVf" in string",
8676 SVfARG(newSVpvn_flags(PL_tokenbuf, tokenbuf_len,
8677 SVs_TEMP | ( UTF ? SVf_UTF8 : 0 ))));
8681 /* build ops for a bareword */
8682 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(PL_tokenbuf + 1,
8684 UTF ? SVf_UTF8 : 0 ));
8685 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8686 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8687 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
8688 | ( UTF ? SVf_UTF8 : 0 ),
8689 ((PL_tokenbuf[0] == '$') ? SVt_PV
8690 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8696 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8700 PERL_ARGS_ASSERT_CHECKCOMMA;
8702 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8703 if (ckWARN(WARN_SYNTAX)) {
8706 for (w = s+2; *w && level; w++) {
8714 /* the list of chars below is for end of statements or
8715 * block / parens, boolean operators (&&, ||, //) and branch
8716 * constructs (or, and, if, until, unless, while, err, for).
8717 * Not a very solid hack... */
8718 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8719 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8720 "%s (...) interpreted as function",name);
8723 while (s < PL_bufend && isSPACE(*s))
8727 while (s < PL_bufend && isSPACE(*s))
8729 if (isIDFIRST_lazy_if(s,UTF)) {
8730 const char * const w = s;
8731 s += UTF ? UTF8SKIP(s) : 1;
8732 while (isALNUM_lazy_if(s,UTF))
8733 s += UTF ? UTF8SKIP(s) : 1;
8734 while (s < PL_bufend && isSPACE(*s))
8738 if (keyword(w, s - w, 0))
8741 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8742 if (gv && GvCVu(gv))
8744 Perl_croak(aTHX_ "No comma allowed after %s", what);
8749 /* Either returns sv, or mortalizes sv and returns a new SV*.
8750 Best used as sv=new_constant(..., sv, ...).
8751 If s, pv are NULL, calls subroutine with one argument,
8752 and type is used with error messages only. */
8755 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8756 SV *sv, SV *pv, const char *type, STRLEN typelen)
8759 HV * table = GvHV(PL_hintgv); /* ^H */
8763 const char *why1 = "", *why2 = "", *why3 = "";
8765 PERL_ARGS_ASSERT_NEW_CONSTANT;
8767 /* charnames doesn't work well if there have been errors found */
8768 if (PL_error_count > 0 && strEQ(key,"charnames"))
8769 return &PL_sv_undef;
8772 || ! (PL_hints & HINT_LOCALIZE_HH)
8773 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
8778 /* Here haven't found what we're looking for. If it is charnames,
8779 * perhaps it needs to be loaded. Try doing that before giving up */
8780 if (strEQ(key,"charnames")) {
8781 Perl_load_module(aTHX_
8783 newSVpvs("_charnames"),
8784 /* version parameter; no need to specify it, as if
8785 * we get too early a version, will fail anyway,
8786 * not being able to find '_charnames' */
8792 table = GvHV(PL_hintgv);
8794 && (PL_hints & HINT_LOCALIZE_HH)
8795 && (cvp = hv_fetch(table, key, keylen, FALSE))
8801 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8802 msg = Perl_newSVpvf(aTHX_
8803 "Constant(%s) unknown", (type ? type: "undef"));
8808 why3 = "} is not defined";
8810 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
8811 (type ? type: "undef"), why1, why2, why3);
8813 yyerror(SvPVX_const(msg));
8818 sv_2mortal(sv); /* Parent created it permanently */
8821 pv = newSVpvn_flags(s, len, SVs_TEMP);
8823 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8825 typesv = &PL_sv_undef;
8827 PUSHSTACKi(PERLSI_OVERLOAD);
8839 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8843 /* Check the eval first */
8844 if (!PL_in_eval && SvTRUE(ERRSV)) {
8845 sv_catpvs(ERRSV, "Propagated");
8846 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
8848 res = SvREFCNT_inc_simple(sv);
8852 SvREFCNT_inc_simple_void(res);
8861 why1 = "Call to &{$^H{";
8863 why3 = "}} did not return a defined value";
8871 /* Returns a NUL terminated string, with the length of the string written to
8875 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8879 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8881 PERL_ARGS_ASSERT_SCAN_WORD;
8885 Perl_croak(aTHX_ ident_too_long);
8886 if (isALNUM(*s) || (!UTF && isALNUMC_L1(*s))) /* UTF handled below */
8888 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
8893 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
8897 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8898 char *t = s + UTF8SKIP(s);
8900 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8904 Perl_croak(aTHX_ ident_too_long);
8905 Copy(s, d, len, char);
8918 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
8921 char *bracket = NULL;
8924 char * const e = d + destlen - 3; /* two-character token, ending NUL */
8926 PERL_ARGS_ASSERT_SCAN_IDENT;
8931 while (isDIGIT(*s)) {
8933 Perl_croak(aTHX_ ident_too_long);
8940 Perl_croak(aTHX_ ident_too_long);
8941 if (isALNUM(*s)) /* UTF handled below */
8943 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
8948 else if (*s == ':' && s[1] == ':') {
8952 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8953 char *t = s + UTF8SKIP(s);
8954 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8956 if (d + (t - s) > e)
8957 Perl_croak(aTHX_ ident_too_long);
8958 Copy(s, d, t - s, char);
8969 if (PL_lex_state != LEX_NORMAL)
8970 PL_lex_state = LEX_INTERPENDMAYBE;
8973 if (*s == '$' && s[1] &&
8974 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
8984 const STRLEN skip = UTF8SKIP(s);
8987 for ( i = 0; i < skip; i++ )
8995 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8999 else if (ck_uni && !bracket)
9002 if (isSPACE(s[-1])) {
9004 const char ch = *s++;
9005 if (!SPACE_OR_TAB(ch)) {
9011 if (isIDFIRST_lazy_if(d,UTF)) {
9015 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
9016 end += UTF8SKIP(end);
9017 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
9018 end += UTF8SKIP(end);
9020 Copy(s, d, end - s, char);
9025 while ((isALNUM(*s) || *s == ':') && d < e)
9028 Perl_croak(aTHX_ ident_too_long);
9031 while (s < send && SPACE_OR_TAB(*s))
9033 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9034 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9035 const char * const brack =
9037 ((*s == '[') ? "[...]" : "{...}");
9038 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9039 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9040 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9041 funny, dest, brack, funny, dest, brack);
9044 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9045 PL_lex_allbrackets++;
9049 /* Handle extended ${^Foo} variables
9050 * 1999-02-27 mjd-perl-patch@plover.com */
9051 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9055 while (isALNUM(*s) && d < e) {
9059 Perl_croak(aTHX_ ident_too_long);
9064 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9065 PL_lex_state = LEX_INTERPEND;
9068 if (PL_lex_state == LEX_NORMAL) {
9069 if (ckWARN(WARN_AMBIGUOUS) &&
9070 (keyword(dest, d - dest, 0)
9071 || get_cvn_flags(dest, d - dest, UTF ? SVf_UTF8 : 0)))
9073 SV *tmp = newSVpvn_flags( dest, d - dest,
9074 SVs_TEMP | (UTF ? SVf_UTF8 : 0) );
9077 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9078 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9079 funny, tmp, funny, tmp);
9084 s = bracket; /* let the parser handle it */
9088 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9089 PL_lex_state = LEX_INTERPEND;
9094 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
9096 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
9097 * the parse starting at 's', based on the subset that are valid in this
9098 * context input to this routine in 'valid_flags'. Advances s. Returns
9099 * TRUE if the input should be treated as a valid flag, so the next char
9100 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
9101 * first call on the current regex. This routine will set it to any
9102 * charset modifier found. The caller shouldn't change it. This way,
9103 * another charset modifier encountered in the parse can be detected as an
9104 * error, as we have decided to allow only one */
9107 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9109 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9110 if (isALNUM_lazy_if(*s, UTF)) {
9111 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9112 UTF ? SVf_UTF8 : 0);
9114 /* Pretend that it worked, so will continue processing before
9123 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
9124 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9125 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9126 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9127 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9128 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9129 case LOCALE_PAT_MOD:
9131 goto multiple_charsets;
9133 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9136 case UNICODE_PAT_MOD:
9138 goto multiple_charsets;
9140 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9143 case ASCII_RESTRICT_PAT_MOD:
9145 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9149 /* Error if previous modifier wasn't an 'a', but if it was, see
9150 * if, and accept, a second occurrence (only) */
9152 || get_regex_charset(*pmfl)
9153 != REGEX_ASCII_RESTRICTED_CHARSET)
9155 goto multiple_charsets;
9157 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9161 case DEPENDS_PAT_MOD:
9163 goto multiple_charsets;
9165 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9174 if (*charset != c) {
9175 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9177 else if (c == 'a') {
9178 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9181 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9184 /* Pretend that it worked, so will continue processing before dieing */
9190 S_scan_pat(pTHX_ char *start, I32 type)
9194 char *s = scan_str(start,!!PL_madskills,FALSE, PL_reg_state.re_reparsing);
9195 const char * const valid_flags =
9196 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9197 char charset = '\0'; /* character set modifier */
9202 PERL_ARGS_ASSERT_SCAN_PAT;
9204 /* this was only needed for the initial scan_str; set it to false
9205 * so that any (?{}) code blocks etc are parsed normally */
9206 PL_reg_state.re_reparsing = FALSE;
9208 const char * const delimiter = skipspace(start);
9212 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9213 : "Search pattern not terminated" ));
9216 pm = (PMOP*)newPMOP(type, 0);
9217 if (PL_multi_open == '?') {
9218 /* This is the only point in the code that sets PMf_ONCE: */
9219 pm->op_pmflags |= PMf_ONCE;
9221 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9222 allows us to restrict the list needed by reset to just the ??
9224 assert(type != OP_TRANS);
9226 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9229 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9232 elements = mg->mg_len / sizeof(PMOP**);
9233 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9234 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9235 mg->mg_len = elements * sizeof(PMOP**);
9236 PmopSTASH_set(pm,PL_curstash);
9243 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9244 * anon CV. False positives like qr/[(?{]/ are harmless */
9246 if (type == OP_QR) {
9248 char *e, *p = SvPV(PL_lex_stuff, len);
9250 for (; p < e; p++) {
9251 if (p[0] == '(' && p[1] == '?'
9252 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9254 pm->op_pmflags |= PMf_HAS_CV;
9258 pm->op_pmflags |= PMf_IS_QR;
9261 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9263 if (PL_madskills && modstart != s) {
9264 SV* tmptoken = newSVpvn(modstart, s - modstart);
9265 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9268 /* issue a warning if /c is specified,but /g is not */
9269 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9271 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9272 "Use of /c modifier is meaningless without /g" );
9275 PL_lex_op = (OP*)pm;
9276 pl_yylval.ival = OP_MATCH;
9281 S_scan_subst(pTHX_ char *start)
9288 char charset = '\0'; /* character set modifier */
9293 PERL_ARGS_ASSERT_SCAN_SUBST;
9295 pl_yylval.ival = OP_NULL;
9297 s = scan_str(start,!!PL_madskills,FALSE,FALSE);
9300 Perl_croak(aTHX_ "Substitution pattern not terminated");
9302 if (s[-1] == PL_multi_open)
9306 CURMAD('q', PL_thisopen);
9307 CURMAD('_', PL_thiswhite);
9308 CURMAD('E', PL_thisstuff);
9309 CURMAD('Q', PL_thisclose);
9310 PL_realtokenstart = s - SvPVX(PL_linestr);
9314 first_start = PL_multi_start;
9315 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
9318 SvREFCNT_dec(PL_lex_stuff);
9319 PL_lex_stuff = NULL;
9321 Perl_croak(aTHX_ "Substitution replacement not terminated");
9323 PL_multi_start = first_start; /* so whole substitution is taken together */
9325 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9329 CURMAD('z', PL_thisopen);
9330 CURMAD('R', PL_thisstuff);
9331 CURMAD('Z', PL_thisclose);
9337 if (*s == EXEC_PAT_MOD) {
9341 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9350 curmad('m', newSVpvn(modstart, s - modstart));
9351 append_madprops(PL_thismad, (OP*)pm, 0);
9355 if ((pm->op_pmflags & PMf_CONTINUE)) {
9356 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9360 SV * const repl = newSVpvs("");
9363 pm->op_pmflags |= PMf_EVAL;
9366 sv_catpvs(repl, "eval ");
9368 sv_catpvs(repl, "do ");
9370 sv_catpvs(repl, "{");
9371 sv_catsv(repl, PL_sublex_info.repl);
9372 sv_catpvs(repl, "}");
9374 SvREFCNT_dec(PL_sublex_info.repl);
9375 PL_sublex_info.repl = repl;
9378 PL_lex_op = (OP*)pm;
9379 pl_yylval.ival = OP_SUBST;
9384 S_scan_trans(pTHX_ char *start)
9392 bool nondestruct = 0;
9397 PERL_ARGS_ASSERT_SCAN_TRANS;
9399 pl_yylval.ival = OP_NULL;
9401 s = scan_str(start,!!PL_madskills,FALSE,FALSE);
9403 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9405 if (s[-1] == PL_multi_open)
9409 CURMAD('q', PL_thisopen);
9410 CURMAD('_', PL_thiswhite);
9411 CURMAD('E', PL_thisstuff);
9412 CURMAD('Q', PL_thisclose);
9413 PL_realtokenstart = s - SvPVX(PL_linestr);
9417 s = scan_str(s,!!PL_madskills,FALSE,FALSE);
9420 SvREFCNT_dec(PL_lex_stuff);
9421 PL_lex_stuff = NULL;
9423 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9426 CURMAD('z', PL_thisopen);
9427 CURMAD('R', PL_thisstuff);
9428 CURMAD('Z', PL_thisclose);
9431 complement = del = squash = 0;
9438 complement = OPpTRANS_COMPLEMENT;
9441 del = OPpTRANS_DELETE;
9444 squash = OPpTRANS_SQUASH;
9456 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9457 o->op_private &= ~OPpTRANS_ALL;
9458 o->op_private |= del|squash|complement|
9459 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9460 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9463 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9468 curmad('m', newSVpvn(modstart, s - modstart));
9469 append_madprops(PL_thismad, o, 0);
9478 Takes a pointer to the first < in <<FOO.
9479 Returns a pointer to the byte following <<FOO.
9481 This function scans a heredoc, which involves different methods
9482 depending on whether we are in a string eval, quoted construct, etc.
9483 This is because PL_linestr could containing a single line of input, or
9484 a whole string being evalled, or the contents of the current quote-
9487 The two basic methods are:
9488 - Steal lines from the input stream
9489 - Scan the heredoc in PL_linestr and remove it therefrom
9491 In a file scope or filtered eval, the first method is used; in a
9492 string eval, the second.
9494 In a quote-like operator, we have to choose between the two,
9495 depending on where we can find a newline. We peek into outer lex-
9496 ing scopes until we find one with a newline in it. If we reach the
9497 outermost lexing scope and it is a file, we use the stream method.
9498 Otherwise it is treated as an eval.
9502 S_scan_heredoc(pTHX_ register char *s)
9505 I32 op_type = OP_SCALAR;
9512 const bool infile = PL_rsfp || PL_parser->filtered;
9513 LEXSHARED *shared = PL_parser->lex_shared;
9515 I32 stuffstart = s - SvPVX(PL_linestr);
9518 PL_realtokenstart = -1;
9521 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9524 d = PL_tokenbuf + 1;
9525 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9526 *PL_tokenbuf = '\n';
9528 while (SPACE_OR_TAB(*peek))
9530 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9533 s = delimcpy(d, e, s, PL_bufend, term, &len);
9535 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9541 /* <<\FOO is equivalent to <<'FOO' */
9545 if (!isALNUM_lazy_if(s,UTF))
9546 deprecate("bare << to mean <<\"\"");
9547 for (; isALNUM_lazy_if(s,UTF); s++) {
9552 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9553 Perl_croak(aTHX_ "Delimiter for here document is too long");
9556 len = d - PL_tokenbuf;
9560 tstart = PL_tokenbuf + 1;
9561 PL_thisclose = newSVpvn(tstart, len - 1);
9562 tstart = SvPVX(PL_linestr) + stuffstart;
9563 PL_thisopen = newSVpvn(tstart, s - tstart);
9564 stuffstart = s - SvPVX(PL_linestr);
9567 #ifndef PERL_STRICT_CR
9568 d = strchr(s, '\r');
9570 char * const olds = s;
9572 while (s < PL_bufend) {
9578 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9587 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9593 tstart = SvPVX(PL_linestr) + stuffstart;
9595 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9597 PL_thisstuff = newSVpvn(tstart, s - tstart);
9600 stuffstart = s - SvPVX(PL_linestr);
9603 tmpstr = newSV_type(SVt_PVIV);
9607 SvIV_set(tmpstr, -1);
9609 else if (term == '`') {
9610 op_type = OP_BACKTICK;
9611 SvIV_set(tmpstr, '\\');
9614 PL_multi_start = CopLINE(PL_curcop) + 1;
9615 PL_multi_open = PL_multi_close = '<';
9616 /* inside a string eval or quote-like operator */
9617 if (!infile || PL_lex_inwhat) {
9619 char *bufptr, *bufend;
9620 char * const olds = s;
9621 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9622 /* These two fields are not set until an inner lexing scope is
9623 entered. But we need them set here. */
9624 shared->ls_bufptr = s;
9625 shared->ls_linestr = PL_linestr;
9627 /* Look for a newline. If the current buffer does not have one,
9628 peek into the line buffer of the parent lexing scope, going
9629 up as many levels as necessary to find one with a newline
9632 while (!(s = (char *)memchr(
9633 (void *)shared->ls_bufptr, '\n',
9634 SvEND(shared->ls_linestr)-shared->ls_bufptr
9636 shared = shared->ls_prev;
9637 /* shared is only null if we have gone beyond the outermost
9638 lexing scope. In a file, we will have broken out of the
9639 loop in the previous iteration. In an eval, the string buf-
9640 fer ends with "\n;", so the while condition below will have
9641 evaluated to false. So shared can never be null. */
9643 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9644 most lexing scope. In a file, shared->ls_linestr at that
9645 level is just one line, so there is no body to steal. */
9646 if (infile && !shared->ls_prev) {
9652 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9655 bufptr = shared->ls_bufptr;
9656 linestr = shared->ls_linestr;
9657 bufend = SvEND(linestr);
9659 while (s < bufend &&
9660 (*s != '\n' || memNE(s,PL_tokenbuf,len)) ) {
9662 ++shared->herelines;
9667 sv_setpvn(tmpstr,d+1,s-d);
9671 sv_catpvn(PL_thisstuff, d + 1, s - d);
9673 PL_thisstuff = newSVpvn(d + 1, s - d);
9674 stuffstart = s - SvPVX(PL_linestr);
9678 /* the preceding stmt passes a newline */
9679 shared->herelines++;
9681 /* s now points to the newline after the heredoc terminator.
9682 d points to the newline before the body of the heredoc.
9685 /* We are going to modify linestr in place here, so set
9686 aside copies of the string if necessary for re-evals or
9688 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
9689 check shared->re_eval_str. */
9690 if (shared->re_eval_start || shared->re_eval_str) {
9691 /* Set aside the rest of the regexp */
9692 if (!shared->re_eval_str)
9693 shared->re_eval_str =
9694 newSVpvn(shared->re_eval_start,
9695 bufend - shared->re_eval_start);
9696 shared->re_eval_start -= s-d;
9698 if (CxTYPE(cx) == CXt_EVAL && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
9699 && cx->blk_eval.cur_text == linestr) {
9700 cx->blk_eval.cur_text = newSVsv(linestr);
9701 SvSCREAM_on(cx->blk_eval.cur_text);
9703 /* Copy everything from s onwards back to d. */
9704 Move(s,d,bufend-s + 1,char);
9705 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
9706 /* Setting PL_bufend only applies when we have not dug deeper
9707 into other scopes, because sublex_done sets PL_bufend to
9708 SvEND(PL_linestr). */
9709 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
9716 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9717 term = PL_tokenbuf[1];
9719 linestr_save = PL_linestr; /* must restore this afterwards */
9720 d = s; /* and this */
9721 PL_linestr = newSVpvs("");
9722 PL_bufend = SvPVX(PL_linestr);
9726 tstart = SvPVX(PL_linestr) + stuffstart;
9728 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9730 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9733 PL_bufptr = PL_bufend;
9734 CopLINE_set(PL_curcop,
9735 PL_multi_start + shared->herelines);
9736 if (!lex_next_chunk(LEX_NO_TERM)
9737 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
9738 SvREFCNT_dec(linestr_save);
9741 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
9742 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
9743 lex_grow_linestr(SvCUR(PL_linestr) + 2);
9744 sv_catpvs(PL_linestr, "\n\0");
9748 stuffstart = s - SvPVX(PL_linestr);
9750 shared->herelines++;
9751 PL_last_lop = PL_last_uni = NULL;
9752 #ifndef PERL_STRICT_CR
9753 if (PL_bufend - PL_linestart >= 2) {
9754 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9755 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9757 PL_bufend[-2] = '\n';
9759 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9761 else if (PL_bufend[-1] == '\r')
9762 PL_bufend[-1] = '\n';
9764 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9765 PL_bufend[-1] = '\n';
9767 if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
9768 SvREFCNT_dec(PL_linestr);
9769 PL_linestr = linestr_save;
9770 PL_linestart = SvPVX(linestr_save);
9771 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9776 sv_catsv(tmpstr,PL_linestr);
9780 PL_multi_end = CopLINE(PL_curcop);
9781 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9782 SvPV_shrink_to_cur(tmpstr);
9785 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9787 else if (PL_encoding)
9788 sv_recode_to_utf8(tmpstr, PL_encoding);
9790 PL_lex_stuff = tmpstr;
9791 pl_yylval.ival = op_type;
9795 SvREFCNT_dec(tmpstr);
9796 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
9797 missingterm(PL_tokenbuf + 1);
9801 takes: current position in input buffer
9802 returns: new position in input buffer
9803 side-effects: pl_yylval and lex_op are set.
9808 <FH> read from filehandle
9809 <pkg::FH> read from package qualified filehandle
9810 <pkg'FH> read from package qualified filehandle
9811 <$fh> read from filehandle in $fh
9817 S_scan_inputsymbol(pTHX_ char *start)
9820 char *s = start; /* current position in buffer */
9823 char *d = PL_tokenbuf; /* start of temp holding space */
9824 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9826 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9828 end = strchr(s, '\n');
9831 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9833 /* die if we didn't have space for the contents of the <>,
9834 or if it didn't end, or if we see a newline
9837 if (len >= (I32)sizeof PL_tokenbuf)
9838 Perl_croak(aTHX_ "Excessively long <> operator");
9840 Perl_croak(aTHX_ "Unterminated <> operator");
9845 Remember, only scalar variables are interpreted as filehandles by
9846 this code. Anything more complex (e.g., <$fh{$num}>) will be
9847 treated as a glob() call.
9848 This code makes use of the fact that except for the $ at the front,
9849 a scalar variable and a filehandle look the same.
9851 if (*d == '$' && d[1]) d++;
9853 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9854 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9855 d += UTF ? UTF8SKIP(d) : 1;
9857 /* If we've tried to read what we allow filehandles to look like, and
9858 there's still text left, then it must be a glob() and not a getline.
9859 Use scan_str to pull out the stuff between the <> and treat it
9860 as nothing more than a string.
9863 if (d - PL_tokenbuf != len) {
9864 pl_yylval.ival = OP_GLOB;
9865 s = scan_str(start,!!PL_madskills,FALSE,FALSE);
9867 Perl_croak(aTHX_ "Glob not terminated");
9871 bool readline_overriden = FALSE;
9874 /* we're in a filehandle read situation */
9877 /* turn <> into <ARGV> */
9879 Copy("ARGV",d,5,char);
9881 /* Check whether readline() is overriden */
9882 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
9884 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9886 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
9887 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
9888 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9889 readline_overriden = TRUE;
9891 /* if <$fh>, create the ops to turn the variable into a
9895 /* try to find it in the pad for this block, otherwise find
9896 add symbol table ops
9898 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
9899 if (tmp != NOT_IN_PAD) {
9900 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9901 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9902 HEK * const stashname = HvNAME_HEK(stash);
9903 SV * const sym = sv_2mortal(newSVhek(stashname));
9904 sv_catpvs(sym, "::");
9910 OP * const o = newOP(OP_PADSV, 0);
9912 PL_lex_op = readline_overriden
9913 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9914 op_append_elem(OP_LIST, o,
9915 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9916 : (OP*)newUNOP(OP_READLINE, 0, o);
9925 ? (GV_ADDMULTI | GV_ADDINEVAL)
9926 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
9928 PL_lex_op = readline_overriden
9929 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9930 op_append_elem(OP_LIST,
9931 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9932 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9933 : (OP*)newUNOP(OP_READLINE, 0,
9934 newUNOP(OP_RV2SV, 0,
9935 newGVOP(OP_GV, 0, gv)));
9937 if (!readline_overriden)
9938 PL_lex_op->op_flags |= OPf_SPECIAL;
9939 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9940 pl_yylval.ival = OP_NULL;
9943 /* If it's none of the above, it must be a literal filehandle
9944 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9946 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9947 PL_lex_op = readline_overriden
9948 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9949 op_append_elem(OP_LIST,
9950 newGVOP(OP_GV, 0, gv),
9951 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9952 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9953 pl_yylval.ival = OP_NULL;
9962 takes: start position in buffer
9963 keep_quoted preserve \ on the embedded delimiter(s)
9964 keep_delims preserve the delimiters around the string
9965 re_reparse compiling a run-time /(?{})/:
9966 collapse // to /, and skip encoding src
9967 returns: position to continue reading from buffer
9968 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9969 updates the read buffer.
9971 This subroutine pulls a string out of the input. It is called for:
9972 q single quotes q(literal text)
9973 ' single quotes 'literal text'
9974 qq double quotes qq(interpolate $here please)
9975 " double quotes "interpolate $here please"
9976 qx backticks qx(/bin/ls -l)
9977 ` backticks `/bin/ls -l`
9978 qw quote words @EXPORT_OK = qw( func() $spam )
9979 m// regexp match m/this/
9980 s/// regexp substitute s/this/that/
9981 tr/// string transliterate tr/this/that/
9982 y/// string transliterate y/this/that/
9983 ($*@) sub prototypes sub foo ($)
9984 (stuff) sub attr parameters sub foo : attr(stuff)
9985 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9987 In most of these cases (all but <>, patterns and transliterate)
9988 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9989 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9990 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9993 It skips whitespace before the string starts, and treats the first
9994 character as the delimiter. If the delimiter is one of ([{< then
9995 the corresponding "close" character )]}> is used as the closing
9996 delimiter. It allows quoting of delimiters, and if the string has
9997 balanced delimiters ([{<>}]) it allows nesting.
9999 On success, the SV with the resulting string is put into lex_stuff or,
10000 if that is already non-NULL, into lex_repl. The second case occurs only
10001 when parsing the RHS of the special constructs s/// and tr/// (y///).
10002 For convenience, the terminating delimiter character is stuffed into
10007 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse)
10010 SV *sv; /* scalar value: string */
10011 const char *tmps; /* temp string, used for delimiter matching */
10012 char *s = start; /* current position in the buffer */
10013 char term; /* terminating character */
10014 char *to; /* current position in the sv's data */
10015 I32 brackets = 1; /* bracket nesting level */
10016 bool has_utf8 = FALSE; /* is there any utf8 content? */
10017 I32 termcode; /* terminating char. code */
10018 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10019 STRLEN termlen; /* length of terminating string */
10020 int last_off = 0; /* last position for nesting bracket */
10026 PERL_ARGS_ASSERT_SCAN_STR;
10028 /* skip space before the delimiter */
10034 if (PL_realtokenstart >= 0) {
10035 stuffstart = PL_realtokenstart;
10036 PL_realtokenstart = -1;
10039 stuffstart = start - SvPVX(PL_linestr);
10041 /* mark where we are, in case we need to report errors */
10044 /* after skipping whitespace, the next character is the terminator */
10047 termcode = termstr[0] = term;
10051 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10052 Copy(s, termstr, termlen, U8);
10053 if (!UTF8_IS_INVARIANT(term))
10057 /* mark where we are */
10058 PL_multi_start = CopLINE(PL_curcop);
10059 PL_multi_open = term;
10061 /* find corresponding closing delimiter */
10062 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10063 termcode = termstr[0] = term = tmps[5];
10065 PL_multi_close = term;
10067 /* create a new SV to hold the contents. 79 is the SV's initial length.
10068 What a random number. */
10069 sv = newSV_type(SVt_PVIV);
10071 SvIV_set(sv, termcode);
10072 (void)SvPOK_only(sv); /* validate pointer */
10074 /* move past delimiter and try to read a complete string */
10076 sv_catpvn(sv, s, termlen);
10079 tstart = SvPVX(PL_linestr) + stuffstart;
10080 if (!PL_thisopen && !keep_delims) {
10081 PL_thisopen = newSVpvn(tstart, s - tstart);
10082 stuffstart = s - SvPVX(PL_linestr);
10086 if (PL_encoding && !UTF && !re_reparse) {
10090 int offset = s - SvPVX_const(PL_linestr);
10091 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10092 &offset, (char*)termstr, termlen);
10093 const char * const ns = SvPVX_const(PL_linestr) + offset;
10094 char * const svlast = SvEND(sv) - 1;
10096 for (; s < ns; s++) {
10097 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10098 COPLINE_INC_WITH_HERELINES;
10101 goto read_more_line;
10103 /* handle quoted delimiters */
10104 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10106 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10108 if ((svlast-1 - t) % 2) {
10109 if (!keep_quoted) {
10110 *(svlast-1) = term;
10112 SvCUR_set(sv, SvCUR(sv) - 1);
10117 if (PL_multi_open == PL_multi_close) {
10123 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10124 /* At here, all closes are "was quoted" one,
10125 so we don't check PL_multi_close. */
10127 if (!keep_quoted && *(t+1) == PL_multi_open)
10132 else if (*t == PL_multi_open)
10140 SvCUR_set(sv, w - SvPVX_const(sv));
10142 last_off = w - SvPVX(sv);
10143 if (--brackets <= 0)
10148 if (!keep_delims) {
10149 SvCUR_set(sv, SvCUR(sv) - 1);
10155 /* extend sv if need be */
10156 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10157 /* set 'to' to the next character in the sv's string */
10158 to = SvPVX(sv)+SvCUR(sv);
10160 /* if open delimiter is the close delimiter read unbridle */
10161 if (PL_multi_open == PL_multi_close) {
10162 for (; s < PL_bufend; s++,to++) {
10163 /* embedded newlines increment the current line number */
10164 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10165 COPLINE_INC_WITH_HERELINES;
10166 /* handle quoted delimiters */
10167 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10170 || (re_reparse && s[1] == '\\'))
10173 /* any other quotes are simply copied straight through */
10177 /* terminate when run out of buffer (the for() condition), or
10178 have found the terminator */
10179 else if (*s == term) {
10182 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10185 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10191 /* if the terminator isn't the same as the start character (e.g.,
10192 matched brackets), we have to allow more in the quoting, and
10193 be prepared for nested brackets.
10196 /* read until we run out of string, or we find the terminator */
10197 for (; s < PL_bufend; s++,to++) {
10198 /* embedded newlines increment the line count */
10199 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10200 COPLINE_INC_WITH_HERELINES;
10201 /* backslashes can escape the open or closing characters */
10202 if (*s == '\\' && s+1 < PL_bufend) {
10203 if (!keep_quoted &&
10204 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10209 /* allow nested opens and closes */
10210 else if (*s == PL_multi_close && --brackets <= 0)
10212 else if (*s == PL_multi_open)
10214 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10219 /* terminate the copied string and update the sv's end-of-string */
10221 SvCUR_set(sv, to - SvPVX_const(sv));
10224 * this next chunk reads more into the buffer if we're not done yet
10228 break; /* handle case where we are done yet :-) */
10230 #ifndef PERL_STRICT_CR
10231 if (to - SvPVX_const(sv) >= 2) {
10232 if ((to[-2] == '\r' && to[-1] == '\n') ||
10233 (to[-2] == '\n' && to[-1] == '\r'))
10237 SvCUR_set(sv, to - SvPVX_const(sv));
10239 else if (to[-1] == '\r')
10242 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10247 /* if we're out of file, or a read fails, bail and reset the current
10248 line marker so we can report where the unterminated string began
10251 if (PL_madskills) {
10252 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10254 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10256 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10259 COPLINE_INC_WITH_HERELINES;
10260 PL_bufptr = PL_bufend;
10261 if (!lex_next_chunk(0)) {
10263 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10272 /* at this point, we have successfully read the delimited string */
10274 if (!PL_encoding || UTF || re_reparse) {
10276 if (PL_madskills) {
10277 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10278 const int len = s - tstart;
10280 sv_catpvn(PL_thisstuff, tstart, len);
10282 PL_thisstuff = newSVpvn(tstart, len);
10283 if (!PL_thisclose && !keep_delims)
10284 PL_thisclose = newSVpvn(s,termlen);
10289 sv_catpvn(sv, s, termlen);
10294 if (PL_madskills) {
10295 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10296 const int len = s - tstart - termlen;
10298 sv_catpvn(PL_thisstuff, tstart, len);
10300 PL_thisstuff = newSVpvn(tstart, len);
10301 if (!PL_thisclose && !keep_delims)
10302 PL_thisclose = newSVpvn(s - termlen,termlen);
10306 if (has_utf8 || (PL_encoding && !re_reparse))
10309 PL_multi_end = CopLINE(PL_curcop);
10311 /* if we allocated too much space, give some back */
10312 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10313 SvLEN_set(sv, SvCUR(sv) + 1);
10314 SvPV_renew(sv, SvLEN(sv));
10317 /* decide whether this is the first or second quoted string we've read
10322 PL_sublex_info.repl = sv;
10330 takes: pointer to position in buffer
10331 returns: pointer to new position in buffer
10332 side-effects: builds ops for the constant in pl_yylval.op
10334 Read a number in any of the formats that Perl accepts:
10336 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10337 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10340 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10342 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10345 If it reads a number without a decimal point or an exponent, it will
10346 try converting the number to an integer and see if it can do so
10347 without loss of precision.
10351 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10354 const char *s = start; /* current position in buffer */
10355 char *d; /* destination in temp buffer */
10356 char *e; /* end of temp buffer */
10357 NV nv; /* number read, as a double */
10358 SV *sv = NULL; /* place to put the converted number */
10359 bool floatit; /* boolean: int or float? */
10360 const char *lastub = NULL; /* position of last underbar */
10361 static char const number_too_long[] = "Number too long";
10363 PERL_ARGS_ASSERT_SCAN_NUM;
10365 /* We use the first character to decide what type of number this is */
10369 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10371 /* if it starts with a 0, it could be an octal number, a decimal in
10372 0.13 disguise, or a hexadecimal number, or a binary number. */
10376 u holds the "number so far"
10377 shift the power of 2 of the base
10378 (hex == 4, octal == 3, binary == 1)
10379 overflowed was the number more than we can hold?
10381 Shift is used when we add a digit. It also serves as an "are
10382 we in octal/hex/binary?" indicator to disallow hex characters
10383 when in octal mode.
10388 bool overflowed = FALSE;
10389 bool just_zero = TRUE; /* just plain 0 or binary number? */
10390 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10391 static const char* const bases[5] =
10392 { "", "binary", "", "octal", "hexadecimal" };
10393 static const char* const Bases[5] =
10394 { "", "Binary", "", "Octal", "Hexadecimal" };
10395 static const char* const maxima[5] =
10397 "0b11111111111111111111111111111111",
10401 const char *base, *Base, *max;
10403 /* check for hex */
10404 if (s[1] == 'x' || s[1] == 'X') {
10408 } else if (s[1] == 'b' || s[1] == 'B') {
10413 /* check for a decimal in disguise */
10414 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10416 /* so it must be octal */
10423 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10424 "Misplaced _ in number");
10428 base = bases[shift];
10429 Base = Bases[shift];
10430 max = maxima[shift];
10432 /* read the rest of the number */
10434 /* x is used in the overflow test,
10435 b is the digit we're adding on. */
10440 /* if we don't mention it, we're done */
10444 /* _ are ignored -- but warned about if consecutive */
10446 if (lastub && s == lastub + 1)
10447 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10448 "Misplaced _ in number");
10452 /* 8 and 9 are not octal */
10453 case '8': case '9':
10455 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10459 case '2': case '3': case '4':
10460 case '5': case '6': case '7':
10462 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10465 case '0': case '1':
10466 b = *s++ & 15; /* ASCII digit -> value of digit */
10470 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10471 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10472 /* make sure they said 0x */
10475 b = (*s++ & 7) + 9;
10477 /* Prepare to put the digit we have onto the end
10478 of the number so far. We check for overflows.
10484 x = u << shift; /* make room for the digit */
10486 if ((x >> shift) != u
10487 && !(PL_hints & HINT_NEW_BINARY)) {
10490 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10491 "Integer overflow in %s number",
10494 u = x | b; /* add the digit to the end */
10497 n *= nvshift[shift];
10498 /* If an NV has not enough bits in its
10499 * mantissa to represent an UV this summing of
10500 * small low-order numbers is a waste of time
10501 * (because the NV cannot preserve the
10502 * low-order bits anyway): we could just
10503 * remember when did we overflow and in the
10504 * end just multiply n by the right
10512 /* if we get here, we had success: make a scalar value from
10517 /* final misplaced underbar check */
10518 if (s[-1] == '_') {
10519 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10523 if (n > 4294967295.0)
10524 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10525 "%s number > %s non-portable",
10531 if (u > 0xffffffff)
10532 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10533 "%s number > %s non-portable",
10538 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10539 sv = new_constant(start, s - start, "integer",
10540 sv, NULL, NULL, 0);
10541 else if (PL_hints & HINT_NEW_BINARY)
10542 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10547 handle decimal numbers.
10548 we're also sent here when we read a 0 as the first digit
10550 case '1': case '2': case '3': case '4': case '5':
10551 case '6': case '7': case '8': case '9': case '.':
10554 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10557 /* read next group of digits and _ and copy into d */
10558 while (isDIGIT(*s) || *s == '_') {
10559 /* skip underscores, checking for misplaced ones
10563 if (lastub && s == lastub + 1)
10564 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10565 "Misplaced _ in number");
10569 /* check for end of fixed-length buffer */
10571 Perl_croak(aTHX_ number_too_long);
10572 /* if we're ok, copy the character */
10577 /* final misplaced underbar check */
10578 if (lastub && s == lastub + 1) {
10579 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10582 /* read a decimal portion if there is one. avoid
10583 3..5 being interpreted as the number 3. followed
10586 if (*s == '.' && s[1] != '.') {
10591 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10592 "Misplaced _ in number");
10596 /* copy, ignoring underbars, until we run out of digits.
10598 for (; isDIGIT(*s) || *s == '_'; s++) {
10599 /* fixed length buffer check */
10601 Perl_croak(aTHX_ number_too_long);
10603 if (lastub && s == lastub + 1)
10604 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10605 "Misplaced _ in number");
10611 /* fractional part ending in underbar? */
10612 if (s[-1] == '_') {
10613 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10614 "Misplaced _ in number");
10616 if (*s == '.' && isDIGIT(s[1])) {
10617 /* oops, it's really a v-string, but without the "v" */
10623 /* read exponent part, if present */
10624 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10628 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10629 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10631 /* stray preinitial _ */
10633 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10634 "Misplaced _ in number");
10638 /* allow positive or negative exponent */
10639 if (*s == '+' || *s == '-')
10642 /* stray initial _ */
10644 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10645 "Misplaced _ in number");
10649 /* read digits of exponent */
10650 while (isDIGIT(*s) || *s == '_') {
10653 Perl_croak(aTHX_ number_too_long);
10657 if (((lastub && s == lastub + 1) ||
10658 (!isDIGIT(s[1]) && s[1] != '_')))
10659 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10660 "Misplaced _ in number");
10668 We try to do an integer conversion first if no characters
10669 indicating "float" have been found.
10674 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10676 if (flags == IS_NUMBER_IN_UV) {
10678 sv = newSViv(uv); /* Prefer IVs over UVs. */
10681 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10682 if (uv <= (UV) IV_MIN)
10683 sv = newSViv(-(IV)uv);
10690 /* terminate the string */
10692 nv = Atof(PL_tokenbuf);
10697 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10698 const char *const key = floatit ? "float" : "integer";
10699 const STRLEN keylen = floatit ? 5 : 7;
10700 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10701 key, keylen, sv, NULL, NULL, 0);
10705 /* if it starts with a v, it could be a v-string */
10708 sv = newSV(5); /* preallocate storage space */
10709 s = scan_vstring(s, PL_bufend, sv);
10713 /* make the op for the constant and return */
10716 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10718 lvalp->opval = NULL;
10724 S_scan_formline(pTHX_ register char *s)
10729 SV * const stuff = newSVpvs("");
10730 bool needargs = FALSE;
10731 bool eofmt = FALSE;
10733 char *tokenstart = s;
10734 SV* savewhite = NULL;
10736 if (PL_madskills) {
10737 savewhite = PL_thiswhite;
10742 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10744 while (!needargs) {
10747 #ifdef PERL_STRICT_CR
10748 while (SPACE_OR_TAB(*t))
10751 while (SPACE_OR_TAB(*t) || *t == '\r')
10754 if (*t == '\n' || t == PL_bufend) {
10759 eol = (char *) memchr(s,'\n',PL_bufend-s);
10763 for (t = s; t < eol; t++) {
10764 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10766 goto enough; /* ~~ must be first line in formline */
10768 if (*t == '@' || *t == '^')
10772 sv_catpvn(stuff, s, eol-s);
10773 #ifndef PERL_STRICT_CR
10774 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10775 char *end = SvPVX(stuff) + SvCUR(stuff);
10778 SvCUR_set(stuff, SvCUR(stuff) - 1);
10786 if ((PL_rsfp || PL_parser->filtered)
10787 && PL_parser->form_lex_state == LEX_NORMAL) {
10790 if (PL_madskills) {
10792 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
10794 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
10797 PL_bufptr = PL_bufend;
10798 COPLINE_INC_WITH_HERELINES;
10799 got_some = lex_next_chunk(0);
10800 CopLINE_dec(PL_curcop);
10803 tokenstart = PL_bufptr;
10811 if (!SvCUR(stuff) || needargs)
10812 PL_lex_state = PL_parser->form_lex_state;
10813 if (SvCUR(stuff)) {
10814 PL_expect = XSTATE;
10816 start_force(PL_curforce);
10817 NEXTVAL_NEXTTOKE.ival = 0;
10818 force_next(FORMLBRACK);
10821 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10823 else if (PL_encoding)
10824 sv_recode_to_utf8(stuff, PL_encoding);
10826 start_force(PL_curforce);
10827 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10831 SvREFCNT_dec(stuff);
10833 PL_lex_formbrack = 0;
10836 if (PL_madskills) {
10838 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
10840 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
10841 PL_thiswhite = savewhite;
10848 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10851 const I32 oldsavestack_ix = PL_savestack_ix;
10852 CV* const outsidecv = PL_compcv;
10854 SAVEI32(PL_subline);
10855 save_item(PL_subname);
10856 SAVESPTR(PL_compcv);
10858 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10859 CvFLAGS(PL_compcv) |= flags;
10861 PL_subline = CopLINE(PL_curcop);
10862 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10863 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10864 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10865 if (outsidecv && CvPADLIST(outsidecv))
10866 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
10868 return oldsavestack_ix;
10872 #pragma segment Perl_yylex
10875 S_yywarn(pTHX_ const char *const s, U32 flags)
10879 PERL_ARGS_ASSERT_YYWARN;
10881 PL_in_eval |= EVAL_WARNONLY;
10882 yyerror_pv(s, flags);
10883 PL_in_eval &= ~EVAL_WARNONLY;
10888 Perl_yyerror(pTHX_ const char *const s)
10890 PERL_ARGS_ASSERT_YYERROR;
10891 return yyerror_pvn(s, strlen(s), 0);
10895 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
10897 PERL_ARGS_ASSERT_YYERROR_PV;
10898 return yyerror_pvn(s, strlen(s), flags);
10902 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
10905 const char *context = NULL;
10908 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
10909 int yychar = PL_parser->yychar;
10910 U32 is_utf8 = flags & SVf_UTF8;
10912 PERL_ARGS_ASSERT_YYERROR_PVN;
10914 if (!yychar || (yychar == ';' && !PL_rsfp))
10915 sv_catpvs(where_sv, "at EOF");
10916 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10917 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10918 PL_oldbufptr != PL_bufptr) {
10921 The code below is removed for NetWare because it abends/crashes on NetWare
10922 when the script has error such as not having the closing quotes like:
10923 if ($var eq "value)
10924 Checking of white spaces is anyway done in NetWare code.
10927 while (isSPACE(*PL_oldoldbufptr))
10930 context = PL_oldoldbufptr;
10931 contlen = PL_bufptr - PL_oldoldbufptr;
10933 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10934 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10937 The code below is removed for NetWare because it abends/crashes on NetWare
10938 when the script has error such as not having the closing quotes like:
10939 if ($var eq "value)
10940 Checking of white spaces is anyway done in NetWare code.
10943 while (isSPACE(*PL_oldbufptr))
10946 context = PL_oldbufptr;
10947 contlen = PL_bufptr - PL_oldbufptr;
10949 else if (yychar > 255)
10950 sv_catpvs(where_sv, "next token ???");
10951 else if (yychar == -2) { /* YYEMPTY */
10952 if (PL_lex_state == LEX_NORMAL ||
10953 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10954 sv_catpvs(where_sv, "at end of line");
10955 else if (PL_lex_inpat)
10956 sv_catpvs(where_sv, "within pattern");
10958 sv_catpvs(where_sv, "within string");
10961 sv_catpvs(where_sv, "next char ");
10963 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10964 else if (isPRINT_LC(yychar)) {
10965 const char string = yychar;
10966 sv_catpvn(where_sv, &string, 1);
10969 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10971 msg = sv_2mortal(newSVpvn_flags(s, len, is_utf8));
10972 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10973 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10975 Perl_sv_catpvf(aTHX_ msg, "near \"%"SVf"\"\n",
10976 SVfARG(newSVpvn_flags(context, contlen,
10977 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
10979 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
10980 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10981 Perl_sv_catpvf(aTHX_ msg,
10982 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10983 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10986 if (PL_in_eval & EVAL_WARNONLY) {
10987 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10991 if (PL_error_count >= 10) {
10992 if (PL_in_eval && SvCUR(ERRSV))
10993 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10994 SVfARG(ERRSV), OutCopFILE(PL_curcop));
10996 Perl_croak(aTHX_ "%s has too many errors.\n",
10997 OutCopFILE(PL_curcop));
11000 PL_in_my_stash = NULL;
11004 #pragma segment Main
11008 S_swallow_bom(pTHX_ U8 *s)
11011 const STRLEN slen = SvCUR(PL_linestr);
11013 PERL_ARGS_ASSERT_SWALLOW_BOM;
11017 if (s[1] == 0xFE) {
11018 /* UTF-16 little-endian? (or UTF-32LE?) */
11019 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11020 /* diag_listed_as: Unsupported script encoding %s */
11021 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11022 #ifndef PERL_NO_UTF16_FILTER
11023 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11025 if (PL_bufend > (char*)s) {
11026 s = add_utf16_textfilter(s, TRUE);
11029 /* diag_listed_as: Unsupported script encoding %s */
11030 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11035 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11036 #ifndef PERL_NO_UTF16_FILTER
11037 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11039 if (PL_bufend > (char *)s) {
11040 s = add_utf16_textfilter(s, FALSE);
11043 /* diag_listed_as: Unsupported script encoding %s */
11044 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11049 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11050 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11051 s += 3; /* UTF-8 */
11057 if (s[2] == 0xFE && s[3] == 0xFF) {
11058 /* UTF-32 big-endian */
11059 /* diag_listed_as: Unsupported script encoding %s */
11060 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11063 else if (s[2] == 0 && s[3] != 0) {
11066 * are a good indicator of UTF-16BE. */
11067 #ifndef PERL_NO_UTF16_FILTER
11068 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11069 s = add_utf16_textfilter(s, FALSE);
11071 /* diag_listed_as: Unsupported script encoding %s */
11072 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11078 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
11079 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11080 s += 4; /* UTF-8 */
11086 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11089 * are a good indicator of UTF-16LE. */
11090 #ifndef PERL_NO_UTF16_FILTER
11091 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11092 s = add_utf16_textfilter(s, TRUE);
11094 /* diag_listed_as: Unsupported script encoding %s */
11095 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11103 #ifndef PERL_NO_UTF16_FILTER
11105 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11108 SV *const filter = FILTER_DATA(idx);
11109 /* We re-use this each time round, throwing the contents away before we
11111 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11112 SV *const utf8_buffer = filter;
11113 IV status = IoPAGE(filter);
11114 const bool reverse = cBOOL(IoLINES(filter));
11117 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11119 /* As we're automatically added, at the lowest level, and hence only called
11120 from this file, we can be sure that we're not called in block mode. Hence
11121 don't bother writing code to deal with block mode. */
11123 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11126 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11128 DEBUG_P(PerlIO_printf(Perl_debug_log,
11129 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11130 FPTR2DPTR(void *, S_utf16_textfilter),
11131 reverse ? 'l' : 'b', idx, maxlen, status,
11132 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11139 /* First, look in our buffer of existing UTF-8 data: */
11140 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11144 } else if (status == 0) {
11146 IoPAGE(filter) = 0;
11147 nl = SvEND(utf8_buffer);
11150 STRLEN got = nl - SvPVX(utf8_buffer);
11151 /* Did we have anything to append? */
11153 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11154 /* Everything else in this code works just fine if SVp_POK isn't
11155 set. This, however, needs it, and we need it to work, else
11156 we loop infinitely because the buffer is never consumed. */
11157 sv_chop(utf8_buffer, nl);
11161 /* OK, not a complete line there, so need to read some more UTF-16.
11162 Read an extra octect if the buffer currently has an odd number. */
11166 if (SvCUR(utf16_buffer) >= 2) {
11167 /* Location of the high octet of the last complete code point.
11168 Gosh, UTF-16 is a pain. All the benefits of variable length,
11169 *coupled* with all the benefits of partial reads and
11171 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11172 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11174 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11178 /* We have the first half of a surrogate. Read more. */
11179 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11182 status = FILTER_READ(idx + 1, utf16_buffer,
11183 160 + (SvCUR(utf16_buffer) & 1));
11184 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11185 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11188 IoPAGE(filter) = status;
11193 chars = SvCUR(utf16_buffer) >> 1;
11194 have = SvCUR(utf8_buffer);
11195 SvGROW(utf8_buffer, have + chars * 3 + 1);
11198 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11199 (U8*)SvPVX_const(utf8_buffer) + have,
11200 chars * 2, &newlen);
11202 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11203 (U8*)SvPVX_const(utf8_buffer) + have,
11204 chars * 2, &newlen);
11206 SvCUR_set(utf8_buffer, have + newlen);
11209 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11210 it's private to us, and utf16_to_utf8{,reversed} take a
11211 (pointer,length) pair, rather than a NUL-terminated string. */
11212 if(SvCUR(utf16_buffer) & 1) {
11213 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11214 SvCUR_set(utf16_buffer, 1);
11216 SvCUR_set(utf16_buffer, 0);
11219 DEBUG_P(PerlIO_printf(Perl_debug_log,
11220 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11222 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11223 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11228 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11230 SV *filter = filter_add(S_utf16_textfilter, NULL);
11232 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11234 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11235 sv_setpvs(filter, "");
11236 IoLINES(filter) = reversed;
11237 IoPAGE(filter) = 1; /* Not EOF */
11239 /* Sadly, we have to return a valid pointer, come what may, so we have to
11240 ignore any error return from this. */
11241 SvCUR_set(PL_linestr, 0);
11242 if (FILTER_READ(0, PL_linestr, 0)) {
11243 SvUTF8_on(PL_linestr);
11245 SvUTF8_on(PL_linestr);
11247 PL_bufend = SvEND(PL_linestr);
11248 return (U8*)SvPVX(PL_linestr);
11253 Returns a pointer to the next character after the parsed
11254 vstring, as well as updating the passed in sv.
11256 Function must be called like
11259 s = scan_vstring(s,e,sv);
11261 where s and e are the start and end of the string.
11262 The sv should already be large enough to store the vstring
11263 passed in, for performance reasons.
11268 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11271 const char *pos = s;
11272 const char *start = s;
11274 PERL_ARGS_ASSERT_SCAN_VSTRING;
11276 if (*pos == 'v') pos++; /* get past 'v' */
11277 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11279 if ( *pos != '.') {
11280 /* this may not be a v-string if followed by => */
11281 const char *next = pos;
11282 while (next < e && isSPACE(*next))
11284 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11285 /* return string not v-string */
11286 sv_setpvn(sv,(char *)s,pos-s);
11287 return (char *)pos;
11291 if (!isALPHA(*pos)) {
11292 U8 tmpbuf[UTF8_MAXBYTES+1];
11295 s++; /* get past 'v' */
11300 /* this is atoi() that tolerates underscores */
11303 const char *end = pos;
11305 while (--end >= s) {
11307 const UV orev = rev;
11308 rev += (*end - '0') * mult;
11311 /* diag_listed_as: Integer overflow in %s number */
11312 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11313 "Integer overflow in decimal number");
11317 if (rev > 0x7FFFFFFF)
11318 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11320 /* Append native character for the rev point */
11321 tmpend = uvchr_to_utf8(tmpbuf, rev);
11322 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11323 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11325 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11331 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11335 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11342 Perl_keyword_plugin_standard(pTHX_
11343 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11345 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11346 PERL_UNUSED_CONTEXT;
11347 PERL_UNUSED_ARG(keyword_ptr);
11348 PERL_UNUSED_ARG(keyword_len);
11349 PERL_UNUSED_ARG(op_ptr);
11350 return KEYWORD_PLUGIN_DECLINE;
11353 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11355 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11357 SAVEI32(PL_lex_brackets);
11358 if (PL_lex_brackets > 100)
11359 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11360 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11361 SAVEI32(PL_lex_allbrackets);
11362 PL_lex_allbrackets = 0;
11363 SAVEI8(PL_lex_fakeeof);
11364 PL_lex_fakeeof = (U8)fakeeof;
11365 if(yyparse(gramtype) && !PL_parser->error_count)
11366 qerror(Perl_mess(aTHX_ "Parse error"));
11369 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11371 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11375 SAVEVPTR(PL_eval_root);
11376 PL_eval_root = NULL;
11377 parse_recdescent(gramtype, fakeeof);
11383 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11385 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11388 if (flags & ~PARSE_OPTIONAL)
11389 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11390 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11391 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11392 if (!PL_parser->error_count)
11393 qerror(Perl_mess(aTHX_ "Parse error"));
11394 exprop = newOP(OP_NULL, 0);
11400 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11402 Parse a Perl arithmetic expression. This may contain operators of precedence
11403 down to the bit shift operators. The expression must be followed (and thus
11404 terminated) either by a comparison or lower-precedence operator or by
11405 something that would normally terminate an expression such as semicolon.
11406 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11407 otherwise it is mandatory. It is up to the caller to ensure that the
11408 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11409 the source of the code to be parsed and the lexical context for the
11412 The op tree representing the expression is returned. If an optional
11413 expression is absent, a null pointer is returned, otherwise the pointer
11416 If an error occurs in parsing or compilation, in most cases a valid op
11417 tree is returned anyway. The error is reflected in the parser state,
11418 normally resulting in a single exception at the top level of parsing
11419 which covers all the compilation errors that occurred. Some compilation
11420 errors, however, will throw an exception immediately.
11426 Perl_parse_arithexpr(pTHX_ U32 flags)
11428 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11432 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11434 Parse a Perl term expression. This may contain operators of precedence
11435 down to the assignment operators. The expression must be followed (and thus
11436 terminated) either by a comma or lower-precedence operator or by
11437 something that would normally terminate an expression such as semicolon.
11438 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11439 otherwise it is mandatory. It is up to the caller to ensure that the
11440 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11441 the source of the code to be parsed and the lexical context for the
11444 The op tree representing the expression is returned. If an optional
11445 expression is absent, a null pointer is returned, otherwise the pointer
11448 If an error occurs in parsing or compilation, in most cases a valid op
11449 tree is returned anyway. The error is reflected in the parser state,
11450 normally resulting in a single exception at the top level of parsing
11451 which covers all the compilation errors that occurred. Some compilation
11452 errors, however, will throw an exception immediately.
11458 Perl_parse_termexpr(pTHX_ U32 flags)
11460 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11464 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11466 Parse a Perl list expression. This may contain operators of precedence
11467 down to the comma operator. The expression must be followed (and thus
11468 terminated) either by a low-precedence logic operator such as C<or> or by
11469 something that would normally terminate an expression such as semicolon.
11470 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11471 otherwise it is mandatory. It is up to the caller to ensure that the
11472 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11473 the source of the code to be parsed and the lexical context for the
11476 The op tree representing the expression is returned. If an optional
11477 expression is absent, a null pointer is returned, otherwise the pointer
11480 If an error occurs in parsing or compilation, in most cases a valid op
11481 tree is returned anyway. The error is reflected in the parser state,
11482 normally resulting in a single exception at the top level of parsing
11483 which covers all the compilation errors that occurred. Some compilation
11484 errors, however, will throw an exception immediately.
11490 Perl_parse_listexpr(pTHX_ U32 flags)
11492 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11496 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11498 Parse a single complete Perl expression. This allows the full
11499 expression grammar, including the lowest-precedence operators such
11500 as C<or>. The expression must be followed (and thus terminated) by a
11501 token that an expression would normally be terminated by: end-of-file,
11502 closing bracketing punctuation, semicolon, or one of the keywords that
11503 signals a postfix expression-statement modifier. If I<flags> includes
11504 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11505 mandatory. It is up to the caller to ensure that the dynamic parser
11506 state (L</PL_parser> et al) is correctly set to reflect the source of
11507 the code to be parsed and the lexical context for the expression.
11509 The op tree representing the expression is returned. If an optional
11510 expression is absent, a null pointer is returned, otherwise the pointer
11513 If an error occurs in parsing or compilation, in most cases a valid op
11514 tree is returned anyway. The error is reflected in the parser state,
11515 normally resulting in a single exception at the top level of parsing
11516 which covers all the compilation errors that occurred. Some compilation
11517 errors, however, will throw an exception immediately.
11523 Perl_parse_fullexpr(pTHX_ U32 flags)
11525 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11529 =for apidoc Amx|OP *|parse_block|U32 flags
11531 Parse a single complete Perl code block. This consists of an opening
11532 brace, a sequence of statements, and a closing brace. The block
11533 constitutes a lexical scope, so C<my> variables and various compile-time
11534 effects can be contained within it. It is up to the caller to ensure
11535 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11536 reflect the source of the code to be parsed and the lexical context for
11539 The op tree representing the code block is returned. This is always a
11540 real op, never a null pointer. It will normally be a C<lineseq> list,
11541 including C<nextstate> or equivalent ops. No ops to construct any kind
11542 of runtime scope are included by virtue of it being a block.
11544 If an error occurs in parsing or compilation, in most cases a valid op
11545 tree (most likely null) is returned anyway. The error is reflected in
11546 the parser state, normally resulting in a single exception at the top
11547 level of parsing which covers all the compilation errors that occurred.
11548 Some compilation errors, however, will throw an exception immediately.
11550 The I<flags> parameter is reserved for future use, and must always
11557 Perl_parse_block(pTHX_ U32 flags)
11560 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11561 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11565 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11567 Parse a single unadorned Perl statement. This may be a normal imperative
11568 statement or a declaration that has compile-time effect. It does not
11569 include any label or other affixture. It is up to the caller to ensure
11570 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11571 reflect the source of the code to be parsed and the lexical context for
11574 The op tree representing the statement is returned. This may be a
11575 null pointer if the statement is null, for example if it was actually
11576 a subroutine definition (which has compile-time side effects). If not
11577 null, it will be ops directly implementing the statement, suitable to
11578 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11579 equivalent op (except for those embedded in a scope contained entirely
11580 within the statement).
11582 If an error occurs in parsing or compilation, in most cases a valid op
11583 tree (most likely null) is returned anyway. The error is reflected in
11584 the parser state, normally resulting in a single exception at the top
11585 level of parsing which covers all the compilation errors that occurred.
11586 Some compilation errors, however, will throw an exception immediately.
11588 The I<flags> parameter is reserved for future use, and must always
11595 Perl_parse_barestmt(pTHX_ U32 flags)
11598 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11599 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11603 =for apidoc Amx|SV *|parse_label|U32 flags
11605 Parse a single label, possibly optional, of the type that may prefix a
11606 Perl statement. It is up to the caller to ensure that the dynamic parser
11607 state (L</PL_parser> et al) is correctly set to reflect the source of
11608 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11609 label is optional, otherwise it is mandatory.
11611 The name of the label is returned in the form of a fresh scalar. If an
11612 optional label is absent, a null pointer is returned.
11614 If an error occurs in parsing, which can only occur if the label is
11615 mandatory, a valid label is returned anyway. The error is reflected in
11616 the parser state, normally resulting in a single exception at the top
11617 level of parsing which covers all the compilation errors that occurred.
11623 Perl_parse_label(pTHX_ U32 flags)
11625 if (flags & ~PARSE_OPTIONAL)
11626 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11627 if (PL_lex_state == LEX_KNOWNEXT) {
11628 PL_parser->yychar = yylex();
11629 if (PL_parser->yychar == LABEL) {
11631 PL_parser->yychar = YYEMPTY;
11632 lsv = newSV_type(SVt_PV);
11633 sv_copypv(lsv, cSVOPx(pl_yylval.opval)->op_sv);
11641 STRLEN wlen, bufptr_pos;
11644 if (!isIDFIRST_lazy_if(s, UTF))
11646 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
11647 if (word_takes_any_delimeter(s, wlen))
11649 bufptr_pos = s - SvPVX(PL_linestr);
11651 lex_read_space(LEX_KEEP_PREVIOUS);
11653 s = SvPVX(PL_linestr) + bufptr_pos;
11654 if (t[0] == ':' && t[1] != ':') {
11655 PL_oldoldbufptr = PL_oldbufptr;
11658 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
11662 if (flags & PARSE_OPTIONAL) {
11665 qerror(Perl_mess(aTHX_ "Parse error"));
11666 return newSVpvs("x");
11673 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11675 Parse a single complete Perl statement. This may be a normal imperative
11676 statement or a declaration that has compile-time effect, and may include
11677 optional labels. It is up to the caller to ensure that the dynamic
11678 parser state (L</PL_parser> et al) is correctly set to reflect the source
11679 of the code to be parsed and the lexical context for the statement.
11681 The op tree representing the statement is returned. This may be a
11682 null pointer if the statement is null, for example if it was actually
11683 a subroutine definition (which has compile-time side effects). If not
11684 null, it will be the result of a L</newSTATEOP> call, normally including
11685 a C<nextstate> or equivalent op.
11687 If an error occurs in parsing or compilation, in most cases a valid op
11688 tree (most likely null) is returned anyway. The error is reflected in
11689 the parser state, normally resulting in a single exception at the top
11690 level of parsing which covers all the compilation errors that occurred.
11691 Some compilation errors, however, will throw an exception immediately.
11693 The I<flags> parameter is reserved for future use, and must always
11700 Perl_parse_fullstmt(pTHX_ U32 flags)
11703 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11704 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11708 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11710 Parse a sequence of zero or more Perl statements. These may be normal
11711 imperative statements, including optional labels, or declarations
11712 that have compile-time effect, or any mixture thereof. The statement
11713 sequence ends when a closing brace or end-of-file is encountered in a
11714 place where a new statement could have validly started. It is up to
11715 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11716 is correctly set to reflect the source of the code to be parsed and the
11717 lexical context for the statements.
11719 The op tree representing the statement sequence is returned. This may
11720 be a null pointer if the statements were all null, for example if there
11721 were no statements or if there were only subroutine definitions (which
11722 have compile-time side effects). If not null, it will be a C<lineseq>
11723 list, normally including C<nextstate> or equivalent ops.
11725 If an error occurs in parsing or compilation, in most cases a valid op
11726 tree is returned anyway. The error is reflected in the parser state,
11727 normally resulting in a single exception at the top level of parsing
11728 which covers all the compilation errors that occurred. Some compilation
11729 errors, however, will throw an exception immediately.
11731 The I<flags> parameter is reserved for future use, and must always
11738 Perl_parse_stmtseq(pTHX_ U32 flags)
11743 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11744 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11745 c = lex_peek_unichar(0);
11746 if (c != -1 && c != /*{*/'}')
11747 qerror(Perl_mess(aTHX_ "Parse error"));
11753 * c-indentation-style: bsd
11754 * c-basic-offset: 4
11755 * indent-tabs-mode: nil
11758 * ex: set ts=8 sts=4 sw=4 et: