3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
27 This is the lower layer of the Perl parser, managing characters and tokens.
29 =for apidoc AmU|yy_parser *|PL_parser
31 Pointer to a structure encapsulating the state of the parsing operation
32 currently in progress. The pointer can be locally changed to perform
33 a nested parse without interfering with the state of an outer parse.
34 Individual members of C<PL_parser> have their own documentation.
40 #define PERL_IN_TOKE_C
42 #include "dquote_static.c"
44 #define new_constant(a,b,c,d,e,f,g) \
45 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
47 #define pl_yylval (PL_parser->yylval)
49 /* XXX temporary backwards compatibility */
50 #define PL_lex_brackets (PL_parser->lex_brackets)
51 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
52 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
53 #define PL_lex_brackstack (PL_parser->lex_brackstack)
54 #define PL_lex_casemods (PL_parser->lex_casemods)
55 #define PL_lex_casestack (PL_parser->lex_casestack)
56 #define PL_lex_defer (PL_parser->lex_defer)
57 #define PL_lex_dojoin (PL_parser->lex_dojoin)
58 #define PL_lex_expect (PL_parser->lex_expect)
59 #define PL_lex_formbrack (PL_parser->lex_formbrack)
60 #define PL_lex_inpat (PL_parser->lex_inpat)
61 #define PL_lex_inwhat (PL_parser->lex_inwhat)
62 #define PL_lex_op (PL_parser->lex_op)
63 #define PL_lex_repl (PL_parser->lex_repl)
64 #define PL_lex_starts (PL_parser->lex_starts)
65 #define PL_lex_stuff (PL_parser->lex_stuff)
66 #define PL_multi_start (PL_parser->multi_start)
67 #define PL_multi_open (PL_parser->multi_open)
68 #define PL_multi_close (PL_parser->multi_close)
69 #define PL_preambled (PL_parser->preambled)
70 #define PL_sublex_info (PL_parser->sublex_info)
71 #define PL_linestr (PL_parser->linestr)
72 #define PL_expect (PL_parser->expect)
73 #define PL_copline (PL_parser->copline)
74 #define PL_bufptr (PL_parser->bufptr)
75 #define PL_oldbufptr (PL_parser->oldbufptr)
76 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
77 #define PL_linestart (PL_parser->linestart)
78 #define PL_bufend (PL_parser->bufend)
79 #define PL_last_uni (PL_parser->last_uni)
80 #define PL_last_lop (PL_parser->last_lop)
81 #define PL_last_lop_op (PL_parser->last_lop_op)
82 #define PL_lex_state (PL_parser->lex_state)
83 #define PL_rsfp (PL_parser->rsfp)
84 #define PL_rsfp_filters (PL_parser->rsfp_filters)
85 #define PL_in_my (PL_parser->in_my)
86 #define PL_in_my_stash (PL_parser->in_my_stash)
87 #define PL_tokenbuf (PL_parser->tokenbuf)
88 #define PL_multi_end (PL_parser->multi_end)
89 #define PL_error_count (PL_parser->error_count)
92 # define PL_endwhite (PL_parser->endwhite)
93 # define PL_faketokens (PL_parser->faketokens)
94 # define PL_lasttoke (PL_parser->lasttoke)
95 # define PL_nextwhite (PL_parser->nextwhite)
96 # define PL_realtokenstart (PL_parser->realtokenstart)
97 # define PL_skipwhite (PL_parser->skipwhite)
98 # define PL_thisclose (PL_parser->thisclose)
99 # define PL_thismad (PL_parser->thismad)
100 # define PL_thisopen (PL_parser->thisopen)
101 # define PL_thisstuff (PL_parser->thisstuff)
102 # define PL_thistoken (PL_parser->thistoken)
103 # define PL_thiswhite (PL_parser->thiswhite)
104 # define PL_thiswhite (PL_parser->thiswhite)
105 # define PL_nexttoke (PL_parser->nexttoke)
106 # define PL_curforce (PL_parser->curforce)
108 # define PL_nexttoke (PL_parser->nexttoke)
109 # define PL_nexttype (PL_parser->nexttype)
110 # define PL_nextval (PL_parser->nextval)
113 static const char* const ident_too_long = "Identifier too long";
116 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
117 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
119 # define CURMAD(slot,sv)
120 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
123 #define XENUMMASK 0x3f
124 #define XFAKEEOF 0x40
125 #define XFAKEBRACK 0x80
127 #ifdef USE_UTF8_SCRIPTS
128 # define UTF (!IN_BYTES)
130 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
133 /* The maximum number of characters preceding the unrecognized one to display */
134 #define UNRECOGNIZED_PRECEDE_COUNT 10
136 /* In variables named $^X, these are the legal values for X.
137 * 1999-02-27 mjd-perl-patch@plover.com */
138 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
140 #define SPACE_OR_TAB(c) isBLANK_A(c)
142 /* LEX_* are values for PL_lex_state, the state of the lexer.
143 * They are arranged oddly so that the guard on the switch statement
144 * can get by with a single comparison (if the compiler is smart enough).
146 * These values refer to the various states within a sublex parse,
147 * i.e. within a double quotish string
150 /* #define LEX_NOTPARSING 11 is done in perl.h. */
152 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
153 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
154 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
155 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
156 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
158 /* at end of code, eg "$x" followed by: */
159 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
160 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
162 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
163 string or after \E, $foo, etc */
164 #define LEX_INTERPCONST 2 /* NOT USED */
165 #define LEX_FORMLINE 1 /* expecting a format line */
166 #define LEX_KNOWNEXT 0 /* next token known; just return it */
170 static const char* const lex_state_names[] = {
189 #include "keywords.h"
191 /* CLINE is a macro that ensures PL_copline has a sane value */
196 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
199 # define SKIPSPACE0(s) skipspace0(s)
200 # define SKIPSPACE1(s) skipspace1(s)
201 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
202 # define PEEKSPACE(s) skipspace2(s,0)
204 # define SKIPSPACE0(s) skipspace(s)
205 # define SKIPSPACE1(s) skipspace(s)
206 # define SKIPSPACE2(s,tsv) skipspace(s)
207 # define PEEKSPACE(s) skipspace(s)
211 * Convenience functions to return different tokens and prime the
212 * lexer for the next token. They all take an argument.
214 * TOKEN : generic token (used for '(', DOLSHARP, etc)
215 * OPERATOR : generic operator
216 * AOPERATOR : assignment operator
217 * PREBLOCK : beginning the block after an if, while, foreach, ...
218 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
219 * PREREF : *EXPR where EXPR is not a simple identifier
220 * TERM : expression term
221 * LOOPX : loop exiting command (goto, last, dump, etc)
222 * FTST : file test operator
223 * FUN0 : zero-argument function
224 * FUN0OP : zero-argument function, with its op created in this file
225 * FUN1 : not used, except for not, which isn't a UNIOP
226 * BOop : bitwise or or xor
228 * SHop : shift operator
229 * PWop : power operator
230 * PMop : pattern-matching operator
231 * Aop : addition-level operator
232 * Mop : multiplication-level operator
233 * Eop : equality-testing operator
234 * Rop : relational operator <= != gt
236 * Also see LOP and lop() below.
239 #ifdef DEBUGGING /* Serve -DT. */
240 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
242 # define REPORT(retval) (retval)
245 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
246 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
247 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
248 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
249 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
250 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
251 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
252 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
253 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
254 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
255 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
256 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
257 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
258 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
259 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
260 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
261 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
262 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
263 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
264 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
265 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
267 /* This bit of chicanery makes a unary function followed by
268 * a parenthesis into a function with one argument, highest precedence.
269 * The UNIDOR macro is for unary functions that can be followed by the //
270 * operator (such as C<shift // 0>).
272 #define UNI3(f,x,have_x) { \
273 pl_yylval.ival = f; \
274 if (have_x) PL_expect = x; \
276 PL_last_uni = PL_oldbufptr; \
277 PL_last_lop_op = f; \
279 return REPORT( (int)FUNC1 ); \
281 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
283 #define UNI(f) UNI3(f,XTERM,1)
284 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
285 #define UNIPROTO(f,optional) { \
286 if (optional) PL_last_uni = PL_oldbufptr; \
290 #define UNIBRACK(f) UNI3(f,0,0)
292 /* grandfather return to old style */
295 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
296 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
297 pl_yylval.ival = (f); \
303 #define COPLINE_INC_WITH_HERELINES \
305 CopLINE_inc(PL_curcop); \
306 if (PL_parser->lex_shared->herelines) \
307 CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \
308 PL_parser->lex_shared->herelines = 0; \
314 /* how to interpret the pl_yylval associated with the token */
318 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
323 static struct debug_tokens {
325 enum token_type type;
327 } const debug_tokens[] =
329 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
330 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
331 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
332 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
333 { ARROW, TOKENTYPE_NONE, "ARROW" },
334 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
335 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
336 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
337 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
338 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
339 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
340 { DO, TOKENTYPE_NONE, "DO" },
341 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
342 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
343 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
344 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
345 { ELSE, TOKENTYPE_NONE, "ELSE" },
346 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
347 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
348 { FOR, TOKENTYPE_IVAL, "FOR" },
349 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
350 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
351 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
352 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
353 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
354 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
355 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
356 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
357 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
358 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
359 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
360 { IF, TOKENTYPE_IVAL, "IF" },
361 { LABEL, TOKENTYPE_PVAL, "LABEL" },
362 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
363 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
364 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
365 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
366 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
367 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
368 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
369 { MY, TOKENTYPE_IVAL, "MY" },
370 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
371 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
372 { OROP, TOKENTYPE_IVAL, "OROP" },
373 { OROR, TOKENTYPE_NONE, "OROR" },
374 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
375 { PEG, TOKENTYPE_NONE, "PEG" },
376 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
377 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
378 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
379 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
380 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
381 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
382 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
383 { PREINC, TOKENTYPE_NONE, "PREINC" },
384 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
385 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
386 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
387 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
388 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
389 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
390 { SUB, TOKENTYPE_NONE, "SUB" },
391 { THING, TOKENTYPE_OPVAL, "THING" },
392 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
393 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
394 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
395 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
396 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
397 { USE, TOKENTYPE_IVAL, "USE" },
398 { WHEN, TOKENTYPE_IVAL, "WHEN" },
399 { WHILE, TOKENTYPE_IVAL, "WHILE" },
400 { WORD, TOKENTYPE_OPVAL, "WORD" },
401 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
402 { 0, TOKENTYPE_NONE, NULL }
405 /* dump the returned token in rv, plus any optional arg in pl_yylval */
408 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
412 PERL_ARGS_ASSERT_TOKEREPORT;
415 const char *name = NULL;
416 enum token_type type = TOKENTYPE_NONE;
417 const struct debug_tokens *p;
418 SV* const report = newSVpvs("<== ");
420 for (p = debug_tokens; p->token; p++) {
421 if (p->token == (int)rv) {
428 Perl_sv_catpv(aTHX_ report, name);
429 else if ((char)rv > ' ' && (char)rv <= '~')
431 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
433 sv_catpvs(report, " (pending identifier)");
436 sv_catpvs(report, "EOF");
438 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
443 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
445 case TOKENTYPE_OPNUM:
446 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
447 PL_op_name[lvalp->ival]);
450 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
452 case TOKENTYPE_OPVAL:
454 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
455 PL_op_name[lvalp->opval->op_type]);
456 if (lvalp->opval->op_type == OP_CONST) {
457 Perl_sv_catpvf(aTHX_ report, " %s",
458 SvPEEK(cSVOPx_sv(lvalp->opval)));
463 sv_catpvs(report, "(opval=null)");
466 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
472 /* print the buffer with suitable escapes */
475 S_printbuf(pTHX_ const char *const fmt, const char *const s)
477 SV* const tmp = newSVpvs("");
479 PERL_ARGS_ASSERT_PRINTBUF;
481 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
488 S_deprecate_commaless_var_list(pTHX) {
490 deprecate("comma-less variable list");
491 return REPORT(','); /* grandfather non-comma-format format */
497 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
498 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
502 S_ao(pTHX_ int toketype)
505 if (*PL_bufptr == '=') {
507 if (toketype == ANDAND)
508 pl_yylval.ival = OP_ANDASSIGN;
509 else if (toketype == OROR)
510 pl_yylval.ival = OP_ORASSIGN;
511 else if (toketype == DORDOR)
512 pl_yylval.ival = OP_DORASSIGN;
520 * When Perl expects an operator and finds something else, no_op
521 * prints the warning. It always prints "<something> found where
522 * operator expected. It prints "Missing semicolon on previous line?"
523 * if the surprise occurs at the start of the line. "do you need to
524 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
525 * where the compiler doesn't know if foo is a method call or a function.
526 * It prints "Missing operator before end of line" if there's nothing
527 * after the missing operator, or "... before <...>" if there is something
528 * after the missing operator.
532 S_no_op(pTHX_ const char *const what, char *s)
535 char * const oldbp = PL_bufptr;
536 const bool is_first = (PL_oldbufptr == PL_linestart);
538 PERL_ARGS_ASSERT_NO_OP;
544 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
545 if (ckWARN_d(WARN_SYNTAX)) {
547 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
548 "\t(Missing semicolon on previous line?)\n");
549 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
551 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
552 t += UTF ? UTF8SKIP(t) : 1)
554 if (t < PL_bufptr && isSPACE(*t))
555 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
556 "\t(Do you need to predeclare %"UTF8f"?)\n",
557 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
561 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
562 "\t(Missing operator before %"UTF8f"?)\n",
563 UTF8fARG(UTF, s - oldbp, oldbp));
571 * Complain about missing quote/regexp/heredoc terminator.
572 * If it's called with NULL then it cauterizes the line buffer.
573 * If we're in a delimited string and the delimiter is a control
574 * character, it's reformatted into a two-char sequence like ^C.
579 S_missingterm(pTHX_ char *s)
585 char * const nl = strrchr(s,'\n');
589 else if (isCNTRL(PL_multi_close)) {
591 tmpbuf[1] = (char)toCTRL(PL_multi_close);
596 *tmpbuf = (char)PL_multi_close;
600 q = strchr(s,'"') ? '\'' : '"';
601 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
607 * Check whether the named feature is enabled.
610 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
613 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
615 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
617 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
619 if (namelen > MAX_FEATURE_LEN)
621 memcpy(&he_name[8], name, namelen);
623 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
624 REFCOUNTED_HE_EXISTS));
628 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
629 * utf16-to-utf8-reversed.
632 #ifdef PERL_CR_FILTER
636 const char *s = SvPVX_const(sv);
637 const char * const e = s + SvCUR(sv);
639 PERL_ARGS_ASSERT_STRIP_RETURN;
641 /* outer loop optimized to do nothing if there are no CR-LFs */
643 if (*s++ == '\r' && *s == '\n') {
644 /* hit a CR-LF, need to copy the rest */
648 if (*s == '\r' && s[1] == '\n')
659 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
661 const I32 count = FILTER_READ(idx+1, sv, maxlen);
662 if (count > 0 && !maxlen)
669 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
671 Creates and initialises a new lexer/parser state object, supplying
672 a context in which to lex and parse from a new source of Perl code.
673 A pointer to the new state object is placed in L</PL_parser>. An entry
674 is made on the save stack so that upon unwinding the new state object
675 will be destroyed and the former value of L</PL_parser> will be restored.
676 Nothing else need be done to clean up the parsing context.
678 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
679 non-null, provides a string (in SV form) containing code to be parsed.
680 A copy of the string is made, so subsequent modification of I<line>
681 does not affect parsing. I<rsfp>, if non-null, provides an input stream
682 from which code will be read to be parsed. If both are non-null, the
683 code in I<line> comes first and must consist of complete lines of input,
684 and I<rsfp> supplies the remainder of the source.
686 The I<flags> parameter is reserved for future use. Currently it is only
687 used by perl internally, so extensions should always pass zero.
692 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
693 can share filters with the current parser.
694 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
695 caller, hence isn't owned by the parser, so shouldn't be closed on parser
696 destruction. This is used to handle the case of defaulting to reading the
697 script from the standard input because no filename was given on the command
698 line (without getting confused by situation where STDIN has been closed, so
699 the script handle is opened on fd 0) */
702 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
705 const char *s = NULL;
706 yy_parser *parser, *oparser;
707 if (flags && flags & ~LEX_START_FLAGS)
708 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
710 /* create and initialise a parser */
712 Newxz(parser, 1, yy_parser);
713 parser->old_parser = oparser = PL_parser;
716 parser->stack = NULL;
718 parser->stack_size = 0;
720 /* on scope exit, free this parser and restore any outer one */
722 parser->saved_curcop = PL_curcop;
724 /* initialise lexer state */
727 parser->curforce = -1;
729 parser->nexttoke = 0;
731 parser->error_count = oparser ? oparser->error_count : 0;
732 parser->copline = NOLINE;
733 parser->lex_state = LEX_NORMAL;
734 parser->expect = XSTATE;
736 parser->rsfp_filters =
737 !(flags & LEX_START_SAME_FILTER) || !oparser
739 : MUTABLE_AV(SvREFCNT_inc(
740 oparser->rsfp_filters
741 ? oparser->rsfp_filters
742 : (oparser->rsfp_filters = newAV())
745 Newx(parser->lex_brackstack, 120, char);
746 Newx(parser->lex_casestack, 12, char);
747 *parser->lex_casestack = '\0';
748 Newxz(parser->lex_shared, 1, LEXSHARED);
752 s = SvPV_const(line, len);
753 parser->linestr = flags & LEX_START_COPIED
754 ? SvREFCNT_inc_simple_NN(line)
755 : newSVpvn_flags(s, len, SvUTF8(line));
756 sv_catpvs(parser->linestr, "\n;");
758 parser->linestr = newSVpvs("\n;");
760 parser->oldoldbufptr =
763 parser->linestart = SvPVX(parser->linestr);
764 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
765 parser->last_lop = parser->last_uni = NULL;
766 parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
767 |LEX_DONT_CLOSE_RSFP);
769 parser->in_pod = parser->filtered = 0;
773 /* delete a parser object */
776 Perl_parser_free(pTHX_ const yy_parser *parser)
778 PERL_ARGS_ASSERT_PARSER_FREE;
780 PL_curcop = parser->saved_curcop;
781 SvREFCNT_dec(parser->linestr);
783 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
784 PerlIO_clearerr(parser->rsfp);
785 else if (parser->rsfp && (!parser->old_parser ||
786 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
787 PerlIO_close(parser->rsfp);
788 SvREFCNT_dec(parser->rsfp_filters);
789 SvREFCNT_dec(parser->lex_stuff);
790 SvREFCNT_dec(parser->sublex_info.repl);
792 Safefree(parser->lex_brackstack);
793 Safefree(parser->lex_casestack);
794 Safefree(parser->lex_shared);
795 PL_parser = parser->old_parser;
800 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
803 I32 nexttoke = parser->lasttoke;
805 I32 nexttoke = parser->nexttoke;
807 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
810 if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
812 && parser->nexttoke[nexttoke].next_val.opval
813 && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
814 && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
815 op_free(parser->nexttoke[nexttoke].next_val.opval);
816 parser->nexttoke[nexttoke].next_val.opval = NULL;
819 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
820 && parser->nextval[nexttoke].opval
821 && parser->nextval[nexttoke].opval->op_slabbed
822 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
823 op_free(parser->nextval[nexttoke].opval);
824 parser->nextval[nexttoke].opval = NULL;
832 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
834 Buffer scalar containing the chunk currently under consideration of the
835 text currently being lexed. This is always a plain string scalar (for
836 which C<SvPOK> is true). It is not intended to be used as a scalar by
837 normal scalar means; instead refer to the buffer directly by the pointer
838 variables described below.
840 The lexer maintains various C<char*> pointers to things in the
841 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
842 reallocated, all of these pointers must be updated. Don't attempt to
843 do this manually, but rather use L</lex_grow_linestr> if you need to
844 reallocate the buffer.
846 The content of the text chunk in the buffer is commonly exactly one
847 complete line of input, up to and including a newline terminator,
848 but there are situations where it is otherwise. The octets of the
849 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
850 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
851 flag on this scalar, which may disagree with it.
853 For direct examination of the buffer, the variable
854 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
855 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
856 of these pointers is usually preferable to examination of the scalar
857 through normal scalar means.
859 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
861 Direct pointer to the end of the chunk of text currently being lexed, the
862 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
863 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
864 always located at the end of the buffer, and does not count as part of
865 the buffer's contents.
867 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
869 Points to the current position of lexing inside the lexer buffer.
870 Characters around this point may be freely examined, within
871 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
872 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
873 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
875 Lexing code (whether in the Perl core or not) moves this pointer past
876 the characters that it consumes. It is also expected to perform some
877 bookkeeping whenever a newline character is consumed. This movement
878 can be more conveniently performed by the function L</lex_read_to>,
879 which handles newlines appropriately.
881 Interpretation of the buffer's octets can be abstracted out by
882 using the slightly higher-level functions L</lex_peek_unichar> and
883 L</lex_read_unichar>.
885 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
887 Points to the start of the current line inside the lexer buffer.
888 This is useful for indicating at which column an error occurred, and
889 not much else. This must be updated by any lexing code that consumes
890 a newline; the function L</lex_read_to> handles this detail.
896 =for apidoc Amx|bool|lex_bufutf8
898 Indicates whether the octets in the lexer buffer
899 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
900 of Unicode characters. If not, they should be interpreted as Latin-1
901 characters. This is analogous to the C<SvUTF8> flag for scalars.
903 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
904 contains valid UTF-8. Lexing code must be robust in the face of invalid
907 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
908 is significant, but not the whole story regarding the input character
909 encoding. Normally, when a file is being read, the scalar contains octets
910 and its C<SvUTF8> flag is off, but the octets should be interpreted as
911 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
912 however, the scalar may have the C<SvUTF8> flag on, and in this case its
913 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
914 is in effect. This logic may change in the future; use this function
915 instead of implementing the logic yourself.
921 Perl_lex_bufutf8(pTHX)
927 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
929 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
930 at least I<len> octets (including terminating NUL). Returns a
931 pointer to the reallocated buffer. This is necessary before making
932 any direct modification of the buffer that would increase its length.
933 L</lex_stuff_pvn> provides a more convenient way to insert text into
936 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
937 this function updates all of the lexer's variables that point directly
944 Perl_lex_grow_linestr(pTHX_ STRLEN len)
948 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
949 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
950 linestr = PL_parser->linestr;
951 buf = SvPVX(linestr);
952 if (len <= SvLEN(linestr))
954 bufend_pos = PL_parser->bufend - buf;
955 bufptr_pos = PL_parser->bufptr - buf;
956 oldbufptr_pos = PL_parser->oldbufptr - buf;
957 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
958 linestart_pos = PL_parser->linestart - buf;
959 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
960 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
961 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
962 PL_parser->lex_shared->re_eval_start - buf : 0;
964 buf = sv_grow(linestr, len);
966 PL_parser->bufend = buf + bufend_pos;
967 PL_parser->bufptr = buf + bufptr_pos;
968 PL_parser->oldbufptr = buf + oldbufptr_pos;
969 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
970 PL_parser->linestart = buf + linestart_pos;
971 if (PL_parser->last_uni)
972 PL_parser->last_uni = buf + last_uni_pos;
973 if (PL_parser->last_lop)
974 PL_parser->last_lop = buf + last_lop_pos;
975 if (PL_parser->lex_shared->re_eval_start)
976 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
981 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
983 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
984 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
985 reallocating the buffer if necessary. This means that lexing code that
986 runs later will see the characters as if they had appeared in the input.
987 It is not recommended to do this as part of normal parsing, and most
988 uses of this facility run the risk of the inserted characters being
989 interpreted in an unintended manner.
991 The string to be inserted is represented by I<len> octets starting
992 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
993 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
994 The characters are recoded for the lexer buffer, according to how the
995 buffer is currently being interpreted (L</lex_bufutf8>). If a string
996 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
997 function is more convenient.
1003 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1007 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1008 if (flags & ~(LEX_STUFF_UTF8))
1009 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1011 if (flags & LEX_STUFF_UTF8) {
1014 STRLEN highhalf = 0; /* Count of variants */
1015 const char *p, *e = pv+len;
1016 for (p = pv; p != e; p++) {
1017 if (! UTF8_IS_INVARIANT(*p)) {
1023 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1024 bufptr = PL_parser->bufptr;
1025 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1026 SvCUR_set(PL_parser->linestr,
1027 SvCUR(PL_parser->linestr) + len+highhalf);
1028 PL_parser->bufend += len+highhalf;
1029 for (p = pv; p != e; p++) {
1031 if (! UTF8_IS_INVARIANT(c)) {
1032 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1033 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1035 *bufptr++ = (char)c;
1040 if (flags & LEX_STUFF_UTF8) {
1041 STRLEN highhalf = 0;
1042 const char *p, *e = pv+len;
1043 for (p = pv; p != e; p++) {
1045 if (UTF8_IS_ABOVE_LATIN1(c)) {
1046 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1047 "non-Latin-1 character into Latin-1 input");
1048 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1051 } else if (! UTF8_IS_INVARIANT(c)) {
1052 /* malformed UTF-8 */
1054 SAVESPTR(PL_warnhook);
1055 PL_warnhook = PERL_WARNHOOK_FATAL;
1056 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
1062 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1063 bufptr = PL_parser->bufptr;
1064 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1065 SvCUR_set(PL_parser->linestr,
1066 SvCUR(PL_parser->linestr) + len-highhalf);
1067 PL_parser->bufend += len-highhalf;
1070 if (UTF8_IS_INVARIANT(*p)) {
1076 *bufptr++ = TWO_BYTE_UTF8_TO_UNI(*p, *(p+1));
1082 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1083 bufptr = PL_parser->bufptr;
1084 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1085 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1086 PL_parser->bufend += len;
1087 Copy(pv, bufptr, len, char);
1093 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1095 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1096 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1097 reallocating the buffer if necessary. This means that lexing code that
1098 runs later will see the characters as if they had appeared in the input.
1099 It is not recommended to do this as part of normal parsing, and most
1100 uses of this facility run the risk of the inserted characters being
1101 interpreted in an unintended manner.
1103 The string to be inserted is represented by octets starting at I<pv>
1104 and continuing to the first nul. These octets are interpreted as either
1105 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1106 in I<flags>. The characters are recoded for the lexer buffer, according
1107 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1108 If it is not convenient to nul-terminate a string to be inserted, the
1109 L</lex_stuff_pvn> function is more appropriate.
1115 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1117 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1118 lex_stuff_pvn(pv, strlen(pv), flags);
1122 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1124 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1125 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1126 reallocating the buffer if necessary. This means that lexing code that
1127 runs later will see the characters as if they had appeared in the input.
1128 It is not recommended to do this as part of normal parsing, and most
1129 uses of this facility run the risk of the inserted characters being
1130 interpreted in an unintended manner.
1132 The string to be inserted is the string value of I<sv>. The characters
1133 are recoded for the lexer buffer, according to how the buffer is currently
1134 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1135 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1136 need to construct a scalar.
1142 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1146 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1148 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1150 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1154 =for apidoc Amx|void|lex_unstuff|char *ptr
1156 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1157 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1158 This hides the discarded text from any lexing code that runs later,
1159 as if the text had never appeared.
1161 This is not the normal way to consume lexed text. For that, use
1168 Perl_lex_unstuff(pTHX_ char *ptr)
1172 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1173 buf = PL_parser->bufptr;
1175 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1178 bufend = PL_parser->bufend;
1180 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1181 unstuff_len = ptr - buf;
1182 Move(ptr, buf, bufend+1-ptr, char);
1183 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1184 PL_parser->bufend = bufend - unstuff_len;
1188 =for apidoc Amx|void|lex_read_to|char *ptr
1190 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1191 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1192 performing the correct bookkeeping whenever a newline character is passed.
1193 This is the normal way to consume lexed text.
1195 Interpretation of the buffer's octets can be abstracted out by
1196 using the slightly higher-level functions L</lex_peek_unichar> and
1197 L</lex_read_unichar>.
1203 Perl_lex_read_to(pTHX_ char *ptr)
1206 PERL_ARGS_ASSERT_LEX_READ_TO;
1207 s = PL_parser->bufptr;
1208 if (ptr < s || ptr > PL_parser->bufend)
1209 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1210 for (; s != ptr; s++)
1212 COPLINE_INC_WITH_HERELINES;
1213 PL_parser->linestart = s+1;
1215 PL_parser->bufptr = ptr;
1219 =for apidoc Amx|void|lex_discard_to|char *ptr
1221 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1222 up to I<ptr>. The remaining content of the buffer will be moved, and
1223 all pointers into the buffer updated appropriately. I<ptr> must not
1224 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1225 it is not permitted to discard text that has yet to be lexed.
1227 Normally it is not necessarily to do this directly, because it suffices to
1228 use the implicit discarding behaviour of L</lex_next_chunk> and things
1229 based on it. However, if a token stretches across multiple lines,
1230 and the lexing code has kept multiple lines of text in the buffer for
1231 that purpose, then after completion of the token it would be wise to
1232 explicitly discard the now-unneeded earlier lines, to avoid future
1233 multi-line tokens growing the buffer without bound.
1239 Perl_lex_discard_to(pTHX_ char *ptr)
1243 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1244 buf = SvPVX(PL_parser->linestr);
1246 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1249 if (ptr > PL_parser->bufptr)
1250 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1251 discard_len = ptr - buf;
1252 if (PL_parser->oldbufptr < ptr)
1253 PL_parser->oldbufptr = ptr;
1254 if (PL_parser->oldoldbufptr < ptr)
1255 PL_parser->oldoldbufptr = ptr;
1256 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1257 PL_parser->last_uni = NULL;
1258 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1259 PL_parser->last_lop = NULL;
1260 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1261 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1262 PL_parser->bufend -= discard_len;
1263 PL_parser->bufptr -= discard_len;
1264 PL_parser->oldbufptr -= discard_len;
1265 PL_parser->oldoldbufptr -= discard_len;
1266 if (PL_parser->last_uni)
1267 PL_parser->last_uni -= discard_len;
1268 if (PL_parser->last_lop)
1269 PL_parser->last_lop -= discard_len;
1273 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1275 Reads in the next chunk of text to be lexed, appending it to
1276 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1277 looked to the end of the current chunk and wants to know more. It is
1278 usual, but not necessary, for lexing to have consumed the entirety of
1279 the current chunk at this time.
1281 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1282 chunk (i.e., the current chunk has been entirely consumed), normally the
1283 current chunk will be discarded at the same time that the new chunk is
1284 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1285 will not be discarded. If the current chunk has not been entirely
1286 consumed, then it will not be discarded regardless of the flag.
1288 Returns true if some new text was added to the buffer, or false if the
1289 buffer has reached the end of the input text.
1294 #define LEX_FAKE_EOF 0x80000000
1295 #define LEX_NO_TERM 0x40000000
1298 Perl_lex_next_chunk(pTHX_ U32 flags)
1302 STRLEN old_bufend_pos, new_bufend_pos;
1303 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1304 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1305 bool got_some_for_debugger = 0;
1307 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1308 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1309 linestr = PL_parser->linestr;
1310 buf = SvPVX(linestr);
1311 if (!(flags & LEX_KEEP_PREVIOUS) &&
1312 PL_parser->bufptr == PL_parser->bufend) {
1313 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1315 if (PL_parser->last_uni != PL_parser->bufend)
1316 PL_parser->last_uni = NULL;
1317 if (PL_parser->last_lop != PL_parser->bufend)
1318 PL_parser->last_lop = NULL;
1319 last_uni_pos = last_lop_pos = 0;
1323 old_bufend_pos = PL_parser->bufend - buf;
1324 bufptr_pos = PL_parser->bufptr - buf;
1325 oldbufptr_pos = PL_parser->oldbufptr - buf;
1326 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1327 linestart_pos = PL_parser->linestart - buf;
1328 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1329 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1331 if (flags & LEX_FAKE_EOF) {
1333 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1335 } else if (filter_gets(linestr, old_bufend_pos)) {
1337 got_some_for_debugger = 1;
1338 } else if (flags & LEX_NO_TERM) {
1341 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1342 sv_setpvs(linestr, "");
1344 /* End of real input. Close filehandle (unless it was STDIN),
1345 * then add implicit termination.
1347 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1348 PerlIO_clearerr(PL_parser->rsfp);
1349 else if (PL_parser->rsfp)
1350 (void)PerlIO_close(PL_parser->rsfp);
1351 PL_parser->rsfp = NULL;
1352 PL_parser->in_pod = PL_parser->filtered = 0;
1354 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1357 if (!PL_in_eval && PL_minus_p) {
1359 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1360 PL_minus_n = PL_minus_p = 0;
1361 } else if (!PL_in_eval && PL_minus_n) {
1362 sv_catpvs(linestr, /*{*/";}");
1365 sv_catpvs(linestr, ";");
1368 buf = SvPVX(linestr);
1369 new_bufend_pos = SvCUR(linestr);
1370 PL_parser->bufend = buf + new_bufend_pos;
1371 PL_parser->bufptr = buf + bufptr_pos;
1372 PL_parser->oldbufptr = buf + oldbufptr_pos;
1373 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1374 PL_parser->linestart = buf + linestart_pos;
1375 if (PL_parser->last_uni)
1376 PL_parser->last_uni = buf + last_uni_pos;
1377 if (PL_parser->last_lop)
1378 PL_parser->last_lop = buf + last_lop_pos;
1379 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1380 PL_curstash != PL_debstash) {
1381 /* debugger active and we're not compiling the debugger code,
1382 * so store the line into the debugger's array of lines
1384 update_debugger_info(NULL, buf+old_bufend_pos,
1385 new_bufend_pos-old_bufend_pos);
1391 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1393 Looks ahead one (Unicode) character in the text currently being lexed.
1394 Returns the codepoint (unsigned integer value) of the next character,
1395 or -1 if lexing has reached the end of the input text. To consume the
1396 peeked character, use L</lex_read_unichar>.
1398 If the next character is in (or extends into) the next chunk of input
1399 text, the next chunk will be read in. Normally the current chunk will be
1400 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1401 then the current chunk will not be discarded.
1403 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1404 is encountered, an exception is generated.
1410 Perl_lex_peek_unichar(pTHX_ U32 flags)
1414 if (flags & ~(LEX_KEEP_PREVIOUS))
1415 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1416 s = PL_parser->bufptr;
1417 bufend = PL_parser->bufend;
1423 if (!lex_next_chunk(flags))
1425 s = PL_parser->bufptr;
1426 bufend = PL_parser->bufend;
1429 if (UTF8_IS_INVARIANT(head))
1431 if (UTF8_IS_START(head)) {
1432 len = UTF8SKIP(&head);
1433 while ((STRLEN)(bufend-s) < len) {
1434 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1436 s = PL_parser->bufptr;
1437 bufend = PL_parser->bufend;
1440 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1441 if (retlen == (STRLEN)-1) {
1442 /* malformed UTF-8 */
1444 SAVESPTR(PL_warnhook);
1445 PL_warnhook = PERL_WARNHOOK_FATAL;
1446 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1452 if (!lex_next_chunk(flags))
1454 s = PL_parser->bufptr;
1461 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1463 Reads the next (Unicode) character in the text currently being lexed.
1464 Returns the codepoint (unsigned integer value) of the character read,
1465 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1466 if lexing has reached the end of the input text. To non-destructively
1467 examine the next character, use L</lex_peek_unichar> instead.
1469 If the next character is in (or extends into) the next chunk of input
1470 text, the next chunk will be read in. Normally the current chunk will be
1471 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1472 then the current chunk will not be discarded.
1474 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1475 is encountered, an exception is generated.
1481 Perl_lex_read_unichar(pTHX_ U32 flags)
1484 if (flags & ~(LEX_KEEP_PREVIOUS))
1485 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1486 c = lex_peek_unichar(flags);
1489 COPLINE_INC_WITH_HERELINES;
1491 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1493 ++(PL_parser->bufptr);
1499 =for apidoc Amx|void|lex_read_space|U32 flags
1501 Reads optional spaces, in Perl style, in the text currently being
1502 lexed. The spaces may include ordinary whitespace characters and
1503 Perl-style comments. C<#line> directives are processed if encountered.
1504 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1505 at a non-space character (or the end of the input text).
1507 If spaces extend into the next chunk of input text, the next chunk will
1508 be read in. Normally the current chunk will be discarded at the same
1509 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1510 chunk will not be discarded.
1515 #define LEX_NO_INCLINE 0x40000000
1516 #define LEX_NO_NEXT_CHUNK 0x80000000
1519 Perl_lex_read_space(pTHX_ U32 flags)
1522 const bool can_incline = !(flags & LEX_NO_INCLINE);
1523 bool need_incline = 0;
1524 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1525 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1528 sv_free(PL_skipwhite);
1529 PL_skipwhite = NULL;
1532 PL_skipwhite = newSVpvs("");
1533 #endif /* PERL_MAD */
1534 s = PL_parser->bufptr;
1535 bufend = PL_parser->bufend;
1541 } while (!(c == '\n' || (c == 0 && s == bufend)));
1542 } else if (c == '\n') {
1545 PL_parser->linestart = s;
1551 } else if (isSPACE(c)) {
1553 } else if (c == 0 && s == bufend) {
1557 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1558 #endif /* PERL_MAD */
1559 if (flags & LEX_NO_NEXT_CHUNK)
1561 PL_parser->bufptr = s;
1562 if (can_incline) COPLINE_INC_WITH_HERELINES;
1563 got_more = lex_next_chunk(flags);
1564 if (can_incline) CopLINE_dec(PL_curcop);
1565 s = PL_parser->bufptr;
1566 bufend = PL_parser->bufend;
1569 if (can_incline && need_incline && PL_parser->rsfp) {
1579 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1580 #endif /* PERL_MAD */
1581 PL_parser->bufptr = s;
1586 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1588 This function performs syntax checking on a prototype, C<proto>.
1589 If C<warn> is true, any illegal characters or mismatched brackets
1590 will trigger illegalproto warnings, declaring that they were
1591 detected in the prototype for C<name>.
1593 The return value is C<true> if this is a valid prototype, and
1594 C<false> if it is not, regardless of whether C<warn> was C<true> or
1597 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1604 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1606 STRLEN len, origlen;
1607 char *p = proto ? SvPV(proto, len) : NULL;
1608 bool bad_proto = FALSE;
1609 bool in_brackets = FALSE;
1610 bool after_slash = FALSE;
1611 char greedy_proto = ' ';
1612 bool proto_after_greedy_proto = FALSE;
1613 bool must_be_last = FALSE;
1614 bool underscore = FALSE;
1615 bool bad_proto_after_underscore = FALSE;
1617 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1623 for (; len--; p++) {
1626 proto_after_greedy_proto = TRUE;
1628 if (!strchr(";@%", *p))
1629 bad_proto_after_underscore = TRUE;
1632 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1639 in_brackets = FALSE;
1640 else if ((*p == '@' || *p == '%') &&
1643 must_be_last = TRUE;
1652 after_slash = FALSE;
1657 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1660 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1661 origlen, UNI_DISPLAY_ISPRINT)
1662 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1664 if (proto_after_greedy_proto)
1665 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1666 "Prototype after '%c' for %"SVf" : %s",
1667 greedy_proto, SVfARG(name), p);
1669 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1670 "Missing ']' in prototype for %"SVf" : %s",
1673 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1674 "Illegal character in prototype for %"SVf" : %s",
1676 if (bad_proto_after_underscore)
1677 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1678 "Illegal character after '_' in prototype for %"SVf" : %s",
1682 return (! (proto_after_greedy_proto || bad_proto) );
1687 * This subroutine has nothing to do with tilting, whether at windmills
1688 * or pinball tables. Its name is short for "increment line". It
1689 * increments the current line number in CopLINE(PL_curcop) and checks
1690 * to see whether the line starts with a comment of the form
1691 * # line 500 "foo.pm"
1692 * If so, it sets the current line number and file to the values in the comment.
1696 S_incline(pTHX_ const char *s)
1704 PERL_ARGS_ASSERT_INCLINE;
1706 COPLINE_INC_WITH_HERELINES;
1707 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1708 && s+1 == PL_bufend && *s == ';') {
1709 /* fake newline in string eval */
1710 CopLINE_dec(PL_curcop);
1715 while (SPACE_OR_TAB(*s))
1717 if (strnEQ(s, "line", 4))
1721 if (SPACE_OR_TAB(*s))
1725 while (SPACE_OR_TAB(*s))
1733 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1735 while (SPACE_OR_TAB(*s))
1737 if (*s == '"' && (t = strchr(s+1, '"'))) {
1743 while (!isSPACE(*t))
1747 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1749 if (*e != '\n' && *e != '\0')
1750 return; /* false alarm */
1752 line_num = atoi(n)-1;
1755 const STRLEN len = t - s;
1757 if (!PL_rsfp && !PL_parser->filtered) {
1758 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1759 * to *{"::_<newfilename"} */
1760 /* However, the long form of evals is only turned on by the
1761 debugger - usually they're "(eval %lu)" */
1762 GV * const cfgv = CopFILEGV(PL_curcop);
1765 STRLEN tmplen2 = len;
1769 if (tmplen2 + 2 <= sizeof smallbuf)
1772 Newx(tmpbuf2, tmplen2 + 2, char);
1777 memcpy(tmpbuf2 + 2, s, tmplen2);
1780 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1782 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1783 /* adjust ${"::_<newfilename"} to store the new file name */
1784 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1785 /* The line number may differ. If that is the case,
1786 alias the saved lines that are in the array.
1787 Otherwise alias the whole array. */
1788 if (CopLINE(PL_curcop) == line_num) {
1789 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1790 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1792 else if (GvAV(cfgv)) {
1793 AV * const av = GvAV(cfgv);
1794 const I32 start = CopLINE(PL_curcop)+1;
1795 I32 items = AvFILLp(av) - start;
1797 AV * const av2 = GvAVn(gv2);
1798 SV **svp = AvARRAY(av) + start;
1799 I32 l = (I32)line_num+1;
1801 av_store(av2, l++, SvREFCNT_inc(*svp++));
1806 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1809 CopFILE_free(PL_curcop);
1810 CopFILE_setn(PL_curcop, s, len);
1812 CopLINE_set(PL_curcop, line_num);
1815 #define skipspace(s) skipspace_flags(s, 0)
1818 /* skip space before PL_thistoken */
1821 S_skipspace0(pTHX_ char *s)
1823 PERL_ARGS_ASSERT_SKIPSPACE0;
1830 PL_thiswhite = newSVpvs("");
1831 sv_catsv(PL_thiswhite, PL_skipwhite);
1832 sv_free(PL_skipwhite);
1835 PL_realtokenstart = s - SvPVX(PL_linestr);
1839 /* skip space after PL_thistoken */
1842 S_skipspace1(pTHX_ char *s)
1844 const char *start = s;
1845 I32 startoff = start - SvPVX(PL_linestr);
1847 PERL_ARGS_ASSERT_SKIPSPACE1;
1852 start = SvPVX(PL_linestr) + startoff;
1853 if (!PL_thistoken && PL_realtokenstart >= 0) {
1854 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1855 PL_thistoken = newSVpvn(tstart, start - tstart);
1857 PL_realtokenstart = -1;
1860 PL_nextwhite = newSVpvs("");
1861 sv_catsv(PL_nextwhite, PL_skipwhite);
1862 sv_free(PL_skipwhite);
1869 S_skipspace2(pTHX_ char *s, SV **svp)
1872 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1873 const I32 startoff = s - SvPVX(PL_linestr);
1875 PERL_ARGS_ASSERT_SKIPSPACE2;
1878 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1879 if (!PL_madskills || !svp)
1881 start = SvPVX(PL_linestr) + startoff;
1882 if (!PL_thistoken && PL_realtokenstart >= 0) {
1883 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1884 PL_thistoken = newSVpvn(tstart, start - tstart);
1885 PL_realtokenstart = -1;
1889 *svp = newSVpvs("");
1890 sv_setsv(*svp, PL_skipwhite);
1891 sv_free(PL_skipwhite);
1900 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1902 AV *av = CopFILEAVx(PL_curcop);
1904 SV * const sv = newSV_type(SVt_PVMG);
1906 sv_setsv_flags(sv, orig_sv, 0); /* no cow */
1908 sv_setpvn(sv, buf, len);
1911 av_store(av, (I32)CopLINE(PL_curcop), sv);
1917 * Called to gobble the appropriate amount and type of whitespace.
1918 * Skips comments as well.
1922 S_skipspace_flags(pTHX_ char *s, U32 flags)
1926 #endif /* PERL_MAD */
1927 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1930 sv_free(PL_skipwhite);
1931 PL_skipwhite = NULL;
1933 #endif /* PERL_MAD */
1934 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1935 while (s < PL_bufend && SPACE_OR_TAB(*s))
1938 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1940 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1941 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1942 LEX_NO_NEXT_CHUNK : 0));
1944 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1945 if (PL_linestart > PL_bufptr)
1946 PL_bufptr = PL_linestart;
1951 PL_skipwhite = newSVpvn(start, s-start);
1952 #endif /* PERL_MAD */
1958 * Check the unary operators to ensure there's no ambiguity in how they're
1959 * used. An ambiguous piece of code would be:
1961 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1962 * the +5 is its argument.
1972 if (PL_oldoldbufptr != PL_last_uni)
1974 while (isSPACE(*PL_last_uni))
1977 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1979 if ((t = strchr(s, '(')) && t < PL_bufptr)
1982 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1983 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1984 (int)(s - PL_last_uni), PL_last_uni);
1988 * LOP : macro to build a list operator. Its behaviour has been replaced
1989 * with a subroutine, S_lop() for which LOP is just another name.
1992 #define LOP(f,x) return lop(f,x,s)
1996 * Build a list operator (or something that might be one). The rules:
1997 * - if we have a next token, then it's a list operator [why?]
1998 * - if the next thing is an opening paren, then it's a function
1999 * - else it's a list operator
2003 S_lop(pTHX_ I32 f, int x, char *s)
2007 PERL_ARGS_ASSERT_LOP;
2013 PL_last_lop = PL_oldbufptr;
2014 PL_last_lop_op = (OPCODE)f;
2023 return REPORT(FUNC);
2026 return REPORT(FUNC);
2029 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
2030 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
2031 return REPORT(LSTOP);
2038 * Sets up for an eventual force_next(). start_force(0) basically does
2039 * an unshift, while start_force(-1) does a push. yylex removes items
2044 S_start_force(pTHX_ int where)
2048 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
2049 where = PL_lasttoke;
2050 assert(PL_curforce < 0 || PL_curforce == where);
2051 if (PL_curforce != where) {
2052 for (i = PL_lasttoke; i > where; --i) {
2053 PL_nexttoke[i] = PL_nexttoke[i-1];
2057 if (PL_curforce < 0) /* in case of duplicate start_force() */
2058 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
2059 PL_curforce = where;
2062 curmad('^', newSVpvs(""));
2063 CURMAD('_', PL_nextwhite);
2068 S_curmad(pTHX_ char slot, SV *sv)
2074 if (PL_curforce < 0)
2075 where = &PL_thismad;
2077 where = &PL_nexttoke[PL_curforce].next_mad;
2083 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2085 else if (PL_encoding) {
2086 sv_recode_to_utf8(sv, PL_encoding);
2091 /* keep a slot open for the head of the list? */
2092 if (slot != '_' && *where && (*where)->mad_key == '^') {
2093 (*where)->mad_key = slot;
2094 sv_free(MUTABLE_SV(((*where)->mad_val)));
2095 (*where)->mad_val = (void*)sv;
2098 addmad(newMADsv(slot, sv), where, 0);
2101 # define start_force(where) NOOP
2102 # define curmad(slot, sv) NOOP
2107 * When the lexer realizes it knows the next token (for instance,
2108 * it is reordering tokens for the parser) then it can call S_force_next
2109 * to know what token to return the next time the lexer is called. Caller
2110 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2111 * and possibly PL_expect to ensure the lexer handles the token correctly.
2115 S_force_next(pTHX_ I32 type)
2120 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2121 tokereport(type, &NEXTVAL_NEXTTOKE);
2125 if (PL_curforce < 0)
2126 start_force(PL_lasttoke);
2127 PL_nexttoke[PL_curforce].next_type = type;
2128 if (PL_lex_state != LEX_KNOWNEXT)
2129 PL_lex_defer = PL_lex_state;
2130 PL_lex_state = LEX_KNOWNEXT;
2131 PL_lex_expect = PL_expect;
2134 PL_nexttype[PL_nexttoke] = type;
2136 if (PL_lex_state != LEX_KNOWNEXT) {
2137 PL_lex_defer = PL_lex_state;
2138 PL_lex_expect = PL_expect;
2139 PL_lex_state = LEX_KNOWNEXT;
2147 int yyc = PL_parser->yychar;
2148 if (yyc != YYEMPTY) {
2151 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2152 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2153 PL_lex_allbrackets--;
2155 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2156 } else if (yyc == '('/*)*/) {
2157 PL_lex_allbrackets--;
2162 PL_parser->yychar = YYEMPTY;
2167 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2170 SV * const sv = newSVpvn_utf8(start, len,
2173 && !is_ascii_string((const U8*)start, len)
2174 && is_utf8_string((const U8*)start, len));
2180 * When the lexer knows the next thing is a word (for instance, it has
2181 * just seen -> and it knows that the next char is a word char, then
2182 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2186 * char *start : buffer position (must be within PL_linestr)
2187 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2188 * int check_keyword : if true, Perl checks to make sure the word isn't
2189 * a keyword (do this if the word is a label, e.g. goto FOO)
2190 * int allow_pack : if true, : characters will also be allowed (require,
2191 * use, etc. do this)
2192 * int allow_initial_tick : used by the "sub" lexer only.
2196 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2202 PERL_ARGS_ASSERT_FORCE_WORD;
2204 start = SKIPSPACE1(start);
2206 if (isIDFIRST_lazy_if(s,UTF) ||
2207 (allow_pack && *s == ':') )
2209 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2210 if (check_keyword) {
2211 char *s2 = PL_tokenbuf;
2212 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2214 if (keyword(s2, len, 0))
2217 start_force(PL_curforce);
2219 curmad('X', newSVpvn(start,s-start));
2220 if (token == METHOD) {
2225 PL_expect = XOPERATOR;
2229 curmad('g', newSVpvs( "forced" ));
2230 NEXTVAL_NEXTTOKE.opval
2231 = (OP*)newSVOP(OP_CONST,0,
2232 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2233 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2241 * Called when the lexer wants $foo *foo &foo etc, but the program
2242 * text only contains the "foo" portion. The first argument is a pointer
2243 * to the "foo", and the second argument is the type symbol to prefix.
2244 * Forces the next token to be a "WORD".
2245 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2249 S_force_ident(pTHX_ const char *s, int kind)
2253 PERL_ARGS_ASSERT_FORCE_IDENT;
2256 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2257 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2258 UTF ? SVf_UTF8 : 0));
2259 start_force(PL_curforce);
2260 NEXTVAL_NEXTTOKE.opval = o;
2263 o->op_private = OPpCONST_ENTERED;
2264 /* XXX see note in pp_entereval() for why we forgo typo
2265 warnings if the symbol must be introduced in an eval.
2267 gv_fetchpvn_flags(s, len,
2268 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2269 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2270 kind == '$' ? SVt_PV :
2271 kind == '@' ? SVt_PVAV :
2272 kind == '%' ? SVt_PVHV :
2280 S_force_ident_maybe_lex(pTHX_ char pit)
2282 start_force(PL_curforce);
2283 NEXTVAL_NEXTTOKE.ival = pit;
2288 Perl_str_to_version(pTHX_ SV *sv)
2293 const char *start = SvPV_const(sv,len);
2294 const char * const end = start + len;
2295 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2297 PERL_ARGS_ASSERT_STR_TO_VERSION;
2299 while (start < end) {
2303 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2308 retval += ((NV)n)/nshift;
2317 * Forces the next token to be a version number.
2318 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2319 * and if "guessing" is TRUE, then no new token is created (and the caller
2320 * must use an alternative parsing method).
2324 S_force_version(pTHX_ char *s, int guessing)
2330 I32 startoff = s - SvPVX(PL_linestr);
2333 PERL_ARGS_ASSERT_FORCE_VERSION;
2341 while (isDIGIT(*d) || *d == '_' || *d == '.')
2345 start_force(PL_curforce);
2346 curmad('X', newSVpvn(s,d-s));
2349 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2351 #ifdef USE_LOCALE_NUMERIC
2352 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2353 setlocale(LC_NUMERIC, "C");
2355 s = scan_num(s, &pl_yylval);
2356 #ifdef USE_LOCALE_NUMERIC
2357 setlocale(LC_NUMERIC, loc);
2360 version = pl_yylval.opval;
2361 ver = cSVOPx(version)->op_sv;
2362 if (SvPOK(ver) && !SvNIOK(ver)) {
2363 SvUPGRADE(ver, SVt_PVNV);
2364 SvNV_set(ver, str_to_version(ver));
2365 SvNOK_on(ver); /* hint that it is a version */
2368 else if (guessing) {
2371 sv_free(PL_nextwhite); /* let next token collect whitespace */
2373 s = SvPVX(PL_linestr) + startoff;
2381 if (PL_madskills && !version) {
2382 sv_free(PL_nextwhite); /* let next token collect whitespace */
2384 s = SvPVX(PL_linestr) + startoff;
2387 /* NOTE: The parser sees the package name and the VERSION swapped */
2388 start_force(PL_curforce);
2389 NEXTVAL_NEXTTOKE.opval = version;
2396 * S_force_strict_version
2397 * Forces the next token to be a version number using strict syntax rules.
2401 S_force_strict_version(pTHX_ char *s)
2406 I32 startoff = s - SvPVX(PL_linestr);
2408 const char *errstr = NULL;
2410 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2412 while (isSPACE(*s)) /* leading whitespace */
2415 if (is_STRICT_VERSION(s,&errstr)) {
2417 s = (char *)scan_version(s, ver, 0);
2418 version = newSVOP(OP_CONST, 0, ver);
2420 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2421 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2425 yyerror(errstr); /* version required */
2430 if (PL_madskills && !version) {
2431 sv_free(PL_nextwhite); /* let next token collect whitespace */
2433 s = SvPVX(PL_linestr) + startoff;
2436 /* NOTE: The parser sees the package name and the VERSION swapped */
2437 start_force(PL_curforce);
2438 NEXTVAL_NEXTTOKE.opval = version;
2446 * Tokenize a quoted string passed in as an SV. It finds the next
2447 * chunk, up to end of string or a backslash. It may make a new
2448 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2453 S_tokeq(pTHX_ SV *sv)
2462 PERL_ARGS_ASSERT_TOKEQ;
2467 s = SvPV_force(sv, len);
2468 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2471 /* This is relying on the SV being "well formed" with a trailing '\0' */
2472 while (s < send && !(*s == '\\' && s[1] == '\\'))
2477 if ( PL_hints & HINT_NEW_STRING ) {
2478 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2482 if (s + 1 < send && (s[1] == '\\'))
2483 s++; /* all that, just for this */
2488 SvCUR_set(sv, d - SvPVX_const(sv));
2490 if ( PL_hints & HINT_NEW_STRING )
2491 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2496 * Now come three functions related to double-quote context,
2497 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2498 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2499 * interact with PL_lex_state, and create fake ( ... ) argument lists
2500 * to handle functions and concatenation.
2504 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2509 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2511 * Pattern matching will set PL_lex_op to the pattern-matching op to
2512 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2514 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2516 * Everything else becomes a FUNC.
2518 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2519 * had an OP_CONST or OP_READLINE). This just sets us up for a
2520 * call to S_sublex_push().
2524 S_sublex_start(pTHX)
2527 const I32 op_type = pl_yylval.ival;
2529 if (op_type == OP_NULL) {
2530 pl_yylval.opval = PL_lex_op;
2534 if (op_type == OP_CONST || op_type == OP_READLINE) {
2535 SV *sv = tokeq(PL_lex_stuff);
2537 if (SvTYPE(sv) == SVt_PVIV) {
2538 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2540 const char * const p = SvPV_const(sv, len);
2541 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2545 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2546 PL_lex_stuff = NULL;
2547 /* Allow <FH> // "foo" */
2548 if (op_type == OP_READLINE)
2549 PL_expect = XTERMORDORDOR;
2552 else if (op_type == OP_BACKTICK && PL_lex_op) {
2553 /* readpipe() was overridden */
2554 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2555 pl_yylval.opval = PL_lex_op;
2557 PL_lex_stuff = NULL;
2561 PL_sublex_info.super_state = PL_lex_state;
2562 PL_sublex_info.sub_inwhat = (U16)op_type;
2563 PL_sublex_info.sub_op = PL_lex_op;
2564 PL_lex_state = LEX_INTERPPUSH;
2568 pl_yylval.opval = PL_lex_op;
2578 * Create a new scope to save the lexing state. The scope will be
2579 * ended in S_sublex_done. Returns a '(', starting the function arguments
2580 * to the uc, lc, etc. found before.
2581 * Sets PL_lex_state to LEX_INTERPCONCAT.
2591 PL_lex_state = PL_sublex_info.super_state;
2592 SAVEBOOL(PL_lex_dojoin);
2593 SAVEI32(PL_lex_brackets);
2594 SAVEI32(PL_lex_allbrackets);
2595 SAVEI32(PL_lex_formbrack);
2596 SAVEI8(PL_lex_fakeeof);
2597 SAVEI32(PL_lex_casemods);
2598 SAVEI32(PL_lex_starts);
2599 SAVEI8(PL_lex_state);
2600 SAVESPTR(PL_lex_repl);
2601 SAVEVPTR(PL_lex_inpat);
2602 SAVEI16(PL_lex_inwhat);
2603 SAVECOPLINE(PL_curcop);
2604 SAVEPPTR(PL_bufptr);
2605 SAVEPPTR(PL_bufend);
2606 SAVEPPTR(PL_oldbufptr);
2607 SAVEPPTR(PL_oldoldbufptr);
2608 SAVEPPTR(PL_last_lop);
2609 SAVEPPTR(PL_last_uni);
2610 SAVEPPTR(PL_linestart);
2611 SAVESPTR(PL_linestr);
2612 SAVEGENERICPV(PL_lex_brackstack);
2613 SAVEGENERICPV(PL_lex_casestack);
2614 SAVEGENERICPV(PL_parser->lex_shared);
2615 SAVEBOOL(PL_parser->lex_re_reparsing);
2617 /* The here-doc parser needs to be able to peek into outer lexing
2618 scopes to find the body of the here-doc. So we put PL_linestr and
2619 PL_bufptr into lex_shared, to ‘share’ those values.
2621 PL_parser->lex_shared->ls_linestr = PL_linestr;
2622 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2624 PL_linestr = PL_lex_stuff;
2625 PL_lex_repl = PL_sublex_info.repl;
2626 PL_lex_stuff = NULL;
2627 PL_sublex_info.repl = NULL;
2629 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2630 = SvPVX(PL_linestr);
2631 PL_bufend += SvCUR(PL_linestr);
2632 PL_last_lop = PL_last_uni = NULL;
2633 SAVEFREESV(PL_linestr);
2634 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2636 PL_lex_dojoin = FALSE;
2637 PL_lex_brackets = PL_lex_formbrack = 0;
2638 PL_lex_allbrackets = 0;
2639 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2640 Newx(PL_lex_brackstack, 120, char);
2641 Newx(PL_lex_casestack, 12, char);
2642 PL_lex_casemods = 0;
2643 *PL_lex_casestack = '\0';
2645 PL_lex_state = LEX_INTERPCONCAT;
2646 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2648 Newxz(shared, 1, LEXSHARED);
2649 shared->ls_prev = PL_parser->lex_shared;
2650 PL_parser->lex_shared = shared;
2652 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2653 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2654 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2655 PL_lex_inpat = PL_sublex_info.sub_op;
2657 PL_lex_inpat = NULL;
2659 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2660 PL_in_eval &= ~EVAL_RE_REPARSING;
2667 * Restores lexer state after a S_sublex_push.
2674 if (!PL_lex_starts++) {
2675 SV * const sv = newSVpvs("");
2676 if (SvUTF8(PL_linestr))
2678 PL_expect = XOPERATOR;
2679 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2683 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2684 PL_lex_state = LEX_INTERPCASEMOD;
2688 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2689 assert(PL_lex_inwhat != OP_TRANSR);
2690 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2691 PL_linestr = PL_lex_repl;
2693 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2694 PL_bufend += SvCUR(PL_linestr);
2695 PL_last_lop = PL_last_uni = NULL;
2696 PL_lex_dojoin = FALSE;
2697 PL_lex_brackets = 0;
2698 PL_lex_allbrackets = 0;
2699 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2700 PL_lex_casemods = 0;
2701 *PL_lex_casestack = '\0';
2703 if (SvEVALED(PL_lex_repl)) {
2704 PL_lex_state = LEX_INTERPNORMAL;
2706 /* we don't clear PL_lex_repl here, so that we can check later
2707 whether this is an evalled subst; that means we rely on the
2708 logic to ensure sublex_done() is called again only via the
2709 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2712 PL_lex_state = LEX_INTERPCONCAT;
2722 PL_endwhite = newSVpvs("");
2723 sv_catsv(PL_endwhite, PL_thiswhite);
2727 sv_setpvs(PL_thistoken,"");
2729 PL_realtokenstart = -1;
2733 PL_bufend = SvPVX(PL_linestr);
2734 PL_bufend += SvCUR(PL_linestr);
2735 PL_expect = XOPERATOR;
2736 PL_sublex_info.sub_inwhat = 0;
2741 PERL_STATIC_INLINE SV*
2742 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2744 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2745 * interior, hence to the "}". Finds what the name resolves to, returning
2746 * an SV* containing it; NULL if no valid one found */
2748 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2755 const U8* first_bad_char_loc;
2756 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2758 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2760 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2762 &first_bad_char_loc))
2764 /* If warnings are on, this will print a more detailed analysis of what
2765 * is wrong than the error message below */
2766 utf8n_to_uvuni(first_bad_char_loc,
2767 e - ((char *) first_bad_char_loc),
2770 /* We deliberately don't try to print the malformed character, which
2771 * might not print very well; it also may be just the first of many
2772 * malformations, so don't print what comes after it */
2773 yyerror(Perl_form(aTHX_
2774 "Malformed UTF-8 character immediately after '%.*s'",
2775 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2779 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2780 /* include the <}> */
2781 e - backslash_ptr + 1);
2783 SvREFCNT_dec_NN(res);
2787 /* See if the charnames handler is the Perl core's, and if so, we can skip
2788 * the validation needed for a user-supplied one, as Perl's does its own
2790 table = GvHV(PL_hintgv); /* ^H */
2791 cvp = hv_fetchs(table, "charnames", FALSE);
2792 if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
2793 && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
2795 const char * const name = HvNAME(stash);
2796 if strEQ(name, "_charnames") {
2801 /* Here, it isn't Perl's charname handler. We can't rely on a
2802 * user-supplied handler to validate the input name. For non-ut8 input,
2803 * look to see that the first character is legal. Then loop through the
2804 * rest checking that each is a continuation */
2806 /* This code needs to be sync'ed with a regex in _charnames.pm which does
2810 if (! isALPHAU(*s)) {
2815 if (! isCHARNAME_CONT(*s)) {
2818 if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2819 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2820 "A sequence of multiple spaces in a charnames "
2821 "alias definition is deprecated");
2825 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2826 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2827 "Trailing white-space in a charnames alias "
2828 "definition is deprecated");
2832 /* Similarly for utf8. For invariants can check directly; for other
2833 * Latin1, can calculate their code point and check; otherwise use a
2835 if (UTF8_IS_INVARIANT(*s)) {
2836 if (! isALPHAU(*s)) {
2840 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2841 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
2847 if (! PL_utf8_charname_begin) {
2848 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2849 PL_utf8_charname_begin = _core_swash_init("utf8",
2850 "_Perl_Charname_Begin",
2852 1, 0, NULL, &flags);
2854 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2861 if (UTF8_IS_INVARIANT(*s)) {
2862 if (! isCHARNAME_CONT(*s)) {
2865 if (*s == ' ' && *(s-1) == ' '
2866 && ckWARN_d(WARN_DEPRECATED)) {
2867 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2868 "A sequence of multiple spaces in a charnam"
2869 "es alias definition is deprecated");
2873 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2874 if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
2882 if (! PL_utf8_charname_continue) {
2883 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2884 PL_utf8_charname_continue = _core_swash_init("utf8",
2885 "_Perl_Charname_Continue",
2887 1, 0, NULL, &flags);
2889 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2895 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2896 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2897 "Trailing white-space in a charnames alias "
2898 "definition is deprecated");
2902 if (SvUTF8(res)) { /* Don't accept malformed input */
2903 const U8* first_bad_char_loc;
2905 const char* const str = SvPV_const(res, len);
2906 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2907 /* If warnings are on, this will print a more detailed analysis of
2908 * what is wrong than the error message below */
2909 utf8n_to_uvuni(first_bad_char_loc,
2910 (char *) first_bad_char_loc - str,
2913 /* We deliberately don't try to print the malformed character,
2914 * which might not print very well; it also may be just the first
2915 * of many malformations, so don't print what comes after it */
2918 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2919 (int) (e - backslash_ptr + 1), backslash_ptr,
2920 (int) ((char *) first_bad_char_loc - str), str
2930 int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
2932 /* The final %.*s makes sure that should the trailing NUL be missing
2933 * that this print won't run off the end of the string */
2936 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2937 (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2938 (int)(e - s + bad_char_size), s + bad_char_size
2940 UTF ? SVf_UTF8 : 0);
2948 Extracts the next constant part of a pattern, double-quoted string,
2949 or transliteration. This is terrifying code.
2951 For example, in parsing the double-quoted string "ab\x63$d", it would
2952 stop at the '$' and return an OP_CONST containing 'abc'.
2954 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2955 processing a pattern (PL_lex_inpat is true), a transliteration
2956 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2958 Returns a pointer to the character scanned up to. If this is
2959 advanced from the start pointer supplied (i.e. if anything was
2960 successfully parsed), will leave an OP_CONST for the substring scanned
2961 in pl_yylval. Caller must intuit reason for not parsing further
2962 by looking at the next characters herself.
2966 \N{FOO} => \N{U+hex_for_character_FOO}
2967 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2970 all other \-char, including \N and \N{ apart from \N{ABC}
2973 @ and $ where it appears to be a var, but not for $ as tail anchor
2978 In transliterations:
2979 characters are VERY literal, except for - not at the start or end
2980 of the string, which indicates a range. If the range is in bytes,
2981 scan_const expands the range to the full set of intermediate
2982 characters. If the range is in utf8, the hyphen is replaced with
2983 a certain range mark which will be handled by pmtrans() in op.c.
2985 In double-quoted strings:
2987 double-quoted style: \r and \n
2988 constants: \x31, etc.
2989 deprecated backrefs: \1 (in substitution replacements)
2990 case and quoting: \U \Q \E
2993 scan_const does *not* construct ops to handle interpolated strings.
2994 It stops processing as soon as it finds an embedded $ or @ variable
2995 and leaves it to the caller to work out what's going on.
2997 embedded arrays (whether in pattern or not) could be:
2998 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
3000 $ in double-quoted strings must be the symbol of an embedded scalar.
3002 $ in pattern could be $foo or could be tail anchor. Assumption:
3003 it's a tail anchor if $ is the last thing in the string, or if it's
3004 followed by one of "()| \r\n\t"
3006 \1 (backreferences) are turned into $1 in substitutions
3008 The structure of the code is
3009 while (there's a character to process) {
3010 handle transliteration ranges
3011 skip regexp comments /(?#comment)/ and codes /(?{code})/
3012 skip #-initiated comments in //x patterns
3013 check for embedded arrays
3014 check for embedded scalars
3016 deprecate \1 in substitution replacements
3017 handle string-changing backslashes \l \U \Q \E, etc.
3018 switch (what was escaped) {
3019 handle \- in a transliteration (becomes a literal -)
3020 if a pattern and not \N{, go treat as regular character
3021 handle \132 (octal characters)
3022 handle \x15 and \x{1234} (hex characters)
3023 handle \N{name} (named characters, also \N{3,5} in a pattern)
3024 handle \cV (control characters)
3025 handle printf-style backslashes (\f, \r, \n, etc)
3028 } (end if backslash)
3029 handle regular character
3030 } (end while character to read)
3035 S_scan_const(pTHX_ char *start)
3038 char *send = PL_bufend; /* end of the constant */
3039 SV *sv = newSV(send - start); /* sv for the constant. See
3040 note below on sizing. */
3041 char *s = start; /* start of the constant */
3042 char *d = SvPVX(sv); /* destination for copies */
3043 bool dorange = FALSE; /* are we in a translit range? */
3044 bool didrange = FALSE; /* did we just finish a range? */
3045 bool in_charclass = FALSE; /* within /[...]/ */
3046 bool has_utf8 = FALSE; /* Output constant is UTF8 */
3047 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
3048 to be UTF8? But, this can
3049 show as true when the source
3050 isn't utf8, as for example
3051 when it is entirely composed
3053 SV *res; /* result from charnames */
3055 /* Note on sizing: The scanned constant is placed into sv, which is
3056 * initialized by newSV() assuming one byte of output for every byte of
3057 * input. This routine expects newSV() to allocate an extra byte for a
3058 * trailing NUL, which this routine will append if it gets to the end of
3059 * the input. There may be more bytes of input than output (eg., \N{LATIN
3060 * CAPITAL LETTER A}), or more output than input if the constant ends up
3061 * recoded to utf8, but each time a construct is found that might increase
3062 * the needed size, SvGROW() is called. Its size parameter each time is
3063 * based on the best guess estimate at the time, namely the length used so
3064 * far, plus the length the current construct will occupy, plus room for
3065 * the trailing NUL, plus one byte for every input byte still unscanned */
3067 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
3070 UV literal_endpoint = 0;
3071 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
3074 PERL_ARGS_ASSERT_SCAN_CONST;
3076 assert(PL_lex_inwhat != OP_TRANSR);
3077 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3078 /* If we are doing a trans and we know we want UTF8 set expectation */
3079 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
3080 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3083 /* Protect sv from errors and fatal warnings. */
3084 ENTER_with_name("scan_const");
3087 while (s < send || dorange) {
3089 /* get transliterations out of the way (they're most literal) */
3090 if (PL_lex_inwhat == OP_TRANS) {
3091 /* expand a range A-Z to the full set of characters. AIE! */
3093 I32 i; /* current expanded character */
3094 I32 min; /* first character in range */
3095 I32 max; /* last character in range */
3106 char * const c = (char*)utf8_hop((U8*)d, -1);
3110 *c = (char)UTF_TO_NATIVE(0xff);
3111 /* mark the range as done, and continue */
3117 i = d - SvPVX_const(sv); /* remember current offset */
3120 SvLEN(sv) + (has_utf8 ?
3121 (512 - UTF_CONTINUATION_MARK +
3124 /* How many two-byte within 0..255: 128 in UTF-8,
3125 * 96 in UTF-8-mod. */
3127 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
3129 d = SvPVX(sv) + i; /* refresh d after realloc */
3133 for (j = 0; j <= 1; j++) {
3134 char * const c = (char*)utf8_hop((U8*)d, -1);
3135 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3141 max = (U8)0xff; /* only to \xff */
3142 uvmax = uv; /* \x{100} to uvmax */
3144 d = c; /* eat endpoint chars */
3149 d -= 2; /* eat the first char and the - */
3150 min = (U8)*d; /* first char in range */
3151 max = (U8)d[1]; /* last char in range */
3158 "Invalid range \"%c-%c\" in transliteration operator",
3159 (char)min, (char)max);
3163 if (literal_endpoint == 2 &&
3164 ((isLOWER(min) && isLOWER(max)) ||
3165 (isUPPER(min) && isUPPER(max)))) {
3167 for (i = min; i <= max; i++)
3169 *d++ = NATIVE_TO_NEED(has_utf8,i);
3171 for (i = min; i <= max; i++)
3173 *d++ = NATIVE_TO_NEED(has_utf8,i);
3178 for (i = min; i <= max; i++)
3181 const U8 ch = (U8)NATIVE_TO_UTF(i);
3182 if (UNI_IS_INVARIANT(ch))
3185 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
3186 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
3195 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3197 *d++ = (char)UTF_TO_NATIVE(0xff);
3199 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3203 /* mark the range as done, and continue */
3207 literal_endpoint = 0;
3212 /* range begins (ignore - as first or last char) */
3213 else if (*s == '-' && s+1 < send && s != start) {
3215 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3222 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
3232 literal_endpoint = 0;
3233 native_range = TRUE;
3238 /* if we get here, we're not doing a transliteration */
3240 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3243 while (s1 >= start && *s1-- == '\\')
3246 in_charclass = TRUE;
3249 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3252 while (s1 >= start && *s1-- == '\\')
3255 in_charclass = FALSE;
3258 /* skip for regexp comments /(?#comment)/, except for the last
3259 * char, which will be done separately.
3260 * Stop on (?{..}) and friends */
3262 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3264 while (s+1 < send && *s != ')')
3265 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3267 else if (!PL_lex_casemods &&
3268 ( s[2] == '{' /* This should match regcomp.c */
3269 || (s[2] == '?' && s[3] == '{')))
3275 /* likewise skip #-initiated comments in //x patterns */
3276 else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3277 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3278 while (s+1 < send && *s != '\n')
3279 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3282 /* no further processing of single-quoted regex */
3283 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3284 goto default_action;
3286 /* check for embedded arrays
3287 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3289 else if (*s == '@' && s[1]) {
3290 if (isWORDCHAR_lazy_if(s+1,UTF))
3292 if (strchr(":'{$", s[1]))
3294 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3295 break; /* in regexp, neither @+ nor @- are interpolated */
3298 /* check for embedded scalars. only stop if we're sure it's a
3301 else if (*s == '$') {
3302 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3304 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3306 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3307 "Possible unintended interpolation of $\\ in regex");
3309 break; /* in regexp, $ might be tail anchor */
3313 /* End of else if chain - OP_TRANS rejoin rest */
3316 if (*s == '\\' && s+1 < send) {
3317 char* e; /* Can be used for ending '}', etc. */
3321 /* warn on \1 - \9 in substitution replacements, but note that \11
3322 * is an octal; and \19 is \1 followed by '9' */
3323 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3324 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3326 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3331 /* string-change backslash escapes */
3332 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3336 /* In a pattern, process \N, but skip any other backslash escapes.
3337 * This is because we don't want to translate an escape sequence
3338 * into a meta symbol and have the regex compiler use the meta
3339 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3340 * in spite of this, we do have to process \N here while the proper
3341 * charnames handler is in scope. See bugs #56444 and #62056.
3342 * There is a complication because \N in a pattern may also stand
3343 * for 'match a non-nl', and not mean a charname, in which case its
3344 * processing should be deferred to the regex compiler. To be a
3345 * charname it must be followed immediately by a '{', and not look
3346 * like \N followed by a curly quantifier, i.e., not something like
3347 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3349 else if (PL_lex_inpat
3352 || regcurly(s + 1, FALSE)))
3354 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
3355 goto default_action;
3360 /* quoted - in transliterations */
3362 if (PL_lex_inwhat == OP_TRANS) {
3369 if ((isALPHANUMERIC(*s)))
3370 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3371 "Unrecognized escape \\%c passed through",
3373 /* default action is to copy the quoted character */
3374 goto default_action;
3377 /* eg. \132 indicates the octal constant 0132 */
3378 case '0': case '1': case '2': case '3':
3379 case '4': case '5': case '6': case '7':
3381 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3383 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
3385 if (len < 3 && s < send && isDIGIT(*s)
3386 && ckWARN(WARN_MISC))
3388 Perl_warner(aTHX_ packWARN(WARN_MISC),
3389 "%s", form_short_octal_warning(s, len));
3392 goto NUM_ESCAPE_INSERT;
3394 /* eg. \o{24} indicates the octal constant \024 */
3399 bool valid = grok_bslash_o(&s, &uv, &error,
3400 TRUE, /* Output warning */
3401 FALSE, /* Not strict */
3402 TRUE, /* Output warnings for
3409 goto NUM_ESCAPE_INSERT;
3412 /* eg. \x24 indicates the hex constant 0x24 */
3417 bool valid = grok_bslash_x(&s, &uv, &error,
3418 TRUE, /* Output warning */
3419 FALSE, /* Not strict */
3420 TRUE, /* Output warnings for
3430 /* Insert oct or hex escaped character. There will always be
3431 * enough room in sv since such escapes will be longer than any
3432 * UTF-8 sequence they can end up as, except if they force us
3433 * to recode the rest of the string into utf8 */
3435 /* Here uv is the ordinal of the next character being added in
3436 * unicode (converted from native). */
3437 if (!UNI_IS_INVARIANT(uv)) {
3438 if (!has_utf8 && uv > 255) {
3439 /* Might need to recode whatever we have accumulated so
3440 * far if it contains any chars variant in utf8 or
3443 SvCUR_set(sv, d - SvPVX_const(sv));
3446 /* See Note on sizing above. */
3447 sv_utf8_upgrade_flags_grow(sv,
3448 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3449 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3450 d = SvPVX(sv) + SvCUR(sv);
3455 d = (char*)uvuni_to_utf8((U8*)d, uv);
3456 if (PL_lex_inwhat == OP_TRANS &&
3457 PL_sublex_info.sub_op) {
3458 PL_sublex_info.sub_op->op_private |=
3459 (PL_lex_repl ? OPpTRANS_FROM_UTF
3463 if (uv > 255 && !dorange)
3464 native_range = FALSE;
3477 /* In a non-pattern \N must be a named character, like \N{LATIN
3478 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3479 * mean to match a non-newline. For non-patterns, named
3480 * characters are converted to their string equivalents. In
3481 * patterns, named characters are not converted to their
3482 * ultimate forms for the same reasons that other escapes
3483 * aren't. Instead, they are converted to the \N{U+...} form
3484 * to get the value from the charnames that is in effect right
3485 * now, while preserving the fact that it was a named character
3486 * so that the regex compiler knows this */
3488 /* This section of code doesn't generally use the
3489 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3490 * a close examination of this macro and determined it is a
3491 * no-op except on utfebcdic variant characters. Every
3492 * character generated by this that would normally need to be
3493 * enclosed by this macro is invariant, so the macro is not
3494 * needed, and would complicate use of copy(). XXX There are
3495 * other parts of this file where the macro is used
3496 * inconsistently, but are saved by it being a no-op */
3498 /* The structure of this section of code (besides checking for
3499 * errors and upgrading to utf8) is:
3500 * Further disambiguate between the two meanings of \N, and if
3501 * not a charname, go process it elsewhere
3502 * If of form \N{U+...}, pass it through if a pattern;
3503 * otherwise convert to utf8
3504 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3505 * pattern; otherwise convert to utf8 */
3507 /* Here, s points to the 'N'; the test below is guaranteed to
3508 * succeed if we are being called on a pattern as we already
3509 * know from a test above that the next character is a '{'.
3510 * On a non-pattern \N must mean 'named sequence, which
3511 * requires braces */
3514 yyerror("Missing braces on \\N{}");
3519 /* If there is no matching '}', it is an error. */
3520 if (! (e = strchr(s, '}'))) {
3521 if (! PL_lex_inpat) {
3522 yyerror("Missing right brace on \\N{}");
3524 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3529 /* Here it looks like a named character */
3531 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3532 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3533 | PERL_SCAN_DISALLOW_PREFIX;
3536 /* For \N{U+...}, the '...' is a unicode value even on
3537 * EBCDIC machines */
3538 s += 2; /* Skip to next char after the 'U+' */
3540 uv = grok_hex(s, &len, &flags, NULL);
3541 if (len == 0 || len != (STRLEN)(e - s)) {
3542 yyerror("Invalid hexadecimal number in \\N{U+...}");
3549 /* On non-EBCDIC platforms, pass through to the regex
3550 * compiler unchanged. The reason we evaluated the
3551 * number above is to make sure there wasn't a syntax
3552 * error. But on EBCDIC we convert to native so
3553 * downstream code can continue to assume it's native
3555 s -= 5; /* Include the '\N{U+' */
3557 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3560 (unsigned int) UNI_TO_NATIVE(uv));
3562 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3566 else { /* Not a pattern: convert the hex to string */
3568 /* If destination is not in utf8, unconditionally
3569 * recode it to be so. This is because \N{} implies
3570 * Unicode semantics, and scalars have to be in utf8
3571 * to guarantee those semantics */
3573 SvCUR_set(sv, d - SvPVX_const(sv));
3576 /* See Note on sizing above. */
3577 sv_utf8_upgrade_flags_grow(
3579 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3580 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3581 d = SvPVX(sv) + SvCUR(sv);
3585 /* Add the string to the output */
3586 if (UNI_IS_INVARIANT(uv)) {
3589 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3592 else /* Here is \N{NAME} but not \N{U+...}. */
3593 if ((res = get_and_check_backslash_N_name(s, e)))
3596 const char *str = SvPV_const(res, len);
3599 if (! len) { /* The name resolved to an empty string */
3600 Copy("\\N{}", d, 4, char);
3604 /* In order to not lose information for the regex
3605 * compiler, pass the result in the specially made
3606 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3607 * the code points in hex of each character
3608 * returned by charnames */
3610 const char *str_end = str + len;
3611 const STRLEN off = d - SvPVX_const(sv);
3613 if (! SvUTF8(res)) {
3614 /* For the non-UTF-8 case, we can determine the
3615 * exact length needed without having to parse
3616 * through the string. Each character takes up
3617 * 2 hex digits plus either a trailing dot or
3619 d = off + SvGROW(sv, off
3621 + 6 /* For the "\N{U+", and
3623 + (STRLEN)(send - e));
3624 Copy("\\N{U+", d, 5, char);
3626 while (str < str_end) {
3628 my_snprintf(hex_string, sizeof(hex_string),
3629 "%02X.", (U8) *str);
3630 Copy(hex_string, d, 3, char);
3634 d--; /* We will overwrite below the final
3635 dot with a right brace */
3638 STRLEN char_length; /* cur char's byte length */
3640 /* and the number of bytes after this is
3641 * translated into hex digits */
3642 STRLEN output_length;
3644 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3645 * for max('U+', '.'); and 1 for NUL */
3646 char hex_string[2 * UTF8_MAXBYTES + 5];
3648 /* Get the first character of the result. */
3649 U32 uv = utf8n_to_uvuni((U8 *) str,
3653 /* Convert first code point to hex, including
3654 * the boiler plate before it. For all these,
3655 * we convert to native format so that
3656 * downstream code can continue to assume the
3657 * input is native */
3659 my_snprintf(hex_string, sizeof(hex_string),
3661 (unsigned int) UNI_TO_NATIVE(uv));
3663 /* Make sure there is enough space to hold it */
3664 d = off + SvGROW(sv, off
3666 + (STRLEN)(send - e)
3667 + 2); /* '}' + NUL */
3669 Copy(hex_string, d, output_length, char);
3672 /* For each subsequent character, append dot and
3673 * its ordinal in hex */
3674 while ((str += char_length) < str_end) {
3675 const STRLEN off = d - SvPVX_const(sv);
3676 U32 uv = utf8n_to_uvuni((U8 *) str,
3681 my_snprintf(hex_string,
3684 (unsigned int) UNI_TO_NATIVE(uv));
3686 d = off + SvGROW(sv, off
3688 + (STRLEN)(send - e)
3689 + 2); /* '}' + NUL */
3690 Copy(hex_string, d, output_length, char);
3695 *d++ = '}'; /* Done. Add the trailing brace */
3698 else { /* Here, not in a pattern. Convert the name to a
3701 /* If destination is not in utf8, unconditionally
3702 * recode it to be so. This is because \N{} implies
3703 * Unicode semantics, and scalars have to be in utf8
3704 * to guarantee those semantics */
3706 SvCUR_set(sv, d - SvPVX_const(sv));
3709 /* See Note on sizing above. */
3710 sv_utf8_upgrade_flags_grow(sv,
3711 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3712 len + (STRLEN)(send - s) + 1);
3713 d = SvPVX(sv) + SvCUR(sv);
3715 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3717 /* See Note on sizing above. (NOTE: SvCUR() is not
3718 * set correctly here). */
3719 const STRLEN off = d - SvPVX_const(sv);
3720 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3722 Copy(str, d, len, char);
3728 } /* End \N{NAME} */
3731 native_range = FALSE; /* \N{} is defined to be Unicode */
3733 s = e + 1; /* Point to just after the '}' */
3736 /* \c is a control character */
3740 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3743 yyerror("Missing control char name in \\c");
3747 /* printf-style backslashes, formfeeds, newlines, etc */
3749 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3752 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3755 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3758 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3761 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3764 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3767 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3773 } /* end if (backslash) */
3780 /* If we started with encoded form, or already know we want it,
3781 then encode the next character */
3782 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3786 /* One might think that it is wasted effort in the case of the
3787 * source being utf8 (this_utf8 == TRUE) to take the next character
3788 * in the source, convert it to an unsigned value, and then convert
3789 * it back again. But the source has not been validated here. The
3790 * routine that does the conversion checks for errors like
3793 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3794 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3796 SvCUR_set(sv, d - SvPVX_const(sv));
3799 /* See Note on sizing above. */
3800 sv_utf8_upgrade_flags_grow(sv,
3801 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3802 need + (STRLEN)(send - s) + 1);
3803 d = SvPVX(sv) + SvCUR(sv);
3805 } else if (need > len) {
3806 /* encoded value larger than old, may need extra space (NOTE:
3807 * SvCUR() is not set correctly here). See Note on sizing
3809 const STRLEN off = d - SvPVX_const(sv);
3810 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3814 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3816 if (uv > 255 && !dorange)
3817 native_range = FALSE;
3821 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3823 } /* while loop to process each character */
3825 /* terminate the string and set up the sv */
3827 SvCUR_set(sv, d - SvPVX_const(sv));
3828 if (SvCUR(sv) >= SvLEN(sv))
3829 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3830 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3833 if (PL_encoding && !has_utf8) {
3834 sv_recode_to_utf8(sv, PL_encoding);
3840 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3841 PL_sublex_info.sub_op->op_private |=
3842 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3846 /* shrink the sv if we allocated more than we used */
3847 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3848 SvPV_shrink_to_cur(sv);
3851 /* return the substring (via pl_yylval) only if we parsed anything */
3852 if (s > PL_bufptr) {
3853 SvREFCNT_inc_simple_void_NN(sv);
3854 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3855 && ! PL_parser->lex_re_reparsing)
3857 const char *const key = PL_lex_inpat ? "qr" : "q";
3858 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3862 if (PL_lex_inwhat == OP_TRANS) {
3865 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3868 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3876 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3879 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3881 LEAVE_with_name("scan_const");
3886 * Returns TRUE if there's more to the expression (e.g., a subscript),
3889 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3891 * ->[ and ->{ return TRUE
3892 * { and [ outside a pattern are always subscripts, so return TRUE
3893 * if we're outside a pattern and it's not { or [, then return FALSE
3894 * if we're in a pattern and the first char is a {
3895 * {4,5} (any digits around the comma) returns FALSE
3896 * if we're in a pattern and the first char is a [
3898 * [SOMETHING] has a funky algorithm to decide whether it's a
3899 * character class or not. It has to deal with things like
3900 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3901 * anything else returns TRUE
3904 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3907 S_intuit_more(pTHX_ char *s)
3911 PERL_ARGS_ASSERT_INTUIT_MORE;
3913 if (PL_lex_brackets)
3915 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3917 if (*s != '{' && *s != '[')
3922 /* In a pattern, so maybe we have {n,m}. */
3924 if (regcurly(s, FALSE)) {
3930 /* On the other hand, maybe we have a character class */
3933 if (*s == ']' || *s == '^')
3936 /* this is terrifying, and it works */
3939 const char * const send = strchr(s,']');
3940 unsigned char un_char, last_un_char;
3941 char tmpbuf[sizeof PL_tokenbuf * 4];
3943 if (!send) /* has to be an expression */
3945 weight = 2; /* let's weigh the evidence */
3949 else if (isDIGIT(*s)) {
3951 if (isDIGIT(s[1]) && s[2] == ']')
3957 Zero(seen,256,char);
3959 for (; s < send; s++) {
3960 last_un_char = un_char;
3961 un_char = (unsigned char)*s;
3966 weight -= seen[un_char] * 10;
3967 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3969 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3970 len = (int)strlen(tmpbuf);
3971 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3972 UTF ? SVf_UTF8 : 0, SVt_PV))
3977 else if (*s == '$' && s[1] &&
3978 strchr("[#!%*<>()-=",s[1])) {
3979 if (/*{*/ strchr("])} =",s[2]))
3988 if (strchr("wds]",s[1]))
3990 else if (seen[(U8)'\''] || seen[(U8)'"'])
3992 else if (strchr("rnftbxcav",s[1]))
3994 else if (isDIGIT(s[1])) {
3996 while (s[1] && isDIGIT(s[1]))
4006 if (strchr("aA01! ",last_un_char))
4008 if (strchr("zZ79~",s[1]))
4010 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4011 weight -= 5; /* cope with negative subscript */
4014 if (!isWORDCHAR(last_un_char)
4015 && !(last_un_char == '$' || last_un_char == '@'
4016 || last_un_char == '&')
4017 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4022 if (keyword(tmpbuf, d - tmpbuf, 0))
4025 if (un_char == last_un_char + 1)
4027 weight -= seen[un_char];
4032 if (weight >= 0) /* probably a character class */
4042 * Does all the checking to disambiguate
4044 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4045 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4047 * First argument is the stuff after the first token, e.g. "bar".
4049 * Not a method if foo is a filehandle.
4050 * Not a method if foo is a subroutine prototyped to take a filehandle.
4051 * Not a method if it's really "Foo $bar"
4052 * Method if it's "foo $bar"
4053 * Not a method if it's really "print foo $bar"
4054 * Method if it's really "foo package::" (interpreted as package->foo)
4055 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4056 * Not a method if bar is a filehandle or package, but is quoted with
4061 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
4064 char *s = start + (*start == '$');
4065 char tmpbuf[sizeof PL_tokenbuf];
4072 PERL_ARGS_ASSERT_INTUIT_METHOD;
4074 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4076 if (cv && SvPOK(cv)) {
4077 const char *proto = CvPROTO(cv);
4079 while (*proto && (isSPACE(*proto) || *proto == ';'))
4086 if (*start == '$') {
4087 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
4088 isUPPER(*PL_tokenbuf))
4091 len = start - SvPVX(PL_linestr);
4095 start = SvPVX(PL_linestr) + len;
4099 return *s == '(' ? FUNCMETH : METHOD;
4102 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4103 /* start is the beginning of the possible filehandle/object,
4104 * and s is the end of it
4105 * tmpbuf is a copy of it (but with single quotes as double colons)
4108 if (!keyword(tmpbuf, len, 0)) {
4109 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4113 soff = s - SvPVX(PL_linestr);
4117 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4118 if (indirgv && GvCVu(indirgv))
4120 /* filehandle or package name makes it a method */
4121 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4123 soff = s - SvPVX(PL_linestr);
4126 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4127 return 0; /* no assumptions -- "=>" quotes bareword */
4129 start_force(PL_curforce);
4130 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4131 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4132 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4134 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4135 ( UTF ? SVf_UTF8 : 0 )));
4140 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4142 return *s == '(' ? FUNCMETH : METHOD;
4148 /* Encoded script support. filter_add() effectively inserts a
4149 * 'pre-processing' function into the current source input stream.
4150 * Note that the filter function only applies to the current source file
4151 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4153 * The datasv parameter (which may be NULL) can be used to pass
4154 * private data to this instance of the filter. The filter function
4155 * can recover the SV using the FILTER_DATA macro and use it to
4156 * store private buffers and state information.
4158 * The supplied datasv parameter is upgraded to a PVIO type
4159 * and the IoDIRP/IoANY field is used to store the function pointer,
4160 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4161 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4162 * private use must be set using malloc'd pointers.
4166 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4175 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4176 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4178 if (!PL_rsfp_filters)
4179 PL_rsfp_filters = newAV();
4182 SvUPGRADE(datasv, SVt_PVIO);
4183 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4184 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4185 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4186 FPTR2DPTR(void *, IoANY(datasv)),
4187 SvPV_nolen(datasv)));
4188 av_unshift(PL_rsfp_filters, 1);
4189 av_store(PL_rsfp_filters, 0, datasv) ;
4191 !PL_parser->filtered
4192 && PL_parser->lex_flags & LEX_EVALBYTES
4193 && PL_bufptr < PL_bufend
4195 const char *s = PL_bufptr;
4196 while (s < PL_bufend) {
4198 SV *linestr = PL_parser->linestr;
4199 char *buf = SvPVX(linestr);
4200 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4201 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4202 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4203 STRLEN const linestart_pos = PL_parser->linestart - buf;
4204 STRLEN const last_uni_pos =
4205 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4206 STRLEN const last_lop_pos =
4207 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4208 av_push(PL_rsfp_filters, linestr);
4209 PL_parser->linestr =
4210 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4211 buf = SvPVX(PL_parser->linestr);
4212 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4213 PL_parser->bufptr = buf + bufptr_pos;
4214 PL_parser->oldbufptr = buf + oldbufptr_pos;
4215 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4216 PL_parser->linestart = buf + linestart_pos;
4217 if (PL_parser->last_uni)
4218 PL_parser->last_uni = buf + last_uni_pos;
4219 if (PL_parser->last_lop)
4220 PL_parser->last_lop = buf + last_lop_pos;
4221 SvLEN(linestr) = SvCUR(linestr);
4222 SvCUR(linestr) = s-SvPVX(linestr);
4223 PL_parser->filtered = 1;
4233 /* Delete most recently added instance of this filter function. */
4235 Perl_filter_del(pTHX_ filter_t funcp)
4240 PERL_ARGS_ASSERT_FILTER_DEL;
4243 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4244 FPTR2DPTR(void*, funcp)));
4246 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4248 /* if filter is on top of stack (usual case) just pop it off */
4249 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4250 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4251 sv_free(av_pop(PL_rsfp_filters));
4255 /* we need to search for the correct entry and clear it */
4256 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4260 /* Invoke the idxth filter function for the current rsfp. */
4261 /* maxlen 0 = read one text line */
4263 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4268 /* This API is bad. It should have been using unsigned int for maxlen.
4269 Not sure if we want to change the API, but if not we should sanity
4270 check the value here. */
4271 unsigned int correct_length
4280 PERL_ARGS_ASSERT_FILTER_READ;
4282 if (!PL_parser || !PL_rsfp_filters)
4284 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4285 /* Provide a default input filter to make life easy. */
4286 /* Note that we append to the line. This is handy. */
4287 DEBUG_P(PerlIO_printf(Perl_debug_log,
4288 "filter_read %d: from rsfp\n", idx));
4289 if (correct_length) {
4292 const int old_len = SvCUR(buf_sv);
4294 /* ensure buf_sv is large enough */
4295 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4296 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4297 correct_length)) <= 0) {
4298 if (PerlIO_error(PL_rsfp))
4299 return -1; /* error */
4301 return 0 ; /* end of file */
4303 SvCUR_set(buf_sv, old_len + len) ;
4304 SvPVX(buf_sv)[old_len + len] = '\0';
4307 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4308 if (PerlIO_error(PL_rsfp))
4309 return -1; /* error */
4311 return 0 ; /* end of file */
4314 return SvCUR(buf_sv);
4316 /* Skip this filter slot if filter has been deleted */
4317 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4318 DEBUG_P(PerlIO_printf(Perl_debug_log,
4319 "filter_read %d: skipped (filter deleted)\n",
4321 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4323 if (SvTYPE(datasv) != SVt_PVIO) {
4324 if (correct_length) {
4326 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4327 if (!remainder) return 0; /* eof */
4328 if (correct_length > remainder) correct_length = remainder;
4329 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4330 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4333 const char *s = SvEND(datasv);
4334 const char *send = SvPVX(datasv) + SvLEN(datasv);
4342 if (s == send) return 0; /* eof */
4343 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4344 SvCUR_set(datasv, s-SvPVX(datasv));
4346 return SvCUR(buf_sv);
4348 /* Get function pointer hidden within datasv */
4349 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4350 DEBUG_P(PerlIO_printf(Perl_debug_log,
4351 "filter_read %d: via function %p (%s)\n",
4352 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4353 /* Call function. The function is expected to */
4354 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4355 /* Return: <0:error, =0:eof, >0:not eof */
4356 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4360 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4364 PERL_ARGS_ASSERT_FILTER_GETS;
4366 #ifdef PERL_CR_FILTER
4367 if (!PL_rsfp_filters) {
4368 filter_add(S_cr_textfilter,NULL);
4371 if (PL_rsfp_filters) {
4373 SvCUR_set(sv, 0); /* start with empty line */
4374 if (FILTER_READ(0, sv, 0) > 0)
4375 return ( SvPVX(sv) ) ;
4380 return (sv_gets(sv, PL_rsfp, append));
4384 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4389 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4391 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4395 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4396 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4398 return GvHV(gv); /* Foo:: */
4401 /* use constant CLASS => 'MyClass' */
4402 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4403 if (gv && GvCV(gv)) {
4404 SV * const sv = cv_const_sv(GvCV(gv));
4406 pkgname = SvPV_const(sv, len);
4409 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4413 * S_readpipe_override
4414 * Check whether readpipe() is overridden, and generates the appropriate
4415 * optree, provided sublex_start() is called afterwards.
4418 S_readpipe_override(pTHX)
4421 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4422 pl_yylval.ival = OP_BACKTICK;
4424 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4426 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4427 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4428 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4430 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4431 op_append_elem(OP_LIST,
4432 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4433 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4440 * The intent of this yylex wrapper is to minimize the changes to the
4441 * tokener when we aren't interested in collecting madprops. It remains
4442 * to be seen how successful this strategy will be...
4449 char *s = PL_bufptr;
4451 /* make sure PL_thiswhite is initialized */
4455 /* previous token ate up our whitespace? */
4456 if (!PL_lasttoke && PL_nextwhite) {
4457 PL_thiswhite = PL_nextwhite;
4461 /* isolate the token, and figure out where it is without whitespace */
4462 PL_realtokenstart = -1;
4466 assert(PL_curforce < 0);
4468 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4469 if (!PL_thistoken) {
4470 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4471 PL_thistoken = newSVpvs("");
4473 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4474 PL_thistoken = newSVpvn(tstart, s - tstart);
4477 if (PL_thismad) /* install head */
4478 CURMAD('X', PL_thistoken);
4481 /* last whitespace of a sublex? */
4482 if (optype == ')' && PL_endwhite) {
4483 CURMAD('X', PL_endwhite);
4488 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4489 if (!PL_thiswhite && !PL_endwhite && !optype) {
4490 sv_free(PL_thistoken);
4495 /* put off final whitespace till peg */
4496 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4497 PL_nextwhite = PL_thiswhite;
4500 else if (PL_thisopen) {
4501 CURMAD('q', PL_thisopen);
4503 sv_free(PL_thistoken);
4507 /* Store actual token text as madprop X */
4508 CURMAD('X', PL_thistoken);
4512 /* add preceding whitespace as madprop _ */
4513 CURMAD('_', PL_thiswhite);
4517 /* add quoted material as madprop = */
4518 CURMAD('=', PL_thisstuff);
4522 /* add terminating quote as madprop Q */
4523 CURMAD('Q', PL_thisclose);
4527 /* special processing based on optype */
4531 /* opval doesn't need a TOKEN since it can already store mp */
4541 if (pl_yylval.opval)
4542 append_madprops(PL_thismad, pl_yylval.opval, 0);
4550 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4563 /* remember any fake bracket that lexer is about to discard */
4564 if (PL_lex_brackets == 1 &&
4565 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4568 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4571 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4572 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4575 break; /* don't bother looking for trailing comment */
4584 /* attach a trailing comment to its statement instead of next token */
4588 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4590 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4592 if (*s == '\n' || *s == '#') {
4593 while (s < PL_bufend && *s != '\n')
4597 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4598 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4611 /* Create new token struct. Note: opvals return early above. */
4612 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4619 S_tokenize_use(pTHX_ int is_use, char *s) {
4622 PERL_ARGS_ASSERT_TOKENIZE_USE;
4624 if (PL_expect != XSTATE)
4625 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4626 is_use ? "use" : "no"));
4629 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4630 s = force_version(s, TRUE);
4631 if (*s == ';' || *s == '}'
4632 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4633 start_force(PL_curforce);
4634 NEXTVAL_NEXTTOKE.opval = NULL;
4637 else if (*s == 'v') {
4638 s = force_word(s,WORD,FALSE,TRUE);
4639 s = force_version(s, FALSE);
4643 s = force_word(s,WORD,FALSE,TRUE);
4644 s = force_version(s, FALSE);
4646 pl_yylval.ival = is_use;
4650 static const char* const exp_name[] =
4651 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4652 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4656 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4658 S_word_takes_any_delimeter(char *p, STRLEN len)
4660 return (len == 1 && strchr("msyq", p[0])) ||
4662 (p[0] == 't' && p[1] == 'r') ||
4663 (p[0] == 'q' && strchr("qwxr", p[1]))));
4669 Works out what to call the token just pulled out of the input
4670 stream. The yacc parser takes care of taking the ops we return and
4671 stitching them into a tree.
4674 The type of the next token
4677 Switch based on the current state:
4678 - if we already built the token before, use it
4679 - if we have a case modifier in a string, deal with that
4680 - handle other cases of interpolation inside a string
4681 - scan the next line if we are inside a format
4682 In the normal state switch on the next character:
4684 if alphabetic, go to key lookup
4685 unrecoginized character - croak
4686 - 0/4/26: handle end-of-line or EOF
4687 - cases for whitespace
4688 - \n and #: handle comments and line numbers
4689 - various operators, brackets and sigils
4692 - 'v': vstrings (or go to key lookup)
4693 - 'x' repetition operator (or go to key lookup)
4694 - other ASCII alphanumerics (key lookup begins here):
4697 scan built-in keyword (but do nothing with it yet)
4698 check for statement label
4699 check for lexical subs
4700 goto just_a_word if there is one
4701 see whether built-in keyword is overridden
4702 switch on keyword number:
4703 - default: just_a_word:
4704 not a built-in keyword; handle bareword lookup
4705 disambiguate between method and sub call
4706 fall back to bareword
4707 - cases for built-in keywords
4712 #pragma segment Perl_yylex
4718 char *s = PL_bufptr;
4722 const bool saw_infix_sigil = PL_parser->saw_infix_sigil;
4726 /* orig_keyword, gvp, and gv are initialized here because
4727 * jump to the label just_a_word_zero can bypass their
4728 * initialization later. */
4729 I32 orig_keyword = 0;
4734 SV* tmp = newSVpvs("");
4735 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4736 (IV)CopLINE(PL_curcop),
4737 lex_state_names[PL_lex_state],
4738 exp_name[PL_expect],
4739 pv_display(tmp, s, strlen(s), 0, 60));
4743 switch (PL_lex_state) {
4745 case LEX_NORMAL: /* Some compilers will produce faster */
4746 case LEX_INTERPNORMAL: /* code if we comment these out. */
4750 /* when we've already built the next token, just pull it out of the queue */
4754 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4756 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4757 PL_nexttoke[PL_lasttoke].next_mad = 0;
4758 if (PL_thismad && PL_thismad->mad_key == '_') {
4759 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4760 PL_thismad->mad_val = 0;
4761 mad_free(PL_thismad);
4766 PL_lex_state = PL_lex_defer;
4767 PL_expect = PL_lex_expect;
4768 PL_lex_defer = LEX_NORMAL;
4769 if (!PL_nexttoke[PL_lasttoke].next_type)
4774 pl_yylval = PL_nextval[PL_nexttoke];
4776 PL_lex_state = PL_lex_defer;
4777 PL_expect = PL_lex_expect;
4778 PL_lex_defer = LEX_NORMAL;
4784 next_type = PL_nexttoke[PL_lasttoke].next_type;
4786 next_type = PL_nexttype[PL_nexttoke];
4788 if (next_type & (7<<24)) {
4789 if (next_type & (1<<24)) {
4790 if (PL_lex_brackets > 100)
4791 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4792 PL_lex_brackstack[PL_lex_brackets++] =
4793 (char) ((next_type >> 16) & 0xff);
4795 if (next_type & (2<<24))
4796 PL_lex_allbrackets++;
4797 if (next_type & (4<<24))
4798 PL_lex_allbrackets--;
4799 next_type &= 0xffff;
4801 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4804 /* interpolated case modifiers like \L \U, including \Q and \E.
4805 when we get here, PL_bufptr is at the \
4807 case LEX_INTERPCASEMOD:
4809 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4811 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4812 PL_bufptr, PL_bufend, *PL_bufptr);
4814 /* handle \E or end of string */
4815 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4817 if (PL_lex_casemods) {
4818 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4819 PL_lex_casestack[PL_lex_casemods] = '\0';
4821 if (PL_bufptr != PL_bufend
4822 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4823 || oldmod == 'F')) {
4825 PL_lex_state = LEX_INTERPCONCAT;
4828 PL_thistoken = newSVpvs("\\E");
4831 PL_lex_allbrackets--;
4834 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4835 /* Got an unpaired \E */
4836 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4837 "Useless use of \\E");
4840 while (PL_bufptr != PL_bufend &&
4841 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4844 PL_thiswhite = newSVpvs("");
4845 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4850 if (PL_bufptr != PL_bufend)
4853 PL_lex_state = LEX_INTERPCONCAT;
4857 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4858 "### Saw case modifier\n"); });
4860 if (s[1] == '\\' && s[2] == 'E') {
4864 PL_thiswhite = newSVpvs("");
4865 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4869 PL_lex_state = LEX_INTERPCONCAT;
4874 if (!PL_madskills) /* when just compiling don't need correct */
4875 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4876 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4877 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4878 (strchr(PL_lex_casestack, 'L')
4879 || strchr(PL_lex_casestack, 'U')
4880 || strchr(PL_lex_casestack, 'F'))) {
4881 PL_lex_casestack[--PL_lex_casemods] = '\0';
4882 PL_lex_allbrackets--;
4885 if (PL_lex_casemods > 10)
4886 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4887 PL_lex_casestack[PL_lex_casemods++] = *s;
4888 PL_lex_casestack[PL_lex_casemods] = '\0';
4889 PL_lex_state = LEX_INTERPCONCAT;
4890 start_force(PL_curforce);
4891 NEXTVAL_NEXTTOKE.ival = 0;
4892 force_next((2<<24)|'(');
4893 start_force(PL_curforce);
4895 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4897 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4899 NEXTVAL_NEXTTOKE.ival = OP_LC;
4901 NEXTVAL_NEXTTOKE.ival = OP_UC;
4903 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4905 NEXTVAL_NEXTTOKE.ival = OP_FC;
4907 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4909 SV* const tmpsv = newSVpvs("\\ ");
4910 /* replace the space with the character we want to escape
4912 SvPVX(tmpsv)[1] = *s;
4918 if (PL_lex_starts) {
4924 sv_free(PL_thistoken);
4925 PL_thistoken = newSVpvs("");
4928 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4929 if (PL_lex_casemods == 1 && PL_lex_inpat)
4938 case LEX_INTERPPUSH:
4939 return REPORT(sublex_push());
4941 case LEX_INTERPSTART:
4942 if (PL_bufptr == PL_bufend)
4943 return REPORT(sublex_done());
4944 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4945 "### Interpolated variable\n"); });
4947 /* for /@a/, we leave the joining for the regex engine to do
4948 * (unless we're within \Q etc) */
4949 PL_lex_dojoin = (*PL_bufptr == '@'
4950 && (!PL_lex_inpat || PL_lex_casemods));
4951 PL_lex_state = LEX_INTERPNORMAL;
4952 if (PL_lex_dojoin) {
4953 start_force(PL_curforce);
4954 NEXTVAL_NEXTTOKE.ival = 0;
4956 start_force(PL_curforce);
4957 force_ident("\"", '$');
4958 start_force(PL_curforce);
4959 NEXTVAL_NEXTTOKE.ival = 0;
4961 start_force(PL_curforce);
4962 NEXTVAL_NEXTTOKE.ival = 0;
4963 force_next((2<<24)|'(');
4964 start_force(PL_curforce);
4965 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4968 /* Convert (?{...}) and friends to 'do {...}' */
4969 if (PL_lex_inpat && *PL_bufptr == '(') {
4970 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4972 if (*PL_bufptr != '{')
4974 start_force(PL_curforce);
4975 /* XXX probably need a CURMAD(something) here */
4976 PL_expect = XTERMBLOCK;
4980 if (PL_lex_starts++) {
4985 sv_free(PL_thistoken);
4986 PL_thistoken = newSVpvs("");
4989 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4990 if (!PL_lex_casemods && PL_lex_inpat)
4997 case LEX_INTERPENDMAYBE:
4998 if (intuit_more(PL_bufptr)) {
4999 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
5005 if (PL_lex_dojoin) {
5006 PL_lex_dojoin = FALSE;
5007 PL_lex_state = LEX_INTERPCONCAT;
5011 sv_free(PL_thistoken);
5012 PL_thistoken = newSVpvs("");
5015 PL_lex_allbrackets--;
5018 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
5019 && SvEVALED(PL_lex_repl))
5021 if (PL_bufptr != PL_bufend)
5022 Perl_croak(aTHX_ "Bad evalled substitution pattern");
5025 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
5026 re_eval_str. If the here-doc body’s length equals the previous
5027 value of re_eval_start, re_eval_start will now be null. So
5028 check re_eval_str as well. */
5029 if (PL_parser->lex_shared->re_eval_start
5030 || PL_parser->lex_shared->re_eval_str) {
5032 if (*PL_bufptr != ')')
5033 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5035 /* having compiled a (?{..}) expression, return the original
5036 * text too, as a const */
5037 if (PL_parser->lex_shared->re_eval_str) {
5038 sv = PL_parser->lex_shared->re_eval_str;
5039 PL_parser->lex_shared->re_eval_str = NULL;
5041 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5042 SvPV_shrink_to_cur(sv);
5044 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5045 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5046 start_force(PL_curforce);
5047 /* XXX probably need a CURMAD(something) here */
5048 NEXTVAL_NEXTTOKE.opval =
5049 (OP*)newSVOP(OP_CONST, 0,
5052 PL_parser->lex_shared->re_eval_start = NULL;
5058 case LEX_INTERPCONCAT:
5060 if (PL_lex_brackets)
5061 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5062 (long) PL_lex_brackets);
5064 if (PL_bufptr == PL_bufend)
5065 return REPORT(sublex_done());
5067 /* m'foo' still needs to be parsed for possible (?{...}) */
5068 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5069 SV *sv = newSVsv(PL_linestr);
5071 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5075 s = scan_const(PL_bufptr);
5077 PL_lex_state = LEX_INTERPCASEMOD;
5079 PL_lex_state = LEX_INTERPSTART;
5082 if (s != PL_bufptr) {
5083 start_force(PL_curforce);
5085 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
5087 NEXTVAL_NEXTTOKE = pl_yylval;
5090 if (PL_lex_starts++) {
5094 sv_free(PL_thistoken);
5095 PL_thistoken = newSVpvs("");
5098 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5099 if (!PL_lex_casemods && PL_lex_inpat)
5112 s = scan_formline(PL_bufptr);
5113 if (!PL_lex_formbrack)
5122 /* We really do *not* want PL_linestr ever becoming a COW. */
5123 assert (!SvIsCOW(PL_linestr));
5125 PL_oldoldbufptr = PL_oldbufptr;
5127 PL_parser->saw_infix_sigil = 0;
5132 sv_free(PL_thistoken);
5135 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
5139 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
5142 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5143 const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
5145 SVs_TEMP | SVf_UTF8),
5146 10, UNI_DISPLAY_ISPRINT))
5147 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5148 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
5149 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5150 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
5158 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
5162 goto fake_eof; /* emulate EOF on ^D or ^Z */
5168 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
5171 if (PL_lex_brackets &&
5172 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
5173 yyerror((const char *)
5175 ? "Format not terminated"
5176 : "Missing right curly or square bracket"));
5178 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5179 "### Tokener got EOF\n");
5183 if (s++ < PL_bufend)
5184 goto retry; /* ignore stray nulls */
5187 if (!PL_in_eval && !PL_preambled) {
5188 PL_preambled = TRUE;
5194 /* Generate a string of Perl code to load the debugger.
5195 * If PERL5DB is set, it will return the contents of that,
5196 * otherwise a compile-time require of perl5db.pl. */
5198 const char * const pdb = PerlEnv_getenv("PERL5DB");
5201 sv_setpv(PL_linestr, pdb);
5202 sv_catpvs(PL_linestr,";");
5204 SETERRNO(0,SS_NORMAL);
5205 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5208 sv_setpvs(PL_linestr,"");
5209 if (PL_preambleav) {
5210 SV **svp = AvARRAY(PL_preambleav);
5211 SV **const end = svp + AvFILLp(PL_preambleav);
5213 sv_catsv(PL_linestr, *svp);
5215 sv_catpvs(PL_linestr, ";");
5217 sv_free(MUTABLE_SV(PL_preambleav));
5218 PL_preambleav = NULL;
5221 sv_catpvs(PL_linestr,
5222 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5223 if (PL_minus_n || PL_minus_p) {
5224 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5226 sv_catpvs(PL_linestr,"chomp;");
5229 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
5230 || *PL_splitstr == '"')
5231 && strchr(PL_splitstr + 1, *PL_splitstr))
5232 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5234 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5235 bytes can be used as quoting characters. :-) */
5236 const char *splits = PL_splitstr;
5237 sv_catpvs(PL_linestr, "our @F=split(q\0");
5240 if (*splits == '\\')
5241 sv_catpvn(PL_linestr, splits, 1);
5242 sv_catpvn(PL_linestr, splits, 1);
5243 } while (*splits++);
5244 /* This loop will embed the trailing NUL of
5245 PL_linestr as the last thing it does before
5247 sv_catpvs(PL_linestr, ");");
5251 sv_catpvs(PL_linestr,"our @F=split(' ');");
5254 sv_catpvs(PL_linestr, "\n");
5255 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5256 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5257 PL_last_lop = PL_last_uni = NULL;
5258 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
5259 update_debugger_info(PL_linestr, NULL, 0);
5264 bof = PL_rsfp ? TRUE : FALSE;
5267 fake_eof = LEX_FAKE_EOF;
5269 PL_bufptr = PL_bufend;
5270 COPLINE_INC_WITH_HERELINES;
5271 if (!lex_next_chunk(fake_eof)) {
5272 CopLINE_dec(PL_curcop);
5274 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5276 CopLINE_dec(PL_curcop);
5279 PL_realtokenstart = -1;
5282 /* If it looks like the start of a BOM or raw UTF-16,
5283 * check if it in fact is. */
5284 if (bof && PL_rsfp &&
5289 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5290 bof = (offset == (Off_t)SvCUR(PL_linestr));
5291 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5292 /* offset may include swallowed CR */
5294 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5297 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5298 s = swallow_bom((U8*)s);
5301 if (PL_parser->in_pod) {
5302 /* Incest with pod. */
5305 sv_catsv(PL_thiswhite, PL_linestr);
5307 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
5308 sv_setpvs(PL_linestr, "");
5309 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5310 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5311 PL_last_lop = PL_last_uni = NULL;
5312 PL_parser->in_pod = 0;
5315 if (PL_rsfp || PL_parser->filtered)
5317 } while (PL_parser->in_pod);
5318 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5319 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5320 PL_last_lop = PL_last_uni = NULL;
5321 if (CopLINE(PL_curcop) == 1) {
5322 while (s < PL_bufend && isSPACE(*s))
5324 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5328 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
5332 if (*s == '#' && *(s+1) == '!')
5334 #ifdef ALTERNATE_SHEBANG
5336 static char const as[] = ALTERNATE_SHEBANG;
5337 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5338 d = s + (sizeof(as) - 1);
5340 #endif /* ALTERNATE_SHEBANG */
5349 while (*d && !isSPACE(*d))
5353 #ifdef ARG_ZERO_IS_SCRIPT
5354 if (ipathend > ipath) {
5356 * HP-UX (at least) sets argv[0] to the script name,
5357 * which makes $^X incorrect. And Digital UNIX and Linux,
5358 * at least, set argv[0] to the basename of the Perl
5359 * interpreter. So, having found "#!", we'll set it right.
5361 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5363 assert(SvPOK(x) || SvGMAGICAL(x));
5364 if (sv_eq(x, CopFILESV(PL_curcop))) {
5365 sv_setpvn(x, ipath, ipathend - ipath);
5371 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
5372 const char * const lstart = SvPV_const(x,llen);
5374 bstart += blen - llen;
5375 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5376 sv_setpvn(x, ipath, ipathend - ipath);
5381 TAINT_NOT; /* $^X is always tainted, but that's OK */
5383 #endif /* ARG_ZERO_IS_SCRIPT */
5388 d = instr(s,"perl -");
5390 d = instr(s,"perl");
5392 /* avoid getting into infinite loops when shebang
5393 * line contains "Perl" rather than "perl" */
5395 for (d = ipathend-4; d >= ipath; --d) {
5396 if ((*d == 'p' || *d == 'P')
5397 && !ibcmp(d, "perl", 4))
5407 #ifdef ALTERNATE_SHEBANG
5409 * If the ALTERNATE_SHEBANG on this system starts with a
5410 * character that can be part of a Perl expression, then if
5411 * we see it but not "perl", we're probably looking at the
5412 * start of Perl code, not a request to hand off to some
5413 * other interpreter. Similarly, if "perl" is there, but
5414 * not in the first 'word' of the line, we assume the line
5415 * contains the start of the Perl program.
5417 if (d && *s != '#') {
5418 const char *c = ipath;
5419 while (*c && !strchr("; \t\r\n\f\v#", *c))
5422 d = NULL; /* "perl" not in first word; ignore */
5424 *s = '#'; /* Don't try to parse shebang line */
5426 #endif /* ALTERNATE_SHEBANG */
5431 !instr(s,"indir") &&
5432 instr(PL_origargv[0],"perl"))
5439 while (s < PL_bufend && isSPACE(*s))
5441 if (s < PL_bufend) {
5442 Newx(newargv,PL_origargc+3,char*);
5444 while (s < PL_bufend && !isSPACE(*s))
5447 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5450 newargv = PL_origargv;
5453 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5455 Perl_croak(aTHX_ "Can't exec %s", ipath);
5458 while (*d && !isSPACE(*d))
5460 while (SPACE_OR_TAB(*d))
5464 const bool switches_done = PL_doswitches;
5465 const U32 oldpdb = PL_perldb;
5466 const bool oldn = PL_minus_n;
5467 const bool oldp = PL_minus_p;
5471 bool baduni = FALSE;
5473 const char *d2 = d1 + 1;
5474 if (parse_unicode_opts((const char **)&d2)
5478 if (baduni || *d1 == 'M' || *d1 == 'm') {
5479 const char * const m = d1;
5480 while (*d1 && !isSPACE(*d1))
5482 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5485 d1 = moreswitches(d1);
5487 if (PL_doswitches && !switches_done) {
5488 int argc = PL_origargc;
5489 char **argv = PL_origargv;
5492 } while (argc && argv[0][0] == '-' && argv[0][1]);
5493 init_argv_symbols(argc,argv);
5495 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5496 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5497 /* if we have already added "LINE: while (<>) {",
5498 we must not do it again */
5500 sv_setpvs(PL_linestr, "");
5501 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5502 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5503 PL_last_lop = PL_last_uni = NULL;
5504 PL_preambled = FALSE;
5505 if (PERLDB_LINE || PERLDB_SAVESRC)
5506 (void)gv_fetchfile(PL_origfilename);
5513 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5514 PL_lex_state = LEX_FORMLINE;
5515 start_force(PL_curforce);
5516 NEXTVAL_NEXTTOKE.ival = 0;
5517 force_next(FORMRBRACK);
5522 #ifdef PERL_STRICT_CR
5523 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5525 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5527 case ' ': case '\t': case '\f': case 013:
5529 PL_realtokenstart = -1;
5532 PL_thiswhite = newSVpvs("");
5533 sv_catpvn(PL_thiswhite, s, 1);
5541 PL_realtokenstart = -1;
5545 if (PL_lex_state != LEX_NORMAL ||
5546 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
5547 if (*s == '#' && s == PL_linestart && PL_in_eval
5548 && !PL_rsfp && !PL_parser->filtered) {
5549 /* handle eval qq[#line 1 "foo"\n ...] */
5550 CopLINE_dec(PL_curcop);
5553 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5555 if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
5559 const bool in_comment = *s == '#';
5561 while (d < PL_bufend && *d != '\n')
5565 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5566 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5570 PL_thiswhite = newSVpvn(s, d - s);
5573 if (in_comment && d == PL_bufend
5574 && PL_lex_state == LEX_INTERPNORMAL
5575 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5576 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5579 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5580 PL_lex_state = LEX_FORMLINE;
5581 start_force(PL_curforce);
5582 NEXTVAL_NEXTTOKE.ival = 0;
5583 force_next(FORMRBRACK);
5589 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5590 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5593 TOKEN(PEG); /* make sure any #! line is accessible */
5598 /* if (PL_madskills && PL_lex_formbrack) { */
5600 while (d < PL_bufend && *d != '\n')
5604 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5605 Perl_croak(aTHX_ "panic: input overflow");
5606 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5608 PL_thiswhite = newSVpvs("");
5609 if (CopLINE(PL_curcop) == 1) {
5610 sv_setpvs(PL_thiswhite, "");
5613 sv_catpvn(PL_thiswhite, s, d - s);
5621 while (s < PL_bufend && *s != '\n')
5625 else if (s > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5626 Perl_croak(aTHX_ "panic: input overflow");
5631 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5639 while (s < PL_bufend && SPACE_OR_TAB(*s))
5642 if (strnEQ(s,"=>",2)) {
5643 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5644 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5645 OPERATOR('-'); /* unary minus */
5647 PL_last_uni = PL_oldbufptr;
5649 case 'r': ftst = OP_FTEREAD; break;
5650 case 'w': ftst = OP_FTEWRITE; break;
5651 case 'x': ftst = OP_FTEEXEC; break;
5652 case 'o': ftst = OP_FTEOWNED; break;
5653 case 'R': ftst = OP_FTRREAD; break;
5654 case 'W': ftst = OP_FTRWRITE; break;
5655 case 'X': ftst = OP_FTREXEC; break;
5656 case 'O': ftst = OP_FTROWNED; break;
5657 case 'e': ftst = OP_FTIS; break;
5658 case 'z': ftst = OP_FTZERO; break;
5659 case 's': ftst = OP_FTSIZE; break;
5660 case 'f': ftst = OP_FTFILE; break;
5661 case 'd': ftst = OP_FTDIR; break;
5662 case 'l': ftst = OP_FTLINK; break;
5663 case 'p': ftst = OP_FTPIPE; break;
5664 case 'S': ftst = OP_FTSOCK; break;
5665 case 'u': ftst = OP_FTSUID; break;
5666 case 'g': ftst = OP_FTSGID; break;
5667 case 'k': ftst = OP_FTSVTX; break;
5668 case 'b': ftst = OP_FTBLK; break;
5669 case 'c': ftst = OP_FTCHR; break;
5670 case 't': ftst = OP_FTTTY; break;
5671 case 'T': ftst = OP_FTTEXT; break;
5672 case 'B': ftst = OP_FTBINARY; break;
5673 case 'M': case 'A': case 'C':
5674 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5676 case 'M': ftst = OP_FTMTIME; break;
5677 case 'A': ftst = OP_FTATIME; break;
5678 case 'C': ftst = OP_FTCTIME; break;
5686 PL_last_lop_op = (OPCODE)ftst;
5687 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5688 "### Saw file test %c\n", (int)tmp);
5693 /* Assume it was a minus followed by a one-letter named
5694 * subroutine call (or a -bareword), then. */
5695 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5696 "### '-%c' looked like a file test but was not\n",
5703 const char tmp = *s++;
5706 if (PL_expect == XOPERATOR)
5711 else if (*s == '>') {
5714 if (isIDFIRST_lazy_if(s,UTF)) {
5715 s = force_word(s,METHOD,FALSE,TRUE);
5723 if (PL_expect == XOPERATOR) {
5724 if (*s == '=' && !PL_lex_allbrackets &&
5725 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5732 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5734 OPERATOR('-'); /* unary minus */
5740 const char tmp = *s++;
5743 if (PL_expect == XOPERATOR)
5748 if (PL_expect == XOPERATOR) {
5749 if (*s == '=' && !PL_lex_allbrackets &&
5750 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5757 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5764 if (PL_expect != XOPERATOR) {
5765 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5766 PL_expect = XOPERATOR;
5767 force_ident(PL_tokenbuf, '*');
5775 if (*s == '=' && !PL_lex_allbrackets &&
5776 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5782 if (*s == '=' && !PL_lex_allbrackets &&
5783 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5787 PL_parser->saw_infix_sigil = 1;
5791 if (PL_expect == XOPERATOR) {
5792 if (s[1] == '=' && !PL_lex_allbrackets &&
5793 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5796 PL_parser->saw_infix_sigil = 1;
5799 PL_tokenbuf[0] = '%';
5800 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5801 sizeof PL_tokenbuf - 1, FALSE);
5802 if (!PL_tokenbuf[1]) {
5805 PL_expect = XOPERATOR;
5806 force_ident_maybe_lex('%');
5810 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5811 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5816 if (PL_lex_brackets > 100)
5817 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5818 PL_lex_brackstack[PL_lex_brackets++] = 0;
5819 PL_lex_allbrackets++;
5821 const char tmp = *s++;
5826 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5828 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5831 Perl_ck_warner_d(aTHX_
5832 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5833 "Smartmatch is experimental");
5839 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5846 goto just_a_word_zero_gv;
5849 switch (PL_expect) {
5855 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5857 PL_bufptr = s; /* update in case we back off */
5860 "Use of := for an empty attribute list is not allowed");
5867 PL_expect = XTERMBLOCK;
5870 stuffstart = s - SvPVX(PL_linestr) - 1;
5874 while (isIDFIRST_lazy_if(s,UTF)) {
5877 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5878 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5879 if (tmp < 0) tmp = -tmp;
5894 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5896 d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
5898 /* MUST advance bufptr here to avoid bogus
5899 "at end of line" context messages from yyerror().
5901 PL_bufptr = s + len;
5902 yyerror("Unterminated attribute parameter in attribute list");
5906 return REPORT(0); /* EOF indicator */
5910 sv_catsv(sv, PL_lex_stuff);
5911 attrs = op_append_elem(OP_LIST, attrs,
5912 newSVOP(OP_CONST, 0, sv));
5913 SvREFCNT_dec(PL_lex_stuff);
5914 PL_lex_stuff = NULL;
5917 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5919 if (PL_in_my == KEY_our) {
5920 deprecate(":unique");
5923 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5926 /* NOTE: any CV attrs applied here need to be part of
5927 the CVf_BUILTIN_ATTRS define in cv.h! */
5928 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5930 CvLVALUE_on(PL_compcv);
5932 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5934 deprecate(":locked");
5936 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5938 CvMETHOD_on(PL_compcv);
5940 /* After we've set the flags, it could be argued that
5941 we don't need to do the attributes.pm-based setting
5942 process, and shouldn't bother appending recognized
5943 flags. To experiment with that, uncomment the
5944 following "else". (Note that's already been
5945 uncommented. That keeps the above-applied built-in
5946 attributes from being intercepted (and possibly
5947 rejected) by a package's attribute routines, but is
5948 justified by the performance win for the common case
5949 of applying only built-in attributes.) */
5951 attrs = op_append_elem(OP_LIST, attrs,
5952 newSVOP(OP_CONST, 0,
5956 if (*s == ':' && s[1] != ':')
5959 break; /* require real whitespace or :'s */
5960 /* XXX losing whitespace on sequential attributes here */
5964 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5965 if (*s != ';' && *s != '}' && *s != tmp
5966 && (tmp != '=' || *s != ')')) {
5967 const char q = ((*s == '\'') ? '"' : '\'');
5968 /* If here for an expression, and parsed no attrs, back
5970 if (tmp == '=' && !attrs) {
5974 /* MUST advance bufptr here to avoid bogus "at end of line"
5975 context messages from yyerror().
5978 yyerror( (const char *)
5980 ? Perl_form(aTHX_ "Invalid separator character "
5981 "%c%c%c in attribute list", q, *s, q)
5982 : "Unterminated attribute list" ) );
5990 start_force(PL_curforce);
5991 NEXTVAL_NEXTTOKE.opval = attrs;
5992 CURMAD('_', PL_nextwhite);
5997 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
5998 (s - SvPVX(PL_linestr)) - stuffstart);
6003 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6007 PL_lex_allbrackets--;
6011 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6012 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6016 PL_lex_allbrackets++;
6019 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6025 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6028 PL_lex_allbrackets--;
6034 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6037 if (PL_lex_brackets <= 0)
6038 yyerror("Unmatched right square bracket");
6041 PL_lex_allbrackets--;
6042 if (PL_lex_state == LEX_INTERPNORMAL) {
6043 if (PL_lex_brackets == 0) {
6044 if (*s == '-' && s[1] == '>')
6045 PL_lex_state = LEX_INTERPENDMAYBE;
6046 else if (*s != '[' && *s != '{')
6047 PL_lex_state = LEX_INTERPEND;
6054 if (PL_lex_brackets > 100) {
6055 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6057 switch (PL_expect) {
6059 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6060 PL_lex_allbrackets++;
6061 OPERATOR(HASHBRACK);
6063 while (s < PL_bufend && SPACE_OR_TAB(*s))
6066 PL_tokenbuf[0] = '\0';
6067 if (d < PL_bufend && *d == '-') {
6068 PL_tokenbuf[0] = '-';
6070 while (d < PL_bufend && SPACE_OR_TAB(*d))
6073 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
6074 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6076 while (d < PL_bufend && SPACE_OR_TAB(*d))
6079 const char minus = (PL_tokenbuf[0] == '-');
6080 s = force_word(s + minus, WORD, FALSE, TRUE);
6088 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6089 PL_lex_allbrackets++;
6094 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6095 PL_lex_allbrackets++;
6100 if (PL_oldoldbufptr == PL_last_lop)
6101 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6103 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6104 PL_lex_allbrackets++;
6107 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6109 /* This hack is to get the ${} in the message. */
6111 yyerror("syntax error");
6114 OPERATOR(HASHBRACK);
6116 /* This hack serves to disambiguate a pair of curlies
6117 * as being a block or an anon hash. Normally, expectation
6118 * determines that, but in cases where we're not in a
6119 * position to expect anything in particular (like inside
6120 * eval"") we have to resolve the ambiguity. This code
6121 * covers the case where the first term in the curlies is a
6122 * quoted string. Most other cases need to be explicitly
6123 * disambiguated by prepending a "+" before the opening
6124 * curly in order to force resolution as an anon hash.
6126 * XXX should probably propagate the outer expectation
6127 * into eval"" to rely less on this hack, but that could
6128 * potentially break current behavior of eval"".
6132 if (*s == '\'' || *s == '"' || *s == '`') {
6133 /* common case: get past first string, handling escapes */
6134 for (t++; t < PL_bufend && *t != *s;)
6135 if (*t++ == '\\' && (*t == '\\' || *t == *s))
6139 else if (*s == 'q') {
6142 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6143 && !isWORDCHAR(*t))))
6145 /* skip q//-like construct */
6147 char open, close, term;
6150 while (t < PL_bufend && isSPACE(*t))
6152 /* check for q => */
6153 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6154 OPERATOR(HASHBRACK);
6158 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6162 for (t++; t < PL_bufend; t++) {
6163 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6165 else if (*t == open)
6169 for (t++; t < PL_bufend; t++) {
6170 if (*t == '\\' && t+1 < PL_bufend)
6172 else if (*t == close && --brackets <= 0)
6174 else if (*t == open)
6181 /* skip plain q word */
6182 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6185 else if (isWORDCHAR_lazy_if(t,UTF)) {
6187 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6190 while (t < PL_bufend && isSPACE(*t))
6192 /* if comma follows first term, call it an anon hash */
6193 /* XXX it could be a comma expression with loop modifiers */
6194 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6195 || (*t == '=' && t[1] == '>')))
6196 OPERATOR(HASHBRACK);
6197 if (PL_expect == XREF)
6200 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6206 pl_yylval.ival = CopLINE(PL_curcop);
6207 if (isSPACE(*s) || *s == '#')
6208 PL_copline = NOLINE; /* invalidate current command line number */
6209 TOKEN(formbrack ? '=' : '{');
6211 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6215 if (PL_lex_brackets <= 0)
6216 yyerror("Unmatched right curly bracket");
6218 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6219 PL_lex_allbrackets--;
6220 if (PL_lex_state == LEX_INTERPNORMAL) {
6221 if (PL_lex_brackets == 0) {
6222 if (PL_expect & XFAKEBRACK) {
6223 PL_expect &= XENUMMASK;
6224 PL_lex_state = LEX_INTERPEND;
6229 PL_thiswhite = newSVpvs("");
6230 sv_catpvs(PL_thiswhite,"}");
6233 return yylex(); /* ignore fake brackets */
6235 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6236 && SvEVALED(PL_lex_repl))
6237 PL_lex_state = LEX_INTERPEND;
6238 else if (*s == '-' && s[1] == '>')
6239 PL_lex_state = LEX_INTERPENDMAYBE;
6240 else if (*s != '[' && *s != '{')
6241 PL_lex_state = LEX_INTERPEND;
6244 if (PL_expect & XFAKEBRACK) {
6245 PL_expect &= XENUMMASK;
6247 return yylex(); /* ignore fake brackets */
6249 start_force(PL_curforce);
6251 curmad('X', newSVpvn(s-1,1));
6252 CURMAD('_', PL_thiswhite);
6254 force_next(formbrack ? '.' : '}');
6255 if (formbrack) LEAVE;
6257 if (PL_madskills && !PL_thistoken)
6258 PL_thistoken = newSVpvs("");
6260 if (formbrack == 2) { /* means . where arguments were expected */
6261 start_force(PL_curforce);
6269 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6270 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6277 if (PL_expect == XOPERATOR) {
6278 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
6279 && isIDFIRST_lazy_if(s,UTF))
6281 CopLINE_dec(PL_curcop);
6282 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6283 CopLINE_inc(PL_curcop);
6285 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6286 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6290 PL_parser->saw_infix_sigil = 1;
6294 PL_tokenbuf[0] = '&';
6295 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
6296 sizeof PL_tokenbuf - 1, TRUE);
6297 if (PL_tokenbuf[1]) {
6298 PL_expect = XOPERATOR;
6299 force_ident_maybe_lex('&');
6303 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6309 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6310 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6317 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6318 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6326 const char tmp = *s++;
6328 if (!PL_lex_allbrackets &&
6329 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6336 if (!PL_lex_allbrackets &&
6337 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
6345 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6346 && strchr("+-*/%.^&|<",tmp))
6347 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6348 "Reversed %c= operator",(int)tmp);
6350 if (PL_expect == XSTATE && isALPHA(tmp) &&
6351 (s == PL_linestart+1 || s[-2] == '\n') )
6353 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6354 || PL_lex_state != LEX_NORMAL) {
6359 if (strnEQ(s,"=cut",4)) {
6375 PL_thiswhite = newSVpvs("");
6376 sv_catpvn(PL_thiswhite, PL_linestart,
6377 PL_bufend - PL_linestart);
6381 PL_parser->in_pod = 1;
6385 if (PL_expect == XBLOCK) {
6387 #ifdef PERL_STRICT_CR
6388 while (SPACE_OR_TAB(*t))
6390 while (SPACE_OR_TAB(*t) || *t == '\r')
6393 if (*t == '\n' || *t == '#') {
6396 SAVEI8(PL_parser->form_lex_state);
6397 SAVEI32(PL_lex_formbrack);
6398 PL_parser->form_lex_state = PL_lex_state;
6399 PL_lex_formbrack = PL_lex_brackets + 1;
6403 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6412 const char tmp = *s++;
6414 /* was this !=~ where !~ was meant?
6415 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6417 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6418 const char *t = s+1;
6420 while (t < PL_bufend && isSPACE(*t))
6423 if (*t == '/' || *t == '?' ||
6424 ((*t == 'm' || *t == 's' || *t == 'y')
6425 && !isWORDCHAR(t[1])) ||
6426 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6427 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6428 "!=~ should be !~");
6430 if (!PL_lex_allbrackets &&
6431 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6443 if (PL_expect != XOPERATOR) {
6444 if (s[1] != '<' && !strchr(s,'>'))
6447 s = scan_heredoc(s);
6449 s = scan_inputsymbol(s);
6450 PL_expect = XOPERATOR;
6451 TOKEN(sublex_start());
6457 if (*s == '=' && !PL_lex_allbrackets &&
6458 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6462 SHop(OP_LEFT_SHIFT);
6467 if (!PL_lex_allbrackets &&
6468 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6475 if (!PL_lex_allbrackets &&
6476 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6484 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6492 const char tmp = *s++;
6494 if (*s == '=' && !PL_lex_allbrackets &&
6495 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6499 SHop(OP_RIGHT_SHIFT);
6501 else if (tmp == '=') {
6502 if (!PL_lex_allbrackets &&
6503 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6511 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6520 if (PL_expect == XOPERATOR) {
6521 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6522 return deprecate_commaless_var_list();
6526 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6527 PL_tokenbuf[0] = '@';
6528 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6529 sizeof PL_tokenbuf - 1, FALSE);
6530 if (PL_expect == XOPERATOR)
6531 no_op("Array length", s);
6532 if (!PL_tokenbuf[1])
6534 PL_expect = XOPERATOR;
6535 force_ident_maybe_lex('#');
6539 PL_tokenbuf[0] = '$';
6540 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6541 sizeof PL_tokenbuf - 1, FALSE);
6542 if (PL_expect == XOPERATOR)
6544 if (!PL_tokenbuf[1]) {
6546 yyerror("Final $ should be \\$ or $name");
6552 const char tmp = *s;
6553 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6556 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6557 && intuit_more(s)) {
6559 PL_tokenbuf[0] = '@';
6560 if (ckWARN(WARN_SYNTAX)) {
6563 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6566 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6567 while (t < PL_bufend && *t != ']')
6569 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6570 "Multidimensional syntax %.*s not supported",
6571 (int)((t - PL_bufptr) + 1), PL_bufptr);
6575 else if (*s == '{') {
6577 PL_tokenbuf[0] = '%';
6578 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6579 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6581 char tmpbuf[sizeof PL_tokenbuf];
6584 } while (isSPACE(*t));
6585 if (isIDFIRST_lazy_if(t,UTF)) {
6587 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6592 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6593 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6594 "You need to quote \"%"UTF8f"\"",
6595 UTF8fARG(UTF, len, tmpbuf));
6601 PL_expect = XOPERATOR;
6602 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6603 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6604 if (!islop || PL_last_lop_op == OP_GREPSTART)
6605 PL_expect = XOPERATOR;
6606 else if (strchr("$@\"'`q", *s))
6607 PL_expect = XTERM; /* e.g. print $fh "foo" */
6608 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6609 PL_expect = XTERM; /* e.g. print $fh &sub */
6610 else if (isIDFIRST_lazy_if(s,UTF)) {
6611 char tmpbuf[sizeof PL_tokenbuf];
6613 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6614 if ((t2 = keyword(tmpbuf, len, 0))) {
6615 /* binary operators exclude handle interpretations */
6627 PL_expect = XTERM; /* e.g. print $fh length() */
6632 PL_expect = XTERM; /* e.g. print $fh subr() */
6635 else if (isDIGIT(*s))
6636 PL_expect = XTERM; /* e.g. print $fh 3 */
6637 else if (*s == '.' && isDIGIT(s[1]))
6638 PL_expect = XTERM; /* e.g. print $fh .3 */
6639 else if ((*s == '?' || *s == '-' || *s == '+')
6640 && !isSPACE(s[1]) && s[1] != '=')
6641 PL_expect = XTERM; /* e.g. print $fh -1 */
6642 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6644 PL_expect = XTERM; /* e.g. print $fh /.../
6645 XXX except DORDOR operator
6647 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6649 PL_expect = XTERM; /* print $fh <<"EOF" */
6652 force_ident_maybe_lex('$');
6656 if (PL_expect == XOPERATOR)
6658 PL_tokenbuf[0] = '@';
6659 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6660 if (!PL_tokenbuf[1]) {
6663 if (PL_lex_state == LEX_NORMAL)
6665 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6667 PL_tokenbuf[0] = '%';
6669 /* Warn about @ where they meant $. */
6670 if (*s == '[' || *s == '{') {
6671 if (ckWARN(WARN_SYNTAX)) {
6672 const char *t = s + 1;
6673 while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6674 t += UTF ? UTF8SKIP(t) : 1;
6675 if (*t == '}' || *t == ']') {
6677 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6678 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
6679 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6680 "Scalar value %"UTF8f" better written as $%"UTF8f,
6681 UTF8fARG(UTF, t-PL_bufptr, PL_bufptr),
6682 UTF8fARG(UTF, t-PL_bufptr-1, PL_bufptr+1));
6687 PL_expect = XOPERATOR;
6688 force_ident_maybe_lex('@');
6691 case '/': /* may be division, defined-or, or pattern */
6692 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6693 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6694 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6699 case '?': /* may either be conditional or pattern */
6700 if (PL_expect == XOPERATOR) {
6703 if (!PL_lex_allbrackets &&
6704 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6708 PL_lex_allbrackets++;
6714 /* A // operator. */
6715 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6716 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6717 LEX_FAKEEOF_LOGIC)) {
6725 if (*s == '=' && !PL_lex_allbrackets &&
6726 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6735 /* Disable warning on "study /blah/" */
6736 if (PL_oldoldbufptr == PL_last_uni
6737 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6738 || memNE(PL_last_uni, "study", 5)
6739 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6743 deprecate("?PATTERN? without explicit operator");
6744 s = scan_pat(s,OP_MATCH);
6745 TERM(sublex_start());
6749 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6750 #ifdef PERL_STRICT_CR
6753 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6755 && (s == PL_linestart || s[-1] == '\n') )
6758 formbrack = 2; /* dot seen where arguments expected */
6761 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6765 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6768 if (!PL_lex_allbrackets &&
6769 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6776 pl_yylval.ival = OPf_SPECIAL;
6782 if (*s == '=' && !PL_lex_allbrackets &&
6783 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6790 case '0': case '1': case '2': case '3': case '4':
6791 case '5': case '6': case '7': case '8': case '9':
6792 s = scan_num(s, &pl_yylval);
6793 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6794 if (PL_expect == XOPERATOR)
6799 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6800 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6801 if (PL_expect == XOPERATOR) {
6802 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6803 return deprecate_commaless_var_list();
6810 pl_yylval.ival = OP_CONST;
6811 TERM(sublex_start());
6814 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6815 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6816 if (PL_expect == XOPERATOR) {
6817 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6818 return deprecate_commaless_var_list();
6825 pl_yylval.ival = OP_CONST;
6826 /* FIXME. I think that this can be const if char *d is replaced by
6827 more localised variables. */
6828 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6829 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6830 pl_yylval.ival = OP_STRINGIFY;
6834 TERM(sublex_start());
6837 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6838 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6839 if (PL_expect == XOPERATOR)
6840 no_op("Backticks",s);
6843 readpipe_override();
6844 TERM(sublex_start());
6848 if (PL_lex_inwhat && isDIGIT(*s))
6849 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6851 if (PL_expect == XOPERATOR)
6852 no_op("Backslash",s);
6856 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6857 char *start = s + 2;
6858 while (isDIGIT(*start) || *start == '_')
6860 if (*start == '.' && isDIGIT(start[1])) {
6861 s = scan_num(s, &pl_yylval);
6864 else if ((*start == ':' && start[1] == ':')
6865 || (PL_expect == XSTATE && *start == ':'))
6867 else if (PL_expect == XSTATE) {
6869 while (d < PL_bufend && isSPACE(*d)) d++;
6870 if (*d == ':') goto keylookup;
6872 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6873 if (!isALPHA(*start) && (PL_expect == XTERM
6874 || PL_expect == XREF || PL_expect == XSTATE
6875 || PL_expect == XTERMORDORDOR)) {
6876 GV *const gv = gv_fetchpvn_flags(s, start - s,
6877 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6879 s = scan_num(s, &pl_yylval);
6886 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6939 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6941 /* Some keywords can be followed by any delimiter, including ':' */
6942 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6944 /* x::* is just a word, unless x is "CORE" */
6945 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6949 while (d < PL_bufend && isSPACE(*d))
6950 d++; /* no comments skipped here, or s### is misparsed */
6952 /* Is this a word before a => operator? */
6953 if (*d == '=' && d[1] == '>') {
6957 = (OP*)newSVOP(OP_CONST, 0,
6958 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6959 pl_yylval.opval->op_private = OPpCONST_BARE;
6963 /* Check for plugged-in keyword */
6967 char *saved_bufptr = PL_bufptr;
6969 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6971 if (result == KEYWORD_PLUGIN_DECLINE) {
6972 /* not a plugged-in keyword */
6973 PL_bufptr = saved_bufptr;
6974 } else if (result == KEYWORD_PLUGIN_STMT) {
6975 pl_yylval.opval = o;
6978 return REPORT(PLUGSTMT);
6979 } else if (result == KEYWORD_PLUGIN_EXPR) {
6980 pl_yylval.opval = o;
6982 PL_expect = XOPERATOR;
6983 return REPORT(PLUGEXPR);
6985 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6990 /* Check for built-in keyword */
6991 tmp = keyword(PL_tokenbuf, len, 0);
6993 /* Is this a label? */
6994 if (!anydelim && PL_expect == XSTATE
6995 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6997 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6998 pl_yylval.pval[len] = '\0';
6999 pl_yylval.pval[len+1] = UTF ? 1 : 0;
7004 /* Check for lexical sub */
7005 if (PL_expect != XOPERATOR) {
7006 char tmpbuf[sizeof PL_tokenbuf + 1];
7008 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7009 off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
7010 if (off != NOT_IN_PAD) {
7011 assert(off); /* we assume this is boolean-true below */
7012 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7013 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7014 HEK * const stashname = HvNAME_HEK(stash);
7015 sv = newSVhek(stashname);
7016 sv_catpvs(sv, "::");
7017 sv_catpvn_flags(sv, PL_tokenbuf, len,
7018 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7019 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7029 rv2cv_op = newOP(OP_PADANY, 0);
7030 rv2cv_op->op_targ = off;
7031 cv = find_lexical_cv(off);
7039 if (tmp < 0) { /* second-class keyword? */
7040 GV *ogv = NULL; /* override (winner) */
7041 GV *hgv = NULL; /* hidden (loser) */
7042 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7044 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7045 UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
7048 if (GvIMPORTED_CV(gv))
7050 else if (! CvMETHOD(cv))
7054 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7055 UTF ? -(I32)len : (I32)len, FALSE)) &&
7056 (gv = *gvp) && isGV_with_GP(gv) &&
7057 GvCVu(gv) && GvIMPORTED_CV(gv))
7064 tmp = 0; /* overridden by import or by GLOBAL */
7067 && -tmp==KEY_lock /* XXX generalizable kludge */
7070 tmp = 0; /* any sub overrides "weak" keyword */
7072 else { /* no override */
7074 if (tmp == KEY_dump) {
7075 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
7076 "dump() better written as CORE::dump()");
7080 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
7081 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7082 "Ambiguous call resolved as CORE::%s(), "
7083 "qualify as such or use &",
7088 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
7089 && (!anydelim || *s != '#')) {
7090 /* no override, and not s### either; skipspace is safe here
7091 * check for => on following line */
7092 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
7093 STRLEN soff = s - SvPVX(PL_linestr);
7094 s = skipspace_flags(s, LEX_NO_INCLINE);
7095 if (*s == '=' && s[1] == '>') goto fat_arrow;
7096 PL_bufptr = SvPVX(PL_linestr) + bufoff;
7097 s = SvPVX(PL_linestr) + soff;
7103 default: /* not a keyword */
7104 /* Trade off - by using this evil construction we can pull the
7105 variable gv into the block labelled keylookup. If not, then
7106 we have to give it function scope so that the goto from the
7107 earlier ':' case doesn't bypass the initialisation. */
7109 just_a_word_zero_gv:
7121 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7122 const char penultchar =
7123 lastchar && PL_bufptr - 2 >= PL_linestart
7127 SV *nextPL_nextwhite = 0;
7131 /* Get the rest if it looks like a package qualifier */
7133 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7135 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7138 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
7139 UTF8fARG(UTF, len, PL_tokenbuf),
7140 *s == '\'' ? "'" : "::");
7145 if (PL_expect == XOPERATOR) {
7146 if (PL_bufptr == PL_linestart) {
7147 CopLINE_dec(PL_curcop);
7148 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7149 CopLINE_inc(PL_curcop);
7152 no_op("Bareword",s);
7155 /* Look for a subroutine with this name in current package,
7156 unless this is a lexical sub, or name is "Foo::",
7157 in which case Foo is a bareword
7158 (and a package name). */
7160 if (len > 2 && !PL_madskills &&
7161 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
7163 if (ckWARN(WARN_BAREWORD)
7164 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7165 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7166 "Bareword \"%"UTF8f"\" refers to nonexistent package",
7167 UTF8fARG(UTF, len, PL_tokenbuf));
7169 PL_tokenbuf[len] = '\0';
7175 /* Mustn't actually add anything to a symbol table.
7176 But also don't want to "initialise" any placeholder
7177 constants that might already be there into full
7178 blown PVGVs with attached PVCV. */
7179 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7180 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
7186 /* if we saw a global override before, get the right name */
7189 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7190 len ? len : strlen(PL_tokenbuf));
7192 SV * const tmp_sv = sv;
7193 sv = newSVpvs("CORE::GLOBAL::");
7194 sv_catsv(sv, tmp_sv);
7195 SvREFCNT_dec(tmp_sv);
7199 if (PL_madskills && !PL_thistoken) {
7200 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
7201 PL_thistoken = newSVpvn(start,s - start);
7202 PL_realtokenstart = s - SvPVX(PL_linestr);
7206 /* Presume this is going to be a bareword of some sort. */
7208 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
7209 pl_yylval.opval->op_private = OPpCONST_BARE;
7211 /* And if "Foo::", then that's what it certainly is. */
7217 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7218 const_op->op_private = OPpCONST_BARE;
7219 rv2cv_op = newCVREF(0, const_op);
7220 cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
7223 /* See if it's the indirect object for a list operator. */
7225 if (PL_oldoldbufptr &&
7226 PL_oldoldbufptr < PL_bufptr &&
7227 (PL_oldoldbufptr == PL_last_lop
7228 || PL_oldoldbufptr == PL_last_uni) &&
7229 /* NO SKIPSPACE BEFORE HERE! */
7230 (PL_expect == XREF ||
7231 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
7233 bool immediate_paren = *s == '(';
7235 /* (Now we can afford to cross potential line boundary.) */
7236 s = SKIPSPACE2(s,nextPL_nextwhite);
7238 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
7241 /* Two barewords in a row may indicate method call. */
7243 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
7244 (tmp = intuit_method(s, gv, cv))) {
7246 if (tmp == METHOD && !PL_lex_allbrackets &&
7247 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7248 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7252 /* If not a declared subroutine, it's an indirect object. */
7253 /* (But it's an indir obj regardless for sort.) */
7254 /* Also, if "_" follows a filetest operator, it's a bareword */
7257 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
7259 (PL_last_lop_op != OP_MAPSTART &&
7260 PL_last_lop_op != OP_GREPSTART))))
7261 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7262 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
7265 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7270 PL_expect = XOPERATOR;
7273 s = SKIPSPACE2(s,nextPL_nextwhite);
7274 PL_nextwhite = nextPL_nextwhite;
7279 /* Is this a word before a => operator? */
7280 if (*s == '=' && s[1] == '>' && !pkgname) {
7283 /* This is our own scalar, created a few lines above,
7285 SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv);
7286 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
7287 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
7288 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
7289 SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv);
7293 /* If followed by a paren, it's certainly a subroutine. */
7298 while (SPACE_OR_TAB(*d))
7300 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
7307 PL_nextwhite = PL_thiswhite;
7310 start_force(PL_curforce);
7312 NEXTVAL_NEXTTOKE.opval =
7313 off ? rv2cv_op : pl_yylval.opval;
7314 PL_expect = XOPERATOR;
7317 PL_nextwhite = nextPL_nextwhite;
7318 curmad('X', PL_thistoken);
7319 PL_thistoken = newSVpvs("");
7323 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7324 else op_free(rv2cv_op), force_next(WORD);
7329 /* If followed by var or block, call it a method (unless sub) */
7331 if ((*s == '$' || *s == '{') && !cv) {
7333 PL_last_lop = PL_oldbufptr;
7334 PL_last_lop_op = OP_METHOD;
7335 if (!PL_lex_allbrackets &&
7336 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7337 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7341 /* If followed by a bareword, see if it looks like indir obj. */
7344 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
7345 && (tmp = intuit_method(s, gv, cv))) {
7347 if (tmp == METHOD && !PL_lex_allbrackets &&
7348 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7349 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7353 /* Not a method, so call it a subroutine (if defined) */
7356 if (lastchar == '-' && penultchar != '-') {
7357 const STRLEN l = len ? len : strlen(PL_tokenbuf);
7358 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7359 "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()",
7360 UTF8fARG(UTF, l, PL_tokenbuf),
7361 UTF8fARG(UTF, l, PL_tokenbuf));
7363 /* Check for a constant sub */
7364 if ((sv = cv_const_sv_or_av(cv))) {
7367 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7368 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7369 if (SvTYPE(sv) == SVt_PVAV)
7370 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7373 pl_yylval.opval->op_private = OPpCONST_FOLDED;
7374 pl_yylval.opval->op_folded = 1;
7375 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7380 op_free(pl_yylval.opval);
7382 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7383 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7384 PL_last_lop = PL_oldbufptr;
7385 PL_last_lop_op = OP_ENTERSUB;
7386 /* Is there a prototype? */
7393 STRLEN protolen = CvPROTOLEN(cv);
7394 const char *proto = CvPROTO(cv);
7396 proto = S_strip_spaces(aTHX_ proto, &protolen);
7399 if ((optional = *proto == ';'))
7402 while (*proto == ';');
7406 *proto == '$' || *proto == '_'
7407 || *proto == '*' || *proto == '+'
7412 *proto == '\\' && proto[1] && proto[2] == '\0'
7415 UNIPROTO(UNIOPSUB,optional);
7416 if (*proto == '\\' && proto[1] == '[') {
7417 const char *p = proto + 2;
7418 while(*p && *p != ']')
7420 if(*p == ']' && !p[1])
7421 UNIPROTO(UNIOPSUB,optional);
7423 if (*proto == '&' && *s == '{') {
7425 sv_setpvs(PL_subname, "__ANON__");
7427 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7428 if (!PL_lex_allbrackets &&
7429 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7430 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7437 PL_nextwhite = PL_thiswhite;
7440 start_force(PL_curforce);
7441 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7444 PL_nextwhite = nextPL_nextwhite;
7445 curmad('X', PL_thistoken);
7446 PL_thistoken = newSVpvs("");
7448 force_next(off ? PRIVATEREF : WORD);
7449 if (!PL_lex_allbrackets &&
7450 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7451 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7456 /* Guess harder when madskills require "best effort". */
7457 if (PL_madskills && (!gv || !GvCVu(gv))) {
7458 int probable_sub = 0;
7459 if (strchr("\"'`$@%0123456789!*+{[<", *s))
7461 else if (isALPHA(*s)) {
7465 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
7466 if (!keyword(tmpbuf, tmplen, 0))
7469 while (d < PL_bufend && isSPACE(*d))
7471 if (*d == '=' && d[1] == '>')
7476 gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
7478 op_free(pl_yylval.opval);
7480 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7481 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7482 PL_last_lop = PL_oldbufptr;
7483 PL_last_lop_op = OP_ENTERSUB;
7484 PL_nextwhite = PL_thiswhite;
7486 start_force(PL_curforce);
7487 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7489 PL_nextwhite = nextPL_nextwhite;
7490 curmad('X', PL_thistoken);
7491 PL_thistoken = newSVpvs("");
7492 force_next(off ? PRIVATEREF : WORD);
7493 if (!PL_lex_allbrackets &&
7494 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7495 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7499 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7501 force_next(off ? PRIVATEREF : WORD);
7502 if (!PL_lex_allbrackets &&
7503 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7504 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7509 /* Call it a bare word */
7511 if (PL_hints & HINT_STRICT_SUBS)
7512 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7515 /* after "print" and similar functions (corresponding to
7516 * "F? L" in opcode.pl), whatever wasn't already parsed as
7517 * a filehandle should be subject to "strict subs".
7518 * Likewise for the optional indirect-object argument to system
7519 * or exec, which can't be a bareword */
7520 if ((PL_last_lop_op == OP_PRINT
7521 || PL_last_lop_op == OP_PRTF
7522 || PL_last_lop_op == OP_SAY
7523 || PL_last_lop_op == OP_SYSTEM
7524 || PL_last_lop_op == OP_EXEC)
7525 && (PL_hints & HINT_STRICT_SUBS))
7526 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7527 if (lastchar != '-') {
7528 if (ckWARN(WARN_RESERVED)) {
7532 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7533 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7541 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7542 && saw_infix_sigil) {
7543 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7544 "Operator or semicolon missing before %c%"UTF8f,
7546 UTF8fARG(UTF, strlen(PL_tokenbuf),
7548 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7549 "Ambiguous use of %c resolved as operator %c",
7550 lastchar, lastchar);
7557 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7562 (OP*)newSVOP(OP_CONST, 0,
7563 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7566 case KEY___PACKAGE__:
7568 (OP*)newSVOP(OP_CONST, 0,
7570 ? newSVhek(HvNAME_HEK(PL_curstash))
7577 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7578 const char *pname = "main";
7581 if (PL_tokenbuf[2] == 'D')
7584 PL_curstash ? PL_curstash : PL_defstash;
7585 pname = HvNAME_get(stash);
7586 plen = HvNAMELEN (stash);
7587 if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
7589 gv = gv_fetchpvn_flags(
7590 Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
7591 plen+6, GV_ADD|putf8, SVt_PVIO
7595 GvIOp(gv) = newIO();
7596 IoIFP(GvIOp(gv)) = PL_rsfp;
7597 #if defined(HAS_FCNTL) && defined(F_SETFD)
7599 const int fd = PerlIO_fileno(PL_rsfp);
7600 fcntl(fd,F_SETFD,fd >= 3);
7603 /* Mark this internal pseudo-handle as clean */
7604 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7605 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7606 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7608 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7609 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7610 /* if the script was opened in binmode, we need to revert
7611 * it to text mode for compatibility; but only iff it has CRs
7612 * XXX this is a questionable hack at best. */
7613 if (PL_bufend-PL_bufptr > 2
7614 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7617 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7618 loc = PerlIO_tell(PL_rsfp);
7619 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7622 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7624 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7625 #endif /* NETWARE */
7627 PerlIO_seek(PL_rsfp, loc, 0);
7631 #ifdef PERLIO_LAYERS
7634 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7635 else if (PL_encoding) {
7642 XPUSHs(PL_encoding);
7644 call_method("name", G_SCALAR);
7648 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7649 Perl_form(aTHX_ ":encoding(%"SVf")",
7658 if (PL_realtokenstart >= 0) {
7659 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7661 PL_endwhite = newSVpvs("");
7662 sv_catsv(PL_endwhite, PL_thiswhite);
7664 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7665 PL_realtokenstart = -1;
7667 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7677 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
7686 if (PL_expect == XSTATE) {
7693 if (*s == ':' && s[1] == ':') {
7697 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7698 if ((*s == ':' && s[1] == ':')
7699 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7703 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7707 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7708 UTF8fARG(UTF, len, PL_tokenbuf));
7711 else if (tmp == KEY_require || tmp == KEY_do
7713 /* that's a way to remember we saw "CORE::" */
7726 LOP(OP_ACCEPT,XTERM);
7729 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7734 LOP(OP_ATAN2,XTERM);
7740 LOP(OP_BINMODE,XTERM);
7743 LOP(OP_BLESS,XTERM);
7752 /* We have to disambiguate the two senses of
7753 "continue". If the next token is a '{' then
7754 treat it as the start of a continue block;
7755 otherwise treat it as a control operator.
7765 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7775 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7784 if (!PL_cryptseen) {
7785 PL_cryptseen = TRUE;
7789 LOP(OP_CRYPT,XTERM);
7792 LOP(OP_CHMOD,XTERM);
7795 LOP(OP_CHOWN,XTERM);
7798 LOP(OP_CONNECT,XTERM);
7818 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7820 if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
7823 force_ident_maybe_lex('&');
7828 if (orig_keyword == KEY_do) {
7837 PL_hints |= HINT_BLOCK_SCOPE;
7847 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7848 STR_WITH_LEN("NDBM_File::"),
7849 STR_WITH_LEN("DB_File::"),
7850 STR_WITH_LEN("GDBM_File::"),
7851 STR_WITH_LEN("SDBM_File::"),
7852 STR_WITH_LEN("ODBM_File::"),
7854 LOP(OP_DBMOPEN,XTERM);
7860 PL_expect = XOPERATOR;
7861 s = force_word(s,WORD,TRUE,FALSE);
7868 pl_yylval.ival = CopLINE(PL_curcop);
7872 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7886 if (*s == '{') { /* block eval */
7887 PL_expect = XTERMBLOCK;
7888 UNIBRACK(OP_ENTERTRY);
7890 else { /* string eval */
7892 UNIBRACK(OP_ENTEREVAL);
7897 UNIBRACK(-OP_ENTEREVAL);
7911 case KEY_endhostent:
7917 case KEY_endservent:
7920 case KEY_endprotoent:
7931 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7933 pl_yylval.ival = CopLINE(PL_curcop);
7935 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7938 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7941 if ((PL_bufend - p) >= 3 &&
7942 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7944 else if ((PL_bufend - p) >= 4 &&
7945 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7948 if (isIDFIRST_lazy_if(p,UTF)) {
7949 p = scan_ident(p, PL_bufend,
7950 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7954 Perl_croak(aTHX_ "Missing $ on loop variable");
7956 s = SvPVX(PL_linestr) + soff;
7962 LOP(OP_FORMLINE,XTERM);
7971 LOP(OP_FCNTL,XTERM);
7977 LOP(OP_FLOCK,XTERM);
7980 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7985 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7990 LOP(OP_GREPSTART, XREF);
7993 PL_expect = XOPERATOR;
7994 s = force_word(s,WORD,TRUE,FALSE);
8009 case KEY_getpriority:
8010 LOP(OP_GETPRIORITY,XTERM);
8012 case KEY_getprotobyname:
8015 case KEY_getprotobynumber:
8016 LOP(OP_GPBYNUMBER,XTERM);
8018 case KEY_getprotoent:
8030 case KEY_getpeername:
8031 UNI(OP_GETPEERNAME);
8033 case KEY_gethostbyname:
8036 case KEY_gethostbyaddr:
8037 LOP(OP_GHBYADDR,XTERM);
8039 case KEY_gethostent:
8042 case KEY_getnetbyname:
8045 case KEY_getnetbyaddr:
8046 LOP(OP_GNBYADDR,XTERM);
8051 case KEY_getservbyname:
8052 LOP(OP_GSBYNAME,XTERM);
8054 case KEY_getservbyport:
8055 LOP(OP_GSBYPORT,XTERM);
8057 case KEY_getservent:
8060 case KEY_getsockname:
8061 UNI(OP_GETSOCKNAME);
8063 case KEY_getsockopt:
8064 LOP(OP_GSOCKOPT,XTERM);
8079 pl_yylval.ival = CopLINE(PL_curcop);
8080 Perl_ck_warner_d(aTHX_
8081 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8082 "given is experimental");
8087 orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
8095 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8097 pl_yylval.ival = CopLINE(PL_curcop);
8101 LOP(OP_INDEX,XTERM);
8107 LOP(OP_IOCTL,XTERM);
8119 PL_expect = XOPERATOR;
8120 s = force_word(s,WORD,TRUE,FALSE);
8137 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8142 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8156 LOP(OP_LISTEN,XTERM);
8165 s = scan_pat(s,OP_MATCH);
8166 TERM(sublex_start());
8169 LOP(OP_MAPSTART, XREF);
8172 LOP(OP_MKDIR,XTERM);
8175 LOP(OP_MSGCTL,XTERM);
8178 LOP(OP_MSGGET,XTERM);
8181 LOP(OP_MSGRCV,XTERM);
8184 LOP(OP_MSGSND,XTERM);
8189 PL_in_my = (U16)tmp;
8191 if (isIDFIRST_lazy_if(s,UTF)) {
8195 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8196 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
8198 if (!FEATURE_LEXSUBS_IS_ENABLED)
8200 "Experimental \"%s\" subs not enabled",
8201 tmp == KEY_my ? "my" :
8202 tmp == KEY_state ? "state" : "our");
8203 Perl_ck_warner_d(aTHX_
8204 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
8205 "The lexical_subs feature is experimental");
8208 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8209 if (!PL_in_my_stash) {
8212 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8213 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8216 if (PL_madskills) { /* just add type to declarator token */
8217 sv_catsv(PL_thistoken, PL_nextwhite);
8219 sv_catpvn(PL_thistoken, start, s - start);
8227 PL_expect = XOPERATOR;
8228 s = force_word(s,WORD,TRUE,FALSE);
8232 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8237 s = tokenize_use(0, s);
8241 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
8244 if (!PL_lex_allbrackets &&
8245 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8246 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8252 if (isIDFIRST_lazy_if(s,UTF)) {
8254 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8256 for (t=d; isSPACE(*t);)
8258 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8260 && !(t[0] == '=' && t[1] == '>')
8261 && !(t[0] == ':' && t[1] == ':')
8262 && !keyword(s, d-s, 0)
8264 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8265 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
8266 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8272 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8274 pl_yylval.ival = OP_OR;
8284 LOP(OP_OPEN_DIR,XTERM);
8287 checkcomma(s,PL_tokenbuf,"filehandle");
8291 checkcomma(s,PL_tokenbuf,"filehandle");
8310 s = force_word(s,WORD,FALSE,TRUE);
8312 s = force_strict_version(s);
8313 PL_lex_expect = XBLOCK;
8317 LOP(OP_PIPE_OP,XTERM);
8320 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8323 pl_yylval.ival = OP_CONST;
8324 TERM(sublex_start());
8331 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8334 PL_expect = XOPERATOR;
8335 if (SvCUR(PL_lex_stuff)) {
8336 int warned_comma = !ckWARN(WARN_QW);
8337 int warned_comment = warned_comma;
8338 d = SvPV_force(PL_lex_stuff, len);
8340 for (; isSPACE(*d) && len; --len, ++d)
8345 if (!warned_comma || !warned_comment) {
8346 for (; !isSPACE(*d) && len; --len, ++d) {
8347 if (!warned_comma && *d == ',') {
8348 Perl_warner(aTHX_ packWARN(WARN_QW),
8349 "Possible attempt to separate words with commas");
8352 else if (!warned_comment && *d == '#') {
8353 Perl_warner(aTHX_ packWARN(WARN_QW),
8354 "Possible attempt to put comments in qw() list");
8360 for (; !isSPACE(*d) && len; --len, ++d)
8363 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8364 words = op_append_elem(OP_LIST, words,
8365 newSVOP(OP_CONST, 0, tokeq(sv)));
8370 words = newNULLLIST();
8372 SvREFCNT_dec(PL_lex_stuff);
8373 PL_lex_stuff = NULL;
8375 PL_expect = XOPERATOR;
8376 pl_yylval.opval = sawparens(words);
8381 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8384 pl_yylval.ival = OP_STRINGIFY;
8385 if (SvIVX(PL_lex_stuff) == '\'')
8386 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8387 TERM(sublex_start());
8390 s = scan_pat(s,OP_QR);
8391 TERM(sublex_start());
8394 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8397 readpipe_override();
8398 TERM(sublex_start());
8405 PL_expect = XOPERATOR;
8407 s = force_version(s, FALSE);
8409 else if (*s != 'v' || !isDIGIT(s[1])
8410 || (s = force_version(s, TRUE), *s == 'v'))
8412 *PL_tokenbuf = '\0';
8413 s = force_word(s,WORD,TRUE,TRUE);
8414 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
8415 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8416 GV_ADD | (UTF ? SVf_UTF8 : 0));
8418 yyerror("<> should be quotes");
8420 if (orig_keyword == KEY_require) {
8428 PL_last_uni = PL_oldbufptr;
8429 PL_last_lop_op = OP_REQUIRE;
8431 return REPORT( (int)REQUIRE );
8437 PL_expect = XOPERATOR;
8438 s = force_word(s,WORD,TRUE,FALSE);
8442 LOP(OP_RENAME,XTERM);
8451 LOP(OP_RINDEX,XTERM);
8460 UNIDOR(OP_READLINE);
8463 UNIDOR(OP_BACKTICK);
8472 LOP(OP_REVERSE,XTERM);
8475 UNIDOR(OP_READLINK);
8482 if (pl_yylval.opval)
8483 TERM(sublex_start());
8485 TOKEN(1); /* force error */
8488 checkcomma(s,PL_tokenbuf,"filehandle");
8498 LOP(OP_SELECT,XTERM);
8504 LOP(OP_SEMCTL,XTERM);
8507 LOP(OP_SEMGET,XTERM);
8510 LOP(OP_SEMOP,XTERM);
8516 LOP(OP_SETPGRP,XTERM);
8518 case KEY_setpriority:
8519 LOP(OP_SETPRIORITY,XTERM);
8521 case KEY_sethostent:
8527 case KEY_setservent:
8530 case KEY_setprotoent:
8540 LOP(OP_SEEKDIR,XTERM);
8542 case KEY_setsockopt:
8543 LOP(OP_SSOCKOPT,XTERM);
8549 LOP(OP_SHMCTL,XTERM);
8552 LOP(OP_SHMGET,XTERM);
8555 LOP(OP_SHMREAD,XTERM);
8558 LOP(OP_SHMWRITE,XTERM);
8561 LOP(OP_SHUTDOWN,XTERM);
8570 LOP(OP_SOCKET,XTERM);
8572 case KEY_socketpair:
8573 LOP(OP_SOCKPAIR,XTERM);
8576 checkcomma(s,PL_tokenbuf,"subroutine name");
8579 s = force_word(s,WORD,TRUE,TRUE);
8583 LOP(OP_SPLIT,XTERM);
8586 LOP(OP_SPRINTF,XTERM);
8589 LOP(OP_SPLICE,XTERM);
8604 LOP(OP_SUBSTR,XTERM);
8610 char * const tmpbuf = PL_tokenbuf + 1;
8611 expectation attrful;
8612 bool have_name, have_proto;
8613 const int key = tmp;
8615 SV *format_name = NULL;
8621 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
8622 SV *subtoken = PL_madskills
8623 ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr))
8628 s = SKIPSPACE2(s,tmpwhite);
8634 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
8635 (*s == ':' && s[1] == ':'))
8638 SV *nametoke = NULL;
8642 attrful = XATTRBLOCK;
8643 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8647 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
8649 if (key == KEY_format)
8650 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8653 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8655 PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
8657 sv_setpvn(PL_subname, tmpbuf, len);
8659 sv_setsv(PL_subname,PL_curstname);
8660 sv_catpvs(PL_subname,"::");
8661 sv_catpvn(PL_subname,tmpbuf,len);
8663 if (SvUTF8(PL_linestr))
8664 SvUTF8_on(PL_subname);
8670 CURMAD('X', nametoke);
8671 CURMAD('_', tmpwhite);
8672 force_ident_maybe_lex('&');
8674 s = SKIPSPACE2(d,tmpwhite);
8680 if (key == KEY_my || key == KEY_our || key==KEY_state)
8683 /* diag_listed_as: Missing name in "%s sub" */
8685 "Missing name in \"%s\"", PL_bufptr);
8687 PL_expect = XTERMBLOCK;
8688 attrful = XATTRTERM;
8689 sv_setpvs(PL_subname,"?");
8693 if (key == KEY_format) {
8695 PL_thistoken = subtoken;
8699 start_force(PL_curforce);
8700 NEXTVAL_NEXTTOKE.opval
8701 = (OP*)newSVOP(OP_CONST,0, format_name);
8702 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8709 /* Look for a prototype */
8711 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8713 Perl_croak(aTHX_ "Prototype not terminated");
8714 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8719 CURMAD('q', PL_thisopen);
8720 CURMAD('_', tmpwhite);
8721 CURMAD('=', PL_thisstuff);
8722 CURMAD('Q', PL_thisclose);
8723 NEXTVAL_NEXTTOKE.opval =
8724 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8725 PL_lex_stuff = NULL;
8728 s = SKIPSPACE2(s,tmpwhite);
8736 if (*s == ':' && s[1] != ':')
8737 PL_expect = attrful;
8738 else if (*s != '{' && key == KEY_sub) {
8740 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8741 else if (*s != ';' && *s != '}')
8742 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8749 curmad('^', newSVpvs(""));
8750 CURMAD('_', tmpwhite);
8754 PL_thistoken = subtoken;
8755 PERL_UNUSED_VAR(have_proto);
8758 NEXTVAL_NEXTTOKE.opval =
8759 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8760 PL_lex_stuff = NULL;
8766 sv_setpvs(PL_subname, "__ANON__");
8768 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8772 force_ident_maybe_lex('&');
8778 LOP(OP_SYSTEM,XREF);
8781 LOP(OP_SYMLINK,XTERM);
8784 LOP(OP_SYSCALL,XTERM);
8787 LOP(OP_SYSOPEN,XTERM);
8790 LOP(OP_SYSSEEK,XTERM);
8793 LOP(OP_SYSREAD,XTERM);
8796 LOP(OP_SYSWRITE,XTERM);
8801 TERM(sublex_start());
8822 LOP(OP_TRUNCATE,XTERM);
8834 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8836 pl_yylval.ival = CopLINE(PL_curcop);
8840 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8842 pl_yylval.ival = CopLINE(PL_curcop);
8846 LOP(OP_UNLINK,XTERM);
8852 LOP(OP_UNPACK,XTERM);
8855 LOP(OP_UTIME,XTERM);
8861 LOP(OP_UNSHIFT,XTERM);
8864 s = tokenize_use(1, s);
8874 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8876 pl_yylval.ival = CopLINE(PL_curcop);
8877 Perl_ck_warner_d(aTHX_
8878 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8879 "when is experimental");
8883 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8885 pl_yylval.ival = CopLINE(PL_curcop);
8889 PL_hints |= HINT_BLOCK_SCOPE;
8896 LOP(OP_WAITPID,XTERM);
8905 ctl_l[0] = toCTRL('L');
8907 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8910 /* Make sure $^L is defined */
8911 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8916 if (PL_expect == XOPERATOR) {
8917 if (*s == '=' && !PL_lex_allbrackets &&
8918 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8926 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8928 pl_yylval.ival = OP_XOR;
8934 #pragma segment Main
8940 Looks up an identifier in the pad or in a package
8943 PRIVATEREF if this is a lexical name.
8944 WORD if this belongs to a package.
8947 if we're in a my declaration
8948 croak if they tried to say my($foo::bar)
8949 build the ops for a my() declaration
8950 if it's an access to a my() variable
8951 build ops for access to a my() variable
8952 if in a dq string, and they've said @foo and we can't find @foo
8954 build ops for a bareword
8958 S_pending_ident(pTHX)
8962 const char pit = (char)pl_yylval.ival;
8963 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8964 /* All routes through this function want to know if there is a colon. */
8965 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8967 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8968 "### Pending identifier '%s'\n", PL_tokenbuf); });
8970 /* if we're in a my(), we can't allow dynamics here.
8971 $foo'bar has already been turned into $foo::bar, so
8972 just check for colons.
8974 if it's a legal name, the OP is a PADANY.
8977 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8979 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8980 "variable %s in \"our\"",
8981 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8982 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8986 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8987 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8988 UTF ? SVf_UTF8 : 0);
8990 pl_yylval.opval = newOP(OP_PADANY, 0);
8991 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8992 UTF ? SVf_UTF8 : 0);
8998 build the ops for accesses to a my() variable.
9003 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
9004 UTF ? SVf_UTF8 : 0);
9005 if (tmp != NOT_IN_PAD) {
9006 /* might be an "our" variable" */
9007 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9008 /* build ops for a bareword */
9009 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9010 HEK * const stashname = HvNAME_HEK(stash);
9011 SV * const sym = newSVhek(stashname);
9012 sv_catpvs(sym, "::");
9013 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9014 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
9015 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9019 ? (GV_ADDMULTI | GV_ADDINEVAL)
9022 ((PL_tokenbuf[0] == '$') ? SVt_PV
9023 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9028 pl_yylval.opval = newOP(OP_PADANY, 0);
9029 pl_yylval.opval->op_targ = tmp;
9035 Whine if they've said @foo in a doublequoted string,
9036 and @foo isn't a variable we can find in the symbol
9039 if (ckWARN(WARN_AMBIGUOUS) &&
9040 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
9041 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
9042 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
9043 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9044 /* DO NOT warn for @- and @+ */
9045 && !( PL_tokenbuf[2] == '\0' &&
9046 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
9049 /* Downgraded from fatal to warning 20000522 mjd */
9050 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9051 "Possible unintended interpolation of %"UTF8f
9053 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9057 /* build ops for a bareword */
9058 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
9059 newSVpvn_flags(PL_tokenbuf + 1,
9061 UTF ? SVf_UTF8 : 0 ));
9062 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9064 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
9065 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
9066 | ( UTF ? SVf_UTF8 : 0 ),
9067 ((PL_tokenbuf[0] == '$') ? SVt_PV
9068 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9074 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9078 PERL_ARGS_ASSERT_CHECKCOMMA;
9080 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9081 if (ckWARN(WARN_SYNTAX)) {
9084 for (w = s+2; *w && level; w++) {
9092 /* the list of chars below is for end of statements or
9093 * block / parens, boolean operators (&&, ||, //) and branch
9094 * constructs (or, and, if, until, unless, while, err, for).
9095 * Not a very solid hack... */
9096 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9097 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9098 "%s (...) interpreted as function",name);
9101 while (s < PL_bufend && isSPACE(*s))
9105 while (s < PL_bufend && isSPACE(*s))
9107 if (isIDFIRST_lazy_if(s,UTF)) {
9108 const char * const w = s;
9109 s += UTF ? UTF8SKIP(s) : 1;
9110 while (isWORDCHAR_lazy_if(s,UTF))
9111 s += UTF ? UTF8SKIP(s) : 1;
9112 while (s < PL_bufend && isSPACE(*s))
9116 if (keyword(w, s - w, 0))
9119 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9120 if (gv && GvCVu(gv))
9122 Perl_croak(aTHX_ "No comma allowed after %s", what);
9127 /* S_new_constant(): do any overload::constant lookup.
9129 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9130 Best used as sv=new_constant(..., sv, ...).
9131 If s, pv are NULL, calls subroutine with one argument,
9132 and <type> is used with error messages only.
9133 <type> is assumed to be well formed UTF-8 */
9136 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9137 SV *sv, SV *pv, const char *type, STRLEN typelen)
9140 HV * table = GvHV(PL_hintgv); /* ^H */
9145 const char *why1 = "", *why2 = "", *why3 = "";
9147 PERL_ARGS_ASSERT_NEW_CONSTANT;
9148 /* We assume that this is true: */
9149 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9152 /* charnames doesn't work well if there have been errors found */
9153 if (PL_error_count > 0 && *key == 'c')
9155 SvREFCNT_dec_NN(sv);
9156 return &PL_sv_undef;
9159 sv_2mortal(sv); /* Parent created it permanently */
9161 || ! (PL_hints & HINT_LOCALIZE_HH)
9162 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9167 /* Here haven't found what we're looking for. If it is charnames,
9168 * perhaps it needs to be loaded. Try doing that before giving up */
9170 Perl_load_module(aTHX_
9172 newSVpvs("_charnames"),
9173 /* version parameter; no need to specify it, as if
9174 * we get too early a version, will fail anyway,
9175 * not being able to find '_charnames' */
9181 table = GvHV(PL_hintgv);
9183 && (PL_hints & HINT_LOCALIZE_HH)
9184 && (cvp = hv_fetch(table, key, keylen, FALSE))
9190 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9191 msg = Perl_form(aTHX_
9192 "Constant(%.*s) unknown",
9193 (int)(type ? typelen : len),
9199 why3 = "} is not defined";
9202 msg = Perl_form(aTHX_
9203 /* The +3 is for '\N{'; -4 for that, plus '}' */
9204 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9208 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9209 (int)(type ? typelen : len),
9210 (type ? type: s), why1, why2, why3);
9213 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9214 return SvREFCNT_inc_simple_NN(sv);
9219 pv = newSVpvn_flags(s, len, SVs_TEMP);
9221 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9223 typesv = &PL_sv_undef;
9225 PUSHSTACKi(PERLSI_OVERLOAD);
9237 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9241 /* Check the eval first */
9242 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9244 const char * errstr;
9245 sv_catpvs(errsv, "Propagated");
9246 errstr = SvPV_const(errsv, errlen);
9247 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9249 res = SvREFCNT_inc_simple_NN(sv);
9253 SvREFCNT_inc_simple_void_NN(res);
9262 why1 = "Call to &{$^H{";
9264 why3 = "}} did not return a defined value";
9266 (void)sv_2mortal(sv);
9273 PERL_STATIC_INLINE void
9274 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
9276 PERL_ARGS_ASSERT_PARSE_IDENT;
9280 Perl_croak(aTHX_ "%s", ident_too_long);
9281 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
9282 /* The UTF-8 case must come first, otherwise things
9283 * like c\N{COMBINING TILDE} would start failing, as the
9284 * isWORDCHAR_A case below would gobble the 'c' up.
9287 char *t = *s + UTF8SKIP(*s);
9288 while (isIDCONT_utf8((U8*)t))
9290 if (*d + (t - *s) > e)
9291 Perl_croak(aTHX_ "%s", ident_too_long);
9292 Copy(*s, *d, t - *s, char);
9296 else if ( isWORDCHAR_A(**s) ) {
9299 } while isWORDCHAR_A(**s);
9301 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
9306 else if (allow_package && **s == ':' && (*s)[1] == ':'
9307 /* Disallow things like Foo::$bar. For the curious, this is
9308 * the code path that triggers the "Bad name after" warning
9309 * when looking for barewords.
9311 && (*s)[2] != '$') {
9321 /* Returns a NUL terminated string, with the length of the string written to
9325 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9329 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9330 bool is_utf8 = cBOOL(UTF);
9332 PERL_ARGS_ASSERT_SCAN_WORD;
9334 parse_ident(&s, &d, e, allow_package, is_utf8);
9341 S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9344 char *bracket = NULL;
9347 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9348 bool is_utf8 = cBOOL(UTF);
9350 PERL_ARGS_ASSERT_SCAN_IDENT;
9355 while (isDIGIT(*s)) {
9357 Perl_croak(aTHX_ "%s", ident_too_long);
9362 parse_ident(&s, &d, e, 1, is_utf8);
9367 /* Either a digit variable, or parse_ident() found an identifier
9368 (anything valid as a bareword), so job done and return. */
9369 if (PL_lex_state != LEX_NORMAL)
9370 PL_lex_state = LEX_INTERPENDMAYBE;
9373 if (*s == '$' && s[1] &&
9374 (isIDFIRST_lazy_if(s+1,is_utf8)
9375 || isDIGIT_A((U8)s[1])
9378 || strnEQ(s+1,"::",2)) )
9380 /* Dereferencing a value in a scalar variable.
9381 The alternatives are different syntaxes for a scalar variable.
9382 Using ' as a leading package separator isn't allowed. :: is. */
9385 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9389 while (s < send && SPACE_OR_TAB(*s))
9393 #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
9394 || isCNTRL_A((U8)(d)) \
9395 || isDIGIT_A((U8)(d)) \
9396 || (!(u) && !UTF8_IS_INVARIANT((U8)(d))))
9398 && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
9401 const STRLEN skip = UTF8SKIP(s);
9404 for ( i = 0; i < skip; i++ )
9412 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9413 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9417 /* Warn about ambiguous code after unary operators if {...} notation isn't
9418 used. There's no difference in ambiguity; it's merely a heuristic
9419 about when not to warn. */
9420 else if (ck_uni && !bracket)
9423 /* If we were processing {...} notation then... */
9424 if (isIDFIRST_lazy_if(d,is_utf8)) {
9425 /* if it starts as a valid identifier, assume that it is one.
9426 (the later check for } being at the expected point will trap
9427 cases where this doesn't pan out.) */
9428 d += is_utf8 ? UTF8SKIP(d) : 1;
9429 parse_ident(&s, &d, e, 1, is_utf8);
9431 while (s < send && SPACE_OR_TAB(*s))
9433 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9434 /* ${foo[0]} and ${foo{bar}} notation. */
9435 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9436 const char * const brack =
9438 ((*s == '[') ? "[...]" : "{...}");
9439 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9440 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9441 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9442 funny, dest, brack, funny, dest, brack);
9445 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9446 PL_lex_allbrackets++;
9450 /* Handle extended ${^Foo} variables
9451 * 1999-02-27 mjd-perl-patch@plover.com */
9452 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9456 while (isWORDCHAR(*s) && d < e) {
9460 Perl_croak(aTHX_ "%s", ident_too_long);
9464 while (s < send && SPACE_OR_TAB(*s))
9467 /* Expect to find a closing } after consuming any trailing whitespace.
9471 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9472 PL_lex_state = LEX_INTERPEND;
9475 if (PL_lex_state == LEX_NORMAL) {
9476 if (ckWARN(WARN_AMBIGUOUS) &&
9477 (keyword(dest, d - dest, 0)
9478 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
9480 SV *tmp = newSVpvn_flags( dest, d - dest,
9481 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9484 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9485 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9486 funny, tmp, funny, tmp);
9491 /* Didn't find the closing } at the point we expected, so restore
9492 state such that the next thing to process is the opening { and */
9493 s = bracket; /* let the parser handle it */
9497 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9498 PL_lex_state = LEX_INTERPEND;
9503 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
9505 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
9506 * the parse starting at 's', based on the subset that are valid in this
9507 * context input to this routine in 'valid_flags'. Advances s. Returns
9508 * TRUE if the input should be treated as a valid flag, so the next char
9509 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
9510 * first call on the current regex. This routine will set it to any
9511 * charset modifier found. The caller shouldn't change it. This way,
9512 * another charset modifier encountered in the parse can be detected as an
9513 * error, as we have decided to allow only one */
9516 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9518 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9519 if (isWORDCHAR_lazy_if(*s, UTF)) {
9520 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9521 UTF ? SVf_UTF8 : 0);
9523 /* Pretend that it worked, so will continue processing before
9532 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
9533 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9534 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9535 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9536 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9537 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9538 case LOCALE_PAT_MOD:
9540 goto multiple_charsets;
9542 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9545 case UNICODE_PAT_MOD:
9547 goto multiple_charsets;
9549 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9552 case ASCII_RESTRICT_PAT_MOD:
9554 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9558 /* Error if previous modifier wasn't an 'a', but if it was, see
9559 * if, and accept, a second occurrence (only) */
9561 || get_regex_charset(*pmfl)
9562 != REGEX_ASCII_RESTRICTED_CHARSET)
9564 goto multiple_charsets;
9566 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9570 case DEPENDS_PAT_MOD:
9572 goto multiple_charsets;
9574 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9583 if (*charset != c) {
9584 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9586 else if (c == 'a') {
9587 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9590 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9593 /* Pretend that it worked, so will continue processing before dieing */
9599 S_scan_pat(pTHX_ char *start, I32 type)
9604 const char * const valid_flags =
9605 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9606 char charset = '\0'; /* character set modifier */
9611 PERL_ARGS_ASSERT_SCAN_PAT;
9613 s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
9614 TRUE /* look for escaped bracketed metas */ );
9617 const char * const delimiter = skipspace(start);
9621 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9622 : "Search pattern not terminated" ));
9625 pm = (PMOP*)newPMOP(type, 0);
9626 if (PL_multi_open == '?') {
9627 /* This is the only point in the code that sets PMf_ONCE: */
9628 pm->op_pmflags |= PMf_ONCE;
9630 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9631 allows us to restrict the list needed by reset to just the ??
9633 assert(type != OP_TRANS);
9635 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9638 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9641 elements = mg->mg_len / sizeof(PMOP**);
9642 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9643 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9644 mg->mg_len = elements * sizeof(PMOP**);
9645 PmopSTASH_set(pm,PL_curstash);
9652 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9653 * anon CV. False positives like qr/[(?{]/ are harmless */
9655 if (type == OP_QR) {
9657 char *e, *p = SvPV(PL_lex_stuff, len);
9659 for (; p < e; p++) {
9660 if (p[0] == '(' && p[1] == '?'
9661 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9663 pm->op_pmflags |= PMf_HAS_CV;
9667 pm->op_pmflags |= PMf_IS_QR;
9670 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9672 if (PL_madskills && modstart != s) {
9673 SV* tmptoken = newSVpvn(modstart, s - modstart);
9674 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9677 /* issue a warning if /c is specified,but /g is not */
9678 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9680 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9681 "Use of /c modifier is meaningless without /g" );
9684 PL_lex_op = (OP*)pm;
9685 pl_yylval.ival = OP_MATCH;
9690 S_scan_subst(pTHX_ char *start)
9697 char charset = '\0'; /* character set modifier */
9702 PERL_ARGS_ASSERT_SCAN_SUBST;
9704 pl_yylval.ival = OP_NULL;
9706 s = scan_str(start,!!PL_madskills,FALSE,FALSE,
9707 TRUE /* look for escaped bracketed metas */ );
9710 Perl_croak(aTHX_ "Substitution pattern not terminated");
9712 if (s[-1] == PL_multi_open)
9716 CURMAD('q', PL_thisopen);
9717 CURMAD('_', PL_thiswhite);
9718 CURMAD('E', PL_thisstuff);
9719 CURMAD('Q', PL_thisclose);
9720 PL_realtokenstart = s - SvPVX(PL_linestr);
9724 first_start = PL_multi_start;
9725 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9728 SvREFCNT_dec(PL_lex_stuff);
9729 PL_lex_stuff = NULL;
9731 Perl_croak(aTHX_ "Substitution replacement not terminated");
9733 PL_multi_start = first_start; /* so whole substitution is taken together */
9735 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9739 CURMAD('z', PL_thisopen);
9740 CURMAD('R', PL_thisstuff);
9741 CURMAD('Z', PL_thisclose);
9747 if (*s == EXEC_PAT_MOD) {
9751 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9760 curmad('m', newSVpvn(modstart, s - modstart));
9761 append_madprops(PL_thismad, (OP*)pm, 0);
9765 if ((pm->op_pmflags & PMf_CONTINUE)) {
9766 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9770 SV * const repl = newSVpvs("");
9773 pm->op_pmflags |= PMf_EVAL;
9776 sv_catpvs(repl, "eval ");
9778 sv_catpvs(repl, "do ");
9780 sv_catpvs(repl, "{");
9781 sv_catsv(repl, PL_sublex_info.repl);
9782 sv_catpvs(repl, "}");
9784 SvREFCNT_dec(PL_sublex_info.repl);
9785 PL_sublex_info.repl = repl;
9788 PL_lex_op = (OP*)pm;
9789 pl_yylval.ival = OP_SUBST;
9794 S_scan_trans(pTHX_ char *start)
9802 bool nondestruct = 0;
9807 PERL_ARGS_ASSERT_SCAN_TRANS;
9809 pl_yylval.ival = OP_NULL;
9811 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
9813 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9815 if (s[-1] == PL_multi_open)
9819 CURMAD('q', PL_thisopen);
9820 CURMAD('_', PL_thiswhite);
9821 CURMAD('E', PL_thisstuff);
9822 CURMAD('Q', PL_thisclose);
9823 PL_realtokenstart = s - SvPVX(PL_linestr);
9827 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9830 SvREFCNT_dec(PL_lex_stuff);
9831 PL_lex_stuff = NULL;
9833 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9836 CURMAD('z', PL_thisopen);
9837 CURMAD('R', PL_thisstuff);
9838 CURMAD('Z', PL_thisclose);
9841 complement = del = squash = 0;
9848 complement = OPpTRANS_COMPLEMENT;
9851 del = OPpTRANS_DELETE;
9854 squash = OPpTRANS_SQUASH;
9866 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9867 o->op_private &= ~OPpTRANS_ALL;
9868 o->op_private |= del|squash|complement|
9869 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9870 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9873 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9878 curmad('m', newSVpvn(modstart, s - modstart));
9879 append_madprops(PL_thismad, o, 0);
9888 Takes a pointer to the first < in <<FOO.
9889 Returns a pointer to the byte following <<FOO.
9891 This function scans a heredoc, which involves different methods
9892 depending on whether we are in a string eval, quoted construct, etc.
9893 This is because PL_linestr could containing a single line of input, or
9894 a whole string being evalled, or the contents of the current quote-
9897 The two basic methods are:
9898 - Steal lines from the input stream
9899 - Scan the heredoc in PL_linestr and remove it therefrom
9901 In a file scope or filtered eval, the first method is used; in a
9902 string eval, the second.
9904 In a quote-like operator, we have to choose between the two,
9905 depending on where we can find a newline. We peek into outer lex-
9906 ing scopes until we find one with a newline in it. If we reach the
9907 outermost lexing scope and it is a file, we use the stream method.
9908 Otherwise it is treated as an eval.
9912 S_scan_heredoc(pTHX_ char *s)
9915 I32 op_type = OP_SCALAR;
9922 const bool infile = PL_rsfp || PL_parser->filtered;
9923 LEXSHARED *shared = PL_parser->lex_shared;
9925 I32 stuffstart = s - SvPVX(PL_linestr);
9928 PL_realtokenstart = -1;
9931 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9934 d = PL_tokenbuf + 1;
9935 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9936 *PL_tokenbuf = '\n';
9938 while (SPACE_OR_TAB(*peek))
9940 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9943 s = delimcpy(d, e, s, PL_bufend, term, &len);
9945 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9951 /* <<\FOO is equivalent to <<'FOO' */
9955 if (!isWORDCHAR_lazy_if(s,UTF))
9956 deprecate("bare << to mean <<\"\"");
9957 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9962 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9963 Perl_croak(aTHX_ "Delimiter for here document is too long");
9966 len = d - PL_tokenbuf;
9970 tstart = PL_tokenbuf + 1;
9971 PL_thisclose = newSVpvn(tstart, len - 1);
9972 tstart = SvPVX(PL_linestr) + stuffstart;
9973 PL_thisopen = newSVpvn(tstart, s - tstart);
9974 stuffstart = s - SvPVX(PL_linestr);
9977 #ifndef PERL_STRICT_CR
9978 d = strchr(s, '\r');
9980 char * const olds = s;
9982 while (s < PL_bufend) {
9988 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9997 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10002 if (PL_madskills) {
10003 tstart = SvPVX(PL_linestr) + stuffstart;
10005 sv_catpvn(PL_thisstuff, tstart, s - tstart);
10007 PL_thisstuff = newSVpvn(tstart, s - tstart);
10010 stuffstart = s - SvPVX(PL_linestr);
10013 tmpstr = newSV_type(SVt_PVIV);
10014 SvGROW(tmpstr, 80);
10015 if (term == '\'') {
10016 op_type = OP_CONST;
10017 SvIV_set(tmpstr, -1);
10019 else if (term == '`') {
10020 op_type = OP_BACKTICK;
10021 SvIV_set(tmpstr, '\\');
10024 PL_multi_start = CopLINE(PL_curcop) + 1;
10025 PL_multi_open = PL_multi_close = '<';
10026 /* inside a string eval or quote-like operator */
10027 if (!infile || PL_lex_inwhat) {
10030 char * const olds = s;
10031 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
10032 /* These two fields are not set until an inner lexing scope is
10033 entered. But we need them set here. */
10034 shared->ls_bufptr = s;
10035 shared->ls_linestr = PL_linestr;
10037 /* Look for a newline. If the current buffer does not have one,
10038 peek into the line buffer of the parent lexing scope, going
10039 up as many levels as necessary to find one with a newline
10042 while (!(s = (char *)memchr(
10043 (void *)shared->ls_bufptr, '\n',
10044 SvEND(shared->ls_linestr)-shared->ls_bufptr
10046 shared = shared->ls_prev;
10047 /* shared is only null if we have gone beyond the outermost
10048 lexing scope. In a file, we will have broken out of the
10049 loop in the previous iteration. In an eval, the string buf-
10050 fer ends with "\n;", so the while condition above will have
10051 evaluated to false. So shared can never be null. */
10053 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10054 most lexing scope. In a file, shared->ls_linestr at that
10055 level is just one line, so there is no body to steal. */
10056 if (infile && !shared->ls_prev) {
10062 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10065 linestr = shared->ls_linestr;
10066 bufend = SvEND(linestr);
10068 while (s < bufend - len + 1 &&
10069 memNE(s,PL_tokenbuf,len) ) {
10071 ++shared->herelines;
10073 if (s >= bufend - len + 1) {
10076 sv_setpvn(tmpstr,d+1,s-d);
10078 if (PL_madskills) {
10080 sv_catpvn(PL_thisstuff, d + 1, s - d);
10082 PL_thisstuff = newSVpvn(d + 1, s - d);
10083 stuffstart = s - SvPVX(PL_linestr);
10087 /* the preceding stmt passes a newline */
10088 shared->herelines++;
10090 /* s now points to the newline after the heredoc terminator.
10091 d points to the newline before the body of the heredoc.
10094 /* We are going to modify linestr in place here, so set
10095 aside copies of the string if necessary for re-evals or
10097 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10098 check shared->re_eval_str. */
10099 if (shared->re_eval_start || shared->re_eval_str) {
10100 /* Set aside the rest of the regexp */
10101 if (!shared->re_eval_str)
10102 shared->re_eval_str =
10103 newSVpvn(shared->re_eval_start,
10104 bufend - shared->re_eval_start);
10105 shared->re_eval_start -= s-d;
10107 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
10108 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
10109 cx->blk_eval.cur_text == linestr)
10111 cx->blk_eval.cur_text = newSVsv(linestr);
10112 SvSCREAM_on(cx->blk_eval.cur_text);
10114 /* Copy everything from s onwards back to d. */
10115 Move(s,d,bufend-s + 1,char);
10116 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10117 /* Setting PL_bufend only applies when we have not dug deeper
10118 into other scopes, because sublex_done sets PL_bufend to
10119 SvEND(PL_linestr). */
10120 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10127 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
10128 term = PL_tokenbuf[1];
10130 linestr_save = PL_linestr; /* must restore this afterwards */
10131 d = s; /* and this */
10132 PL_linestr = newSVpvs("");
10133 PL_bufend = SvPVX(PL_linestr);
10136 if (PL_madskills) {
10137 tstart = SvPVX(PL_linestr) + stuffstart;
10139 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10141 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10144 PL_bufptr = PL_bufend;
10145 CopLINE_set(PL_curcop,
10146 PL_multi_start + shared->herelines);
10147 if (!lex_next_chunk(LEX_NO_TERM)
10148 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10149 SvREFCNT_dec(linestr_save);
10152 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10153 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10154 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10155 /* ^That should be enough to avoid this needing to grow: */
10156 sv_catpvs(PL_linestr, "\n\0");
10157 assert(s == SvPVX(PL_linestr));
10158 PL_bufend = SvEND(PL_linestr);
10162 stuffstart = s - SvPVX(PL_linestr);
10164 shared->herelines++;
10165 PL_last_lop = PL_last_uni = NULL;
10166 #ifndef PERL_STRICT_CR
10167 if (PL_bufend - PL_linestart >= 2) {
10168 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
10169 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10171 PL_bufend[-2] = '\n';
10173 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10175 else if (PL_bufend[-1] == '\r')
10176 PL_bufend[-1] = '\n';
10178 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10179 PL_bufend[-1] = '\n';
10181 if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
10182 SvREFCNT_dec(PL_linestr);
10183 PL_linestr = linestr_save;
10184 PL_linestart = SvPVX(linestr_save);
10185 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10190 sv_catsv(tmpstr,PL_linestr);
10194 PL_multi_end = CopLINE(PL_curcop);
10195 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10196 SvPV_shrink_to_cur(tmpstr);
10199 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10201 else if (PL_encoding)
10202 sv_recode_to_utf8(tmpstr, PL_encoding);
10204 PL_lex_stuff = tmpstr;
10205 pl_yylval.ival = op_type;
10209 SvREFCNT_dec(tmpstr);
10210 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10211 missingterm(PL_tokenbuf + 1);
10214 /* scan_inputsymbol
10215 takes: current position in input buffer
10216 returns: new position in input buffer
10217 side-effects: pl_yylval and lex_op are set.
10222 <FH> read from filehandle
10223 <pkg::FH> read from package qualified filehandle
10224 <pkg'FH> read from package qualified filehandle
10225 <$fh> read from filehandle in $fh
10226 <*.h> filename glob
10231 S_scan_inputsymbol(pTHX_ char *start)
10234 char *s = start; /* current position in buffer */
10237 char *d = PL_tokenbuf; /* start of temp holding space */
10238 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10240 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10242 end = strchr(s, '\n');
10245 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10247 /* die if we didn't have space for the contents of the <>,
10248 or if it didn't end, or if we see a newline
10251 if (len >= (I32)sizeof PL_tokenbuf)
10252 Perl_croak(aTHX_ "Excessively long <> operator");
10254 Perl_croak(aTHX_ "Unterminated <> operator");
10259 Remember, only scalar variables are interpreted as filehandles by
10260 this code. Anything more complex (e.g., <$fh{$num}>) will be
10261 treated as a glob() call.
10262 This code makes use of the fact that except for the $ at the front,
10263 a scalar variable and a filehandle look the same.
10265 if (*d == '$' && d[1]) d++;
10267 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10268 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
10269 d += UTF ? UTF8SKIP(d) : 1;
10271 /* If we've tried to read what we allow filehandles to look like, and
10272 there's still text left, then it must be a glob() and not a getline.
10273 Use scan_str to pull out the stuff between the <> and treat it
10274 as nothing more than a string.
10277 if (d - PL_tokenbuf != len) {
10278 pl_yylval.ival = OP_GLOB;
10279 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
10281 Perl_croak(aTHX_ "Glob not terminated");
10285 bool readline_overriden = FALSE;
10288 /* we're in a filehandle read situation */
10291 /* turn <> into <ARGV> */
10293 Copy("ARGV",d,5,char);
10295 /* Check whether readline() is overriden */
10296 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
10298 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
10300 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
10301 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
10302 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
10303 readline_overriden = TRUE;
10305 /* if <$fh>, create the ops to turn the variable into a
10309 /* try to find it in the pad for this block, otherwise find
10310 add symbol table ops
10312 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
10313 if (tmp != NOT_IN_PAD) {
10314 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10315 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10316 HEK * const stashname = HvNAME_HEK(stash);
10317 SV * const sym = sv_2mortal(newSVhek(stashname));
10318 sv_catpvs(sym, "::");
10319 sv_catpv(sym, d+1);
10324 OP * const o = newOP(OP_PADSV, 0);
10326 PL_lex_op = readline_overriden
10327 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10328 op_append_elem(OP_LIST, o,
10329 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10330 : (OP*)newUNOP(OP_READLINE, 0, o);
10339 ? (GV_ADDMULTI | GV_ADDINEVAL)
10340 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
10342 PL_lex_op = readline_overriden
10343 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10344 op_append_elem(OP_LIST,
10345 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10346 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10347 : (OP*)newUNOP(OP_READLINE, 0,
10348 newUNOP(OP_RV2SV, 0,
10349 newGVOP(OP_GV, 0, gv)));
10351 if (!readline_overriden)
10352 PL_lex_op->op_flags |= OPf_SPECIAL;
10353 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10354 pl_yylval.ival = OP_NULL;
10357 /* If it's none of the above, it must be a literal filehandle
10358 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10360 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10361 PL_lex_op = readline_overriden
10362 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10363 op_append_elem(OP_LIST,
10364 newGVOP(OP_GV, 0, gv),
10365 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10366 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10367 pl_yylval.ival = OP_NULL;
10376 takes: start position in buffer
10377 keep_quoted preserve \ on the embedded delimiter(s)
10378 keep_delims preserve the delimiters around the string
10379 re_reparse compiling a run-time /(?{})/:
10380 collapse // to /, and skip encoding src
10381 returns: position to continue reading from buffer
10382 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10383 updates the read buffer.
10385 This subroutine pulls a string out of the input. It is called for:
10386 q single quotes q(literal text)
10387 ' single quotes 'literal text'
10388 qq double quotes qq(interpolate $here please)
10389 " double quotes "interpolate $here please"
10390 qx backticks qx(/bin/ls -l)
10391 ` backticks `/bin/ls -l`
10392 qw quote words @EXPORT_OK = qw( func() $spam )
10393 m// regexp match m/this/
10394 s/// regexp substitute s/this/that/
10395 tr/// string transliterate tr/this/that/
10396 y/// string transliterate y/this/that/
10397 ($*@) sub prototypes sub foo ($)
10398 (stuff) sub attr parameters sub foo : attr(stuff)
10399 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10401 In most of these cases (all but <>, patterns and transliterate)
10402 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10403 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10404 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10407 It skips whitespace before the string starts, and treats the first
10408 character as the delimiter. If the delimiter is one of ([{< then
10409 the corresponding "close" character )]}> is used as the closing
10410 delimiter. It allows quoting of delimiters, and if the string has
10411 balanced delimiters ([{<>}]) it allows nesting.
10413 On success, the SV with the resulting string is put into lex_stuff or,
10414 if that is already non-NULL, into lex_repl. The second case occurs only
10415 when parsing the RHS of the special constructs s/// and tr/// (y///).
10416 For convenience, the terminating delimiter character is stuffed into
10421 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
10422 bool deprecate_escaped_meta /* Should we issue a deprecation warning
10423 for certain paired metacharacters that
10424 appear escaped within it */
10428 SV *sv; /* scalar value: string */
10429 const char *tmps; /* temp string, used for delimiter matching */
10430 char *s = start; /* current position in the buffer */
10431 char term; /* terminating character */
10432 char *to; /* current position in the sv's data */
10433 I32 brackets = 1; /* bracket nesting level */
10434 bool has_utf8 = FALSE; /* is there any utf8 content? */
10435 I32 termcode; /* terminating char. code */
10436 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10437 STRLEN termlen; /* length of terminating string */
10438 int last_off = 0; /* last position for nesting bracket */
10439 char *escaped_open = NULL;
10445 PERL_ARGS_ASSERT_SCAN_STR;
10447 /* skip space before the delimiter */
10453 if (PL_realtokenstart >= 0) {
10454 stuffstart = PL_realtokenstart;
10455 PL_realtokenstart = -1;
10458 stuffstart = start - SvPVX(PL_linestr);
10460 /* mark where we are, in case we need to report errors */
10463 /* after skipping whitespace, the next character is the terminator */
10466 termcode = termstr[0] = term;
10470 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10471 Copy(s, termstr, termlen, U8);
10472 if (!UTF8_IS_INVARIANT(term))
10476 /* mark where we are */
10477 PL_multi_start = CopLINE(PL_curcop);
10478 PL_multi_open = term;
10480 /* find corresponding closing delimiter */
10481 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10482 termcode = termstr[0] = term = tmps[5];
10484 PL_multi_close = term;
10486 /* A warning is raised if the input parameter requires it for escaped (by a
10487 * backslash) paired metacharacters {} [] and () when the delimiters are
10488 * those same characters, and the backslash is ineffective. This doesn't
10489 * happen for <>, as they aren't metas. */
10490 if (deprecate_escaped_meta
10491 && (PL_multi_open == PL_multi_close
10492 || ! ckWARN_d(WARN_DEPRECATED)
10493 || PL_multi_open == '<'))
10495 deprecate_escaped_meta = FALSE;
10498 /* create a new SV to hold the contents. 79 is the SV's initial length.
10499 What a random number. */
10500 sv = newSV_type(SVt_PVIV);
10502 SvIV_set(sv, termcode);
10503 (void)SvPOK_only(sv); /* validate pointer */
10505 /* move past delimiter and try to read a complete string */
10507 sv_catpvn(sv, s, termlen);
10510 tstart = SvPVX(PL_linestr) + stuffstart;
10511 if (PL_madskills && !PL_thisopen && !keep_delims) {
10512 PL_thisopen = newSVpvn(tstart, s - tstart);
10513 stuffstart = s - SvPVX(PL_linestr);
10517 if (PL_encoding && !UTF && !re_reparse) {
10521 int offset = s - SvPVX_const(PL_linestr);
10522 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10523 &offset, (char*)termstr, termlen);
10527 if (SvIsCOW(PL_linestr)) {
10528 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
10529 STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
10530 STRLEN last_lop_pos, re_eval_start_pos, s_pos;
10531 char *buf = SvPVX(PL_linestr);
10532 bufend_pos = PL_parser->bufend - buf;
10533 bufptr_pos = PL_parser->bufptr - buf;
10534 oldbufptr_pos = PL_parser->oldbufptr - buf;
10535 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
10536 linestart_pos = PL_parser->linestart - buf;
10537 last_uni_pos = PL_parser->last_uni
10538 ? PL_parser->last_uni - buf
10540 last_lop_pos = PL_parser->last_lop
10541 ? PL_parser->last_lop - buf
10543 re_eval_start_pos =
10544 PL_parser->lex_shared->re_eval_start ?
10545 PL_parser->lex_shared->re_eval_start - buf : 0;
10548 sv_force_normal(PL_linestr);
10550 buf = SvPVX(PL_linestr);
10551 PL_parser->bufend = buf + bufend_pos;
10552 PL_parser->bufptr = buf + bufptr_pos;
10553 PL_parser->oldbufptr = buf + oldbufptr_pos;
10554 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
10555 PL_parser->linestart = buf + linestart_pos;
10556 if (PL_parser->last_uni)
10557 PL_parser->last_uni = buf + last_uni_pos;
10558 if (PL_parser->last_lop)
10559 PL_parser->last_lop = buf + last_lop_pos;
10560 if (PL_parser->lex_shared->re_eval_start)
10561 PL_parser->lex_shared->re_eval_start =
10562 buf + re_eval_start_pos;
10565 ns = SvPVX_const(PL_linestr) + offset;
10566 svlast = SvEND(sv) - 1;
10568 for (; s < ns; s++) {
10569 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10570 COPLINE_INC_WITH_HERELINES;
10573 goto read_more_line;
10575 /* handle quoted delimiters */
10576 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10578 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10580 if ((svlast-1 - t) % 2) {
10581 if (!keep_quoted) {
10582 *(svlast-1) = term;
10584 SvCUR_set(sv, SvCUR(sv) - 1);
10589 if (PL_multi_open == PL_multi_close) {
10595 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10596 /* At here, all closes are "was quoted" one,
10597 so we don't check PL_multi_close. */
10599 if (!keep_quoted && *(t+1) == PL_multi_open)
10604 else if (*t == PL_multi_open)
10612 SvCUR_set(sv, w - SvPVX_const(sv));
10614 last_off = w - SvPVX(sv);
10615 if (--brackets <= 0)
10620 if (!keep_delims) {
10621 SvCUR_set(sv, SvCUR(sv) - 1);
10627 /* extend sv if need be */
10628 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10629 /* set 'to' to the next character in the sv's string */
10630 to = SvPVX(sv)+SvCUR(sv);
10632 /* if open delimiter is the close delimiter read unbridle */
10633 if (PL_multi_open == PL_multi_close) {
10634 for (; s < PL_bufend; s++,to++) {
10635 /* embedded newlines increment the current line number */
10636 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10637 COPLINE_INC_WITH_HERELINES;
10638 /* handle quoted delimiters */
10639 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10642 || (re_reparse && s[1] == '\\'))
10645 /* any other quotes are simply copied straight through */
10649 /* terminate when run out of buffer (the for() condition), or
10650 have found the terminator */
10651 else if (*s == term) {
10654 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10657 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10663 /* if the terminator isn't the same as the start character (e.g.,
10664 matched brackets), we have to allow more in the quoting, and
10665 be prepared for nested brackets.
10668 /* read until we run out of string, or we find the terminator */
10669 for (; s < PL_bufend; s++,to++) {
10670 /* embedded newlines increment the line count */
10671 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10672 COPLINE_INC_WITH_HERELINES;
10673 /* backslashes can escape the open or closing characters */
10674 if (*s == '\\' && s+1 < PL_bufend) {
10675 if (!keep_quoted &&
10676 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10680 /* Here, 'deprecate_escaped_meta' is true iff the
10681 * delimiters are paired metacharacters, and 's' points
10682 * to an occurrence of one of them within the string,
10683 * which was preceded by a backslash. If this is a
10684 * context where the delimiter is also a metacharacter,
10685 * the backslash is useless, and deprecated. () and []
10686 * are meta in any context. {} are meta only when
10687 * appearing in a quantifier or in things like '\p{'
10688 * (but '\\p{' isn't meta). They also aren't meta
10689 * unless there is a matching closed, escaped char
10690 * later on within the string. If 's' points to an
10691 * open, set a flag; if to a close, test that flag, and
10692 * raise a warning if it was set */
10694 if (deprecate_escaped_meta) {
10695 if (*s == PL_multi_open) {
10699 /* Look for a closing '\}' */
10700 else if (regcurly(s, TRUE)) {
10703 /* Look for e.g. '\x{' */
10704 else if (s - start > 2
10705 && _generic_isCC(*(s-2),
10706 _CC_BACKSLASH_FOO_LBRACE_IS_META))
10707 { /* Exclude '\\x', '\\\\x', etc. */
10708 char *lookbehind = s - 4;
10709 bool is_meta = TRUE;
10710 while (lookbehind >= start
10711 && *lookbehind == '\\')
10713 is_meta = ! is_meta;
10721 else if (escaped_open) {
10722 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10723 "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open);
10724 escaped_open = NULL;
10731 /* allow nested opens and closes */
10732 else if (*s == PL_multi_close && --brackets <= 0)
10734 else if (*s == PL_multi_open)
10736 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10741 /* terminate the copied string and update the sv's end-of-string */
10743 SvCUR_set(sv, to - SvPVX_const(sv));
10746 * this next chunk reads more into the buffer if we're not done yet
10750 break; /* handle case where we are done yet :-) */
10752 #ifndef PERL_STRICT_CR
10753 if (to - SvPVX_const(sv) >= 2) {
10754 if ((to[-2] == '\r' && to[-1] == '\n') ||
10755 (to[-2] == '\n' && to[-1] == '\r'))
10759 SvCUR_set(sv, to - SvPVX_const(sv));
10761 else if (to[-1] == '\r')
10764 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10769 /* if we're out of file, or a read fails, bail and reset the current
10770 line marker so we can report where the unterminated string began
10773 if (PL_madskills) {
10774 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10776 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10778 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10781 COPLINE_INC_WITH_HERELINES;
10782 PL_bufptr = PL_bufend;
10783 if (!lex_next_chunk(0)) {
10785 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10794 /* at this point, we have successfully read the delimited string */
10796 if (!PL_encoding || UTF || re_reparse) {
10798 if (PL_madskills) {
10799 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10800 const int len = s - tstart;
10802 sv_catpvn(PL_thisstuff, tstart, len);
10804 PL_thisstuff = newSVpvn(tstart, len);
10805 if (!PL_thisclose && !keep_delims)
10806 PL_thisclose = newSVpvn(s,termlen);
10811 sv_catpvn(sv, s, termlen);
10816 if (PL_madskills) {
10817 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10818 const int len = s - tstart - termlen;
10820 sv_catpvn(PL_thisstuff, tstart, len);
10822 PL_thisstuff = newSVpvn(tstart, len);
10823 if (!PL_thisclose && !keep_delims)
10824 PL_thisclose = newSVpvn(s - termlen,termlen);
10828 if (has_utf8 || (PL_encoding && !re_reparse))
10831 PL_multi_end = CopLINE(PL_curcop);
10833 /* if we allocated too much space, give some back */
10834 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10835 SvLEN_set(sv, SvCUR(sv) + 1);
10836 SvPV_renew(sv, SvLEN(sv));
10839 /* decide whether this is the first or second quoted string we've read
10844 PL_sublex_info.repl = sv;
10852 takes: pointer to position in buffer
10853 returns: pointer to new position in buffer
10854 side-effects: builds ops for the constant in pl_yylval.op
10856 Read a number in any of the formats that Perl accepts:
10858 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10859 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10862 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10864 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10867 If it reads a number without a decimal point or an exponent, it will
10868 try converting the number to an integer and see if it can do so
10869 without loss of precision.
10873 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10876 const char *s = start; /* current position in buffer */
10877 char *d; /* destination in temp buffer */
10878 char *e; /* end of temp buffer */
10879 NV nv; /* number read, as a double */
10880 SV *sv = NULL; /* place to put the converted number */
10881 bool floatit; /* boolean: int or float? */
10882 const char *lastub = NULL; /* position of last underbar */
10883 static const char* const number_too_long = "Number too long";
10885 PERL_ARGS_ASSERT_SCAN_NUM;
10887 /* We use the first character to decide what type of number this is */
10891 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10893 /* if it starts with a 0, it could be an octal number, a decimal in
10894 0.13 disguise, or a hexadecimal number, or a binary number. */
10898 u holds the "number so far"
10899 shift the power of 2 of the base
10900 (hex == 4, octal == 3, binary == 1)
10901 overflowed was the number more than we can hold?
10903 Shift is used when we add a digit. It also serves as an "are
10904 we in octal/hex/binary?" indicator to disallow hex characters
10905 when in octal mode.
10910 bool overflowed = FALSE;
10911 bool just_zero = TRUE; /* just plain 0 or binary number? */
10912 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10913 static const char* const bases[5] =
10914 { "", "binary", "", "octal", "hexadecimal" };
10915 static const char* const Bases[5] =
10916 { "", "Binary", "", "Octal", "Hexadecimal" };
10917 static const char* const maxima[5] =
10919 "0b11111111111111111111111111111111",
10923 const char *base, *Base, *max;
10925 /* check for hex */
10926 if (s[1] == 'x' || s[1] == 'X') {
10930 } else if (s[1] == 'b' || s[1] == 'B') {
10935 /* check for a decimal in disguise */
10936 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10938 /* so it must be octal */
10945 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10946 "Misplaced _ in number");
10950 base = bases[shift];
10951 Base = Bases[shift];
10952 max = maxima[shift];
10954 /* read the rest of the number */
10956 /* x is used in the overflow test,
10957 b is the digit we're adding on. */
10962 /* if we don't mention it, we're done */
10966 /* _ are ignored -- but warned about if consecutive */
10968 if (lastub && s == lastub + 1)
10969 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10970 "Misplaced _ in number");
10974 /* 8 and 9 are not octal */
10975 case '8': case '9':
10977 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10981 case '2': case '3': case '4':
10982 case '5': case '6': case '7':
10984 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10987 case '0': case '1':
10988 b = *s++ & 15; /* ASCII digit -> value of digit */
10992 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10993 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10994 /* make sure they said 0x */
10997 b = (*s++ & 7) + 9;
10999 /* Prepare to put the digit we have onto the end
11000 of the number so far. We check for overflows.
11006 x = u << shift; /* make room for the digit */
11008 if ((x >> shift) != u
11009 && !(PL_hints & HINT_NEW_BINARY)) {
11012 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11013 "Integer overflow in %s number",
11016 u = x | b; /* add the digit to the end */
11019 n *= nvshift[shift];
11020 /* If an NV has not enough bits in its
11021 * mantissa to represent an UV this summing of
11022 * small low-order numbers is a waste of time
11023 * (because the NV cannot preserve the
11024 * low-order bits anyway): we could just
11025 * remember when did we overflow and in the
11026 * end just multiply n by the right
11034 /* if we get here, we had success: make a scalar value from
11039 /* final misplaced underbar check */
11040 if (s[-1] == '_') {
11041 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11045 if (n > 4294967295.0)
11046 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11047 "%s number > %s non-portable",
11053 if (u > 0xffffffff)
11054 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11055 "%s number > %s non-portable",
11060 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11061 sv = new_constant(start, s - start, "integer",
11062 sv, NULL, NULL, 0);
11063 else if (PL_hints & HINT_NEW_BINARY)
11064 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11069 handle decimal numbers.
11070 we're also sent here when we read a 0 as the first digit
11072 case '1': case '2': case '3': case '4': case '5':
11073 case '6': case '7': case '8': case '9': case '.':
11076 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11079 /* read next group of digits and _ and copy into d */
11080 while (isDIGIT(*s) || *s == '_') {
11081 /* skip underscores, checking for misplaced ones
11085 if (lastub && s == lastub + 1)
11086 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11087 "Misplaced _ in number");
11091 /* check for end of fixed-length buffer */
11093 Perl_croak(aTHX_ "%s", number_too_long);
11094 /* if we're ok, copy the character */
11099 /* final misplaced underbar check */
11100 if (lastub && s == lastub + 1) {
11101 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11104 /* read a decimal portion if there is one. avoid
11105 3..5 being interpreted as the number 3. followed
11108 if (*s == '.' && s[1] != '.') {
11113 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11114 "Misplaced _ in number");
11118 /* copy, ignoring underbars, until we run out of digits.
11120 for (; isDIGIT(*s) || *s == '_'; s++) {
11121 /* fixed length buffer check */
11123 Perl_croak(aTHX_ "%s", number_too_long);
11125 if (lastub && s == lastub + 1)
11126 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11127 "Misplaced _ in number");
11133 /* fractional part ending in underbar? */
11134 if (s[-1] == '_') {
11135 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11136 "Misplaced _ in number");
11138 if (*s == '.' && isDIGIT(s[1])) {
11139 /* oops, it's really a v-string, but without the "v" */
11145 /* read exponent part, if present */
11146 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
11150 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
11151 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
11153 /* stray preinitial _ */
11155 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11156 "Misplaced _ in number");
11160 /* allow positive or negative exponent */
11161 if (*s == '+' || *s == '-')
11164 /* stray initial _ */
11166 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11167 "Misplaced _ in number");
11171 /* read digits of exponent */
11172 while (isDIGIT(*s) || *s == '_') {
11175 Perl_croak(aTHX_ "%s", number_too_long);
11179 if (((lastub && s == lastub + 1) ||
11180 (!isDIGIT(s[1]) && s[1] != '_')))
11181 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11182 "Misplaced _ in number");
11190 We try to do an integer conversion first if no characters
11191 indicating "float" have been found.
11196 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11198 if (flags == IS_NUMBER_IN_UV) {
11200 sv = newSViv(uv); /* Prefer IVs over UVs. */
11203 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11204 if (uv <= (UV) IV_MIN)
11205 sv = newSViv(-(IV)uv);
11212 /* terminate the string */
11214 nv = Atof(PL_tokenbuf);
11219 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11220 const char *const key = floatit ? "float" : "integer";
11221 const STRLEN keylen = floatit ? 5 : 7;
11222 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11223 key, keylen, sv, NULL, NULL, 0);
11227 /* if it starts with a v, it could be a v-string */
11230 sv = newSV(5); /* preallocate storage space */
11231 ENTER_with_name("scan_vstring");
11233 s = scan_vstring(s, PL_bufend, sv);
11234 SvREFCNT_inc_simple_void_NN(sv);
11235 LEAVE_with_name("scan_vstring");
11239 /* make the op for the constant and return */
11242 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11244 lvalp->opval = NULL;
11250 S_scan_formline(pTHX_ char *s)
11255 SV * const stuff = newSVpvs("");
11256 bool needargs = FALSE;
11257 bool eofmt = FALSE;
11259 char *tokenstart = s;
11260 SV* savewhite = NULL;
11262 if (PL_madskills) {
11263 savewhite = PL_thiswhite;
11268 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11270 while (!needargs) {
11273 #ifdef PERL_STRICT_CR
11274 while (SPACE_OR_TAB(*t))
11277 while (SPACE_OR_TAB(*t) || *t == '\r')
11280 if (*t == '\n' || t == PL_bufend) {
11285 eol = (char *) memchr(s,'\n',PL_bufend-s);
11289 for (t = s; t < eol; t++) {
11290 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11292 goto enough; /* ~~ must be first line in formline */
11294 if (*t == '@' || *t == '^')
11298 sv_catpvn(stuff, s, eol-s);
11299 #ifndef PERL_STRICT_CR
11300 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11301 char *end = SvPVX(stuff) + SvCUR(stuff);
11304 SvCUR_set(stuff, SvCUR(stuff) - 1);
11312 if ((PL_rsfp || PL_parser->filtered)
11313 && PL_parser->form_lex_state == LEX_NORMAL) {
11316 if (PL_madskills) {
11318 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
11320 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
11323 PL_bufptr = PL_bufend;
11324 COPLINE_INC_WITH_HERELINES;
11325 got_some = lex_next_chunk(0);
11326 CopLINE_dec(PL_curcop);
11329 tokenstart = PL_bufptr;
11337 if (!SvCUR(stuff) || needargs)
11338 PL_lex_state = PL_parser->form_lex_state;
11339 if (SvCUR(stuff)) {
11340 PL_expect = XSTATE;
11342 start_force(PL_curforce);
11343 NEXTVAL_NEXTTOKE.ival = 0;
11344 force_next(FORMLBRACK);
11347 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11349 else if (PL_encoding)
11350 sv_recode_to_utf8(stuff, PL_encoding);
11352 start_force(PL_curforce);
11353 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
11357 SvREFCNT_dec(stuff);
11359 PL_lex_formbrack = 0;
11362 if (PL_madskills) {
11364 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
11366 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
11367 PL_thiswhite = savewhite;
11374 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11377 const I32 oldsavestack_ix = PL_savestack_ix;
11378 CV* const outsidecv = PL_compcv;
11380 SAVEI32(PL_subline);
11381 save_item(PL_subname);
11382 SAVESPTR(PL_compcv);
11384 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11385 CvFLAGS(PL_compcv) |= flags;
11387 PL_subline = CopLINE(PL_curcop);
11388 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11389 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11390 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11391 if (outsidecv && CvPADLIST(outsidecv))
11392 CvPADLIST(PL_compcv)->xpadl_outid =
11393 PadlistNAMES(CvPADLIST(outsidecv));
11395 return oldsavestack_ix;
11399 #pragma segment Perl_yylex
11402 S_yywarn(pTHX_ const char *const s, U32 flags)
11406 PERL_ARGS_ASSERT_YYWARN;
11408 PL_in_eval |= EVAL_WARNONLY;
11409 yyerror_pv(s, flags);
11410 PL_in_eval &= ~EVAL_WARNONLY;
11415 Perl_yyerror(pTHX_ const char *const s)
11417 PERL_ARGS_ASSERT_YYERROR;
11418 return yyerror_pvn(s, strlen(s), 0);
11422 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11424 PERL_ARGS_ASSERT_YYERROR_PV;
11425 return yyerror_pvn(s, strlen(s), flags);
11429 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11432 const char *context = NULL;
11435 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11436 int yychar = PL_parser->yychar;
11438 PERL_ARGS_ASSERT_YYERROR_PVN;
11440 if (!yychar || (yychar == ';' && !PL_rsfp))
11441 sv_catpvs(where_sv, "at EOF");
11442 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
11443 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
11444 PL_oldbufptr != PL_bufptr) {
11447 The code below is removed for NetWare because it abends/crashes on NetWare
11448 when the script has error such as not having the closing quotes like:
11449 if ($var eq "value)
11450 Checking of white spaces is anyway done in NetWare code.
11453 while (isSPACE(*PL_oldoldbufptr))
11456 context = PL_oldoldbufptr;
11457 contlen = PL_bufptr - PL_oldoldbufptr;
11459 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
11460 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
11463 The code below is removed for NetWare because it abends/crashes on NetWare
11464 when the script has error such as not having the closing quotes like:
11465 if ($var eq "value)
11466 Checking of white spaces is anyway done in NetWare code.
11469 while (isSPACE(*PL_oldbufptr))
11472 context = PL_oldbufptr;
11473 contlen = PL_bufptr - PL_oldbufptr;
11475 else if (yychar > 255)
11476 sv_catpvs(where_sv, "next token ???");
11477 else if (yychar == -2) { /* YYEMPTY */
11478 if (PL_lex_state == LEX_NORMAL ||
11479 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11480 sv_catpvs(where_sv, "at end of line");
11481 else if (PL_lex_inpat)
11482 sv_catpvs(where_sv, "within pattern");
11484 sv_catpvs(where_sv, "within string");
11487 sv_catpvs(where_sv, "next char ");
11489 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11490 else if (isPRINT_LC(yychar)) {
11491 const char string = yychar;
11492 sv_catpvn(where_sv, &string, 1);
11495 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11497 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11498 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11499 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11501 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
11502 UTF8fARG(UTF, contlen, context));
11504 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
11505 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
11506 Perl_sv_catpvf(aTHX_ msg,
11507 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11508 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11511 if (PL_in_eval & EVAL_WARNONLY) {
11512 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
11516 if (PL_error_count >= 10) {
11518 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
11519 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11520 SVfARG(errsv), OutCopFILE(PL_curcop));
11522 Perl_croak(aTHX_ "%s has too many errors.\n",
11523 OutCopFILE(PL_curcop));
11526 PL_in_my_stash = NULL;
11530 #pragma segment Main
11534 S_swallow_bom(pTHX_ U8 *s)
11537 const STRLEN slen = SvCUR(PL_linestr);
11539 PERL_ARGS_ASSERT_SWALLOW_BOM;
11543 if (s[1] == 0xFE) {
11544 /* UTF-16 little-endian? (or UTF-32LE?) */
11545 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11546 /* diag_listed_as: Unsupported script encoding %s */
11547 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11548 #ifndef PERL_NO_UTF16_FILTER
11549 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11551 if (PL_bufend > (char*)s) {
11552 s = add_utf16_textfilter(s, TRUE);
11555 /* diag_listed_as: Unsupported script encoding %s */
11556 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11561 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11562 #ifndef PERL_NO_UTF16_FILTER
11563 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11565 if (PL_bufend > (char *)s) {
11566 s = add_utf16_textfilter(s, FALSE);
11569 /* diag_listed_as: Unsupported script encoding %s */
11570 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11575 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11576 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11577 s += 3; /* UTF-8 */
11583 if (s[2] == 0xFE && s[3] == 0xFF) {
11584 /* UTF-32 big-endian */
11585 /* diag_listed_as: Unsupported script encoding %s */
11586 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11589 else if (s[2] == 0 && s[3] != 0) {
11592 * are a good indicator of UTF-16BE. */
11593 #ifndef PERL_NO_UTF16_FILTER
11594 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11595 s = add_utf16_textfilter(s, FALSE);
11597 /* diag_listed_as: Unsupported script encoding %s */
11598 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11604 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
11605 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11606 s += 4; /* UTF-8 */
11612 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11615 * are a good indicator of UTF-16LE. */
11616 #ifndef PERL_NO_UTF16_FILTER
11617 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11618 s = add_utf16_textfilter(s, TRUE);
11620 /* diag_listed_as: Unsupported script encoding %s */
11621 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11629 #ifndef PERL_NO_UTF16_FILTER
11631 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11634 SV *const filter = FILTER_DATA(idx);
11635 /* We re-use this each time round, throwing the contents away before we
11637 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11638 SV *const utf8_buffer = filter;
11639 IV status = IoPAGE(filter);
11640 const bool reverse = cBOOL(IoLINES(filter));
11643 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11645 /* As we're automatically added, at the lowest level, and hence only called
11646 from this file, we can be sure that we're not called in block mode. Hence
11647 don't bother writing code to deal with block mode. */
11649 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11652 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11654 DEBUG_P(PerlIO_printf(Perl_debug_log,
11655 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11656 FPTR2DPTR(void *, S_utf16_textfilter),
11657 reverse ? 'l' : 'b', idx, maxlen, status,
11658 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11665 /* First, look in our buffer of existing UTF-8 data: */
11666 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11670 } else if (status == 0) {
11672 IoPAGE(filter) = 0;
11673 nl = SvEND(utf8_buffer);
11676 STRLEN got = nl - SvPVX(utf8_buffer);
11677 /* Did we have anything to append? */
11679 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11680 /* Everything else in this code works just fine if SVp_POK isn't
11681 set. This, however, needs it, and we need it to work, else
11682 we loop infinitely because the buffer is never consumed. */
11683 sv_chop(utf8_buffer, nl);
11687 /* OK, not a complete line there, so need to read some more UTF-16.
11688 Read an extra octect if the buffer currently has an odd number. */
11692 if (SvCUR(utf16_buffer) >= 2) {
11693 /* Location of the high octet of the last complete code point.
11694 Gosh, UTF-16 is a pain. All the benefits of variable length,
11695 *coupled* with all the benefits of partial reads and
11697 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11698 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11700 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11704 /* We have the first half of a surrogate. Read more. */
11705 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11708 status = FILTER_READ(idx + 1, utf16_buffer,
11709 160 + (SvCUR(utf16_buffer) & 1));
11710 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11711 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11714 IoPAGE(filter) = status;
11719 chars = SvCUR(utf16_buffer) >> 1;
11720 have = SvCUR(utf8_buffer);
11721 SvGROW(utf8_buffer, have + chars * 3 + 1);
11724 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11725 (U8*)SvPVX_const(utf8_buffer) + have,
11726 chars * 2, &newlen);
11728 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11729 (U8*)SvPVX_const(utf8_buffer) + have,
11730 chars * 2, &newlen);
11732 SvCUR_set(utf8_buffer, have + newlen);
11735 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11736 it's private to us, and utf16_to_utf8{,reversed} take a
11737 (pointer,length) pair, rather than a NUL-terminated string. */
11738 if(SvCUR(utf16_buffer) & 1) {
11739 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11740 SvCUR_set(utf16_buffer, 1);
11742 SvCUR_set(utf16_buffer, 0);
11745 DEBUG_P(PerlIO_printf(Perl_debug_log,
11746 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11748 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11749 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11754 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11756 SV *filter = filter_add(S_utf16_textfilter, NULL);
11758 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11760 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11761 sv_setpvs(filter, "");
11762 IoLINES(filter) = reversed;
11763 IoPAGE(filter) = 1; /* Not EOF */
11765 /* Sadly, we have to return a valid pointer, come what may, so we have to
11766 ignore any error return from this. */
11767 SvCUR_set(PL_linestr, 0);
11768 if (FILTER_READ(0, PL_linestr, 0)) {
11769 SvUTF8_on(PL_linestr);
11771 SvUTF8_on(PL_linestr);
11773 PL_bufend = SvEND(PL_linestr);
11774 return (U8*)SvPVX(PL_linestr);
11779 Returns a pointer to the next character after the parsed
11780 vstring, as well as updating the passed in sv.
11782 Function must be called like
11784 sv = sv_2mortal(newSV(5));
11785 s = scan_vstring(s,e,sv);
11787 where s and e are the start and end of the string.
11788 The sv should already be large enough to store the vstring
11789 passed in, for performance reasons.
11791 This function may croak if fatal warnings are enabled in the
11792 calling scope, hence the sv_2mortal in the example (to prevent
11793 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11799 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11802 const char *pos = s;
11803 const char *start = s;
11805 PERL_ARGS_ASSERT_SCAN_VSTRING;
11807 if (*pos == 'v') pos++; /* get past 'v' */
11808 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11810 if ( *pos != '.') {
11811 /* this may not be a v-string if followed by => */
11812 const char *next = pos;
11813 while (next < e && isSPACE(*next))
11815 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11816 /* return string not v-string */
11817 sv_setpvn(sv,(char *)s,pos-s);
11818 return (char *)pos;
11822 if (!isALPHA(*pos)) {
11823 U8 tmpbuf[UTF8_MAXBYTES+1];
11826 s++; /* get past 'v' */
11831 /* this is atoi() that tolerates underscores */
11834 const char *end = pos;
11836 while (--end >= s) {
11838 const UV orev = rev;
11839 rev += (*end - '0') * mult;
11842 /* diag_listed_as: Integer overflow in %s number */
11843 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11844 "Integer overflow in decimal number");
11848 if (rev > 0x7FFFFFFF)
11849 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11851 /* Append native character for the rev point */
11852 tmpend = uvchr_to_utf8(tmpbuf, rev);
11853 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11854 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11856 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11862 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11866 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11873 Perl_keyword_plugin_standard(pTHX_
11874 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11876 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11877 PERL_UNUSED_CONTEXT;
11878 PERL_UNUSED_ARG(keyword_ptr);
11879 PERL_UNUSED_ARG(keyword_len);
11880 PERL_UNUSED_ARG(op_ptr);
11881 return KEYWORD_PLUGIN_DECLINE;
11884 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11886 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11888 SAVEI32(PL_lex_brackets);
11889 if (PL_lex_brackets > 100)
11890 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11891 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11892 SAVEI32(PL_lex_allbrackets);
11893 PL_lex_allbrackets = 0;
11894 SAVEI8(PL_lex_fakeeof);
11895 PL_lex_fakeeof = (U8)fakeeof;
11896 if(yyparse(gramtype) && !PL_parser->error_count)
11897 qerror(Perl_mess(aTHX_ "Parse error"));
11900 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11902 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11906 SAVEVPTR(PL_eval_root);
11907 PL_eval_root = NULL;
11908 parse_recdescent(gramtype, fakeeof);
11914 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11916 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11919 if (flags & ~PARSE_OPTIONAL)
11920 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11921 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11922 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11923 if (!PL_parser->error_count)
11924 qerror(Perl_mess(aTHX_ "Parse error"));
11925 exprop = newOP(OP_NULL, 0);
11931 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11933 Parse a Perl arithmetic expression. This may contain operators of precedence
11934 down to the bit shift operators. The expression must be followed (and thus
11935 terminated) either by a comparison or lower-precedence operator or by
11936 something that would normally terminate an expression such as semicolon.
11937 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11938 otherwise it is mandatory. It is up to the caller to ensure that the
11939 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11940 the source of the code to be parsed and the lexical context for the
11943 The op tree representing the expression is returned. If an optional
11944 expression is absent, a null pointer is returned, otherwise the pointer
11947 If an error occurs in parsing or compilation, in most cases a valid op
11948 tree is returned anyway. The error is reflected in the parser state,
11949 normally resulting in a single exception at the top level of parsing
11950 which covers all the compilation errors that occurred. Some compilation
11951 errors, however, will throw an exception immediately.
11957 Perl_parse_arithexpr(pTHX_ U32 flags)
11959 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11963 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11965 Parse a Perl term expression. This may contain operators of precedence
11966 down to the assignment operators. The expression must be followed (and thus
11967 terminated) either by a comma or lower-precedence operator or by
11968 something that would normally terminate an expression such as semicolon.
11969 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11970 otherwise it is mandatory. It is up to the caller to ensure that the
11971 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11972 the source of the code to be parsed and the lexical context for the
11975 The op tree representing the expression is returned. If an optional
11976 expression is absent, a null pointer is returned, otherwise the pointer
11979 If an error occurs in parsing or compilation, in most cases a valid op
11980 tree is returned anyway. The error is reflected in the parser state,
11981 normally resulting in a single exception at the top level of parsing
11982 which covers all the compilation errors that occurred. Some compilation
11983 errors, however, will throw an exception immediately.
11989 Perl_parse_termexpr(pTHX_ U32 flags)
11991 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11995 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11997 Parse a Perl list expression. This may contain operators of precedence
11998 down to the comma operator. The expression must be followed (and thus
11999 terminated) either by a low-precedence logic operator such as C<or> or by
12000 something that would normally terminate an expression such as semicolon.
12001 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
12002 otherwise it is mandatory. It is up to the caller to ensure that the
12003 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12004 the source of the code to be parsed and the lexical context for the
12007 The op tree representing the expression is returned. If an optional
12008 expression is absent, a null pointer is returned, otherwise the pointer
12011 If an error occurs in parsing or compilation, in most cases a valid op
12012 tree is returned anyway. The error is reflected in the parser state,
12013 normally resulting in a single exception at the top level of parsing
12014 which covers all the compilation errors that occurred. Some compilation
12015 errors, however, will throw an exception immediately.
12021 Perl_parse_listexpr(pTHX_ U32 flags)
12023 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12027 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
12029 Parse a single complete Perl expression. This allows the full
12030 expression grammar, including the lowest-precedence operators such
12031 as C<or>. The expression must be followed (and thus terminated) by a
12032 token that an expression would normally be terminated by: end-of-file,
12033 closing bracketing punctuation, semicolon, or one of the keywords that
12034 signals a postfix expression-statement modifier. If I<flags> includes
12035 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
12036 mandatory. It is up to the caller to ensure that the dynamic parser
12037 state (L</PL_parser> et al) is correctly set to reflect the source of
12038 the code to be parsed and the lexical context for the expression.
12040 The op tree representing the expression is returned. If an optional
12041 expression is absent, a null pointer is returned, otherwise the pointer
12044 If an error occurs in parsing or compilation, in most cases a valid op
12045 tree is returned anyway. The error is reflected in the parser state,
12046 normally resulting in a single exception at the top level of parsing
12047 which covers all the compilation errors that occurred. Some compilation
12048 errors, however, will throw an exception immediately.
12054 Perl_parse_fullexpr(pTHX_ U32 flags)
12056 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12060 =for apidoc Amx|OP *|parse_block|U32 flags
12062 Parse a single complete Perl code block. This consists of an opening
12063 brace, a sequence of statements, and a closing brace. The block
12064 constitutes a lexical scope, so C<my> variables and various compile-time
12065 effects can be contained within it. It is up to the caller to ensure
12066 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12067 reflect the source of the code to be parsed and the lexical context for
12070 The op tree representing the code block is returned. This is always a
12071 real op, never a null pointer. It will normally be a C<lineseq> list,
12072 including C<nextstate> or equivalent ops. No ops to construct any kind
12073 of runtime scope are included by virtue of it being a block.
12075 If an error occurs in parsing or compilation, in most cases a valid op
12076 tree (most likely null) is returned anyway. The error is reflected in
12077 the parser state, normally resulting in a single exception at the top
12078 level of parsing which covers all the compilation errors that occurred.
12079 Some compilation errors, however, will throw an exception immediately.
12081 The I<flags> parameter is reserved for future use, and must always
12088 Perl_parse_block(pTHX_ U32 flags)
12091 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12092 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12096 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12098 Parse a single unadorned Perl statement. This may be a normal imperative
12099 statement or a declaration that has compile-time effect. It does not
12100 include any label or other affixture. It is up to the caller to ensure
12101 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12102 reflect the source of the code to be parsed and the lexical context for
12105 The op tree representing the statement is returned. This may be a
12106 null pointer if the statement is null, for example if it was actually
12107 a subroutine definition (which has compile-time side effects). If not
12108 null, it will be ops directly implementing the statement, suitable to
12109 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12110 equivalent op (except for those embedded in a scope contained entirely
12111 within the statement).
12113 If an error occurs in parsing or compilation, in most cases a valid op
12114 tree (most likely null) is returned anyway. The error is reflected in
12115 the parser state, normally resulting in a single exception at the top
12116 level of parsing which covers all the compilation errors that occurred.
12117 Some compilation errors, however, will throw an exception immediately.
12119 The I<flags> parameter is reserved for future use, and must always
12126 Perl_parse_barestmt(pTHX_ U32 flags)
12129 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12130 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12134 =for apidoc Amx|SV *|parse_label|U32 flags
12136 Parse a single label, possibly optional, of the type that may prefix a
12137 Perl statement. It is up to the caller to ensure that the dynamic parser
12138 state (L</PL_parser> et al) is correctly set to reflect the source of
12139 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
12140 label is optional, otherwise it is mandatory.
12142 The name of the label is returned in the form of a fresh scalar. If an
12143 optional label is absent, a null pointer is returned.
12145 If an error occurs in parsing, which can only occur if the label is
12146 mandatory, a valid label is returned anyway. The error is reflected in
12147 the parser state, normally resulting in a single exception at the top
12148 level of parsing which covers all the compilation errors that occurred.
12154 Perl_parse_label(pTHX_ U32 flags)
12156 if (flags & ~PARSE_OPTIONAL)
12157 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12158 if (PL_lex_state == LEX_KNOWNEXT) {
12159 PL_parser->yychar = yylex();
12160 if (PL_parser->yychar == LABEL) {
12161 char * const lpv = pl_yylval.pval;
12162 STRLEN llen = strlen(lpv);
12163 PL_parser->yychar = YYEMPTY;
12164 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12171 STRLEN wlen, bufptr_pos;
12174 if (!isIDFIRST_lazy_if(s, UTF))
12176 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12177 if (word_takes_any_delimeter(s, wlen))
12179 bufptr_pos = s - SvPVX(PL_linestr);
12181 lex_read_space(LEX_KEEP_PREVIOUS);
12183 s = SvPVX(PL_linestr) + bufptr_pos;
12184 if (t[0] == ':' && t[1] != ':') {
12185 PL_oldoldbufptr = PL_oldbufptr;
12188 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12192 if (flags & PARSE_OPTIONAL) {
12195 qerror(Perl_mess(aTHX_ "Parse error"));
12196 return newSVpvs("x");
12203 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12205 Parse a single complete Perl statement. This may be a normal imperative
12206 statement or a declaration that has compile-time effect, and may include
12207 optional labels. It is up to the caller to ensure that the dynamic
12208 parser state (L</PL_parser> et al) is correctly set to reflect the source
12209 of the code to be parsed and the lexical context for the statement.
12211 The op tree representing the statement is returned. This may be a
12212 null pointer if the statement is null, for example if it was actually
12213 a subroutine definition (which has compile-time side effects). If not
12214 null, it will be the result of a L</newSTATEOP> call, normally including
12215 a C<nextstate> or equivalent op.
12217 If an error occurs in parsing or compilation, in most cases a valid op
12218 tree (most likely null) is returned anyway. The error is reflected in
12219 the parser state, normally resulting in a single exception at the top
12220 level of parsing which covers all the compilation errors that occurred.
12221 Some compilation errors, however, will throw an exception immediately.
12223 The I<flags> parameter is reserved for future use, and must always
12230 Perl_parse_fullstmt(pTHX_ U32 flags)
12233 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12234 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12238 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12240 Parse a sequence of zero or more Perl statements. These may be normal
12241 imperative statements, including optional labels, or declarations
12242 that have compile-time effect, or any mixture thereof. The statement
12243 sequence ends when a closing brace or end-of-file is encountered in a
12244 place where a new statement could have validly started. It is up to
12245 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12246 is correctly set to reflect the source of the code to be parsed and the
12247 lexical context for the statements.
12249 The op tree representing the statement sequence is returned. This may
12250 be a null pointer if the statements were all null, for example if there
12251 were no statements or if there were only subroutine definitions (which
12252 have compile-time side effects). If not null, it will be a C<lineseq>
12253 list, normally including C<nextstate> or equivalent ops.
12255 If an error occurs in parsing or compilation, in most cases a valid op
12256 tree is returned anyway. The error is reflected in the parser state,
12257 normally resulting in a single exception at the top level of parsing
12258 which covers all the compilation errors that occurred. Some compilation
12259 errors, however, will throw an exception immediately.
12261 The I<flags> parameter is reserved for future use, and must always
12268 Perl_parse_stmtseq(pTHX_ U32 flags)
12273 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12274 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12275 c = lex_peek_unichar(0);
12276 if (c != -1 && c != /*{*/'}')
12277 qerror(Perl_mess(aTHX_ "Parse error"));
12283 * c-indentation-style: bsd
12284 * c-basic-offset: 4
12285 * indent-tabs-mode: nil
12288 * ex: set ts=8 sts=4 sw=4 et: