3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
27 This is the lower layer of the Perl parser, managing characters and tokens.
29 =for apidoc AmU|yy_parser *|PL_parser
31 Pointer to a structure encapsulating the state of the parsing operation
32 currently in progress. The pointer can be locally changed to perform
33 a nested parse without interfering with the state of an outer parse.
34 Individual members of C<PL_parser> have their own documentation.
40 #define PERL_IN_TOKE_C
42 #include "dquote_static.c"
44 #define new_constant(a,b,c,d,e,f,g) \
45 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
47 #define pl_yylval (PL_parser->yylval)
49 /* XXX temporary backwards compatibility */
50 #define PL_lex_brackets (PL_parser->lex_brackets)
51 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
52 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
53 #define PL_lex_brackstack (PL_parser->lex_brackstack)
54 #define PL_lex_casemods (PL_parser->lex_casemods)
55 #define PL_lex_casestack (PL_parser->lex_casestack)
56 #define PL_lex_defer (PL_parser->lex_defer)
57 #define PL_lex_dojoin (PL_parser->lex_dojoin)
58 #define PL_lex_expect (PL_parser->lex_expect)
59 #define PL_lex_formbrack (PL_parser->lex_formbrack)
60 #define PL_lex_inpat (PL_parser->lex_inpat)
61 #define PL_lex_inwhat (PL_parser->lex_inwhat)
62 #define PL_lex_op (PL_parser->lex_op)
63 #define PL_lex_repl (PL_parser->lex_repl)
64 #define PL_lex_starts (PL_parser->lex_starts)
65 #define PL_lex_stuff (PL_parser->lex_stuff)
66 #define PL_multi_start (PL_parser->multi_start)
67 #define PL_multi_open (PL_parser->multi_open)
68 #define PL_multi_close (PL_parser->multi_close)
69 #define PL_preambled (PL_parser->preambled)
70 #define PL_sublex_info (PL_parser->sublex_info)
71 #define PL_linestr (PL_parser->linestr)
72 #define PL_expect (PL_parser->expect)
73 #define PL_copline (PL_parser->copline)
74 #define PL_bufptr (PL_parser->bufptr)
75 #define PL_oldbufptr (PL_parser->oldbufptr)
76 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
77 #define PL_linestart (PL_parser->linestart)
78 #define PL_bufend (PL_parser->bufend)
79 #define PL_last_uni (PL_parser->last_uni)
80 #define PL_last_lop (PL_parser->last_lop)
81 #define PL_last_lop_op (PL_parser->last_lop_op)
82 #define PL_lex_state (PL_parser->lex_state)
83 #define PL_rsfp (PL_parser->rsfp)
84 #define PL_rsfp_filters (PL_parser->rsfp_filters)
85 #define PL_in_my (PL_parser->in_my)
86 #define PL_in_my_stash (PL_parser->in_my_stash)
87 #define PL_tokenbuf (PL_parser->tokenbuf)
88 #define PL_multi_end (PL_parser->multi_end)
89 #define PL_error_count (PL_parser->error_count)
92 # define PL_endwhite (PL_parser->endwhite)
93 # define PL_faketokens (PL_parser->faketokens)
94 # define PL_lasttoke (PL_parser->lasttoke)
95 # define PL_nextwhite (PL_parser->nextwhite)
96 # define PL_realtokenstart (PL_parser->realtokenstart)
97 # define PL_skipwhite (PL_parser->skipwhite)
98 # define PL_thisclose (PL_parser->thisclose)
99 # define PL_thismad (PL_parser->thismad)
100 # define PL_thisopen (PL_parser->thisopen)
101 # define PL_thisstuff (PL_parser->thisstuff)
102 # define PL_thistoken (PL_parser->thistoken)
103 # define PL_thiswhite (PL_parser->thiswhite)
104 # define PL_thiswhite (PL_parser->thiswhite)
105 # define PL_nexttoke (PL_parser->nexttoke)
106 # define PL_curforce (PL_parser->curforce)
108 # define PL_nexttoke (PL_parser->nexttoke)
109 # define PL_nexttype (PL_parser->nexttype)
110 # define PL_nextval (PL_parser->nextval)
113 static const char* const ident_too_long = "Identifier too long";
116 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
117 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
119 # define CURMAD(slot,sv)
120 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
123 #define XENUMMASK 0x3f
124 #define XFAKEEOF 0x40
125 #define XFAKEBRACK 0x80
127 #ifdef USE_UTF8_SCRIPTS
128 # define UTF (!IN_BYTES)
130 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
133 /* The maximum number of characters preceding the unrecognized one to display */
134 #define UNRECOGNIZED_PRECEDE_COUNT 10
136 /* In variables named $^X, these are the legal values for X.
137 * 1999-02-27 mjd-perl-patch@plover.com */
138 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
140 #define SPACE_OR_TAB(c) isBLANK_A(c)
142 /* LEX_* are values for PL_lex_state, the state of the lexer.
143 * They are arranged oddly so that the guard on the switch statement
144 * can get by with a single comparison (if the compiler is smart enough).
146 * These values refer to the various states within a sublex parse,
147 * i.e. within a double quotish string
150 /* #define LEX_NOTPARSING 11 is done in perl.h. */
152 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
153 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
154 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
155 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
156 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
158 /* at end of code, eg "$x" followed by: */
159 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
160 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
162 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
163 string or after \E, $foo, etc */
164 #define LEX_INTERPCONST 2 /* NOT USED */
165 #define LEX_FORMLINE 1 /* expecting a format line */
166 #define LEX_KNOWNEXT 0 /* next token known; just return it */
170 static const char* const lex_state_names[] = {
189 #include "keywords.h"
191 /* CLINE is a macro that ensures PL_copline has a sane value */
196 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
199 # define SKIPSPACE0(s) skipspace0(s)
200 # define SKIPSPACE1(s) skipspace1(s)
201 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
202 # define PEEKSPACE(s) skipspace2(s,0)
204 # define SKIPSPACE0(s) skipspace(s)
205 # define SKIPSPACE1(s) skipspace(s)
206 # define SKIPSPACE2(s,tsv) skipspace(s)
207 # define PEEKSPACE(s) skipspace(s)
211 * Convenience functions to return different tokens and prime the
212 * lexer for the next token. They all take an argument.
214 * TOKEN : generic token (used for '(', DOLSHARP, etc)
215 * OPERATOR : generic operator
216 * AOPERATOR : assignment operator
217 * PREBLOCK : beginning the block after an if, while, foreach, ...
218 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
219 * PREREF : *EXPR where EXPR is not a simple identifier
220 * TERM : expression term
221 * LOOPX : loop exiting command (goto, last, dump, etc)
222 * FTST : file test operator
223 * FUN0 : zero-argument function
224 * FUN0OP : zero-argument function, with its op created in this file
225 * FUN1 : not used, except for not, which isn't a UNIOP
226 * BOop : bitwise or or xor
228 * SHop : shift operator
229 * PWop : power operator
230 * PMop : pattern-matching operator
231 * Aop : addition-level operator
232 * Mop : multiplication-level operator
233 * Eop : equality-testing operator
234 * Rop : relational operator <= != gt
236 * Also see LOP and lop() below.
239 #ifdef DEBUGGING /* Serve -DT. */
240 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
242 # define REPORT(retval) (retval)
245 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
246 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
247 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
248 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
249 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
250 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
251 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
252 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
253 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
254 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
255 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
256 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
257 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
258 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
259 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
260 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
261 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
262 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
263 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
264 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
265 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
267 /* This bit of chicanery makes a unary function followed by
268 * a parenthesis into a function with one argument, highest precedence.
269 * The UNIDOR macro is for unary functions that can be followed by the //
270 * operator (such as C<shift // 0>).
272 #define UNI3(f,x,have_x) { \
273 pl_yylval.ival = f; \
274 if (have_x) PL_expect = x; \
276 PL_last_uni = PL_oldbufptr; \
277 PL_last_lop_op = f; \
279 return REPORT( (int)FUNC1 ); \
281 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
283 #define UNI(f) UNI3(f,XTERM,1)
284 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
285 #define UNIPROTO(f,optional) { \
286 if (optional) PL_last_uni = PL_oldbufptr; \
290 #define UNIBRACK(f) UNI3(f,0,0)
292 /* grandfather return to old style */
295 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
296 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
297 pl_yylval.ival = (f); \
303 #define COPLINE_INC_WITH_HERELINES \
305 CopLINE_inc(PL_curcop); \
306 if (PL_parser->lex_shared->herelines) \
307 CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \
308 PL_parser->lex_shared->herelines = 0; \
314 /* how to interpret the pl_yylval associated with the token */
318 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
323 static struct debug_tokens {
325 enum token_type type;
327 } const debug_tokens[] =
329 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
330 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
331 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
332 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
333 { ARROW, TOKENTYPE_NONE, "ARROW" },
334 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
335 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
336 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
337 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
338 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
339 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
340 { DO, TOKENTYPE_NONE, "DO" },
341 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
342 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
343 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
344 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
345 { ELSE, TOKENTYPE_NONE, "ELSE" },
346 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
347 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
348 { FOR, TOKENTYPE_IVAL, "FOR" },
349 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
350 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
351 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
352 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
353 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
354 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
355 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
356 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
357 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
358 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
359 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
360 { IF, TOKENTYPE_IVAL, "IF" },
361 { LABEL, TOKENTYPE_PVAL, "LABEL" },
362 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
363 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
364 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
365 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
366 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
367 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
368 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
369 { MY, TOKENTYPE_IVAL, "MY" },
370 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
371 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
372 { OROP, TOKENTYPE_IVAL, "OROP" },
373 { OROR, TOKENTYPE_NONE, "OROR" },
374 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
375 { PEG, TOKENTYPE_NONE, "PEG" },
376 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
377 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
378 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
379 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
380 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
381 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
382 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
383 { PREINC, TOKENTYPE_NONE, "PREINC" },
384 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
385 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
386 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
387 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
388 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
389 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
390 { SUB, TOKENTYPE_NONE, "SUB" },
391 { THING, TOKENTYPE_OPVAL, "THING" },
392 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
393 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
394 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
395 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
396 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
397 { USE, TOKENTYPE_IVAL, "USE" },
398 { WHEN, TOKENTYPE_IVAL, "WHEN" },
399 { WHILE, TOKENTYPE_IVAL, "WHILE" },
400 { WORD, TOKENTYPE_OPVAL, "WORD" },
401 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
402 { 0, TOKENTYPE_NONE, NULL }
405 /* dump the returned token in rv, plus any optional arg in pl_yylval */
408 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
412 PERL_ARGS_ASSERT_TOKEREPORT;
415 const char *name = NULL;
416 enum token_type type = TOKENTYPE_NONE;
417 const struct debug_tokens *p;
418 SV* const report = newSVpvs("<== ");
420 for (p = debug_tokens; p->token; p++) {
421 if (p->token == (int)rv) {
428 Perl_sv_catpv(aTHX_ report, name);
429 else if ((char)rv > ' ' && (char)rv <= '~')
431 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
433 sv_catpvs(report, " (pending identifier)");
436 sv_catpvs(report, "EOF");
438 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
443 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
445 case TOKENTYPE_OPNUM:
446 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
447 PL_op_name[lvalp->ival]);
450 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
452 case TOKENTYPE_OPVAL:
454 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
455 PL_op_name[lvalp->opval->op_type]);
456 if (lvalp->opval->op_type == OP_CONST) {
457 Perl_sv_catpvf(aTHX_ report, " %s",
458 SvPEEK(cSVOPx_sv(lvalp->opval)));
463 sv_catpvs(report, "(opval=null)");
466 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
472 /* print the buffer with suitable escapes */
475 S_printbuf(pTHX_ const char *const fmt, const char *const s)
477 SV* const tmp = newSVpvs("");
479 PERL_ARGS_ASSERT_PRINTBUF;
481 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
488 S_deprecate_commaless_var_list(pTHX) {
490 deprecate("comma-less variable list");
491 return REPORT(','); /* grandfather non-comma-format format */
497 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
498 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
502 S_ao(pTHX_ int toketype)
505 if (*PL_bufptr == '=') {
507 if (toketype == ANDAND)
508 pl_yylval.ival = OP_ANDASSIGN;
509 else if (toketype == OROR)
510 pl_yylval.ival = OP_ORASSIGN;
511 else if (toketype == DORDOR)
512 pl_yylval.ival = OP_DORASSIGN;
520 * When Perl expects an operator and finds something else, no_op
521 * prints the warning. It always prints "<something> found where
522 * operator expected. It prints "Missing semicolon on previous line?"
523 * if the surprise occurs at the start of the line. "do you need to
524 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
525 * where the compiler doesn't know if foo is a method call or a function.
526 * It prints "Missing operator before end of line" if there's nothing
527 * after the missing operator, or "... before <...>" if there is something
528 * after the missing operator.
532 S_no_op(pTHX_ const char *const what, char *s)
535 char * const oldbp = PL_bufptr;
536 const bool is_first = (PL_oldbufptr == PL_linestart);
538 PERL_ARGS_ASSERT_NO_OP;
544 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
545 if (ckWARN_d(WARN_SYNTAX)) {
547 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
548 "\t(Missing semicolon on previous line?)\n");
549 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
551 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
552 t += UTF ? UTF8SKIP(t) : 1)
554 if (t < PL_bufptr && isSPACE(*t))
555 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
556 "\t(Do you need to predeclare %"SVf"?)\n",
557 SVfARG(newSVpvn_flags(PL_oldoldbufptr, (STRLEN)(t - PL_oldoldbufptr),
558 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
562 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
563 "\t(Missing operator before %"SVf"?)\n",
564 SVfARG(newSVpvn_flags(oldbp, (STRLEN)(s - oldbp),
565 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
573 * Complain about missing quote/regexp/heredoc terminator.
574 * If it's called with NULL then it cauterizes the line buffer.
575 * If we're in a delimited string and the delimiter is a control
576 * character, it's reformatted into a two-char sequence like ^C.
581 S_missingterm(pTHX_ char *s)
587 char * const nl = strrchr(s,'\n');
591 else if (isCNTRL(PL_multi_close)) {
593 tmpbuf[1] = (char)toCTRL(PL_multi_close);
598 *tmpbuf = (char)PL_multi_close;
602 q = strchr(s,'"') ? '\'' : '"';
603 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
609 * Check whether the named feature is enabled.
612 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
615 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
617 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
619 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
621 if (namelen > MAX_FEATURE_LEN)
623 memcpy(&he_name[8], name, namelen);
625 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
626 REFCOUNTED_HE_EXISTS));
630 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
631 * utf16-to-utf8-reversed.
634 #ifdef PERL_CR_FILTER
638 const char *s = SvPVX_const(sv);
639 const char * const e = s + SvCUR(sv);
641 PERL_ARGS_ASSERT_STRIP_RETURN;
643 /* outer loop optimized to do nothing if there are no CR-LFs */
645 if (*s++ == '\r' && *s == '\n') {
646 /* hit a CR-LF, need to copy the rest */
650 if (*s == '\r' && s[1] == '\n')
661 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
663 const I32 count = FILTER_READ(idx+1, sv, maxlen);
664 if (count > 0 && !maxlen)
671 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
673 Creates and initialises a new lexer/parser state object, supplying
674 a context in which to lex and parse from a new source of Perl code.
675 A pointer to the new state object is placed in L</PL_parser>. An entry
676 is made on the save stack so that upon unwinding the new state object
677 will be destroyed and the former value of L</PL_parser> will be restored.
678 Nothing else need be done to clean up the parsing context.
680 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
681 non-null, provides a string (in SV form) containing code to be parsed.
682 A copy of the string is made, so subsequent modification of I<line>
683 does not affect parsing. I<rsfp>, if non-null, provides an input stream
684 from which code will be read to be parsed. If both are non-null, the
685 code in I<line> comes first and must consist of complete lines of input,
686 and I<rsfp> supplies the remainder of the source.
688 The I<flags> parameter is reserved for future use. Currently it is only
689 used by perl internally, so extensions should always pass zero.
694 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
695 can share filters with the current parser.
696 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
697 caller, hence isn't owned by the parser, so shouldn't be closed on parser
698 destruction. This is used to handle the case of defaulting to reading the
699 script from the standard input because no filename was given on the command
700 line (without getting confused by situation where STDIN has been closed, so
701 the script handle is opened on fd 0) */
704 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
707 const char *s = NULL;
708 yy_parser *parser, *oparser;
709 if (flags && flags & ~LEX_START_FLAGS)
710 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
712 /* create and initialise a parser */
714 Newxz(parser, 1, yy_parser);
715 parser->old_parser = oparser = PL_parser;
718 parser->stack = NULL;
720 parser->stack_size = 0;
722 /* on scope exit, free this parser and restore any outer one */
724 parser->saved_curcop = PL_curcop;
726 /* initialise lexer state */
729 parser->curforce = -1;
731 parser->nexttoke = 0;
733 parser->error_count = oparser ? oparser->error_count : 0;
734 parser->copline = NOLINE;
735 parser->lex_state = LEX_NORMAL;
736 parser->expect = XSTATE;
738 parser->rsfp_filters =
739 !(flags & LEX_START_SAME_FILTER) || !oparser
741 : MUTABLE_AV(SvREFCNT_inc(
742 oparser->rsfp_filters
743 ? oparser->rsfp_filters
744 : (oparser->rsfp_filters = newAV())
747 Newx(parser->lex_brackstack, 120, char);
748 Newx(parser->lex_casestack, 12, char);
749 *parser->lex_casestack = '\0';
750 Newxz(parser->lex_shared, 1, LEXSHARED);
754 s = SvPV_const(line, len);
755 parser->linestr = flags & LEX_START_COPIED
756 ? SvREFCNT_inc_simple_NN(line)
757 : newSVpvn_flags(s, len, SvUTF8(line));
758 sv_catpvs(parser->linestr, "\n;");
760 parser->linestr = newSVpvs("\n;");
762 parser->oldoldbufptr =
765 parser->linestart = SvPVX(parser->linestr);
766 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
767 parser->last_lop = parser->last_uni = NULL;
768 parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
769 |LEX_DONT_CLOSE_RSFP);
771 parser->in_pod = parser->filtered = 0;
775 /* delete a parser object */
778 Perl_parser_free(pTHX_ const yy_parser *parser)
780 PERL_ARGS_ASSERT_PARSER_FREE;
782 PL_curcop = parser->saved_curcop;
783 SvREFCNT_dec(parser->linestr);
785 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
786 PerlIO_clearerr(parser->rsfp);
787 else if (parser->rsfp && (!parser->old_parser ||
788 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
789 PerlIO_close(parser->rsfp);
790 SvREFCNT_dec(parser->rsfp_filters);
791 SvREFCNT_dec(parser->lex_stuff);
792 SvREFCNT_dec(parser->sublex_info.repl);
794 Safefree(parser->lex_brackstack);
795 Safefree(parser->lex_casestack);
796 Safefree(parser->lex_shared);
797 PL_parser = parser->old_parser;
802 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
805 I32 nexttoke = parser->lasttoke;
807 I32 nexttoke = parser->nexttoke;
809 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
812 if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
814 && parser->nexttoke[nexttoke].next_val.opval
815 && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
816 && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
817 op_free(parser->nexttoke[nexttoke].next_val.opval);
818 parser->nexttoke[nexttoke].next_val.opval = NULL;
821 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
822 && parser->nextval[nexttoke].opval
823 && parser->nextval[nexttoke].opval->op_slabbed
824 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
825 op_free(parser->nextval[nexttoke].opval);
826 parser->nextval[nexttoke].opval = NULL;
834 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
836 Buffer scalar containing the chunk currently under consideration of the
837 text currently being lexed. This is always a plain string scalar (for
838 which C<SvPOK> is true). It is not intended to be used as a scalar by
839 normal scalar means; instead refer to the buffer directly by the pointer
840 variables described below.
842 The lexer maintains various C<char*> pointers to things in the
843 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
844 reallocated, all of these pointers must be updated. Don't attempt to
845 do this manually, but rather use L</lex_grow_linestr> if you need to
846 reallocate the buffer.
848 The content of the text chunk in the buffer is commonly exactly one
849 complete line of input, up to and including a newline terminator,
850 but there are situations where it is otherwise. The octets of the
851 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
852 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
853 flag on this scalar, which may disagree with it.
855 For direct examination of the buffer, the variable
856 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
857 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
858 of these pointers is usually preferable to examination of the scalar
859 through normal scalar means.
861 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
863 Direct pointer to the end of the chunk of text currently being lexed, the
864 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
865 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
866 always located at the end of the buffer, and does not count as part of
867 the buffer's contents.
869 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
871 Points to the current position of lexing inside the lexer buffer.
872 Characters around this point may be freely examined, within
873 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
874 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
875 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
877 Lexing code (whether in the Perl core or not) moves this pointer past
878 the characters that it consumes. It is also expected to perform some
879 bookkeeping whenever a newline character is consumed. This movement
880 can be more conveniently performed by the function L</lex_read_to>,
881 which handles newlines appropriately.
883 Interpretation of the buffer's octets can be abstracted out by
884 using the slightly higher-level functions L</lex_peek_unichar> and
885 L</lex_read_unichar>.
887 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
889 Points to the start of the current line inside the lexer buffer.
890 This is useful for indicating at which column an error occurred, and
891 not much else. This must be updated by any lexing code that consumes
892 a newline; the function L</lex_read_to> handles this detail.
898 =for apidoc Amx|bool|lex_bufutf8
900 Indicates whether the octets in the lexer buffer
901 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
902 of Unicode characters. If not, they should be interpreted as Latin-1
903 characters. This is analogous to the C<SvUTF8> flag for scalars.
905 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
906 contains valid UTF-8. Lexing code must be robust in the face of invalid
909 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
910 is significant, but not the whole story regarding the input character
911 encoding. Normally, when a file is being read, the scalar contains octets
912 and its C<SvUTF8> flag is off, but the octets should be interpreted as
913 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
914 however, the scalar may have the C<SvUTF8> flag on, and in this case its
915 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
916 is in effect. This logic may change in the future; use this function
917 instead of implementing the logic yourself.
923 Perl_lex_bufutf8(pTHX)
929 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
931 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
932 at least I<len> octets (including terminating NUL). Returns a
933 pointer to the reallocated buffer. This is necessary before making
934 any direct modification of the buffer that would increase its length.
935 L</lex_stuff_pvn> provides a more convenient way to insert text into
938 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
939 this function updates all of the lexer's variables that point directly
946 Perl_lex_grow_linestr(pTHX_ STRLEN len)
950 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
951 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
952 linestr = PL_parser->linestr;
953 buf = SvPVX(linestr);
954 if (len <= SvLEN(linestr))
956 bufend_pos = PL_parser->bufend - buf;
957 bufptr_pos = PL_parser->bufptr - buf;
958 oldbufptr_pos = PL_parser->oldbufptr - buf;
959 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
960 linestart_pos = PL_parser->linestart - buf;
961 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
962 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
963 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
964 PL_parser->lex_shared->re_eval_start - buf : 0;
966 buf = sv_grow(linestr, len);
968 PL_parser->bufend = buf + bufend_pos;
969 PL_parser->bufptr = buf + bufptr_pos;
970 PL_parser->oldbufptr = buf + oldbufptr_pos;
971 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
972 PL_parser->linestart = buf + linestart_pos;
973 if (PL_parser->last_uni)
974 PL_parser->last_uni = buf + last_uni_pos;
975 if (PL_parser->last_lop)
976 PL_parser->last_lop = buf + last_lop_pos;
977 if (PL_parser->lex_shared->re_eval_start)
978 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
983 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
985 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
986 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
987 reallocating the buffer if necessary. This means that lexing code that
988 runs later will see the characters as if they had appeared in the input.
989 It is not recommended to do this as part of normal parsing, and most
990 uses of this facility run the risk of the inserted characters being
991 interpreted in an unintended manner.
993 The string to be inserted is represented by I<len> octets starting
994 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
995 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
996 The characters are recoded for the lexer buffer, according to how the
997 buffer is currently being interpreted (L</lex_bufutf8>). If a string
998 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
999 function is more convenient.
1005 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1009 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1010 if (flags & ~(LEX_STUFF_UTF8))
1011 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1013 if (flags & LEX_STUFF_UTF8) {
1016 STRLEN highhalf = 0; /* Count of variants */
1017 const char *p, *e = pv+len;
1018 for (p = pv; p != e; p++) {
1019 if (! UTF8_IS_INVARIANT(*p)) {
1025 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1026 bufptr = PL_parser->bufptr;
1027 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1028 SvCUR_set(PL_parser->linestr,
1029 SvCUR(PL_parser->linestr) + len+highhalf);
1030 PL_parser->bufend += len+highhalf;
1031 for (p = pv; p != e; p++) {
1033 if (! UTF8_IS_INVARIANT(c)) {
1034 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1035 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1037 *bufptr++ = (char)c;
1042 if (flags & LEX_STUFF_UTF8) {
1043 STRLEN highhalf = 0;
1044 const char *p, *e = pv+len;
1045 for (p = pv; p != e; p++) {
1047 if (UTF8_IS_ABOVE_LATIN1(c)) {
1048 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1049 "non-Latin-1 character into Latin-1 input");
1050 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1053 } else if (! UTF8_IS_INVARIANT(c)) {
1054 /* malformed UTF-8 */
1056 SAVESPTR(PL_warnhook);
1057 PL_warnhook = PERL_WARNHOOK_FATAL;
1058 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
1064 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1065 bufptr = PL_parser->bufptr;
1066 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1067 SvCUR_set(PL_parser->linestr,
1068 SvCUR(PL_parser->linestr) + len-highhalf);
1069 PL_parser->bufend += len-highhalf;
1072 if (UTF8_IS_INVARIANT(*p)) {
1078 *bufptr++ = TWO_BYTE_UTF8_TO_UNI(*p, *(p+1));
1084 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1085 bufptr = PL_parser->bufptr;
1086 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1087 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1088 PL_parser->bufend += len;
1089 Copy(pv, bufptr, len, char);
1095 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1097 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1098 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1099 reallocating the buffer if necessary. This means that lexing code that
1100 runs later will see the characters as if they had appeared in the input.
1101 It is not recommended to do this as part of normal parsing, and most
1102 uses of this facility run the risk of the inserted characters being
1103 interpreted in an unintended manner.
1105 The string to be inserted is represented by octets starting at I<pv>
1106 and continuing to the first nul. These octets are interpreted as either
1107 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1108 in I<flags>. The characters are recoded for the lexer buffer, according
1109 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1110 If it is not convenient to nul-terminate a string to be inserted, the
1111 L</lex_stuff_pvn> function is more appropriate.
1117 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1119 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1120 lex_stuff_pvn(pv, strlen(pv), flags);
1124 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1126 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1127 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1128 reallocating the buffer if necessary. This means that lexing code that
1129 runs later will see the characters as if they had appeared in the input.
1130 It is not recommended to do this as part of normal parsing, and most
1131 uses of this facility run the risk of the inserted characters being
1132 interpreted in an unintended manner.
1134 The string to be inserted is the string value of I<sv>. The characters
1135 are recoded for the lexer buffer, according to how the buffer is currently
1136 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1137 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1138 need to construct a scalar.
1144 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1148 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1150 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1152 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1156 =for apidoc Amx|void|lex_unstuff|char *ptr
1158 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1159 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1160 This hides the discarded text from any lexing code that runs later,
1161 as if the text had never appeared.
1163 This is not the normal way to consume lexed text. For that, use
1170 Perl_lex_unstuff(pTHX_ char *ptr)
1174 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1175 buf = PL_parser->bufptr;
1177 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1180 bufend = PL_parser->bufend;
1182 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1183 unstuff_len = ptr - buf;
1184 Move(ptr, buf, bufend+1-ptr, char);
1185 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1186 PL_parser->bufend = bufend - unstuff_len;
1190 =for apidoc Amx|void|lex_read_to|char *ptr
1192 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1193 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1194 performing the correct bookkeeping whenever a newline character is passed.
1195 This is the normal way to consume lexed text.
1197 Interpretation of the buffer's octets can be abstracted out by
1198 using the slightly higher-level functions L</lex_peek_unichar> and
1199 L</lex_read_unichar>.
1205 Perl_lex_read_to(pTHX_ char *ptr)
1208 PERL_ARGS_ASSERT_LEX_READ_TO;
1209 s = PL_parser->bufptr;
1210 if (ptr < s || ptr > PL_parser->bufend)
1211 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1212 for (; s != ptr; s++)
1214 COPLINE_INC_WITH_HERELINES;
1215 PL_parser->linestart = s+1;
1217 PL_parser->bufptr = ptr;
1221 =for apidoc Amx|void|lex_discard_to|char *ptr
1223 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1224 up to I<ptr>. The remaining content of the buffer will be moved, and
1225 all pointers into the buffer updated appropriately. I<ptr> must not
1226 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1227 it is not permitted to discard text that has yet to be lexed.
1229 Normally it is not necessarily to do this directly, because it suffices to
1230 use the implicit discarding behaviour of L</lex_next_chunk> and things
1231 based on it. However, if a token stretches across multiple lines,
1232 and the lexing code has kept multiple lines of text in the buffer for
1233 that purpose, then after completion of the token it would be wise to
1234 explicitly discard the now-unneeded earlier lines, to avoid future
1235 multi-line tokens growing the buffer without bound.
1241 Perl_lex_discard_to(pTHX_ char *ptr)
1245 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1246 buf = SvPVX(PL_parser->linestr);
1248 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1251 if (ptr > PL_parser->bufptr)
1252 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1253 discard_len = ptr - buf;
1254 if (PL_parser->oldbufptr < ptr)
1255 PL_parser->oldbufptr = ptr;
1256 if (PL_parser->oldoldbufptr < ptr)
1257 PL_parser->oldoldbufptr = ptr;
1258 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1259 PL_parser->last_uni = NULL;
1260 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1261 PL_parser->last_lop = NULL;
1262 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1263 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1264 PL_parser->bufend -= discard_len;
1265 PL_parser->bufptr -= discard_len;
1266 PL_parser->oldbufptr -= discard_len;
1267 PL_parser->oldoldbufptr -= discard_len;
1268 if (PL_parser->last_uni)
1269 PL_parser->last_uni -= discard_len;
1270 if (PL_parser->last_lop)
1271 PL_parser->last_lop -= discard_len;
1275 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1277 Reads in the next chunk of text to be lexed, appending it to
1278 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1279 looked to the end of the current chunk and wants to know more. It is
1280 usual, but not necessary, for lexing to have consumed the entirety of
1281 the current chunk at this time.
1283 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1284 chunk (i.e., the current chunk has been entirely consumed), normally the
1285 current chunk will be discarded at the same time that the new chunk is
1286 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1287 will not be discarded. If the current chunk has not been entirely
1288 consumed, then it will not be discarded regardless of the flag.
1290 Returns true if some new text was added to the buffer, or false if the
1291 buffer has reached the end of the input text.
1296 #define LEX_FAKE_EOF 0x80000000
1297 #define LEX_NO_TERM 0x40000000
1300 Perl_lex_next_chunk(pTHX_ U32 flags)
1304 STRLEN old_bufend_pos, new_bufend_pos;
1305 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1306 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1307 bool got_some_for_debugger = 0;
1309 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1310 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1311 linestr = PL_parser->linestr;
1312 buf = SvPVX(linestr);
1313 if (!(flags & LEX_KEEP_PREVIOUS) &&
1314 PL_parser->bufptr == PL_parser->bufend) {
1315 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1317 if (PL_parser->last_uni != PL_parser->bufend)
1318 PL_parser->last_uni = NULL;
1319 if (PL_parser->last_lop != PL_parser->bufend)
1320 PL_parser->last_lop = NULL;
1321 last_uni_pos = last_lop_pos = 0;
1325 old_bufend_pos = PL_parser->bufend - buf;
1326 bufptr_pos = PL_parser->bufptr - buf;
1327 oldbufptr_pos = PL_parser->oldbufptr - buf;
1328 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1329 linestart_pos = PL_parser->linestart - buf;
1330 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1331 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1333 if (flags & LEX_FAKE_EOF) {
1335 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1337 } else if (filter_gets(linestr, old_bufend_pos)) {
1339 got_some_for_debugger = 1;
1340 } else if (flags & LEX_NO_TERM) {
1343 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1344 sv_setpvs(linestr, "");
1346 /* End of real input. Close filehandle (unless it was STDIN),
1347 * then add implicit termination.
1349 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1350 PerlIO_clearerr(PL_parser->rsfp);
1351 else if (PL_parser->rsfp)
1352 (void)PerlIO_close(PL_parser->rsfp);
1353 PL_parser->rsfp = NULL;
1354 PL_parser->in_pod = PL_parser->filtered = 0;
1356 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1359 if (!PL_in_eval && PL_minus_p) {
1361 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1362 PL_minus_n = PL_minus_p = 0;
1363 } else if (!PL_in_eval && PL_minus_n) {
1364 sv_catpvs(linestr, /*{*/";}");
1367 sv_catpvs(linestr, ";");
1370 buf = SvPVX(linestr);
1371 new_bufend_pos = SvCUR(linestr);
1372 PL_parser->bufend = buf + new_bufend_pos;
1373 PL_parser->bufptr = buf + bufptr_pos;
1374 PL_parser->oldbufptr = buf + oldbufptr_pos;
1375 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1376 PL_parser->linestart = buf + linestart_pos;
1377 if (PL_parser->last_uni)
1378 PL_parser->last_uni = buf + last_uni_pos;
1379 if (PL_parser->last_lop)
1380 PL_parser->last_lop = buf + last_lop_pos;
1381 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1382 PL_curstash != PL_debstash) {
1383 /* debugger active and we're not compiling the debugger code,
1384 * so store the line into the debugger's array of lines
1386 update_debugger_info(NULL, buf+old_bufend_pos,
1387 new_bufend_pos-old_bufend_pos);
1393 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1395 Looks ahead one (Unicode) character in the text currently being lexed.
1396 Returns the codepoint (unsigned integer value) of the next character,
1397 or -1 if lexing has reached the end of the input text. To consume the
1398 peeked character, use L</lex_read_unichar>.
1400 If the next character is in (or extends into) the next chunk of input
1401 text, the next chunk will be read in. Normally the current chunk will be
1402 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1403 then the current chunk will not be discarded.
1405 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1406 is encountered, an exception is generated.
1412 Perl_lex_peek_unichar(pTHX_ U32 flags)
1416 if (flags & ~(LEX_KEEP_PREVIOUS))
1417 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1418 s = PL_parser->bufptr;
1419 bufend = PL_parser->bufend;
1425 if (!lex_next_chunk(flags))
1427 s = PL_parser->bufptr;
1428 bufend = PL_parser->bufend;
1431 if (UTF8_IS_INVARIANT(head))
1433 if (UTF8_IS_START(head)) {
1434 len = UTF8SKIP(&head);
1435 while ((STRLEN)(bufend-s) < len) {
1436 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1438 s = PL_parser->bufptr;
1439 bufend = PL_parser->bufend;
1442 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1443 if (retlen == (STRLEN)-1) {
1444 /* malformed UTF-8 */
1446 SAVESPTR(PL_warnhook);
1447 PL_warnhook = PERL_WARNHOOK_FATAL;
1448 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1454 if (!lex_next_chunk(flags))
1456 s = PL_parser->bufptr;
1463 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1465 Reads the next (Unicode) character in the text currently being lexed.
1466 Returns the codepoint (unsigned integer value) of the character read,
1467 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1468 if lexing has reached the end of the input text. To non-destructively
1469 examine the next character, use L</lex_peek_unichar> instead.
1471 If the next character is in (or extends into) the next chunk of input
1472 text, the next chunk will be read in. Normally the current chunk will be
1473 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1474 then the current chunk will not be discarded.
1476 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1477 is encountered, an exception is generated.
1483 Perl_lex_read_unichar(pTHX_ U32 flags)
1486 if (flags & ~(LEX_KEEP_PREVIOUS))
1487 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1488 c = lex_peek_unichar(flags);
1491 COPLINE_INC_WITH_HERELINES;
1493 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1495 ++(PL_parser->bufptr);
1501 =for apidoc Amx|void|lex_read_space|U32 flags
1503 Reads optional spaces, in Perl style, in the text currently being
1504 lexed. The spaces may include ordinary whitespace characters and
1505 Perl-style comments. C<#line> directives are processed if encountered.
1506 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1507 at a non-space character (or the end of the input text).
1509 If spaces extend into the next chunk of input text, the next chunk will
1510 be read in. Normally the current chunk will be discarded at the same
1511 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1512 chunk will not be discarded.
1517 #define LEX_NO_NEXT_CHUNK 0x80000000
1520 Perl_lex_read_space(pTHX_ U32 flags)
1523 bool need_incline = 0;
1524 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
1525 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1528 sv_free(PL_skipwhite);
1529 PL_skipwhite = NULL;
1532 PL_skipwhite = newSVpvs("");
1533 #endif /* PERL_MAD */
1534 s = PL_parser->bufptr;
1535 bufend = PL_parser->bufend;
1541 } while (!(c == '\n' || (c == 0 && s == bufend)));
1542 } else if (c == '\n') {
1544 PL_parser->linestart = s;
1549 } else if (isSPACE(c)) {
1551 } else if (c == 0 && s == bufend) {
1555 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1556 #endif /* PERL_MAD */
1557 if (flags & LEX_NO_NEXT_CHUNK)
1559 PL_parser->bufptr = s;
1560 COPLINE_INC_WITH_HERELINES;
1561 got_more = lex_next_chunk(flags);
1562 CopLINE_dec(PL_curcop);
1563 s = PL_parser->bufptr;
1564 bufend = PL_parser->bufend;
1567 if (need_incline && PL_parser->rsfp) {
1577 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1578 #endif /* PERL_MAD */
1579 PL_parser->bufptr = s;
1584 * This subroutine has nothing to do with tilting, whether at windmills
1585 * or pinball tables. Its name is short for "increment line". It
1586 * increments the current line number in CopLINE(PL_curcop) and checks
1587 * to see whether the line starts with a comment of the form
1588 * # line 500 "foo.pm"
1589 * If so, it sets the current line number and file to the values in the comment.
1593 S_incline(pTHX_ const char *s)
1601 PERL_ARGS_ASSERT_INCLINE;
1603 COPLINE_INC_WITH_HERELINES;
1604 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1605 && s+1 == PL_bufend && *s == ';') {
1606 /* fake newline in string eval */
1607 CopLINE_dec(PL_curcop);
1612 while (SPACE_OR_TAB(*s))
1614 if (strnEQ(s, "line", 4))
1618 if (SPACE_OR_TAB(*s))
1622 while (SPACE_OR_TAB(*s))
1630 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1632 while (SPACE_OR_TAB(*s))
1634 if (*s == '"' && (t = strchr(s+1, '"'))) {
1640 while (!isSPACE(*t))
1644 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1646 if (*e != '\n' && *e != '\0')
1647 return; /* false alarm */
1649 line_num = atoi(n)-1;
1652 const STRLEN len = t - s;
1653 SV *const temp_sv = CopFILESV(PL_curcop);
1658 cf = SvPVX(temp_sv);
1659 tmplen = SvCUR(temp_sv);
1665 if (!PL_rsfp && !PL_parser->filtered) {
1666 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1667 * to *{"::_<newfilename"} */
1668 /* However, the long form of evals is only turned on by the
1669 debugger - usually they're "(eval %lu)" */
1673 STRLEN tmplen2 = len;
1674 if (tmplen + 2 <= sizeof smallbuf)
1677 Newx(tmpbuf, tmplen + 2, char);
1680 memcpy(tmpbuf + 2, cf, tmplen);
1682 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1687 if (tmplen2 + 2 <= sizeof smallbuf)
1690 Newx(tmpbuf2, tmplen2 + 2, char);
1692 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1693 /* Either they malloc'd it, or we malloc'd it,
1694 so no prefix is present in ours. */
1699 memcpy(tmpbuf2 + 2, s, tmplen2);
1702 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1704 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1705 /* adjust ${"::_<newfilename"} to store the new file name */
1706 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1707 /* The line number may differ. If that is the case,
1708 alias the saved lines that are in the array.
1709 Otherwise alias the whole array. */
1710 if (CopLINE(PL_curcop) == line_num) {
1711 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1712 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1714 else if (GvAV(*gvp)) {
1715 AV * const av = GvAV(*gvp);
1716 const I32 start = CopLINE(PL_curcop)+1;
1717 I32 items = AvFILLp(av) - start;
1719 AV * const av2 = GvAVn(gv2);
1720 SV **svp = AvARRAY(av) + start;
1721 I32 l = (I32)line_num+1;
1723 av_store(av2, l++, SvREFCNT_inc(*svp++));
1728 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1730 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1732 CopFILE_free(PL_curcop);
1733 CopFILE_setn(PL_curcop, s, len);
1735 CopLINE_set(PL_curcop, line_num);
1739 /* skip space before PL_thistoken */
1742 S_skipspace0(pTHX_ char *s)
1744 PERL_ARGS_ASSERT_SKIPSPACE0;
1751 PL_thiswhite = newSVpvs("");
1752 sv_catsv(PL_thiswhite, PL_skipwhite);
1753 sv_free(PL_skipwhite);
1756 PL_realtokenstart = s - SvPVX(PL_linestr);
1760 /* skip space after PL_thistoken */
1763 S_skipspace1(pTHX_ char *s)
1765 const char *start = s;
1766 I32 startoff = start - SvPVX(PL_linestr);
1768 PERL_ARGS_ASSERT_SKIPSPACE1;
1773 start = SvPVX(PL_linestr) + startoff;
1774 if (!PL_thistoken && PL_realtokenstart >= 0) {
1775 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1776 PL_thistoken = newSVpvn(tstart, start - tstart);
1778 PL_realtokenstart = -1;
1781 PL_nextwhite = newSVpvs("");
1782 sv_catsv(PL_nextwhite, PL_skipwhite);
1783 sv_free(PL_skipwhite);
1790 S_skipspace2(pTHX_ char *s, SV **svp)
1793 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1794 const I32 startoff = s - SvPVX(PL_linestr);
1796 PERL_ARGS_ASSERT_SKIPSPACE2;
1799 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1800 if (!PL_madskills || !svp)
1802 start = SvPVX(PL_linestr) + startoff;
1803 if (!PL_thistoken && PL_realtokenstart >= 0) {
1804 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1805 PL_thistoken = newSVpvn(tstart, start - tstart);
1806 PL_realtokenstart = -1;
1810 *svp = newSVpvs("");
1811 sv_setsv(*svp, PL_skipwhite);
1812 sv_free(PL_skipwhite);
1821 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1823 AV *av = CopFILEAVx(PL_curcop);
1825 SV * const sv = newSV_type(SVt_PVMG);
1827 sv_setsv(sv, orig_sv);
1829 sv_setpvn(sv, buf, len);
1832 av_store(av, (I32)CopLINE(PL_curcop), sv);
1838 * Called to gobble the appropriate amount and type of whitespace.
1839 * Skips comments as well.
1843 S_skipspace(pTHX_ char *s)
1847 #endif /* PERL_MAD */
1848 PERL_ARGS_ASSERT_SKIPSPACE;
1851 sv_free(PL_skipwhite);
1852 PL_skipwhite = NULL;
1854 #endif /* PERL_MAD */
1855 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1856 while (s < PL_bufend && SPACE_OR_TAB(*s))
1859 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1861 lex_read_space(LEX_KEEP_PREVIOUS |
1862 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1863 LEX_NO_NEXT_CHUNK : 0));
1865 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1866 if (PL_linestart > PL_bufptr)
1867 PL_bufptr = PL_linestart;
1872 PL_skipwhite = newSVpvn(start, s-start);
1873 #endif /* PERL_MAD */
1879 * Check the unary operators to ensure there's no ambiguity in how they're
1880 * used. An ambiguous piece of code would be:
1882 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1883 * the +5 is its argument.
1893 if (PL_oldoldbufptr != PL_last_uni)
1895 while (isSPACE(*PL_last_uni))
1898 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1900 if ((t = strchr(s, '(')) && t < PL_bufptr)
1903 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1904 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1905 (int)(s - PL_last_uni), PL_last_uni);
1909 * LOP : macro to build a list operator. Its behaviour has been replaced
1910 * with a subroutine, S_lop() for which LOP is just another name.
1913 #define LOP(f,x) return lop(f,x,s)
1917 * Build a list operator (or something that might be one). The rules:
1918 * - if we have a next token, then it's a list operator [why?]
1919 * - if the next thing is an opening paren, then it's a function
1920 * - else it's a list operator
1924 S_lop(pTHX_ I32 f, int x, char *s)
1928 PERL_ARGS_ASSERT_LOP;
1934 PL_last_lop = PL_oldbufptr;
1935 PL_last_lop_op = (OPCODE)f;
1944 return REPORT(FUNC);
1947 return REPORT(FUNC);
1950 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1951 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1952 return REPORT(LSTOP);
1959 * Sets up for an eventual force_next(). start_force(0) basically does
1960 * an unshift, while start_force(-1) does a push. yylex removes items
1965 S_start_force(pTHX_ int where)
1969 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1970 where = PL_lasttoke;
1971 assert(PL_curforce < 0 || PL_curforce == where);
1972 if (PL_curforce != where) {
1973 for (i = PL_lasttoke; i > where; --i) {
1974 PL_nexttoke[i] = PL_nexttoke[i-1];
1978 if (PL_curforce < 0) /* in case of duplicate start_force() */
1979 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1980 PL_curforce = where;
1983 curmad('^', newSVpvs(""));
1984 CURMAD('_', PL_nextwhite);
1989 S_curmad(pTHX_ char slot, SV *sv)
1995 if (PL_curforce < 0)
1996 where = &PL_thismad;
1998 where = &PL_nexttoke[PL_curforce].next_mad;
2004 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2006 else if (PL_encoding) {
2007 sv_recode_to_utf8(sv, PL_encoding);
2012 /* keep a slot open for the head of the list? */
2013 if (slot != '_' && *where && (*where)->mad_key == '^') {
2014 (*where)->mad_key = slot;
2015 sv_free(MUTABLE_SV(((*where)->mad_val)));
2016 (*where)->mad_val = (void*)sv;
2019 addmad(newMADsv(slot, sv), where, 0);
2022 # define start_force(where) NOOP
2023 # define curmad(slot, sv) NOOP
2028 * When the lexer realizes it knows the next token (for instance,
2029 * it is reordering tokens for the parser) then it can call S_force_next
2030 * to know what token to return the next time the lexer is called. Caller
2031 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2032 * and possibly PL_expect to ensure the lexer handles the token correctly.
2036 S_force_next(pTHX_ I32 type)
2041 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2042 tokereport(type, &NEXTVAL_NEXTTOKE);
2046 if (PL_curforce < 0)
2047 start_force(PL_lasttoke);
2048 PL_nexttoke[PL_curforce].next_type = type;
2049 if (PL_lex_state != LEX_KNOWNEXT)
2050 PL_lex_defer = PL_lex_state;
2051 PL_lex_state = LEX_KNOWNEXT;
2052 PL_lex_expect = PL_expect;
2055 PL_nexttype[PL_nexttoke] = type;
2057 if (PL_lex_state != LEX_KNOWNEXT) {
2058 PL_lex_defer = PL_lex_state;
2059 PL_lex_expect = PL_expect;
2060 PL_lex_state = LEX_KNOWNEXT;
2068 int yyc = PL_parser->yychar;
2069 if (yyc != YYEMPTY) {
2072 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2073 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2074 PL_lex_allbrackets--;
2076 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2077 } else if (yyc == '('/*)*/) {
2078 PL_lex_allbrackets--;
2083 PL_parser->yychar = YYEMPTY;
2088 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2091 SV * const sv = newSVpvn_utf8(start, len,
2094 && !is_ascii_string((const U8*)start, len)
2095 && is_utf8_string((const U8*)start, len));
2101 * When the lexer knows the next thing is a word (for instance, it has
2102 * just seen -> and it knows that the next char is a word char, then
2103 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2107 * char *start : buffer position (must be within PL_linestr)
2108 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2109 * int check_keyword : if true, Perl checks to make sure the word isn't
2110 * a keyword (do this if the word is a label, e.g. goto FOO)
2111 * int allow_pack : if true, : characters will also be allowed (require,
2112 * use, etc. do this)
2113 * int allow_initial_tick : used by the "sub" lexer only.
2117 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
2123 PERL_ARGS_ASSERT_FORCE_WORD;
2125 start = SKIPSPACE1(start);
2127 if (isIDFIRST_lazy_if(s,UTF) ||
2128 (allow_pack && *s == ':') ||
2129 (allow_initial_tick && *s == '\'') )
2131 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2132 if (check_keyword && keyword(PL_tokenbuf, len, 0))
2134 start_force(PL_curforce);
2136 curmad('X', newSVpvn(start,s-start));
2137 if (token == METHOD) {
2142 PL_expect = XOPERATOR;
2146 curmad('g', newSVpvs( "forced" ));
2147 NEXTVAL_NEXTTOKE.opval
2148 = (OP*)newSVOP(OP_CONST,0,
2149 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2150 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2158 * Called when the lexer wants $foo *foo &foo etc, but the program
2159 * text only contains the "foo" portion. The first argument is a pointer
2160 * to the "foo", and the second argument is the type symbol to prefix.
2161 * Forces the next token to be a "WORD".
2162 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2166 S_force_ident(pTHX_ const char *s, int kind)
2170 PERL_ARGS_ASSERT_FORCE_IDENT;
2173 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2174 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2175 UTF ? SVf_UTF8 : 0));
2176 start_force(PL_curforce);
2177 NEXTVAL_NEXTTOKE.opval = o;
2180 o->op_private = OPpCONST_ENTERED;
2181 /* XXX see note in pp_entereval() for why we forgo typo
2182 warnings if the symbol must be introduced in an eval.
2184 gv_fetchpvn_flags(s, len,
2185 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2186 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2187 kind == '$' ? SVt_PV :
2188 kind == '@' ? SVt_PVAV :
2189 kind == '%' ? SVt_PVHV :
2197 S_force_ident_maybe_lex(pTHX_ char pit)
2199 start_force(PL_curforce);
2200 NEXTVAL_NEXTTOKE.ival = pit;
2205 Perl_str_to_version(pTHX_ SV *sv)
2210 const char *start = SvPV_const(sv,len);
2211 const char * const end = start + len;
2212 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2214 PERL_ARGS_ASSERT_STR_TO_VERSION;
2216 while (start < end) {
2220 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2225 retval += ((NV)n)/nshift;
2234 * Forces the next token to be a version number.
2235 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2236 * and if "guessing" is TRUE, then no new token is created (and the caller
2237 * must use an alternative parsing method).
2241 S_force_version(pTHX_ char *s, int guessing)
2247 I32 startoff = s - SvPVX(PL_linestr);
2250 PERL_ARGS_ASSERT_FORCE_VERSION;
2258 while (isDIGIT(*d) || *d == '_' || *d == '.')
2262 start_force(PL_curforce);
2263 curmad('X', newSVpvn(s,d-s));
2266 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2268 #ifdef USE_LOCALE_NUMERIC
2269 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2270 setlocale(LC_NUMERIC, "C");
2272 s = scan_num(s, &pl_yylval);
2273 #ifdef USE_LOCALE_NUMERIC
2274 setlocale(LC_NUMERIC, loc);
2277 version = pl_yylval.opval;
2278 ver = cSVOPx(version)->op_sv;
2279 if (SvPOK(ver) && !SvNIOK(ver)) {
2280 SvUPGRADE(ver, SVt_PVNV);
2281 SvNV_set(ver, str_to_version(ver));
2282 SvNOK_on(ver); /* hint that it is a version */
2285 else if (guessing) {
2288 sv_free(PL_nextwhite); /* let next token collect whitespace */
2290 s = SvPVX(PL_linestr) + startoff;
2298 if (PL_madskills && !version) {
2299 sv_free(PL_nextwhite); /* let next token collect whitespace */
2301 s = SvPVX(PL_linestr) + startoff;
2304 /* NOTE: The parser sees the package name and the VERSION swapped */
2305 start_force(PL_curforce);
2306 NEXTVAL_NEXTTOKE.opval = version;
2313 * S_force_strict_version
2314 * Forces the next token to be a version number using strict syntax rules.
2318 S_force_strict_version(pTHX_ char *s)
2323 I32 startoff = s - SvPVX(PL_linestr);
2325 const char *errstr = NULL;
2327 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2329 while (isSPACE(*s)) /* leading whitespace */
2332 if (is_STRICT_VERSION(s,&errstr)) {
2334 s = (char *)scan_version(s, ver, 0);
2335 version = newSVOP(OP_CONST, 0, ver);
2337 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2338 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2342 yyerror(errstr); /* version required */
2347 if (PL_madskills && !version) {
2348 sv_free(PL_nextwhite); /* let next token collect whitespace */
2350 s = SvPVX(PL_linestr) + startoff;
2353 /* NOTE: The parser sees the package name and the VERSION swapped */
2354 start_force(PL_curforce);
2355 NEXTVAL_NEXTTOKE.opval = version;
2363 * Tokenize a quoted string passed in as an SV. It finds the next
2364 * chunk, up to end of string or a backslash. It may make a new
2365 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2370 S_tokeq(pTHX_ SV *sv)
2379 PERL_ARGS_ASSERT_TOKEQ;
2384 s = SvPV_force(sv, len);
2385 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2388 /* This is relying on the SV being "well formed" with a trailing '\0' */
2389 while (s < send && !(*s == '\\' && s[1] == '\\'))
2394 if ( PL_hints & HINT_NEW_STRING ) {
2395 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2399 if (s + 1 < send && (s[1] == '\\'))
2400 s++; /* all that, just for this */
2405 SvCUR_set(sv, d - SvPVX_const(sv));
2407 if ( PL_hints & HINT_NEW_STRING )
2408 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2413 * Now come three functions related to double-quote context,
2414 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2415 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2416 * interact with PL_lex_state, and create fake ( ... ) argument lists
2417 * to handle functions and concatenation.
2421 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2426 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2428 * Pattern matching will set PL_lex_op to the pattern-matching op to
2429 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2431 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2433 * Everything else becomes a FUNC.
2435 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2436 * had an OP_CONST or OP_READLINE). This just sets us up for a
2437 * call to S_sublex_push().
2441 S_sublex_start(pTHX)
2444 const I32 op_type = pl_yylval.ival;
2446 if (op_type == OP_NULL) {
2447 pl_yylval.opval = PL_lex_op;
2451 if (op_type == OP_CONST || op_type == OP_READLINE) {
2452 SV *sv = tokeq(PL_lex_stuff);
2454 if (SvTYPE(sv) == SVt_PVIV) {
2455 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2457 const char * const p = SvPV_const(sv, len);
2458 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2462 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2463 PL_lex_stuff = NULL;
2464 /* Allow <FH> // "foo" */
2465 if (op_type == OP_READLINE)
2466 PL_expect = XTERMORDORDOR;
2469 else if (op_type == OP_BACKTICK && PL_lex_op) {
2470 /* readpipe() vas overriden */
2471 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2472 pl_yylval.opval = PL_lex_op;
2474 PL_lex_stuff = NULL;
2478 PL_sublex_info.super_state = PL_lex_state;
2479 PL_sublex_info.sub_inwhat = (U16)op_type;
2480 PL_sublex_info.sub_op = PL_lex_op;
2481 PL_lex_state = LEX_INTERPPUSH;
2485 pl_yylval.opval = PL_lex_op;
2495 * Create a new scope to save the lexing state. The scope will be
2496 * ended in S_sublex_done. Returns a '(', starting the function arguments
2497 * to the uc, lc, etc. found before.
2498 * Sets PL_lex_state to LEX_INTERPCONCAT.
2508 PL_lex_state = PL_sublex_info.super_state;
2509 SAVEBOOL(PL_lex_dojoin);
2510 SAVEI32(PL_lex_brackets);
2511 SAVEI32(PL_lex_allbrackets);
2512 SAVEI32(PL_lex_formbrack);
2513 SAVEI8(PL_lex_fakeeof);
2514 SAVEI32(PL_lex_casemods);
2515 SAVEI32(PL_lex_starts);
2516 SAVEI8(PL_lex_state);
2517 SAVESPTR(PL_lex_repl);
2518 SAVEVPTR(PL_lex_inpat);
2519 SAVEI16(PL_lex_inwhat);
2520 SAVECOPLINE(PL_curcop);
2521 SAVEPPTR(PL_bufptr);
2522 SAVEPPTR(PL_bufend);
2523 SAVEPPTR(PL_oldbufptr);
2524 SAVEPPTR(PL_oldoldbufptr);
2525 SAVEPPTR(PL_last_lop);
2526 SAVEPPTR(PL_last_uni);
2527 SAVEPPTR(PL_linestart);
2528 SAVESPTR(PL_linestr);
2529 SAVEGENERICPV(PL_lex_brackstack);
2530 SAVEGENERICPV(PL_lex_casestack);
2531 SAVEGENERICPV(PL_parser->lex_shared);
2532 SAVEBOOL(PL_parser->lex_re_reparsing);
2534 /* The here-doc parser needs to be able to peek into outer lexing
2535 scopes to find the body of the here-doc. So we put PL_linestr and
2536 PL_bufptr into lex_shared, to ‘share’ those values.
2538 PL_parser->lex_shared->ls_linestr = PL_linestr;
2539 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2541 PL_linestr = PL_lex_stuff;
2542 PL_lex_repl = PL_sublex_info.repl;
2543 PL_lex_stuff = NULL;
2544 PL_sublex_info.repl = NULL;
2546 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2547 = SvPVX(PL_linestr);
2548 PL_bufend += SvCUR(PL_linestr);
2549 PL_last_lop = PL_last_uni = NULL;
2550 SAVEFREESV(PL_linestr);
2551 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2553 PL_lex_dojoin = FALSE;
2554 PL_lex_brackets = PL_lex_formbrack = 0;
2555 PL_lex_allbrackets = 0;
2556 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2557 Newx(PL_lex_brackstack, 120, char);
2558 Newx(PL_lex_casestack, 12, char);
2559 PL_lex_casemods = 0;
2560 *PL_lex_casestack = '\0';
2562 PL_lex_state = LEX_INTERPCONCAT;
2563 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2565 Newxz(shared, 1, LEXSHARED);
2566 shared->ls_prev = PL_parser->lex_shared;
2567 PL_parser->lex_shared = shared;
2569 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2570 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2571 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2572 PL_lex_inpat = PL_sublex_info.sub_op;
2574 PL_lex_inpat = NULL;
2576 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2577 PL_in_eval &= ~EVAL_RE_REPARSING;
2584 * Restores lexer state after a S_sublex_push.
2591 if (!PL_lex_starts++) {
2592 SV * const sv = newSVpvs("");
2593 if (SvUTF8(PL_linestr))
2595 PL_expect = XOPERATOR;
2596 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2600 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2601 PL_lex_state = LEX_INTERPCASEMOD;
2605 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2606 assert(PL_lex_inwhat != OP_TRANSR);
2607 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2608 PL_linestr = PL_lex_repl;
2610 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2611 PL_bufend += SvCUR(PL_linestr);
2612 PL_last_lop = PL_last_uni = NULL;
2613 PL_lex_dojoin = FALSE;
2614 PL_lex_brackets = 0;
2615 PL_lex_allbrackets = 0;
2616 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2617 PL_lex_casemods = 0;
2618 *PL_lex_casestack = '\0';
2620 if (SvEVALED(PL_lex_repl)) {
2621 PL_lex_state = LEX_INTERPNORMAL;
2623 /* we don't clear PL_lex_repl here, so that we can check later
2624 whether this is an evalled subst; that means we rely on the
2625 logic to ensure sublex_done() is called again only via the
2626 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2629 PL_lex_state = LEX_INTERPCONCAT;
2639 PL_endwhite = newSVpvs("");
2640 sv_catsv(PL_endwhite, PL_thiswhite);
2644 sv_setpvs(PL_thistoken,"");
2646 PL_realtokenstart = -1;
2650 PL_bufend = SvPVX(PL_linestr);
2651 PL_bufend += SvCUR(PL_linestr);
2652 PL_expect = XOPERATOR;
2653 PL_sublex_info.sub_inwhat = 0;
2658 PERL_STATIC_INLINE SV*
2659 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2661 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2662 * interior, hence to the "}". Finds what the name resolves to, returning
2663 * an SV* containing it; NULL if no valid one found */
2665 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2672 const U8* first_bad_char_loc;
2673 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2675 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2677 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2679 &first_bad_char_loc))
2681 /* If warnings are on, this will print a more detailed analysis of what
2682 * is wrong than the error message below */
2683 utf8n_to_uvuni(first_bad_char_loc,
2684 e - ((char *) first_bad_char_loc),
2687 /* We deliberately don't try to print the malformed character, which
2688 * might not print very well; it also may be just the first of many
2689 * malformations, so don't print what comes after it */
2690 yyerror(Perl_form(aTHX_
2691 "Malformed UTF-8 character immediately after '%.*s'",
2692 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2696 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2697 /* include the <}> */
2698 e - backslash_ptr + 1);
2700 SvREFCNT_dec_NN(res);
2704 /* See if the charnames handler is the Perl core's, and if so, we can skip
2705 * the validation needed for a user-supplied one, as Perl's does its own
2707 table = GvHV(PL_hintgv); /* ^H */
2708 cvp = hv_fetchs(table, "charnames", FALSE);
2709 if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
2710 && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
2712 const char * const name = HvNAME(stash);
2713 if strEQ(name, "_charnames") {
2718 /* Here, it isn't Perl's charname handler. We can't rely on a
2719 * user-supplied handler to validate the input name. For non-ut8 input,
2720 * look to see that the first character is legal. Then loop through the
2721 * rest checking that each is a continuation */
2723 /* This code needs to be sync'ed with a regex in _charnames.pm which does
2727 if (! isALPHAU(*s)) {
2732 if (! isCHARNAME_CONT(*s)) {
2735 if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2736 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2737 "A sequence of multiple spaces in a charnames "
2738 "alias definition is deprecated");
2742 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2743 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2744 "Trailing white-space in a charnames alias "
2745 "definition is deprecated");
2749 /* Similarly for utf8. For invariants can check directly; for other
2750 * Latin1, can calculate their code point and check; otherwise use a
2752 if (UTF8_IS_INVARIANT(*s)) {
2753 if (! isALPHAU(*s)) {
2757 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2758 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
2764 if (! PL_utf8_charname_begin) {
2765 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2766 PL_utf8_charname_begin = _core_swash_init("utf8",
2767 "_Perl_Charname_Begin",
2769 1, 0, NULL, &flags);
2771 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2778 if (UTF8_IS_INVARIANT(*s)) {
2779 if (! isCHARNAME_CONT(*s)) {
2782 if (*s == ' ' && *(s-1) == ' '
2783 && ckWARN_d(WARN_DEPRECATED)) {
2784 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2785 "A sequence of multiple spaces in a charnam"
2786 "es alias definition is deprecated");
2790 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2791 if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
2799 if (! PL_utf8_charname_continue) {
2800 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2801 PL_utf8_charname_continue = _core_swash_init("utf8",
2802 "_Perl_Charname_Continue",
2804 1, 0, NULL, &flags);
2806 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2812 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2813 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2814 "Trailing white-space in a charnames alias "
2815 "definition is deprecated");
2819 if (SvUTF8(res)) { /* Don't accept malformed input */
2820 const U8* first_bad_char_loc;
2822 const char* const str = SvPV_const(res, len);
2823 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2824 /* If warnings are on, this will print a more detailed analysis of
2825 * what is wrong than the error message below */
2826 utf8n_to_uvuni(first_bad_char_loc,
2827 (char *) first_bad_char_loc - str,
2830 /* We deliberately don't try to print the malformed character,
2831 * which might not print very well; it also may be just the first
2832 * of many malformations, so don't print what comes after it */
2835 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2836 (int) (e - backslash_ptr + 1), backslash_ptr,
2837 (int) ((char *) first_bad_char_loc - str), str
2847 int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
2849 /* The final %.*s makes sure that should the trailing NUL be missing
2850 * that this print won't run off the end of the string */
2853 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2854 (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2855 (int)(e - s + bad_char_size), s + bad_char_size
2857 UTF ? SVf_UTF8 : 0);
2865 Extracts the next constant part of a pattern, double-quoted string,
2866 or transliteration. This is terrifying code.
2868 For example, in parsing the double-quoted string "ab\x63$d", it would
2869 stop at the '$' and return an OP_CONST containing 'abc'.
2871 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2872 processing a pattern (PL_lex_inpat is true), a transliteration
2873 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2875 Returns a pointer to the character scanned up to. If this is
2876 advanced from the start pointer supplied (i.e. if anything was
2877 successfully parsed), will leave an OP_CONST for the substring scanned
2878 in pl_yylval. Caller must intuit reason for not parsing further
2879 by looking at the next characters herself.
2883 \N{FOO} => \N{U+hex_for_character_FOO}
2884 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2887 all other \-char, including \N and \N{ apart from \N{ABC}
2890 @ and $ where it appears to be a var, but not for $ as tail anchor
2895 In transliterations:
2896 characters are VERY literal, except for - not at the start or end
2897 of the string, which indicates a range. If the range is in bytes,
2898 scan_const expands the range to the full set of intermediate
2899 characters. If the range is in utf8, the hyphen is replaced with
2900 a certain range mark which will be handled by pmtrans() in op.c.
2902 In double-quoted strings:
2904 double-quoted style: \r and \n
2905 constants: \x31, etc.
2906 deprecated backrefs: \1 (in substitution replacements)
2907 case and quoting: \U \Q \E
2910 scan_const does *not* construct ops to handle interpolated strings.
2911 It stops processing as soon as it finds an embedded $ or @ variable
2912 and leaves it to the caller to work out what's going on.
2914 embedded arrays (whether in pattern or not) could be:
2915 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2917 $ in double-quoted strings must be the symbol of an embedded scalar.
2919 $ in pattern could be $foo or could be tail anchor. Assumption:
2920 it's a tail anchor if $ is the last thing in the string, or if it's
2921 followed by one of "()| \r\n\t"
2923 \1 (backreferences) are turned into $1 in substitutions
2925 The structure of the code is
2926 while (there's a character to process) {
2927 handle transliteration ranges
2928 skip regexp comments /(?#comment)/ and codes /(?{code})/
2929 skip #-initiated comments in //x patterns
2930 check for embedded arrays
2931 check for embedded scalars
2933 deprecate \1 in substitution replacements
2934 handle string-changing backslashes \l \U \Q \E, etc.
2935 switch (what was escaped) {
2936 handle \- in a transliteration (becomes a literal -)
2937 if a pattern and not \N{, go treat as regular character
2938 handle \132 (octal characters)
2939 handle \x15 and \x{1234} (hex characters)
2940 handle \N{name} (named characters, also \N{3,5} in a pattern)
2941 handle \cV (control characters)
2942 handle printf-style backslashes (\f, \r, \n, etc)
2945 } (end if backslash)
2946 handle regular character
2947 } (end while character to read)
2952 S_scan_const(pTHX_ char *start)
2955 char *send = PL_bufend; /* end of the constant */
2956 SV *sv = newSV(send - start); /* sv for the constant. See
2957 note below on sizing. */
2958 char *s = start; /* start of the constant */
2959 char *d = SvPVX(sv); /* destination for copies */
2960 bool dorange = FALSE; /* are we in a translit range? */
2961 bool didrange = FALSE; /* did we just finish a range? */
2962 bool in_charclass = FALSE; /* within /[...]/ */
2963 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2964 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2965 to be UTF8? But, this can
2966 show as true when the source
2967 isn't utf8, as for example
2968 when it is entirely composed
2970 SV *res; /* result from charnames */
2972 /* Note on sizing: The scanned constant is placed into sv, which is
2973 * initialized by newSV() assuming one byte of output for every byte of
2974 * input. This routine expects newSV() to allocate an extra byte for a
2975 * trailing NUL, which this routine will append if it gets to the end of
2976 * the input. There may be more bytes of input than output (eg., \N{LATIN
2977 * CAPITAL LETTER A}), or more output than input if the constant ends up
2978 * recoded to utf8, but each time a construct is found that might increase
2979 * the needed size, SvGROW() is called. Its size parameter each time is
2980 * based on the best guess estimate at the time, namely the length used so
2981 * far, plus the length the current construct will occupy, plus room for
2982 * the trailing NUL, plus one byte for every input byte still unscanned */
2984 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2987 UV literal_endpoint = 0;
2988 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2991 PERL_ARGS_ASSERT_SCAN_CONST;
2993 assert(PL_lex_inwhat != OP_TRANSR);
2994 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2995 /* If we are doing a trans and we know we want UTF8 set expectation */
2996 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2997 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3000 /* Protect sv from errors and fatal warnings. */
3001 ENTER_with_name("scan_const");
3004 while (s < send || dorange) {
3006 /* get transliterations out of the way (they're most literal) */
3007 if (PL_lex_inwhat == OP_TRANS) {
3008 /* expand a range A-Z to the full set of characters. AIE! */
3010 I32 i; /* current expanded character */
3011 I32 min; /* first character in range */
3012 I32 max; /* last character in range */
3023 char * const c = (char*)utf8_hop((U8*)d, -1);
3027 *c = (char)UTF_TO_NATIVE(0xff);
3028 /* mark the range as done, and continue */
3034 i = d - SvPVX_const(sv); /* remember current offset */
3037 SvLEN(sv) + (has_utf8 ?
3038 (512 - UTF_CONTINUATION_MARK +
3041 /* How many two-byte within 0..255: 128 in UTF-8,
3042 * 96 in UTF-8-mod. */
3044 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
3046 d = SvPVX(sv) + i; /* refresh d after realloc */
3050 for (j = 0; j <= 1; j++) {
3051 char * const c = (char*)utf8_hop((U8*)d, -1);
3052 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3058 max = (U8)0xff; /* only to \xff */
3059 uvmax = uv; /* \x{100} to uvmax */
3061 d = c; /* eat endpoint chars */
3066 d -= 2; /* eat the first char and the - */
3067 min = (U8)*d; /* first char in range */
3068 max = (U8)d[1]; /* last char in range */
3075 "Invalid range \"%c-%c\" in transliteration operator",
3076 (char)min, (char)max);
3080 if (literal_endpoint == 2 &&
3081 ((isLOWER(min) && isLOWER(max)) ||
3082 (isUPPER(min) && isUPPER(max)))) {
3084 for (i = min; i <= max; i++)
3086 *d++ = NATIVE_TO_NEED(has_utf8,i);
3088 for (i = min; i <= max; i++)
3090 *d++ = NATIVE_TO_NEED(has_utf8,i);
3095 for (i = min; i <= max; i++)
3098 const U8 ch = (U8)NATIVE_TO_UTF(i);
3099 if (UNI_IS_INVARIANT(ch))
3102 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
3103 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
3112 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3114 *d++ = (char)UTF_TO_NATIVE(0xff);
3116 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3120 /* mark the range as done, and continue */
3124 literal_endpoint = 0;
3129 /* range begins (ignore - as first or last char) */
3130 else if (*s == '-' && s+1 < send && s != start) {
3132 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3139 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
3149 literal_endpoint = 0;
3150 native_range = TRUE;
3155 /* if we get here, we're not doing a transliteration */
3157 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3160 while (s1 >= start && *s1-- == '\\')
3163 in_charclass = TRUE;
3166 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3169 while (s1 >= start && *s1-- == '\\')
3172 in_charclass = FALSE;
3175 /* skip for regexp comments /(?#comment)/, except for the last
3176 * char, which will be done separately.
3177 * Stop on (?{..}) and friends */
3179 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
3181 while (s+1 < send && *s != ')')
3182 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3184 else if (!PL_lex_casemods && !in_charclass &&
3185 ( s[2] == '{' /* This should match regcomp.c */
3186 || (s[2] == '?' && s[3] == '{')))
3192 /* likewise skip #-initiated comments in //x patterns */
3193 else if (*s == '#' && PL_lex_inpat &&
3194 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3195 while (s+1 < send && *s != '\n')
3196 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3199 /* no further processing of single-quoted regex */
3200 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3201 goto default_action;
3203 /* check for embedded arrays
3204 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3206 else if (*s == '@' && s[1]) {
3207 if (isWORDCHAR_lazy_if(s+1,UTF))
3209 if (strchr(":'{$", s[1]))
3211 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3212 break; /* in regexp, neither @+ nor @- are interpolated */
3215 /* check for embedded scalars. only stop if we're sure it's a
3218 else if (*s == '$') {
3219 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3221 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3223 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3224 "Possible unintended interpolation of $\\ in regex");
3226 break; /* in regexp, $ might be tail anchor */
3230 /* End of else if chain - OP_TRANS rejoin rest */
3233 if (*s == '\\' && s+1 < send) {
3234 char* e; /* Can be used for ending '}', etc. */
3238 /* warn on \1 - \9 in substitution replacements, but note that \11
3239 * is an octal; and \19 is \1 followed by '9' */
3240 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3241 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3243 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3248 /* string-change backslash escapes */
3249 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3253 /* In a pattern, process \N, but skip any other backslash escapes.
3254 * This is because we don't want to translate an escape sequence
3255 * into a meta symbol and have the regex compiler use the meta
3256 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3257 * in spite of this, we do have to process \N here while the proper
3258 * charnames handler is in scope. See bugs #56444 and #62056.
3259 * There is a complication because \N in a pattern may also stand
3260 * for 'match a non-nl', and not mean a charname, in which case its
3261 * processing should be deferred to the regex compiler. To be a
3262 * charname it must be followed immediately by a '{', and not look
3263 * like \N followed by a curly quantifier, i.e., not something like
3264 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3266 else if (PL_lex_inpat
3269 || regcurly(s + 1, FALSE)))
3271 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
3272 goto default_action;
3277 /* quoted - in transliterations */
3279 if (PL_lex_inwhat == OP_TRANS) {
3286 if ((isALPHANUMERIC(*s)))
3287 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3288 "Unrecognized escape \\%c passed through",
3290 /* default action is to copy the quoted character */
3291 goto default_action;
3294 /* eg. \132 indicates the octal constant 0132 */
3295 case '0': case '1': case '2': case '3':
3296 case '4': case '5': case '6': case '7':
3298 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3300 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
3302 if (len < 3 && s < send && isDIGIT(*s)
3303 && ckWARN(WARN_MISC))
3305 Perl_warner(aTHX_ packWARN(WARN_MISC),
3306 "%s", form_short_octal_warning(s, len));
3309 goto NUM_ESCAPE_INSERT;
3311 /* eg. \o{24} indicates the octal constant \024 */
3316 bool valid = grok_bslash_o(&s, &uv, &error,
3317 TRUE, /* Output warning */
3318 FALSE, /* Not strict */
3319 TRUE, /* Output warnings for
3326 goto NUM_ESCAPE_INSERT;
3329 /* eg. \x24 indicates the hex constant 0x24 */
3334 bool valid = grok_bslash_x(&s, &uv, &error,
3335 TRUE, /* Output warning */
3336 FALSE, /* Not strict */
3337 TRUE, /* Output warnings for
3347 /* Insert oct or hex escaped character. There will always be
3348 * enough room in sv since such escapes will be longer than any
3349 * UTF-8 sequence they can end up as, except if they force us
3350 * to recode the rest of the string into utf8 */
3352 /* Here uv is the ordinal of the next character being added in
3353 * unicode (converted from native). */
3354 if (!UNI_IS_INVARIANT(uv)) {
3355 if (!has_utf8 && uv > 255) {
3356 /* Might need to recode whatever we have accumulated so
3357 * far if it contains any chars variant in utf8 or
3360 SvCUR_set(sv, d - SvPVX_const(sv));
3363 /* See Note on sizing above. */
3364 sv_utf8_upgrade_flags_grow(sv,
3365 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3366 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3367 d = SvPVX(sv) + SvCUR(sv);
3372 d = (char*)uvuni_to_utf8((U8*)d, uv);
3373 if (PL_lex_inwhat == OP_TRANS &&
3374 PL_sublex_info.sub_op) {
3375 PL_sublex_info.sub_op->op_private |=
3376 (PL_lex_repl ? OPpTRANS_FROM_UTF
3380 if (uv > 255 && !dorange)
3381 native_range = FALSE;
3394 /* In a non-pattern \N must be a named character, like \N{LATIN
3395 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3396 * mean to match a non-newline. For non-patterns, named
3397 * characters are converted to their string equivalents. In
3398 * patterns, named characters are not converted to their
3399 * ultimate forms for the same reasons that other escapes
3400 * aren't. Instead, they are converted to the \N{U+...} form
3401 * to get the value from the charnames that is in effect right
3402 * now, while preserving the fact that it was a named character
3403 * so that the regex compiler knows this */
3405 /* This section of code doesn't generally use the
3406 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3407 * a close examination of this macro and determined it is a
3408 * no-op except on utfebcdic variant characters. Every
3409 * character generated by this that would normally need to be
3410 * enclosed by this macro is invariant, so the macro is not
3411 * needed, and would complicate use of copy(). XXX There are
3412 * other parts of this file where the macro is used
3413 * inconsistently, but are saved by it being a no-op */
3415 /* The structure of this section of code (besides checking for
3416 * errors and upgrading to utf8) is:
3417 * Further disambiguate between the two meanings of \N, and if
3418 * not a charname, go process it elsewhere
3419 * If of form \N{U+...}, pass it through if a pattern;
3420 * otherwise convert to utf8
3421 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3422 * pattern; otherwise convert to utf8 */
3424 /* Here, s points to the 'N'; the test below is guaranteed to
3425 * succeed if we are being called on a pattern as we already
3426 * know from a test above that the next character is a '{'.
3427 * On a non-pattern \N must mean 'named sequence, which
3428 * requires braces */
3431 yyerror("Missing braces on \\N{}");
3436 /* If there is no matching '}', it is an error. */
3437 if (! (e = strchr(s, '}'))) {
3438 if (! PL_lex_inpat) {
3439 yyerror("Missing right brace on \\N{}");
3441 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3446 /* Here it looks like a named character */
3448 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3449 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3450 | PERL_SCAN_DISALLOW_PREFIX;
3453 /* For \N{U+...}, the '...' is a unicode value even on
3454 * EBCDIC machines */
3455 s += 2; /* Skip to next char after the 'U+' */
3457 uv = grok_hex(s, &len, &flags, NULL);
3458 if (len == 0 || len != (STRLEN)(e - s)) {
3459 yyerror("Invalid hexadecimal number in \\N{U+...}");
3466 /* On non-EBCDIC platforms, pass through to the regex
3467 * compiler unchanged. The reason we evaluated the
3468 * number above is to make sure there wasn't a syntax
3469 * error. But on EBCDIC we convert to native so
3470 * downstream code can continue to assume it's native
3472 s -= 5; /* Include the '\N{U+' */
3474 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3477 (unsigned int) UNI_TO_NATIVE(uv));
3479 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3483 else { /* Not a pattern: convert the hex to string */
3485 /* If destination is not in utf8, unconditionally
3486 * recode it to be so. This is because \N{} implies
3487 * Unicode semantics, and scalars have to be in utf8
3488 * to guarantee those semantics */
3490 SvCUR_set(sv, d - SvPVX_const(sv));
3493 /* See Note on sizing above. */
3494 sv_utf8_upgrade_flags_grow(
3496 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3497 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3498 d = SvPVX(sv) + SvCUR(sv);
3502 /* Add the string to the output */
3503 if (UNI_IS_INVARIANT(uv)) {
3506 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3509 else /* Here is \N{NAME} but not \N{U+...}. */
3510 if ((res = get_and_check_backslash_N_name(s, e)))
3513 const char *str = SvPV_const(res, len);
3516 if (! len) { /* The name resolved to an empty string */
3517 Copy("\\N{}", d, 4, char);
3521 /* In order to not lose information for the regex
3522 * compiler, pass the result in the specially made
3523 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3524 * the code points in hex of each character
3525 * returned by charnames */
3527 const char *str_end = str + len;
3528 const STRLEN off = d - SvPVX_const(sv);
3530 if (! SvUTF8(res)) {
3531 /* For the non-UTF-8 case, we can determine the
3532 * exact length needed without having to parse
3533 * through the string. Each character takes up
3534 * 2 hex digits plus either a trailing dot or
3536 d = off + SvGROW(sv, off
3538 + 6 /* For the "\N{U+", and
3540 + (STRLEN)(send - e));
3541 Copy("\\N{U+", d, 5, char);
3543 while (str < str_end) {
3545 my_snprintf(hex_string, sizeof(hex_string),
3546 "%02X.", (U8) *str);
3547 Copy(hex_string, d, 3, char);
3551 d--; /* We will overwrite below the final
3552 dot with a right brace */
3555 STRLEN char_length; /* cur char's byte length */
3557 /* and the number of bytes after this is
3558 * translated into hex digits */
3559 STRLEN output_length;
3561 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3562 * for max('U+', '.'); and 1 for NUL */
3563 char hex_string[2 * UTF8_MAXBYTES + 5];
3565 /* Get the first character of the result. */
3566 U32 uv = utf8n_to_uvuni((U8 *) str,
3570 /* Convert first code point to hex, including
3571 * the boiler plate before it. For all these,
3572 * we convert to native format so that
3573 * downstream code can continue to assume the
3574 * input is native */
3576 my_snprintf(hex_string, sizeof(hex_string),
3578 (unsigned int) UNI_TO_NATIVE(uv));
3580 /* Make sure there is enough space to hold it */
3581 d = off + SvGROW(sv, off
3583 + (STRLEN)(send - e)
3584 + 2); /* '}' + NUL */
3586 Copy(hex_string, d, output_length, char);
3589 /* For each subsequent character, append dot and
3590 * its ordinal in hex */
3591 while ((str += char_length) < str_end) {
3592 const STRLEN off = d - SvPVX_const(sv);
3593 U32 uv = utf8n_to_uvuni((U8 *) str,
3598 my_snprintf(hex_string,
3601 (unsigned int) UNI_TO_NATIVE(uv));
3603 d = off + SvGROW(sv, off
3605 + (STRLEN)(send - e)
3606 + 2); /* '}' + NUL */
3607 Copy(hex_string, d, output_length, char);
3612 *d++ = '}'; /* Done. Add the trailing brace */
3615 else { /* Here, not in a pattern. Convert the name to a
3618 /* If destination is not in utf8, unconditionally
3619 * recode it to be so. This is because \N{} implies
3620 * Unicode semantics, and scalars have to be in utf8
3621 * to guarantee those semantics */
3623 SvCUR_set(sv, d - SvPVX_const(sv));
3626 /* See Note on sizing above. */
3627 sv_utf8_upgrade_flags_grow(sv,
3628 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3629 len + (STRLEN)(send - s) + 1);
3630 d = SvPVX(sv) + SvCUR(sv);
3632 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3634 /* See Note on sizing above. (NOTE: SvCUR() is not
3635 * set correctly here). */
3636 const STRLEN off = d - SvPVX_const(sv);
3637 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3639 Copy(str, d, len, char);
3645 } /* End \N{NAME} */
3648 native_range = FALSE; /* \N{} is defined to be Unicode */
3650 s = e + 1; /* Point to just after the '}' */
3653 /* \c is a control character */
3657 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3660 yyerror("Missing control char name in \\c");
3664 /* printf-style backslashes, formfeeds, newlines, etc */
3666 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3669 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3672 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3675 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3678 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3681 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3684 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3690 } /* end if (backslash) */
3697 /* If we started with encoded form, or already know we want it,
3698 then encode the next character */
3699 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3703 /* One might think that it is wasted effort in the case of the
3704 * source being utf8 (this_utf8 == TRUE) to take the next character
3705 * in the source, convert it to an unsigned value, and then convert
3706 * it back again. But the source has not been validated here. The
3707 * routine that does the conversion checks for errors like
3710 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3711 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3713 SvCUR_set(sv, d - SvPVX_const(sv));
3716 /* See Note on sizing above. */
3717 sv_utf8_upgrade_flags_grow(sv,
3718 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3719 need + (STRLEN)(send - s) + 1);
3720 d = SvPVX(sv) + SvCUR(sv);
3722 } else if (need > len) {
3723 /* encoded value larger than old, may need extra space (NOTE:
3724 * SvCUR() is not set correctly here). See Note on sizing
3726 const STRLEN off = d - SvPVX_const(sv);
3727 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3731 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3733 if (uv > 255 && !dorange)
3734 native_range = FALSE;
3738 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3740 } /* while loop to process each character */
3742 /* terminate the string and set up the sv */
3744 SvCUR_set(sv, d - SvPVX_const(sv));
3745 if (SvCUR(sv) >= SvLEN(sv))
3746 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3747 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3750 if (PL_encoding && !has_utf8) {
3751 sv_recode_to_utf8(sv, PL_encoding);
3757 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3758 PL_sublex_info.sub_op->op_private |=
3759 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3763 /* shrink the sv if we allocated more than we used */
3764 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3765 SvPV_shrink_to_cur(sv);
3768 /* return the substring (via pl_yylval) only if we parsed anything */
3769 if (s > PL_bufptr) {
3770 SvREFCNT_inc_simple_void_NN(sv);
3771 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3772 && ! PL_parser->lex_re_reparsing)
3774 const char *const key = PL_lex_inpat ? "qr" : "q";
3775 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3779 if (PL_lex_inwhat == OP_TRANS) {
3782 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3785 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3793 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3796 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3798 LEAVE_with_name("scan_const");
3803 * Returns TRUE if there's more to the expression (e.g., a subscript),
3806 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3808 * ->[ and ->{ return TRUE
3809 * { and [ outside a pattern are always subscripts, so return TRUE
3810 * if we're outside a pattern and it's not { or [, then return FALSE
3811 * if we're in a pattern and the first char is a {
3812 * {4,5} (any digits around the comma) returns FALSE
3813 * if we're in a pattern and the first char is a [
3815 * [SOMETHING] has a funky algorithm to decide whether it's a
3816 * character class or not. It has to deal with things like
3817 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3818 * anything else returns TRUE
3821 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3824 S_intuit_more(pTHX_ char *s)
3828 PERL_ARGS_ASSERT_INTUIT_MORE;
3830 if (PL_lex_brackets)
3832 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3834 if (*s != '{' && *s != '[')
3839 /* In a pattern, so maybe we have {n,m}. */
3841 if (regcurly(s, FALSE)) {
3847 /* On the other hand, maybe we have a character class */
3850 if (*s == ']' || *s == '^')
3853 /* this is terrifying, and it works */
3856 const char * const send = strchr(s,']');
3857 unsigned char un_char, last_un_char;
3858 char tmpbuf[sizeof PL_tokenbuf * 4];
3860 if (!send) /* has to be an expression */
3862 weight = 2; /* let's weigh the evidence */
3866 else if (isDIGIT(*s)) {
3868 if (isDIGIT(s[1]) && s[2] == ']')
3874 Zero(seen,256,char);
3876 for (; s < send; s++) {
3877 last_un_char = un_char;
3878 un_char = (unsigned char)*s;
3883 weight -= seen[un_char] * 10;
3884 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3886 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3887 len = (int)strlen(tmpbuf);
3888 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3889 UTF ? SVf_UTF8 : 0, SVt_PV))
3894 else if (*s == '$' && s[1] &&
3895 strchr("[#!%*<>()-=",s[1])) {
3896 if (/*{*/ strchr("])} =",s[2]))
3905 if (strchr("wds]",s[1]))
3907 else if (seen[(U8)'\''] || seen[(U8)'"'])
3909 else if (strchr("rnftbxcav",s[1]))
3911 else if (isDIGIT(s[1])) {
3913 while (s[1] && isDIGIT(s[1]))
3923 if (strchr("aA01! ",last_un_char))
3925 if (strchr("zZ79~",s[1]))
3927 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3928 weight -= 5; /* cope with negative subscript */
3931 if (!isWORDCHAR(last_un_char)
3932 && !(last_un_char == '$' || last_un_char == '@'
3933 || last_un_char == '&')
3934 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3939 if (keyword(tmpbuf, d - tmpbuf, 0))
3942 if (un_char == last_un_char + 1)
3944 weight -= seen[un_char];
3949 if (weight >= 0) /* probably a character class */
3959 * Does all the checking to disambiguate
3961 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3962 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3964 * First argument is the stuff after the first token, e.g. "bar".
3966 * Not a method if foo is a filehandle.
3967 * Not a method if foo is a subroutine prototyped to take a filehandle.
3968 * Not a method if it's really "Foo $bar"
3969 * Method if it's "foo $bar"
3970 * Not a method if it's really "print foo $bar"
3971 * Method if it's really "foo package::" (interpreted as package->foo)
3972 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3973 * Not a method if bar is a filehandle or package, but is quoted with
3978 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3981 char *s = start + (*start == '$');
3982 char tmpbuf[sizeof PL_tokenbuf];
3989 PERL_ARGS_ASSERT_INTUIT_METHOD;
3991 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3993 if (cv && SvPOK(cv)) {
3994 const char *proto = CvPROTO(cv);
4003 if (*start == '$') {
4004 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
4005 isUPPER(*PL_tokenbuf))
4008 len = start - SvPVX(PL_linestr);
4012 start = SvPVX(PL_linestr) + len;
4016 return *s == '(' ? FUNCMETH : METHOD;
4019 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4020 /* start is the beginning of the possible filehandle/object,
4021 * and s is the end of it
4022 * tmpbuf is a copy of it (but with single quotes as double colons)
4025 if (!keyword(tmpbuf, len, 0)) {
4026 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4030 soff = s - SvPVX(PL_linestr);
4034 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4035 if (indirgv && GvCVu(indirgv))
4037 /* filehandle or package name makes it a method */
4038 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4040 soff = s - SvPVX(PL_linestr);
4043 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4044 return 0; /* no assumptions -- "=>" quotes bareword */
4046 start_force(PL_curforce);
4047 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4048 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4049 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4051 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4052 ( UTF ? SVf_UTF8 : 0 )));
4057 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4059 return *s == '(' ? FUNCMETH : METHOD;
4065 /* Encoded script support. filter_add() effectively inserts a
4066 * 'pre-processing' function into the current source input stream.
4067 * Note that the filter function only applies to the current source file
4068 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4070 * The datasv parameter (which may be NULL) can be used to pass
4071 * private data to this instance of the filter. The filter function
4072 * can recover the SV using the FILTER_DATA macro and use it to
4073 * store private buffers and state information.
4075 * The supplied datasv parameter is upgraded to a PVIO type
4076 * and the IoDIRP/IoANY field is used to store the function pointer,
4077 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4078 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4079 * private use must be set using malloc'd pointers.
4083 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4092 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4093 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4095 if (!PL_rsfp_filters)
4096 PL_rsfp_filters = newAV();
4099 SvUPGRADE(datasv, SVt_PVIO);
4100 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4101 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4102 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4103 FPTR2DPTR(void *, IoANY(datasv)),
4104 SvPV_nolen(datasv)));
4105 av_unshift(PL_rsfp_filters, 1);
4106 av_store(PL_rsfp_filters, 0, datasv) ;
4108 !PL_parser->filtered
4109 && PL_parser->lex_flags & LEX_EVALBYTES
4110 && PL_bufptr < PL_bufend
4112 const char *s = PL_bufptr;
4113 while (s < PL_bufend) {
4115 SV *linestr = PL_parser->linestr;
4116 char *buf = SvPVX(linestr);
4117 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4118 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4119 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4120 STRLEN const linestart_pos = PL_parser->linestart - buf;
4121 STRLEN const last_uni_pos =
4122 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4123 STRLEN const last_lop_pos =
4124 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4125 av_push(PL_rsfp_filters, linestr);
4126 PL_parser->linestr =
4127 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4128 buf = SvPVX(PL_parser->linestr);
4129 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4130 PL_parser->bufptr = buf + bufptr_pos;
4131 PL_parser->oldbufptr = buf + oldbufptr_pos;
4132 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4133 PL_parser->linestart = buf + linestart_pos;
4134 if (PL_parser->last_uni)
4135 PL_parser->last_uni = buf + last_uni_pos;
4136 if (PL_parser->last_lop)
4137 PL_parser->last_lop = buf + last_lop_pos;
4138 SvLEN(linestr) = SvCUR(linestr);
4139 SvCUR(linestr) = s-SvPVX(linestr);
4140 PL_parser->filtered = 1;
4150 /* Delete most recently added instance of this filter function. */
4152 Perl_filter_del(pTHX_ filter_t funcp)
4157 PERL_ARGS_ASSERT_FILTER_DEL;
4160 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4161 FPTR2DPTR(void*, funcp)));
4163 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4165 /* if filter is on top of stack (usual case) just pop it off */
4166 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4167 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4168 sv_free(av_pop(PL_rsfp_filters));
4172 /* we need to search for the correct entry and clear it */
4173 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4177 /* Invoke the idxth filter function for the current rsfp. */
4178 /* maxlen 0 = read one text line */
4180 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4185 /* This API is bad. It should have been using unsigned int for maxlen.
4186 Not sure if we want to change the API, but if not we should sanity
4187 check the value here. */
4188 unsigned int correct_length
4197 PERL_ARGS_ASSERT_FILTER_READ;
4199 if (!PL_parser || !PL_rsfp_filters)
4201 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4202 /* Provide a default input filter to make life easy. */
4203 /* Note that we append to the line. This is handy. */
4204 DEBUG_P(PerlIO_printf(Perl_debug_log,
4205 "filter_read %d: from rsfp\n", idx));
4206 if (correct_length) {
4209 const int old_len = SvCUR(buf_sv);
4211 /* ensure buf_sv is large enough */
4212 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4213 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4214 correct_length)) <= 0) {
4215 if (PerlIO_error(PL_rsfp))
4216 return -1; /* error */
4218 return 0 ; /* end of file */
4220 SvCUR_set(buf_sv, old_len + len) ;
4221 SvPVX(buf_sv)[old_len + len] = '\0';
4224 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4225 if (PerlIO_error(PL_rsfp))
4226 return -1; /* error */
4228 return 0 ; /* end of file */
4231 return SvCUR(buf_sv);
4233 /* Skip this filter slot if filter has been deleted */
4234 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4235 DEBUG_P(PerlIO_printf(Perl_debug_log,
4236 "filter_read %d: skipped (filter deleted)\n",
4238 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4240 if (SvTYPE(datasv) != SVt_PVIO) {
4241 if (correct_length) {
4243 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4244 if (!remainder) return 0; /* eof */
4245 if (correct_length > remainder) correct_length = remainder;
4246 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4247 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4250 const char *s = SvEND(datasv);
4251 const char *send = SvPVX(datasv) + SvLEN(datasv);
4259 if (s == send) return 0; /* eof */
4260 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4261 SvCUR_set(datasv, s-SvPVX(datasv));
4263 return SvCUR(buf_sv);
4265 /* Get function pointer hidden within datasv */
4266 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4267 DEBUG_P(PerlIO_printf(Perl_debug_log,
4268 "filter_read %d: via function %p (%s)\n",
4269 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4270 /* Call function. The function is expected to */
4271 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4272 /* Return: <0:error, =0:eof, >0:not eof */
4273 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4277 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4281 PERL_ARGS_ASSERT_FILTER_GETS;
4283 #ifdef PERL_CR_FILTER
4284 if (!PL_rsfp_filters) {
4285 filter_add(S_cr_textfilter,NULL);
4288 if (PL_rsfp_filters) {
4290 SvCUR_set(sv, 0); /* start with empty line */
4291 if (FILTER_READ(0, sv, 0) > 0)
4292 return ( SvPVX(sv) ) ;
4297 return (sv_gets(sv, PL_rsfp, append));
4301 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4306 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4308 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4312 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4313 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4315 return GvHV(gv); /* Foo:: */
4318 /* use constant CLASS => 'MyClass' */
4319 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4320 if (gv && GvCV(gv)) {
4321 SV * const sv = cv_const_sv(GvCV(gv));
4323 pkgname = SvPV_const(sv, len);
4326 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4330 * S_readpipe_override
4331 * Check whether readpipe() is overridden, and generates the appropriate
4332 * optree, provided sublex_start() is called afterwards.
4335 S_readpipe_override(pTHX)
4338 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4339 pl_yylval.ival = OP_BACKTICK;
4341 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4343 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4344 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4345 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4347 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4348 op_append_elem(OP_LIST,
4349 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4350 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4357 * The intent of this yylex wrapper is to minimize the changes to the
4358 * tokener when we aren't interested in collecting madprops. It remains
4359 * to be seen how successful this strategy will be...
4366 char *s = PL_bufptr;
4368 /* make sure PL_thiswhite is initialized */
4372 /* previous token ate up our whitespace? */
4373 if (!PL_lasttoke && PL_nextwhite) {
4374 PL_thiswhite = PL_nextwhite;
4378 /* isolate the token, and figure out where it is without whitespace */
4379 PL_realtokenstart = -1;
4383 assert(PL_curforce < 0);
4385 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4386 if (!PL_thistoken) {
4387 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4388 PL_thistoken = newSVpvs("");
4390 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4391 PL_thistoken = newSVpvn(tstart, s - tstart);
4394 if (PL_thismad) /* install head */
4395 CURMAD('X', PL_thistoken);
4398 /* last whitespace of a sublex? */
4399 if (optype == ')' && PL_endwhite) {
4400 CURMAD('X', PL_endwhite);
4405 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4406 if (!PL_thiswhite && !PL_endwhite && !optype) {
4407 sv_free(PL_thistoken);
4412 /* put off final whitespace till peg */
4413 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4414 PL_nextwhite = PL_thiswhite;
4417 else if (PL_thisopen) {
4418 CURMAD('q', PL_thisopen);
4420 sv_free(PL_thistoken);
4424 /* Store actual token text as madprop X */
4425 CURMAD('X', PL_thistoken);
4429 /* add preceding whitespace as madprop _ */
4430 CURMAD('_', PL_thiswhite);
4434 /* add quoted material as madprop = */
4435 CURMAD('=', PL_thisstuff);
4439 /* add terminating quote as madprop Q */
4440 CURMAD('Q', PL_thisclose);
4444 /* special processing based on optype */
4448 /* opval doesn't need a TOKEN since it can already store mp */
4458 if (pl_yylval.opval)
4459 append_madprops(PL_thismad, pl_yylval.opval, 0);
4467 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4480 /* remember any fake bracket that lexer is about to discard */
4481 if (PL_lex_brackets == 1 &&
4482 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4485 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4488 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4489 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4492 break; /* don't bother looking for trailing comment */
4501 /* attach a trailing comment to its statement instead of next token */
4505 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4507 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4509 if (*s == '\n' || *s == '#') {
4510 while (s < PL_bufend && *s != '\n')
4514 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4515 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4528 /* Create new token struct. Note: opvals return early above. */
4529 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4536 S_tokenize_use(pTHX_ int is_use, char *s) {
4539 PERL_ARGS_ASSERT_TOKENIZE_USE;
4541 if (PL_expect != XSTATE)
4542 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4543 is_use ? "use" : "no"));
4546 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4547 s = force_version(s, TRUE);
4548 if (*s == ';' || *s == '}'
4549 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4550 start_force(PL_curforce);
4551 NEXTVAL_NEXTTOKE.opval = NULL;
4554 else if (*s == 'v') {
4555 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4556 s = force_version(s, FALSE);
4560 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4561 s = force_version(s, FALSE);
4563 pl_yylval.ival = is_use;
4567 static const char* const exp_name[] =
4568 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4569 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4573 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4575 S_word_takes_any_delimeter(char *p, STRLEN len)
4577 return (len == 1 && strchr("msyq", p[0])) ||
4579 (p[0] == 't' && p[1] == 'r') ||
4580 (p[0] == 'q' && strchr("qwxr", p[1]))));
4586 Works out what to call the token just pulled out of the input
4587 stream. The yacc parser takes care of taking the ops we return and
4588 stitching them into a tree.
4591 The type of the next token
4594 Switch based on the current state:
4595 - if we already built the token before, use it
4596 - if we have a case modifier in a string, deal with that
4597 - handle other cases of interpolation inside a string
4598 - scan the next line if we are inside a format
4599 In the normal state switch on the next character:
4601 if alphabetic, go to key lookup
4602 unrecoginized character - croak
4603 - 0/4/26: handle end-of-line or EOF
4604 - cases for whitespace
4605 - \n and #: handle comments and line numbers
4606 - various operators, brackets and sigils
4609 - 'v': vstrings (or go to key lookup)
4610 - 'x' repetition operator (or go to key lookup)
4611 - other ASCII alphanumerics (key lookup begins here):
4614 scan built-in keyword (but do nothing with it yet)
4615 check for statement label
4616 check for lexical subs
4617 goto just_a_word if there is one
4618 see whether built-in keyword is overridden
4619 switch on keyword number:
4620 - default: just_a_word:
4621 not a built-in keyword; handle bareword lookup
4622 disambiguate between method and sub call
4623 fall back to bareword
4624 - cases for built-in keywords
4629 #pragma segment Perl_yylex
4635 char *s = PL_bufptr;
4642 /* orig_keyword, gvp, and gv are initialized here because
4643 * jump to the label just_a_word_zero can bypass their
4644 * initialization later. */
4645 I32 orig_keyword = 0;
4650 SV* tmp = newSVpvs("");
4651 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4652 (IV)CopLINE(PL_curcop),
4653 lex_state_names[PL_lex_state],
4654 exp_name[PL_expect],
4655 pv_display(tmp, s, strlen(s), 0, 60));
4659 switch (PL_lex_state) {
4661 case LEX_NORMAL: /* Some compilers will produce faster */
4662 case LEX_INTERPNORMAL: /* code if we comment these out. */
4666 /* when we've already built the next token, just pull it out of the queue */
4670 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4672 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4673 PL_nexttoke[PL_lasttoke].next_mad = 0;
4674 if (PL_thismad && PL_thismad->mad_key == '_') {
4675 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4676 PL_thismad->mad_val = 0;
4677 mad_free(PL_thismad);
4682 PL_lex_state = PL_lex_defer;
4683 PL_expect = PL_lex_expect;
4684 PL_lex_defer = LEX_NORMAL;
4685 if (!PL_nexttoke[PL_lasttoke].next_type)
4690 pl_yylval = PL_nextval[PL_nexttoke];
4692 PL_lex_state = PL_lex_defer;
4693 PL_expect = PL_lex_expect;
4694 PL_lex_defer = LEX_NORMAL;
4700 next_type = PL_nexttoke[PL_lasttoke].next_type;
4702 next_type = PL_nexttype[PL_nexttoke];
4704 if (next_type & (7<<24)) {
4705 if (next_type & (1<<24)) {
4706 if (PL_lex_brackets > 100)
4707 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4708 PL_lex_brackstack[PL_lex_brackets++] =
4709 (char) ((next_type >> 16) & 0xff);
4711 if (next_type & (2<<24))
4712 PL_lex_allbrackets++;
4713 if (next_type & (4<<24))
4714 PL_lex_allbrackets--;
4715 next_type &= 0xffff;
4717 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4720 /* interpolated case modifiers like \L \U, including \Q and \E.
4721 when we get here, PL_bufptr is at the \
4723 case LEX_INTERPCASEMOD:
4725 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4727 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4728 PL_bufptr, PL_bufend, *PL_bufptr);
4730 /* handle \E or end of string */
4731 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4733 if (PL_lex_casemods) {
4734 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4735 PL_lex_casestack[PL_lex_casemods] = '\0';
4737 if (PL_bufptr != PL_bufend
4738 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4739 || oldmod == 'F')) {
4741 PL_lex_state = LEX_INTERPCONCAT;
4744 PL_thistoken = newSVpvs("\\E");
4747 PL_lex_allbrackets--;
4750 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4751 /* Got an unpaired \E */
4752 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4753 "Useless use of \\E");
4756 while (PL_bufptr != PL_bufend &&
4757 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4760 PL_thiswhite = newSVpvs("");
4761 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4766 if (PL_bufptr != PL_bufend)
4769 PL_lex_state = LEX_INTERPCONCAT;
4773 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4774 "### Saw case modifier\n"); });
4776 if (s[1] == '\\' && s[2] == 'E') {
4780 PL_thiswhite = newSVpvs("");
4781 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4785 PL_lex_state = LEX_INTERPCONCAT;
4790 if (!PL_madskills) /* when just compiling don't need correct */
4791 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4792 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4793 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4794 (strchr(PL_lex_casestack, 'L')
4795 || strchr(PL_lex_casestack, 'U')
4796 || strchr(PL_lex_casestack, 'F'))) {
4797 PL_lex_casestack[--PL_lex_casemods] = '\0';
4798 PL_lex_allbrackets--;
4801 if (PL_lex_casemods > 10)
4802 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4803 PL_lex_casestack[PL_lex_casemods++] = *s;
4804 PL_lex_casestack[PL_lex_casemods] = '\0';
4805 PL_lex_state = LEX_INTERPCONCAT;
4806 start_force(PL_curforce);
4807 NEXTVAL_NEXTTOKE.ival = 0;
4808 force_next((2<<24)|'(');
4809 start_force(PL_curforce);
4811 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4813 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4815 NEXTVAL_NEXTTOKE.ival = OP_LC;
4817 NEXTVAL_NEXTTOKE.ival = OP_UC;
4819 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4821 NEXTVAL_NEXTTOKE.ival = OP_FC;
4823 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4825 SV* const tmpsv = newSVpvs("\\ ");
4826 /* replace the space with the character we want to escape
4828 SvPVX(tmpsv)[1] = *s;
4834 if (PL_lex_starts) {
4840 sv_free(PL_thistoken);
4841 PL_thistoken = newSVpvs("");
4844 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4845 if (PL_lex_casemods == 1 && PL_lex_inpat)
4854 case LEX_INTERPPUSH:
4855 return REPORT(sublex_push());
4857 case LEX_INTERPSTART:
4858 if (PL_bufptr == PL_bufend)
4859 return REPORT(sublex_done());
4860 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4861 "### Interpolated variable\n"); });
4863 /* for /@a/, we leave the joining for the regex engine to do
4864 * (unless we're within \Q etc) */
4865 PL_lex_dojoin = (*PL_bufptr == '@'
4866 && (!PL_lex_inpat || PL_lex_casemods));
4867 PL_lex_state = LEX_INTERPNORMAL;
4868 if (PL_lex_dojoin) {
4869 start_force(PL_curforce);
4870 NEXTVAL_NEXTTOKE.ival = 0;
4872 start_force(PL_curforce);
4873 force_ident("\"", '$');
4874 start_force(PL_curforce);
4875 NEXTVAL_NEXTTOKE.ival = 0;
4877 start_force(PL_curforce);
4878 NEXTVAL_NEXTTOKE.ival = 0;
4879 force_next((2<<24)|'(');
4880 start_force(PL_curforce);
4881 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4884 /* Convert (?{...}) and friends to 'do {...}' */
4885 if (PL_lex_inpat && *PL_bufptr == '(') {
4886 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4888 if (*PL_bufptr != '{')
4890 start_force(PL_curforce);
4891 /* XXX probably need a CURMAD(something) here */
4892 PL_expect = XTERMBLOCK;
4896 if (PL_lex_starts++) {
4901 sv_free(PL_thistoken);
4902 PL_thistoken = newSVpvs("");
4905 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4906 if (!PL_lex_casemods && PL_lex_inpat)
4913 case LEX_INTERPENDMAYBE:
4914 if (intuit_more(PL_bufptr)) {
4915 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4921 if (PL_lex_dojoin) {
4922 PL_lex_dojoin = FALSE;
4923 PL_lex_state = LEX_INTERPCONCAT;
4927 sv_free(PL_thistoken);
4928 PL_thistoken = newSVpvs("");
4931 PL_lex_allbrackets--;
4934 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4935 && SvEVALED(PL_lex_repl))
4937 if (PL_bufptr != PL_bufend)
4938 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4941 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4942 re_eval_str. If the here-doc body’s length equals the previous
4943 value of re_eval_start, re_eval_start will now be null. So
4944 check re_eval_str as well. */
4945 if (PL_parser->lex_shared->re_eval_start
4946 || PL_parser->lex_shared->re_eval_str) {
4948 if (*PL_bufptr != ')')
4949 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4951 /* having compiled a (?{..}) expression, return the original
4952 * text too, as a const */
4953 if (PL_parser->lex_shared->re_eval_str) {
4954 sv = PL_parser->lex_shared->re_eval_str;
4955 PL_parser->lex_shared->re_eval_str = NULL;
4957 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4958 SvPV_shrink_to_cur(sv);
4960 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4961 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4962 start_force(PL_curforce);
4963 /* XXX probably need a CURMAD(something) here */
4964 NEXTVAL_NEXTTOKE.opval =
4965 (OP*)newSVOP(OP_CONST, 0,
4968 PL_parser->lex_shared->re_eval_start = NULL;
4974 case LEX_INTERPCONCAT:
4976 if (PL_lex_brackets)
4977 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4978 (long) PL_lex_brackets);
4980 if (PL_bufptr == PL_bufend)
4981 return REPORT(sublex_done());
4983 /* m'foo' still needs to be parsed for possible (?{...}) */
4984 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4985 SV *sv = newSVsv(PL_linestr);
4987 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4991 s = scan_const(PL_bufptr);
4993 PL_lex_state = LEX_INTERPCASEMOD;
4995 PL_lex_state = LEX_INTERPSTART;
4998 if (s != PL_bufptr) {
4999 start_force(PL_curforce);
5001 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
5003 NEXTVAL_NEXTTOKE = pl_yylval;
5006 if (PL_lex_starts++) {
5010 sv_free(PL_thistoken);
5011 PL_thistoken = newSVpvs("");
5014 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5015 if (!PL_lex_casemods && PL_lex_inpat)
5028 s = scan_formline(PL_bufptr);
5029 if (!PL_lex_formbrack)
5039 PL_oldoldbufptr = PL_oldbufptr;
5045 sv_free(PL_thistoken);
5048 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
5052 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
5055 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5056 const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
5058 SVs_TEMP | SVf_UTF8),
5059 10, UNI_DISPLAY_ISPRINT))
5060 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5061 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
5062 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5063 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
5071 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
5075 goto fake_eof; /* emulate EOF on ^D or ^Z */
5081 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
5084 if (PL_lex_brackets &&
5085 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
5086 yyerror((const char *)
5088 ? "Format not terminated"
5089 : "Missing right curly or square bracket"));
5091 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5092 "### Tokener got EOF\n");
5096 if (s++ < PL_bufend)
5097 goto retry; /* ignore stray nulls */
5100 if (!PL_in_eval && !PL_preambled) {
5101 PL_preambled = TRUE;
5107 /* Generate a string of Perl code to load the debugger.
5108 * If PERL5DB is set, it will return the contents of that,
5109 * otherwise a compile-time require of perl5db.pl. */
5111 const char * const pdb = PerlEnv_getenv("PERL5DB");
5114 sv_setpv(PL_linestr, pdb);
5115 sv_catpvs(PL_linestr,";");
5117 SETERRNO(0,SS_NORMAL);
5118 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5121 sv_setpvs(PL_linestr,"");
5122 if (PL_preambleav) {
5123 SV **svp = AvARRAY(PL_preambleav);
5124 SV **const end = svp + AvFILLp(PL_preambleav);
5126 sv_catsv(PL_linestr, *svp);
5128 sv_catpvs(PL_linestr, ";");
5130 sv_free(MUTABLE_SV(PL_preambleav));
5131 PL_preambleav = NULL;
5134 sv_catpvs(PL_linestr,
5135 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5136 if (PL_minus_n || PL_minus_p) {
5137 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5139 sv_catpvs(PL_linestr,"chomp;");
5142 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
5143 || *PL_splitstr == '"')
5144 && strchr(PL_splitstr + 1, *PL_splitstr))
5145 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5147 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5148 bytes can be used as quoting characters. :-) */
5149 const char *splits = PL_splitstr;
5150 sv_catpvs(PL_linestr, "our @F=split(q\0");
5153 if (*splits == '\\')
5154 sv_catpvn(PL_linestr, splits, 1);
5155 sv_catpvn(PL_linestr, splits, 1);
5156 } while (*splits++);
5157 /* This loop will embed the trailing NUL of
5158 PL_linestr as the last thing it does before
5160 sv_catpvs(PL_linestr, ");");
5164 sv_catpvs(PL_linestr,"our @F=split(' ');");
5167 sv_catpvs(PL_linestr, "\n");
5168 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5169 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5170 PL_last_lop = PL_last_uni = NULL;
5171 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
5172 update_debugger_info(PL_linestr, NULL, 0);
5177 bof = PL_rsfp ? TRUE : FALSE;
5180 fake_eof = LEX_FAKE_EOF;
5182 PL_bufptr = PL_bufend;
5183 COPLINE_INC_WITH_HERELINES;
5184 if (!lex_next_chunk(fake_eof)) {
5185 CopLINE_dec(PL_curcop);
5187 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5189 CopLINE_dec(PL_curcop);
5192 PL_realtokenstart = -1;
5195 /* If it looks like the start of a BOM or raw UTF-16,
5196 * check if it in fact is. */
5197 if (bof && PL_rsfp &&
5202 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5203 bof = (offset == (Off_t)SvCUR(PL_linestr));
5204 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5205 /* offset may include swallowed CR */
5207 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5210 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5211 s = swallow_bom((U8*)s);
5214 if (PL_parser->in_pod) {
5215 /* Incest with pod. */
5218 sv_catsv(PL_thiswhite, PL_linestr);
5220 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
5221 sv_setpvs(PL_linestr, "");
5222 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5223 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5224 PL_last_lop = PL_last_uni = NULL;
5225 PL_parser->in_pod = 0;
5228 if (PL_rsfp || PL_parser->filtered)
5230 } while (PL_parser->in_pod);
5231 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5232 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5233 PL_last_lop = PL_last_uni = NULL;
5234 if (CopLINE(PL_curcop) == 1) {
5235 while (s < PL_bufend && isSPACE(*s))
5237 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5241 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
5245 if (*s == '#' && *(s+1) == '!')
5247 #ifdef ALTERNATE_SHEBANG
5249 static char const as[] = ALTERNATE_SHEBANG;
5250 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5251 d = s + (sizeof(as) - 1);
5253 #endif /* ALTERNATE_SHEBANG */
5262 while (*d && !isSPACE(*d))
5266 #ifdef ARG_ZERO_IS_SCRIPT
5267 if (ipathend > ipath) {
5269 * HP-UX (at least) sets argv[0] to the script name,
5270 * which makes $^X incorrect. And Digital UNIX and Linux,
5271 * at least, set argv[0] to the basename of the Perl
5272 * interpreter. So, having found "#!", we'll set it right.
5274 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5276 assert(SvPOK(x) || SvGMAGICAL(x));
5277 if (sv_eq(x, CopFILESV(PL_curcop))) {
5278 sv_setpvn(x, ipath, ipathend - ipath);
5284 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
5285 const char * const lstart = SvPV_const(x,llen);
5287 bstart += blen - llen;
5288 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5289 sv_setpvn(x, ipath, ipathend - ipath);
5294 TAINT_NOT; /* $^X is always tainted, but that's OK */
5296 #endif /* ARG_ZERO_IS_SCRIPT */
5301 d = instr(s,"perl -");
5303 d = instr(s,"perl");
5305 /* avoid getting into infinite loops when shebang
5306 * line contains "Perl" rather than "perl" */
5308 for (d = ipathend-4; d >= ipath; --d) {
5309 if ((*d == 'p' || *d == 'P')
5310 && !ibcmp(d, "perl", 4))
5320 #ifdef ALTERNATE_SHEBANG
5322 * If the ALTERNATE_SHEBANG on this system starts with a
5323 * character that can be part of a Perl expression, then if
5324 * we see it but not "perl", we're probably looking at the
5325 * start of Perl code, not a request to hand off to some
5326 * other interpreter. Similarly, if "perl" is there, but
5327 * not in the first 'word' of the line, we assume the line
5328 * contains the start of the Perl program.
5330 if (d && *s != '#') {
5331 const char *c = ipath;
5332 while (*c && !strchr("; \t\r\n\f\v#", *c))
5335 d = NULL; /* "perl" not in first word; ignore */
5337 *s = '#'; /* Don't try to parse shebang line */
5339 #endif /* ALTERNATE_SHEBANG */
5344 !instr(s,"indir") &&
5345 instr(PL_origargv[0],"perl"))
5352 while (s < PL_bufend && isSPACE(*s))
5354 if (s < PL_bufend) {
5355 Newx(newargv,PL_origargc+3,char*);
5357 while (s < PL_bufend && !isSPACE(*s))
5360 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5363 newargv = PL_origargv;
5366 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5368 Perl_croak(aTHX_ "Can't exec %s", ipath);
5371 while (*d && !isSPACE(*d))
5373 while (SPACE_OR_TAB(*d))
5377 const bool switches_done = PL_doswitches;
5378 const U32 oldpdb = PL_perldb;
5379 const bool oldn = PL_minus_n;
5380 const bool oldp = PL_minus_p;
5384 bool baduni = FALSE;
5386 const char *d2 = d1 + 1;
5387 if (parse_unicode_opts((const char **)&d2)
5391 if (baduni || *d1 == 'M' || *d1 == 'm') {
5392 const char * const m = d1;
5393 while (*d1 && !isSPACE(*d1))
5395 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5398 d1 = moreswitches(d1);
5400 if (PL_doswitches && !switches_done) {
5401 int argc = PL_origargc;
5402 char **argv = PL_origargv;
5405 } while (argc && argv[0][0] == '-' && argv[0][1]);
5406 init_argv_symbols(argc,argv);
5408 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5409 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5410 /* if we have already added "LINE: while (<>) {",
5411 we must not do it again */
5413 sv_setpvs(PL_linestr, "");
5414 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5415 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5416 PL_last_lop = PL_last_uni = NULL;
5417 PL_preambled = FALSE;
5418 if (PERLDB_LINE || PERLDB_SAVESRC)
5419 (void)gv_fetchfile(PL_origfilename);
5426 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5427 PL_lex_state = LEX_FORMLINE;
5428 start_force(PL_curforce);
5429 NEXTVAL_NEXTTOKE.ival = 0;
5430 force_next(FORMRBRACK);
5435 #ifdef PERL_STRICT_CR
5436 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5438 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5440 case ' ': case '\t': case '\f': case 013:
5442 PL_realtokenstart = -1;
5445 PL_thiswhite = newSVpvs("");
5446 sv_catpvn(PL_thiswhite, s, 1);
5454 PL_realtokenstart = -1;
5458 if (PL_lex_state != LEX_NORMAL ||
5459 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
5460 if (*s == '#' && s == PL_linestart && PL_in_eval
5461 && !PL_rsfp && !PL_parser->filtered) {
5462 /* handle eval qq[#line 1 "foo"\n ...] */
5463 CopLINE_dec(PL_curcop);
5466 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5468 if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
5472 const bool in_comment = *s == '#';
5474 while (d < PL_bufend && *d != '\n')
5478 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5479 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5483 PL_thiswhite = newSVpvn(s, d - s);
5486 if (in_comment && d == PL_bufend
5487 && PL_lex_state == LEX_INTERPNORMAL
5488 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5489 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5492 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5493 PL_lex_state = LEX_FORMLINE;
5494 start_force(PL_curforce);
5495 NEXTVAL_NEXTTOKE.ival = 0;
5496 force_next(FORMRBRACK);
5502 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5503 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5506 TOKEN(PEG); /* make sure any #! line is accessible */
5511 /* if (PL_madskills && PL_lex_formbrack) { */
5513 while (d < PL_bufend && *d != '\n')
5517 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5518 Perl_croak(aTHX_ "panic: input overflow");
5519 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5521 PL_thiswhite = newSVpvs("");
5522 if (CopLINE(PL_curcop) == 1) {
5523 sv_setpvs(PL_thiswhite, "");
5526 sv_catpvn(PL_thiswhite, s, d - s);
5540 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5548 while (s < PL_bufend && SPACE_OR_TAB(*s))
5551 if (strnEQ(s,"=>",2)) {
5552 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
5553 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5554 OPERATOR('-'); /* unary minus */
5556 PL_last_uni = PL_oldbufptr;
5558 case 'r': ftst = OP_FTEREAD; break;
5559 case 'w': ftst = OP_FTEWRITE; break;
5560 case 'x': ftst = OP_FTEEXEC; break;
5561 case 'o': ftst = OP_FTEOWNED; break;
5562 case 'R': ftst = OP_FTRREAD; break;
5563 case 'W': ftst = OP_FTRWRITE; break;
5564 case 'X': ftst = OP_FTREXEC; break;
5565 case 'O': ftst = OP_FTROWNED; break;
5566 case 'e': ftst = OP_FTIS; break;
5567 case 'z': ftst = OP_FTZERO; break;
5568 case 's': ftst = OP_FTSIZE; break;
5569 case 'f': ftst = OP_FTFILE; break;
5570 case 'd': ftst = OP_FTDIR; break;
5571 case 'l': ftst = OP_FTLINK; break;
5572 case 'p': ftst = OP_FTPIPE; break;
5573 case 'S': ftst = OP_FTSOCK; break;
5574 case 'u': ftst = OP_FTSUID; break;
5575 case 'g': ftst = OP_FTSGID; break;
5576 case 'k': ftst = OP_FTSVTX; break;
5577 case 'b': ftst = OP_FTBLK; break;
5578 case 'c': ftst = OP_FTCHR; break;
5579 case 't': ftst = OP_FTTTY; break;
5580 case 'T': ftst = OP_FTTEXT; break;
5581 case 'B': ftst = OP_FTBINARY; break;
5582 case 'M': case 'A': case 'C':
5583 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5585 case 'M': ftst = OP_FTMTIME; break;
5586 case 'A': ftst = OP_FTATIME; break;
5587 case 'C': ftst = OP_FTCTIME; break;
5595 PL_last_lop_op = (OPCODE)ftst;
5596 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5597 "### Saw file test %c\n", (int)tmp);
5602 /* Assume it was a minus followed by a one-letter named
5603 * subroutine call (or a -bareword), then. */
5604 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5605 "### '-%c' looked like a file test but was not\n",
5612 const char tmp = *s++;
5615 if (PL_expect == XOPERATOR)
5620 else if (*s == '>') {
5623 if (isIDFIRST_lazy_if(s,UTF)) {
5624 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
5632 if (PL_expect == XOPERATOR) {
5633 if (*s == '=' && !PL_lex_allbrackets &&
5634 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5641 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5643 OPERATOR('-'); /* unary minus */
5649 const char tmp = *s++;
5652 if (PL_expect == XOPERATOR)
5657 if (PL_expect == XOPERATOR) {
5658 if (*s == '=' && !PL_lex_allbrackets &&
5659 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5666 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5673 if (PL_expect != XOPERATOR) {
5674 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5675 PL_expect = XOPERATOR;
5676 force_ident(PL_tokenbuf, '*');
5684 if (*s == '=' && !PL_lex_allbrackets &&
5685 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5691 if (*s == '=' && !PL_lex_allbrackets &&
5692 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5699 if (PL_expect == XOPERATOR) {
5700 if (s[1] == '=' && !PL_lex_allbrackets &&
5701 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5706 PL_tokenbuf[0] = '%';
5707 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5708 sizeof PL_tokenbuf - 1, FALSE);
5709 if (!PL_tokenbuf[1]) {
5712 PL_expect = XOPERATOR;
5713 force_ident_maybe_lex('%');
5717 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5718 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5723 if (PL_lex_brackets > 100)
5724 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5725 PL_lex_brackstack[PL_lex_brackets++] = 0;
5726 PL_lex_allbrackets++;
5728 const char tmp = *s++;
5733 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5735 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5738 Perl_ck_warner_d(aTHX_
5739 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5740 "Smartmatch is experimental");
5746 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5753 goto just_a_word_zero_gv;
5756 switch (PL_expect) {
5762 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5764 PL_bufptr = s; /* update in case we back off */
5767 "Use of := for an empty attribute list is not allowed");
5774 PL_expect = XTERMBLOCK;
5777 stuffstart = s - SvPVX(PL_linestr) - 1;
5781 while (isIDFIRST_lazy_if(s,UTF)) {
5784 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5785 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5786 if (tmp < 0) tmp = -tmp;
5801 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5803 d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
5805 /* MUST advance bufptr here to avoid bogus
5806 "at end of line" context messages from yyerror().
5808 PL_bufptr = s + len;
5809 yyerror("Unterminated attribute parameter in attribute list");
5813 return REPORT(0); /* EOF indicator */
5817 sv_catsv(sv, PL_lex_stuff);
5818 attrs = op_append_elem(OP_LIST, attrs,
5819 newSVOP(OP_CONST, 0, sv));
5820 SvREFCNT_dec(PL_lex_stuff);
5821 PL_lex_stuff = NULL;
5824 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5826 if (PL_in_my == KEY_our) {
5827 deprecate(":unique");
5830 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5833 /* NOTE: any CV attrs applied here need to be part of
5834 the CVf_BUILTIN_ATTRS define in cv.h! */
5835 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5837 CvLVALUE_on(PL_compcv);
5839 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5841 deprecate(":locked");
5843 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5845 CvMETHOD_on(PL_compcv);
5847 /* After we've set the flags, it could be argued that
5848 we don't need to do the attributes.pm-based setting
5849 process, and shouldn't bother appending recognized
5850 flags. To experiment with that, uncomment the
5851 following "else". (Note that's already been
5852 uncommented. That keeps the above-applied built-in
5853 attributes from being intercepted (and possibly
5854 rejected) by a package's attribute routines, but is
5855 justified by the performance win for the common case
5856 of applying only built-in attributes.) */
5858 attrs = op_append_elem(OP_LIST, attrs,
5859 newSVOP(OP_CONST, 0,
5863 if (*s == ':' && s[1] != ':')
5866 break; /* require real whitespace or :'s */
5867 /* XXX losing whitespace on sequential attributes here */
5871 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5872 if (*s != ';' && *s != '}' && *s != tmp
5873 && (tmp != '=' || *s != ')')) {
5874 const char q = ((*s == '\'') ? '"' : '\'');
5875 /* If here for an expression, and parsed no attrs, back
5877 if (tmp == '=' && !attrs) {
5881 /* MUST advance bufptr here to avoid bogus "at end of line"
5882 context messages from yyerror().
5885 yyerror( (const char *)
5887 ? Perl_form(aTHX_ "Invalid separator character "
5888 "%c%c%c in attribute list", q, *s, q)
5889 : "Unterminated attribute list" ) );
5897 start_force(PL_curforce);
5898 NEXTVAL_NEXTTOKE.opval = attrs;
5899 CURMAD('_', PL_nextwhite);
5904 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
5905 (s - SvPVX(PL_linestr)) - stuffstart);
5910 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5914 PL_lex_allbrackets--;
5918 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5919 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5923 PL_lex_allbrackets++;
5926 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5932 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5935 PL_lex_allbrackets--;
5941 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5944 if (PL_lex_brackets <= 0)
5945 yyerror("Unmatched right square bracket");
5948 PL_lex_allbrackets--;
5949 if (PL_lex_state == LEX_INTERPNORMAL) {
5950 if (PL_lex_brackets == 0) {
5951 if (*s == '-' && s[1] == '>')
5952 PL_lex_state = LEX_INTERPENDMAYBE;
5953 else if (*s != '[' && *s != '{')
5954 PL_lex_state = LEX_INTERPEND;
5961 if (PL_lex_brackets > 100) {
5962 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5964 switch (PL_expect) {
5966 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5967 PL_lex_allbrackets++;
5968 OPERATOR(HASHBRACK);
5970 while (s < PL_bufend && SPACE_OR_TAB(*s))
5973 PL_tokenbuf[0] = '\0';
5974 if (d < PL_bufend && *d == '-') {
5975 PL_tokenbuf[0] = '-';
5977 while (d < PL_bufend && SPACE_OR_TAB(*d))
5980 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5981 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5983 while (d < PL_bufend && SPACE_OR_TAB(*d))
5986 const char minus = (PL_tokenbuf[0] == '-');
5987 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
5995 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5996 PL_lex_allbrackets++;
6001 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6002 PL_lex_allbrackets++;
6007 if (PL_oldoldbufptr == PL_last_lop)
6008 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6010 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6011 PL_lex_allbrackets++;
6014 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6016 /* This hack is to get the ${} in the message. */
6018 yyerror("syntax error");
6021 OPERATOR(HASHBRACK);
6023 /* This hack serves to disambiguate a pair of curlies
6024 * as being a block or an anon hash. Normally, expectation
6025 * determines that, but in cases where we're not in a
6026 * position to expect anything in particular (like inside
6027 * eval"") we have to resolve the ambiguity. This code
6028 * covers the case where the first term in the curlies is a
6029 * quoted string. Most other cases need to be explicitly
6030 * disambiguated by prepending a "+" before the opening
6031 * curly in order to force resolution as an anon hash.
6033 * XXX should probably propagate the outer expectation
6034 * into eval"" to rely less on this hack, but that could
6035 * potentially break current behavior of eval"".
6039 if (*s == '\'' || *s == '"' || *s == '`') {
6040 /* common case: get past first string, handling escapes */
6041 for (t++; t < PL_bufend && *t != *s;)
6042 if (*t++ == '\\' && (*t == '\\' || *t == *s))
6046 else if (*s == 'q') {
6049 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6050 && !isWORDCHAR(*t))))
6052 /* skip q//-like construct */
6054 char open, close, term;
6057 while (t < PL_bufend && isSPACE(*t))
6059 /* check for q => */
6060 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6061 OPERATOR(HASHBRACK);
6065 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6069 for (t++; t < PL_bufend; t++) {
6070 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6072 else if (*t == open)
6076 for (t++; t < PL_bufend; t++) {
6077 if (*t == '\\' && t+1 < PL_bufend)
6079 else if (*t == close && --brackets <= 0)
6081 else if (*t == open)
6088 /* skip plain q word */
6089 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6092 else if (isWORDCHAR_lazy_if(t,UTF)) {
6094 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6097 while (t < PL_bufend && isSPACE(*t))
6099 /* if comma follows first term, call it an anon hash */
6100 /* XXX it could be a comma expression with loop modifiers */
6101 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6102 || (*t == '=' && t[1] == '>')))
6103 OPERATOR(HASHBRACK);
6104 if (PL_expect == XREF)
6107 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6113 pl_yylval.ival = CopLINE(PL_curcop);
6114 if (isSPACE(*s) || *s == '#')
6115 PL_copline = NOLINE; /* invalidate current command line number */
6116 TOKEN(formbrack ? '=' : '{');
6118 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6122 if (PL_lex_brackets <= 0)
6123 yyerror("Unmatched right curly bracket");
6125 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6126 PL_lex_allbrackets--;
6127 if (PL_lex_state == LEX_INTERPNORMAL) {
6128 if (PL_lex_brackets == 0) {
6129 if (PL_expect & XFAKEBRACK) {
6130 PL_expect &= XENUMMASK;
6131 PL_lex_state = LEX_INTERPEND;
6136 PL_thiswhite = newSVpvs("");
6137 sv_catpvs(PL_thiswhite,"}");
6140 return yylex(); /* ignore fake brackets */
6142 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6143 && SvEVALED(PL_lex_repl))
6144 PL_lex_state = LEX_INTERPEND;
6145 else if (*s == '-' && s[1] == '>')
6146 PL_lex_state = LEX_INTERPENDMAYBE;
6147 else if (*s != '[' && *s != '{')
6148 PL_lex_state = LEX_INTERPEND;
6151 if (PL_expect & XFAKEBRACK) {
6152 PL_expect &= XENUMMASK;
6154 return yylex(); /* ignore fake brackets */
6156 start_force(PL_curforce);
6158 curmad('X', newSVpvn(s-1,1));
6159 CURMAD('_', PL_thiswhite);
6161 force_next(formbrack ? '.' : '}');
6162 if (formbrack) LEAVE;
6164 if (PL_madskills && !PL_thistoken)
6165 PL_thistoken = newSVpvs("");
6167 if (formbrack == 2) { /* means . where arguments were expected */
6168 start_force(PL_curforce);
6176 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6177 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6184 if (PL_expect == XOPERATOR) {
6185 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
6186 && isIDFIRST_lazy_if(s,UTF))
6188 CopLINE_dec(PL_curcop);
6189 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6190 CopLINE_inc(PL_curcop);
6192 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6193 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6200 PL_tokenbuf[0] = '&';
6201 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
6202 sizeof PL_tokenbuf - 1, TRUE);
6203 if (PL_tokenbuf[1]) {
6204 PL_expect = XOPERATOR;
6205 force_ident_maybe_lex('&');
6209 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6215 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6216 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6223 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6224 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6232 const char tmp = *s++;
6234 if (!PL_lex_allbrackets &&
6235 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6242 if (!PL_lex_allbrackets &&
6243 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
6251 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6252 && strchr("+-*/%.^&|<",tmp))
6253 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6254 "Reversed %c= operator",(int)tmp);
6256 if (PL_expect == XSTATE && isALPHA(tmp) &&
6257 (s == PL_linestart+1 || s[-2] == '\n') )
6259 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6260 || PL_lex_state != LEX_NORMAL) {
6265 if (strnEQ(s,"=cut",4)) {
6281 PL_thiswhite = newSVpvs("");
6282 sv_catpvn(PL_thiswhite, PL_linestart,
6283 PL_bufend - PL_linestart);
6287 PL_parser->in_pod = 1;
6291 if (PL_expect == XBLOCK) {
6293 #ifdef PERL_STRICT_CR
6294 while (SPACE_OR_TAB(*t))
6296 while (SPACE_OR_TAB(*t) || *t == '\r')
6299 if (*t == '\n' || *t == '#') {
6302 SAVEI8(PL_parser->form_lex_state);
6303 SAVEI32(PL_lex_formbrack);
6304 PL_parser->form_lex_state = PL_lex_state;
6305 PL_lex_formbrack = PL_lex_brackets + 1;
6309 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6318 const char tmp = *s++;
6320 /* was this !=~ where !~ was meant?
6321 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6323 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6324 const char *t = s+1;
6326 while (t < PL_bufend && isSPACE(*t))
6329 if (*t == '/' || *t == '?' ||
6330 ((*t == 'm' || *t == 's' || *t == 'y')
6331 && !isWORDCHAR(t[1])) ||
6332 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6333 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6334 "!=~ should be !~");
6336 if (!PL_lex_allbrackets &&
6337 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6349 if (PL_expect != XOPERATOR) {
6350 if (s[1] != '<' && !strchr(s,'>'))
6353 s = scan_heredoc(s);
6355 s = scan_inputsymbol(s);
6356 PL_expect = XOPERATOR;
6357 TOKEN(sublex_start());
6363 if (*s == '=' && !PL_lex_allbrackets &&
6364 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6368 SHop(OP_LEFT_SHIFT);
6373 if (!PL_lex_allbrackets &&
6374 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6381 if (!PL_lex_allbrackets &&
6382 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6390 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6398 const char tmp = *s++;
6400 if (*s == '=' && !PL_lex_allbrackets &&
6401 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6405 SHop(OP_RIGHT_SHIFT);
6407 else if (tmp == '=') {
6408 if (!PL_lex_allbrackets &&
6409 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6417 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6426 if (PL_expect == XOPERATOR) {
6427 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6428 return deprecate_commaless_var_list();
6432 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6433 PL_tokenbuf[0] = '@';
6434 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6435 sizeof PL_tokenbuf - 1, FALSE);
6436 if (PL_expect == XOPERATOR)
6437 no_op("Array length", s);
6438 if (!PL_tokenbuf[1])
6440 PL_expect = XOPERATOR;
6441 force_ident_maybe_lex('#');
6445 PL_tokenbuf[0] = '$';
6446 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6447 sizeof PL_tokenbuf - 1, FALSE);
6448 if (PL_expect == XOPERATOR)
6450 if (!PL_tokenbuf[1]) {
6452 yyerror("Final $ should be \\$ or $name");
6458 const char tmp = *s;
6459 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6462 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6463 && intuit_more(s)) {
6465 PL_tokenbuf[0] = '@';
6466 if (ckWARN(WARN_SYNTAX)) {
6469 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6472 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6473 while (t < PL_bufend && *t != ']')
6475 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6476 "Multidimensional syntax %.*s not supported",
6477 (int)((t - PL_bufptr) + 1), PL_bufptr);
6481 else if (*s == '{') {
6483 PL_tokenbuf[0] = '%';
6484 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6485 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6487 char tmpbuf[sizeof PL_tokenbuf];
6490 } while (isSPACE(*t));
6491 if (isIDFIRST_lazy_if(t,UTF)) {
6493 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6498 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6499 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6500 "You need to quote \"%"SVf"\"",
6501 SVfARG(newSVpvn_flags(tmpbuf, len,
6502 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
6508 PL_expect = XOPERATOR;
6509 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6510 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6511 if (!islop || PL_last_lop_op == OP_GREPSTART)
6512 PL_expect = XOPERATOR;
6513 else if (strchr("$@\"'`q", *s))
6514 PL_expect = XTERM; /* e.g. print $fh "foo" */
6515 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6516 PL_expect = XTERM; /* e.g. print $fh &sub */
6517 else if (isIDFIRST_lazy_if(s,UTF)) {
6518 char tmpbuf[sizeof PL_tokenbuf];
6520 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6521 if ((t2 = keyword(tmpbuf, len, 0))) {
6522 /* binary operators exclude handle interpretations */
6534 PL_expect = XTERM; /* e.g. print $fh length() */
6539 PL_expect = XTERM; /* e.g. print $fh subr() */
6542 else if (isDIGIT(*s))
6543 PL_expect = XTERM; /* e.g. print $fh 3 */
6544 else if (*s == '.' && isDIGIT(s[1]))
6545 PL_expect = XTERM; /* e.g. print $fh .3 */
6546 else if ((*s == '?' || *s == '-' || *s == '+')
6547 && !isSPACE(s[1]) && s[1] != '=')
6548 PL_expect = XTERM; /* e.g. print $fh -1 */
6549 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6551 PL_expect = XTERM; /* e.g. print $fh /.../
6552 XXX except DORDOR operator
6554 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6556 PL_expect = XTERM; /* print $fh <<"EOF" */
6559 force_ident_maybe_lex('$');
6563 if (PL_expect == XOPERATOR)
6565 PL_tokenbuf[0] = '@';
6566 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6567 if (!PL_tokenbuf[1]) {
6570 if (PL_lex_state == LEX_NORMAL)
6572 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6574 PL_tokenbuf[0] = '%';
6576 /* Warn about @ where they meant $. */
6577 if (*s == '[' || *s == '{') {
6578 if (ckWARN(WARN_SYNTAX)) {
6579 const char *t = s + 1;
6580 while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6581 t += UTF ? UTF8SKIP(t) : 1;
6582 if (*t == '}' || *t == ']') {
6584 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6585 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
6586 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6587 "Scalar value %"SVf" better written as $%"SVf,
6588 SVfARG(newSVpvn_flags(PL_bufptr, (STRLEN)(t-PL_bufptr),
6589 SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))),
6590 SVfARG(newSVpvn_flags(PL_bufptr+1, (STRLEN)(t-PL_bufptr-1),
6591 SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))));
6596 PL_expect = XOPERATOR;
6597 force_ident_maybe_lex('@');
6600 case '/': /* may be division, defined-or, or pattern */
6601 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6602 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6603 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6608 case '?': /* may either be conditional or pattern */
6609 if (PL_expect == XOPERATOR) {
6612 if (!PL_lex_allbrackets &&
6613 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6617 PL_lex_allbrackets++;
6623 /* A // operator. */
6624 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6625 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6626 LEX_FAKEEOF_LOGIC)) {
6634 if (*s == '=' && !PL_lex_allbrackets &&
6635 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6644 /* Disable warning on "study /blah/" */
6645 if (PL_oldoldbufptr == PL_last_uni
6646 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6647 || memNE(PL_last_uni, "study", 5)
6648 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6652 deprecate("?PATTERN? without explicit operator");
6653 s = scan_pat(s,OP_MATCH);
6654 TERM(sublex_start());
6658 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6659 #ifdef PERL_STRICT_CR
6662 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6664 && (s == PL_linestart || s[-1] == '\n') )
6667 formbrack = 2; /* dot seen where arguments expected */
6670 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6674 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6677 if (!PL_lex_allbrackets &&
6678 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6685 pl_yylval.ival = OPf_SPECIAL;
6691 if (*s == '=' && !PL_lex_allbrackets &&
6692 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6699 case '0': case '1': case '2': case '3': case '4':
6700 case '5': case '6': case '7': case '8': case '9':
6701 s = scan_num(s, &pl_yylval);
6702 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6703 if (PL_expect == XOPERATOR)
6708 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6709 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6710 if (PL_expect == XOPERATOR) {
6711 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6712 return deprecate_commaless_var_list();
6719 pl_yylval.ival = OP_CONST;
6720 TERM(sublex_start());
6723 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6724 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6725 if (PL_expect == XOPERATOR) {
6726 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6727 return deprecate_commaless_var_list();
6734 pl_yylval.ival = OP_CONST;
6735 /* FIXME. I think that this can be const if char *d is replaced by
6736 more localised variables. */
6737 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6738 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6739 pl_yylval.ival = OP_STRINGIFY;
6743 TERM(sublex_start());
6746 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6747 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6748 if (PL_expect == XOPERATOR)
6749 no_op("Backticks",s);
6752 readpipe_override();
6753 TERM(sublex_start());
6757 if (PL_lex_inwhat && isDIGIT(*s))
6758 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6760 if (PL_expect == XOPERATOR)
6761 no_op("Backslash",s);
6765 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6766 char *start = s + 2;
6767 while (isDIGIT(*start) || *start == '_')
6769 if (*start == '.' && isDIGIT(start[1])) {
6770 s = scan_num(s, &pl_yylval);
6773 else if ((*start == ':' && start[1] == ':')
6774 || (PL_expect == XSTATE && *start == ':'))
6776 else if (PL_expect == XSTATE) {
6778 while (d < PL_bufend && isSPACE(*d)) d++;
6779 if (*d == ':') goto keylookup;
6781 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6782 if (!isALPHA(*start) && (PL_expect == XTERM
6783 || PL_expect == XREF || PL_expect == XSTATE
6784 || PL_expect == XTERMORDORDOR)) {
6785 GV *const gv = gv_fetchpvn_flags(s, start - s,
6786 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6788 s = scan_num(s, &pl_yylval);
6795 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6848 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6850 /* Some keywords can be followed by any delimiter, including ':' */
6851 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6853 /* x::* is just a word, unless x is "CORE" */
6854 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6858 while (d < PL_bufend && isSPACE(*d))
6859 d++; /* no comments skipped here, or s### is misparsed */
6861 /* Is this a word before a => operator? */
6862 if (*d == '=' && d[1] == '>') {
6865 = (OP*)newSVOP(OP_CONST, 0,
6866 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6867 pl_yylval.opval->op_private = OPpCONST_BARE;
6871 /* Check for plugged-in keyword */
6875 char *saved_bufptr = PL_bufptr;
6877 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6879 if (result == KEYWORD_PLUGIN_DECLINE) {
6880 /* not a plugged-in keyword */
6881 PL_bufptr = saved_bufptr;
6882 } else if (result == KEYWORD_PLUGIN_STMT) {
6883 pl_yylval.opval = o;
6886 return REPORT(PLUGSTMT);
6887 } else if (result == KEYWORD_PLUGIN_EXPR) {
6888 pl_yylval.opval = o;
6890 PL_expect = XOPERATOR;
6891 return REPORT(PLUGEXPR);
6893 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6898 /* Check for built-in keyword */
6899 tmp = keyword(PL_tokenbuf, len, 0);
6901 /* Is this a label? */
6902 if (!anydelim && PL_expect == XSTATE
6903 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6905 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6906 pl_yylval.pval[len] = '\0';
6907 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6912 /* Check for lexical sub */
6913 if (PL_expect != XOPERATOR) {
6914 char tmpbuf[sizeof PL_tokenbuf + 1];
6916 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6917 off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
6918 if (off != NOT_IN_PAD) {
6919 assert(off); /* we assume this is boolean-true below */
6920 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6921 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6922 HEK * const stashname = HvNAME_HEK(stash);
6923 sv = newSVhek(stashname);
6924 sv_catpvs(sv, "::");
6925 sv_catpvn_flags(sv, PL_tokenbuf, len,
6926 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6927 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6937 rv2cv_op = newOP(OP_PADANY, 0);
6938 rv2cv_op->op_targ = off;
6939 cv = find_lexical_cv(off);
6947 if (tmp < 0) { /* second-class keyword? */
6948 GV *ogv = NULL; /* override (winner) */
6949 GV *hgv = NULL; /* hidden (loser) */
6950 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6952 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6953 UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
6956 if (GvIMPORTED_CV(gv))
6958 else if (! CvMETHOD(cv))
6962 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6963 UTF ? -(I32)len : (I32)len, FALSE)) &&
6964 (gv = *gvp) && isGV_with_GP(gv) &&
6965 GvCVu(gv) && GvIMPORTED_CV(gv))
6972 tmp = 0; /* overridden by import or by GLOBAL */
6975 && -tmp==KEY_lock /* XXX generalizable kludge */
6978 tmp = 0; /* any sub overrides "weak" keyword */
6980 else { /* no override */
6982 if (tmp == KEY_dump) {
6983 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6984 "dump() better written as CORE::dump()");
6988 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
6989 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6990 "Ambiguous call resolved as CORE::%s(), "
6991 "qualify as such or use &",
6999 default: /* not a keyword */
7000 /* Trade off - by using this evil construction we can pull the
7001 variable gv into the block labelled keylookup. If not, then
7002 we have to give it function scope so that the goto from the
7003 earlier ':' case doesn't bypass the initialisation. */
7005 just_a_word_zero_gv:
7017 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7018 const char penultchar =
7019 lastchar && PL_bufptr - 2 >= PL_linestart
7023 SV *nextPL_nextwhite = 0;
7027 /* Get the rest if it looks like a package qualifier */
7029 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7031 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7034 Perl_croak(aTHX_ "Bad name after %"SVf"%s",
7035 SVfARG(newSVpvn_flags(PL_tokenbuf, len,
7036 (UTF ? SVf_UTF8 : 0) | SVs_TEMP )),
7037 *s == '\'' ? "'" : "::");
7042 if (PL_expect == XOPERATOR) {
7043 if (PL_bufptr == PL_linestart) {
7044 CopLINE_dec(PL_curcop);
7045 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7046 CopLINE_inc(PL_curcop);
7049 no_op("Bareword",s);
7052 /* Look for a subroutine with this name in current package,
7053 unless this is a lexical sub, or name is "Foo::",
7054 in which case Foo is a bareword
7055 (and a package name). */
7057 if (len > 2 && !PL_madskills &&
7058 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
7060 if (ckWARN(WARN_BAREWORD)
7061 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7062 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7063 "Bareword \"%"SVf"\" refers to nonexistent package",
7064 SVfARG(newSVpvn_flags(PL_tokenbuf, len,
7065 (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
7067 PL_tokenbuf[len] = '\0';
7073 /* Mustn't actually add anything to a symbol table.
7074 But also don't want to "initialise" any placeholder
7075 constants that might already be there into full
7076 blown PVGVs with attached PVCV. */
7077 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7078 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
7084 /* if we saw a global override before, get the right name */
7087 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7088 len ? len : strlen(PL_tokenbuf));
7090 SV * const tmp_sv = sv;
7091 sv = newSVpvs("CORE::GLOBAL::");
7092 sv_catsv(sv, tmp_sv);
7093 SvREFCNT_dec(tmp_sv);
7097 if (PL_madskills && !PL_thistoken) {
7098 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
7099 PL_thistoken = newSVpvn(start,s - start);
7100 PL_realtokenstart = s - SvPVX(PL_linestr);
7104 /* Presume this is going to be a bareword of some sort. */
7106 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
7107 pl_yylval.opval->op_private = OPpCONST_BARE;
7109 /* And if "Foo::", then that's what it certainly is. */
7115 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7116 const_op->op_private = OPpCONST_BARE;
7117 rv2cv_op = newCVREF(0, const_op);
7118 cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
7121 /* See if it's the indirect object for a list operator. */
7123 if (PL_oldoldbufptr &&
7124 PL_oldoldbufptr < PL_bufptr &&
7125 (PL_oldoldbufptr == PL_last_lop
7126 || PL_oldoldbufptr == PL_last_uni) &&
7127 /* NO SKIPSPACE BEFORE HERE! */
7128 (PL_expect == XREF ||
7129 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
7131 bool immediate_paren = *s == '(';
7133 /* (Now we can afford to cross potential line boundary.) */
7134 s = SKIPSPACE2(s,nextPL_nextwhite);
7136 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
7139 /* Two barewords in a row may indicate method call. */
7141 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
7142 (tmp = intuit_method(s, gv, cv))) {
7144 if (tmp == METHOD && !PL_lex_allbrackets &&
7145 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7146 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7150 /* If not a declared subroutine, it's an indirect object. */
7151 /* (But it's an indir obj regardless for sort.) */
7152 /* Also, if "_" follows a filetest operator, it's a bareword */
7155 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
7157 (PL_last_lop_op != OP_MAPSTART &&
7158 PL_last_lop_op != OP_GREPSTART))))
7159 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7160 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
7163 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7168 PL_expect = XOPERATOR;
7171 s = SKIPSPACE2(s,nextPL_nextwhite);
7172 PL_nextwhite = nextPL_nextwhite;
7177 /* Is this a word before a => operator? */
7178 if (*s == '=' && s[1] == '>' && !pkgname) {
7181 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
7182 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
7183 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
7187 /* If followed by a paren, it's certainly a subroutine. */
7192 while (SPACE_OR_TAB(*d))
7194 if (*d == ')' && (sv = cv_const_sv(cv))) {
7201 PL_nextwhite = PL_thiswhite;
7204 start_force(PL_curforce);
7206 NEXTVAL_NEXTTOKE.opval =
7207 off ? rv2cv_op : pl_yylval.opval;
7208 PL_expect = XOPERATOR;
7211 PL_nextwhite = nextPL_nextwhite;
7212 curmad('X', PL_thistoken);
7213 PL_thistoken = newSVpvs("");
7217 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7218 else op_free(rv2cv_op), force_next(WORD);
7223 /* If followed by var or block, call it a method (unless sub) */
7225 if ((*s == '$' || *s == '{') && !cv) {
7227 PL_last_lop = PL_oldbufptr;
7228 PL_last_lop_op = OP_METHOD;
7229 if (!PL_lex_allbrackets &&
7230 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7231 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7235 /* If followed by a bareword, see if it looks like indir obj. */
7238 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
7239 && (tmp = intuit_method(s, gv, cv))) {
7241 if (tmp == METHOD && !PL_lex_allbrackets &&
7242 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7243 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7247 /* Not a method, so call it a subroutine (if defined) */
7250 if (lastchar == '-' && penultchar != '-') {
7251 const SV *tmpsv = newSVpvn_flags( PL_tokenbuf, len ? len : strlen(PL_tokenbuf), (UTF ? SVf_UTF8 : 0) | SVs_TEMP );
7252 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7253 "Ambiguous use of -%"SVf" resolved as -&%"SVf"()",
7254 SVfARG(tmpsv), SVfARG(tmpsv));
7256 /* Check for a constant sub */
7257 if ((sv = cv_const_sv(cv))) {
7260 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7261 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7262 pl_yylval.opval->op_private = OPpCONST_FOLDED;
7263 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7267 op_free(pl_yylval.opval);
7269 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7270 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7271 PL_last_lop = PL_oldbufptr;
7272 PL_last_lop_op = OP_ENTERSUB;
7273 /* Is there a prototype? */
7280 STRLEN protolen = CvPROTOLEN(cv);
7281 const char *proto = CvPROTO(cv);
7285 if ((optional = *proto == ';'))
7288 while (*proto == ';');
7292 *proto == '$' || *proto == '_'
7293 || *proto == '*' || *proto == '+'
7298 *proto == '\\' && proto[1] && proto[2] == '\0'
7301 UNIPROTO(UNIOPSUB,optional);
7302 if (*proto == '\\' && proto[1] == '[') {
7303 const char *p = proto + 2;
7304 while(*p && *p != ']')
7306 if(*p == ']' && !p[1])
7307 UNIPROTO(UNIOPSUB,optional);
7309 if (*proto == '&' && *s == '{') {
7311 sv_setpvs(PL_subname, "__ANON__");
7313 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7314 if (!PL_lex_allbrackets &&
7315 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7316 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7323 PL_nextwhite = PL_thiswhite;
7326 start_force(PL_curforce);
7327 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7330 PL_nextwhite = nextPL_nextwhite;
7331 curmad('X', PL_thistoken);
7332 PL_thistoken = newSVpvs("");
7334 force_next(off ? PRIVATEREF : WORD);
7335 if (!PL_lex_allbrackets &&
7336 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7337 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7342 /* Guess harder when madskills require "best effort". */
7343 if (PL_madskills && (!gv || !GvCVu(gv))) {
7344 int probable_sub = 0;
7345 if (strchr("\"'`$@%0123456789!*+{[<", *s))
7347 else if (isALPHA(*s)) {
7351 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
7352 if (!keyword(tmpbuf, tmplen, 0))
7355 while (d < PL_bufend && isSPACE(*d))
7357 if (*d == '=' && d[1] == '>')
7362 gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
7364 op_free(pl_yylval.opval);
7366 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7367 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7368 PL_last_lop = PL_oldbufptr;
7369 PL_last_lop_op = OP_ENTERSUB;
7370 PL_nextwhite = PL_thiswhite;
7372 start_force(PL_curforce);
7373 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7375 PL_nextwhite = nextPL_nextwhite;
7376 curmad('X', PL_thistoken);
7377 PL_thistoken = newSVpvs("");
7378 force_next(off ? PRIVATEREF : WORD);
7379 if (!PL_lex_allbrackets &&
7380 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7381 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7385 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7387 force_next(off ? PRIVATEREF : WORD);
7388 if (!PL_lex_allbrackets &&
7389 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7390 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7395 /* Call it a bare word */
7397 if (PL_hints & HINT_STRICT_SUBS)
7398 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7401 /* after "print" and similar functions (corresponding to
7402 * "F? L" in opcode.pl), whatever wasn't already parsed as
7403 * a filehandle should be subject to "strict subs".
7404 * Likewise for the optional indirect-object argument to system
7405 * or exec, which can't be a bareword */
7406 if ((PL_last_lop_op == OP_PRINT
7407 || PL_last_lop_op == OP_PRTF
7408 || PL_last_lop_op == OP_SAY
7409 || PL_last_lop_op == OP_SYSTEM
7410 || PL_last_lop_op == OP_EXEC)
7411 && (PL_hints & HINT_STRICT_SUBS))
7412 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7413 if (lastchar != '-') {
7414 if (ckWARN(WARN_RESERVED)) {
7418 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7419 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7427 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
7428 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7429 "Operator or semicolon missing before %c%"SVf,
7430 lastchar, SVfARG(newSVpvn_flags(PL_tokenbuf,
7431 strlen(PL_tokenbuf),
7432 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
7433 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7434 "Ambiguous use of %c resolved as operator %c",
7435 lastchar, lastchar);
7442 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7447 (OP*)newSVOP(OP_CONST, 0,
7448 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7451 case KEY___PACKAGE__:
7453 (OP*)newSVOP(OP_CONST, 0,
7455 ? newSVhek(HvNAME_HEK(PL_curstash))
7462 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7463 const char *pname = "main";
7466 if (PL_tokenbuf[2] == 'D')
7469 PL_curstash ? PL_curstash : PL_defstash;
7470 pname = HvNAME_get(stash);
7471 plen = HvNAMELEN (stash);
7472 if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
7474 gv = gv_fetchpvn_flags(
7475 Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
7476 plen+6, GV_ADD|putf8, SVt_PVIO
7480 GvIOp(gv) = newIO();
7481 IoIFP(GvIOp(gv)) = PL_rsfp;
7482 #if defined(HAS_FCNTL) && defined(F_SETFD)
7484 const int fd = PerlIO_fileno(PL_rsfp);
7485 fcntl(fd,F_SETFD,fd >= 3);
7488 /* Mark this internal pseudo-handle as clean */
7489 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7490 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7491 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7493 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7494 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7495 /* if the script was opened in binmode, we need to revert
7496 * it to text mode for compatibility; but only iff it has CRs
7497 * XXX this is a questionable hack at best. */
7498 if (PL_bufend-PL_bufptr > 2
7499 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7502 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7503 loc = PerlIO_tell(PL_rsfp);
7504 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7507 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7509 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7510 #endif /* NETWARE */
7512 PerlIO_seek(PL_rsfp, loc, 0);
7516 #ifdef PERLIO_LAYERS
7519 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7520 else if (PL_encoding) {
7527 XPUSHs(PL_encoding);
7529 call_method("name", G_SCALAR);
7533 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7534 Perl_form(aTHX_ ":encoding(%"SVf")",
7543 if (PL_realtokenstart >= 0) {
7544 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7546 PL_endwhite = newSVpvs("");
7547 sv_catsv(PL_endwhite, PL_thiswhite);
7549 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7550 PL_realtokenstart = -1;
7552 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7562 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
7571 if (PL_expect == XSTATE) {
7578 if (*s == ':' && s[1] == ':') {
7582 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7583 if ((*s == ':' && s[1] == ':')
7584 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7588 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7592 Perl_croak(aTHX_ "CORE::%"SVf" is not a keyword",
7593 SVfARG(newSVpvn_flags(PL_tokenbuf, len,
7594 (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
7597 else if (tmp == KEY_require || tmp == KEY_do
7599 /* that's a way to remember we saw "CORE::" */
7612 LOP(OP_ACCEPT,XTERM);
7615 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7620 LOP(OP_ATAN2,XTERM);
7626 LOP(OP_BINMODE,XTERM);
7629 LOP(OP_BLESS,XTERM);
7638 /* We have to disambiguate the two senses of
7639 "continue". If the next token is a '{' then
7640 treat it as the start of a continue block;
7641 otherwise treat it as a control operator.
7651 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7661 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7670 if (!PL_cryptseen) {
7671 PL_cryptseen = TRUE;
7675 LOP(OP_CRYPT,XTERM);
7678 LOP(OP_CHMOD,XTERM);
7681 LOP(OP_CHOWN,XTERM);
7684 LOP(OP_CONNECT,XTERM);
7704 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7706 if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
7709 force_ident_maybe_lex('&');
7714 if (orig_keyword == KEY_do) {
7723 PL_hints |= HINT_BLOCK_SCOPE;
7733 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7734 STR_WITH_LEN("NDBM_File::"),
7735 STR_WITH_LEN("DB_File::"),
7736 STR_WITH_LEN("GDBM_File::"),
7737 STR_WITH_LEN("SDBM_File::"),
7738 STR_WITH_LEN("ODBM_File::"),
7740 LOP(OP_DBMOPEN,XTERM);
7746 PL_expect = XOPERATOR;
7747 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7754 pl_yylval.ival = CopLINE(PL_curcop);
7758 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7772 if (*s == '{') { /* block eval */
7773 PL_expect = XTERMBLOCK;
7774 UNIBRACK(OP_ENTERTRY);
7776 else { /* string eval */
7778 UNIBRACK(OP_ENTEREVAL);
7783 UNIBRACK(-OP_ENTEREVAL);
7797 case KEY_endhostent:
7803 case KEY_endservent:
7806 case KEY_endprotoent:
7817 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7819 pl_yylval.ival = CopLINE(PL_curcop);
7821 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7824 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7827 if ((PL_bufend - p) >= 3 &&
7828 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7830 else if ((PL_bufend - p) >= 4 &&
7831 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7834 if (isIDFIRST_lazy_if(p,UTF)) {
7835 p = scan_ident(p, PL_bufend,
7836 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7840 Perl_croak(aTHX_ "Missing $ on loop variable");
7842 s = SvPVX(PL_linestr) + soff;
7848 LOP(OP_FORMLINE,XTERM);
7857 LOP(OP_FCNTL,XTERM);
7863 LOP(OP_FLOCK,XTERM);
7866 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7871 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7876 LOP(OP_GREPSTART, XREF);
7879 PL_expect = XOPERATOR;
7880 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7895 case KEY_getpriority:
7896 LOP(OP_GETPRIORITY,XTERM);
7898 case KEY_getprotobyname:
7901 case KEY_getprotobynumber:
7902 LOP(OP_GPBYNUMBER,XTERM);
7904 case KEY_getprotoent:
7916 case KEY_getpeername:
7917 UNI(OP_GETPEERNAME);
7919 case KEY_gethostbyname:
7922 case KEY_gethostbyaddr:
7923 LOP(OP_GHBYADDR,XTERM);
7925 case KEY_gethostent:
7928 case KEY_getnetbyname:
7931 case KEY_getnetbyaddr:
7932 LOP(OP_GNBYADDR,XTERM);
7937 case KEY_getservbyname:
7938 LOP(OP_GSBYNAME,XTERM);
7940 case KEY_getservbyport:
7941 LOP(OP_GSBYPORT,XTERM);
7943 case KEY_getservent:
7946 case KEY_getsockname:
7947 UNI(OP_GETSOCKNAME);
7949 case KEY_getsockopt:
7950 LOP(OP_GSOCKOPT,XTERM);
7965 pl_yylval.ival = CopLINE(PL_curcop);
7966 Perl_ck_warner_d(aTHX_
7967 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7968 "given is experimental");
7973 orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
7981 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7983 pl_yylval.ival = CopLINE(PL_curcop);
7987 LOP(OP_INDEX,XTERM);
7993 LOP(OP_IOCTL,XTERM);
8005 PL_expect = XOPERATOR;
8006 s = force_word(s,WORD,TRUE,FALSE,FALSE);
8023 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8028 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8042 LOP(OP_LISTEN,XTERM);
8051 s = scan_pat(s,OP_MATCH);
8052 TERM(sublex_start());
8055 LOP(OP_MAPSTART, XREF);
8058 LOP(OP_MKDIR,XTERM);
8061 LOP(OP_MSGCTL,XTERM);
8064 LOP(OP_MSGGET,XTERM);
8067 LOP(OP_MSGRCV,XTERM);
8070 LOP(OP_MSGSND,XTERM);
8075 PL_in_my = (U16)tmp;
8077 if (isIDFIRST_lazy_if(s,UTF)) {
8081 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8082 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
8084 if (!FEATURE_LEXSUBS_IS_ENABLED)
8086 "Experimental \"%s\" subs not enabled",
8087 tmp == KEY_my ? "my" :
8088 tmp == KEY_state ? "state" : "our");
8089 Perl_ck_warner_d(aTHX_
8090 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
8091 "The lexical_subs feature is experimental");
8094 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8095 if (!PL_in_my_stash) {
8098 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8099 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8102 if (PL_madskills) { /* just add type to declarator token */
8103 sv_catsv(PL_thistoken, PL_nextwhite);
8105 sv_catpvn(PL_thistoken, start, s - start);
8113 PL_expect = XOPERATOR;
8114 s = force_word(s,WORD,TRUE,FALSE,FALSE);
8118 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8123 s = tokenize_use(0, s);
8127 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
8130 if (!PL_lex_allbrackets &&
8131 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8132 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8138 if (isIDFIRST_lazy_if(s,UTF)) {
8140 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8142 for (t=d; isSPACE(*t);)
8144 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8146 && !(t[0] == '=' && t[1] == '>')
8147 && !(t[0] == ':' && t[1] == ':')
8148 && !keyword(s, d-s, 0)
8150 SV *tmpsv = newSVpvn_flags(s, (STRLEN)(d-s),
8151 SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8152 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8153 "Precedence problem: open %"SVf" should be open(%"SVf")",
8154 SVfARG(tmpsv), SVfARG(tmpsv));
8160 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8162 pl_yylval.ival = OP_OR;
8172 LOP(OP_OPEN_DIR,XTERM);
8175 checkcomma(s,PL_tokenbuf,"filehandle");
8179 checkcomma(s,PL_tokenbuf,"filehandle");
8198 s = force_word(s,WORD,FALSE,TRUE,FALSE);
8200 s = force_strict_version(s);
8201 PL_lex_expect = XBLOCK;
8205 LOP(OP_PIPE_OP,XTERM);
8208 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8211 pl_yylval.ival = OP_CONST;
8212 TERM(sublex_start());
8219 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8222 PL_expect = XOPERATOR;
8223 if (SvCUR(PL_lex_stuff)) {
8224 int warned_comma = !ckWARN(WARN_QW);
8225 int warned_comment = warned_comma;
8226 d = SvPV_force(PL_lex_stuff, len);
8228 for (; isSPACE(*d) && len; --len, ++d)
8233 if (!warned_comma || !warned_comment) {
8234 for (; !isSPACE(*d) && len; --len, ++d) {
8235 if (!warned_comma && *d == ',') {
8236 Perl_warner(aTHX_ packWARN(WARN_QW),
8237 "Possible attempt to separate words with commas");
8240 else if (!warned_comment && *d == '#') {
8241 Perl_warner(aTHX_ packWARN(WARN_QW),
8242 "Possible attempt to put comments in qw() list");
8248 for (; !isSPACE(*d) && len; --len, ++d)
8251 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8252 words = op_append_elem(OP_LIST, words,
8253 newSVOP(OP_CONST, 0, tokeq(sv)));
8258 words = newNULLLIST();
8260 SvREFCNT_dec(PL_lex_stuff);
8261 PL_lex_stuff = NULL;
8263 PL_expect = XOPERATOR;
8264 pl_yylval.opval = sawparens(words);
8269 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8272 pl_yylval.ival = OP_STRINGIFY;
8273 if (SvIVX(PL_lex_stuff) == '\'')
8274 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8275 TERM(sublex_start());
8278 s = scan_pat(s,OP_QR);
8279 TERM(sublex_start());
8282 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8285 readpipe_override();
8286 TERM(sublex_start());
8293 PL_expect = XOPERATOR;
8295 s = force_version(s, FALSE);
8297 else if (*s != 'v' || !isDIGIT(s[1])
8298 || (s = force_version(s, TRUE), *s == 'v'))
8300 *PL_tokenbuf = '\0';
8301 s = force_word(s,WORD,TRUE,TRUE,FALSE);
8302 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
8303 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8304 GV_ADD | (UTF ? SVf_UTF8 : 0));
8306 yyerror("<> should be quotes");
8308 if (orig_keyword == KEY_require) {
8316 PL_last_uni = PL_oldbufptr;
8317 PL_last_lop_op = OP_REQUIRE;
8319 return REPORT( (int)REQUIRE );
8325 PL_expect = XOPERATOR;
8326 s = force_word(s,WORD,TRUE,FALSE,FALSE);
8330 LOP(OP_RENAME,XTERM);
8339 LOP(OP_RINDEX,XTERM);
8348 UNIDOR(OP_READLINE);
8351 UNIDOR(OP_BACKTICK);
8360 LOP(OP_REVERSE,XTERM);
8363 UNIDOR(OP_READLINK);
8370 if (pl_yylval.opval)
8371 TERM(sublex_start());
8373 TOKEN(1); /* force error */
8376 checkcomma(s,PL_tokenbuf,"filehandle");
8386 LOP(OP_SELECT,XTERM);
8392 LOP(OP_SEMCTL,XTERM);
8395 LOP(OP_SEMGET,XTERM);
8398 LOP(OP_SEMOP,XTERM);
8404 LOP(OP_SETPGRP,XTERM);
8406 case KEY_setpriority:
8407 LOP(OP_SETPRIORITY,XTERM);
8409 case KEY_sethostent:
8415 case KEY_setservent:
8418 case KEY_setprotoent:
8428 LOP(OP_SEEKDIR,XTERM);
8430 case KEY_setsockopt:
8431 LOP(OP_SSOCKOPT,XTERM);
8437 LOP(OP_SHMCTL,XTERM);
8440 LOP(OP_SHMGET,XTERM);
8443 LOP(OP_SHMREAD,XTERM);
8446 LOP(OP_SHMWRITE,XTERM);
8449 LOP(OP_SHUTDOWN,XTERM);
8458 LOP(OP_SOCKET,XTERM);
8460 case KEY_socketpair:
8461 LOP(OP_SOCKPAIR,XTERM);
8464 checkcomma(s,PL_tokenbuf,"subroutine name");
8467 s = force_word(s,WORD,TRUE,TRUE,FALSE);
8471 LOP(OP_SPLIT,XTERM);
8474 LOP(OP_SPRINTF,XTERM);
8477 LOP(OP_SPLICE,XTERM);
8492 LOP(OP_SUBSTR,XTERM);
8498 char * const tmpbuf = PL_tokenbuf + 1;
8499 SSize_t tboffset = 0;
8500 expectation attrful;
8501 bool have_name, have_proto;
8502 const int key = tmp;
8507 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
8508 SV *subtoken = PL_madskills
8509 ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr))
8514 s = SKIPSPACE2(s,tmpwhite);
8520 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
8521 (*s == ':' && s[1] == ':'))
8524 SV *nametoke = NULL;
8528 attrful = XATTRBLOCK;
8529 /* remember buffer pos'n for later force_word */
8530 tboffset = s - PL_oldbufptr;
8531 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8535 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
8538 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8540 PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
8542 sv_setpvn(PL_subname, tmpbuf, len);
8544 sv_setsv(PL_subname,PL_curstname);
8545 sv_catpvs(PL_subname,"::");
8546 sv_catpvn(PL_subname,tmpbuf,len);
8548 if (SvUTF8(PL_linestr))
8549 SvUTF8_on(PL_subname);
8555 CURMAD('X', nametoke);
8556 CURMAD('_', tmpwhite);
8557 force_ident_maybe_lex('&');
8559 s = SKIPSPACE2(d,tmpwhite);
8565 if (key == KEY_my || key == KEY_our || key==KEY_state)
8568 /* diag_listed_as: Missing name in "%s sub" */
8570 "Missing name in \"%s\"", PL_bufptr);
8572 PL_expect = XTERMBLOCK;
8573 attrful = XATTRTERM;
8574 sv_setpvs(PL_subname,"?");
8578 if (key == KEY_format) {
8580 PL_thistoken = subtoken;
8582 PERL_UNUSED_VAR(tboffset);
8585 (void) force_word(PL_oldbufptr + tboffset, WORD,
8591 /* Look for a prototype */
8594 bool bad_proto = FALSE;
8595 bool in_brackets = FALSE;
8596 char greedy_proto = ' ';
8597 bool proto_after_greedy_proto = FALSE;
8598 bool must_be_last = FALSE;
8599 bool underscore = FALSE;
8600 bool seen_underscore = FALSE;
8601 const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
8604 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8606 Perl_croak(aTHX_ "Prototype not terminated");
8607 /* strip spaces and check for bad characters */
8608 d = SvPV(PL_lex_stuff, tmplen);
8610 for (p = d; tmplen; tmplen--, ++p) {
8614 if (warnillegalproto) {
8616 proto_after_greedy_proto = TRUE;
8617 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
8622 if ( !strchr(";@%", *p) )
8629 else if ( *p == ']' ) {
8630 in_brackets = FALSE;
8632 else if ( (*p == '@' || *p == '%') &&
8633 ( tmp < 2 || d[tmp-2] != '\\' ) &&
8635 must_be_last = TRUE;
8638 else if ( *p == '_' ) {
8639 underscore = seen_underscore = TRUE;
8646 if (proto_after_greedy_proto)
8647 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8648 "Prototype after '%c' for %"SVf" : %s",
8649 greedy_proto, SVfARG(PL_subname), d);
8651 SV *dsv = newSVpvs_flags("", SVs_TEMP);
8652 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8653 "Illegal character %sin prototype for %"SVf" : %s",
8654 seen_underscore ? "after '_' " : "",
8656 SvUTF8(PL_lex_stuff)
8657 ? sv_uni_display(dsv,
8658 newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8),
8660 UNI_DISPLAY_ISPRINT)
8661 : pv_pretty(dsv, d, tmp, 60, NULL, NULL,
8662 PERL_PV_ESCAPE_NONASCII));
8664 SvCUR_set(PL_lex_stuff, tmp);
8669 CURMAD('q', PL_thisopen);
8670 CURMAD('_', tmpwhite);
8671 CURMAD('=', PL_thisstuff);
8672 CURMAD('Q', PL_thisclose);
8673 NEXTVAL_NEXTTOKE.opval =
8674 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8675 PL_lex_stuff = NULL;
8678 s = SKIPSPACE2(s,tmpwhite);
8686 if (*s == ':' && s[1] != ':')
8687 PL_expect = attrful;
8688 else if (*s != '{' && key == KEY_sub) {
8690 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8691 else if (*s != ';' && *s != '}')
8692 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8699 curmad('^', newSVpvs(""));
8700 CURMAD('_', tmpwhite);
8704 PL_thistoken = subtoken;
8705 PERL_UNUSED_VAR(have_proto);
8708 NEXTVAL_NEXTTOKE.opval =
8709 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8710 PL_lex_stuff = NULL;
8716 sv_setpvs(PL_subname, "__ANON__");
8718 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8722 force_ident_maybe_lex('&');
8728 LOP(OP_SYSTEM,XREF);
8731 LOP(OP_SYMLINK,XTERM);
8734 LOP(OP_SYSCALL,XTERM);
8737 LOP(OP_SYSOPEN,XTERM);
8740 LOP(OP_SYSSEEK,XTERM);
8743 LOP(OP_SYSREAD,XTERM);
8746 LOP(OP_SYSWRITE,XTERM);
8751 TERM(sublex_start());
8772 LOP(OP_TRUNCATE,XTERM);
8784 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8786 pl_yylval.ival = CopLINE(PL_curcop);
8790 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8792 pl_yylval.ival = CopLINE(PL_curcop);
8796 LOP(OP_UNLINK,XTERM);
8802 LOP(OP_UNPACK,XTERM);
8805 LOP(OP_UTIME,XTERM);
8811 LOP(OP_UNSHIFT,XTERM);
8814 s = tokenize_use(1, s);
8824 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8826 pl_yylval.ival = CopLINE(PL_curcop);
8827 Perl_ck_warner_d(aTHX_
8828 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8829 "when is experimental");
8833 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8835 pl_yylval.ival = CopLINE(PL_curcop);
8839 PL_hints |= HINT_BLOCK_SCOPE;
8846 LOP(OP_WAITPID,XTERM);
8855 ctl_l[0] = toCTRL('L');
8857 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8860 /* Make sure $^L is defined */
8861 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8866 if (PL_expect == XOPERATOR) {
8867 if (*s == '=' && !PL_lex_allbrackets &&
8868 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8876 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8878 pl_yylval.ival = OP_XOR;
8884 #pragma segment Main
8890 Looks up an identifier in the pad or in a package
8893 PRIVATEREF if this is a lexical name.
8894 WORD if this belongs to a package.
8897 if we're in a my declaration
8898 croak if they tried to say my($foo::bar)
8899 build the ops for a my() declaration
8900 if it's an access to a my() variable
8901 build ops for access to a my() variable
8902 if in a dq string, and they've said @foo and we can't find @foo
8904 build ops for a bareword
8908 S_pending_ident(pTHX)
8912 const char pit = (char)pl_yylval.ival;
8913 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8914 /* All routes through this function want to know if there is a colon. */
8915 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8917 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8918 "### Pending identifier '%s'\n", PL_tokenbuf); });
8920 /* if we're in a my(), we can't allow dynamics here.
8921 $foo'bar has already been turned into $foo::bar, so
8922 just check for colons.
8924 if it's a legal name, the OP is a PADANY.
8927 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8929 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8930 "variable %s in \"our\"",
8931 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8932 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8936 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8937 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8938 UTF ? SVf_UTF8 : 0);
8940 pl_yylval.opval = newOP(OP_PADANY, 0);
8941 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8942 UTF ? SVf_UTF8 : 0);
8948 build the ops for accesses to a my() variable.
8953 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8954 UTF ? SVf_UTF8 : 0);
8955 if (tmp != NOT_IN_PAD) {
8956 /* might be an "our" variable" */
8957 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8958 /* build ops for a bareword */
8959 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8960 HEK * const stashname = HvNAME_HEK(stash);
8961 SV * const sym = newSVhek(stashname);
8962 sv_catpvs(sym, "::");
8963 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8964 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8965 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8969 ? (GV_ADDMULTI | GV_ADDINEVAL)
8972 ((PL_tokenbuf[0] == '$') ? SVt_PV
8973 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8978 pl_yylval.opval = newOP(OP_PADANY, 0);
8979 pl_yylval.opval->op_targ = tmp;
8985 Whine if they've said @foo in a doublequoted string,
8986 and @foo isn't a variable we can find in the symbol
8989 if (ckWARN(WARN_AMBIGUOUS) &&
8990 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8991 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8992 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8993 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8994 /* DO NOT warn for @- and @+ */
8995 && !( PL_tokenbuf[2] == '\0' &&
8996 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8999 /* Downgraded from fatal to warning 20000522 mjd */
9000 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9001 "Possible unintended interpolation of %"SVf" in string",
9002 SVfARG(newSVpvn_flags(PL_tokenbuf, tokenbuf_len,
9003 SVs_TEMP | ( UTF ? SVf_UTF8 : 0 ))));
9007 /* build ops for a bareword */
9008 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
9009 newSVpvn_flags(PL_tokenbuf + 1,
9011 UTF ? SVf_UTF8 : 0 ));
9012 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9014 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
9015 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
9016 | ( UTF ? SVf_UTF8 : 0 ),
9017 ((PL_tokenbuf[0] == '$') ? SVt_PV
9018 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9024 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9028 PERL_ARGS_ASSERT_CHECKCOMMA;
9030 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9031 if (ckWARN(WARN_SYNTAX)) {
9034 for (w = s+2; *w && level; w++) {
9042 /* the list of chars below is for end of statements or
9043 * block / parens, boolean operators (&&, ||, //) and branch
9044 * constructs (or, and, if, until, unless, while, err, for).
9045 * Not a very solid hack... */
9046 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9047 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9048 "%s (...) interpreted as function",name);
9051 while (s < PL_bufend && isSPACE(*s))
9055 while (s < PL_bufend && isSPACE(*s))
9057 if (isIDFIRST_lazy_if(s,UTF)) {
9058 const char * const w = s;
9059 s += UTF ? UTF8SKIP(s) : 1;
9060 while (isWORDCHAR_lazy_if(s,UTF))
9061 s += UTF ? UTF8SKIP(s) : 1;
9062 while (s < PL_bufend && isSPACE(*s))
9066 if (keyword(w, s - w, 0))
9069 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9070 if (gv && GvCVu(gv))
9072 Perl_croak(aTHX_ "No comma allowed after %s", what);
9077 /* S_new_constant(): do any overload::constant lookup.
9079 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9080 Best used as sv=new_constant(..., sv, ...).
9081 If s, pv are NULL, calls subroutine with one argument,
9082 and <type> is used with error messages only.
9083 <type> is assumed to be well formed UTF-8 */
9086 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9087 SV *sv, SV *pv, const char *type, STRLEN typelen)
9090 HV * table = GvHV(PL_hintgv); /* ^H */
9095 const char *why1 = "", *why2 = "", *why3 = "";
9097 PERL_ARGS_ASSERT_NEW_CONSTANT;
9098 /* We assume that this is true: */
9099 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9102 /* charnames doesn't work well if there have been errors found */
9103 if (PL_error_count > 0 && *key == 'c')
9105 SvREFCNT_dec_NN(sv);
9106 return &PL_sv_undef;
9109 sv_2mortal(sv); /* Parent created it permanently */
9111 || ! (PL_hints & HINT_LOCALIZE_HH)
9112 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9117 /* Here haven't found what we're looking for. If it is charnames,
9118 * perhaps it needs to be loaded. Try doing that before giving up */
9120 Perl_load_module(aTHX_
9122 newSVpvs("_charnames"),
9123 /* version parameter; no need to specify it, as if
9124 * we get too early a version, will fail anyway,
9125 * not being able to find '_charnames' */
9131 table = GvHV(PL_hintgv);
9133 && (PL_hints & HINT_LOCALIZE_HH)
9134 && (cvp = hv_fetch(table, key, keylen, FALSE))
9140 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9141 msg = Perl_form(aTHX_
9142 "Constant(%.*s) unknown",
9143 (int)(type ? typelen : len),
9149 why3 = "} is not defined";
9152 msg = Perl_form(aTHX_
9153 /* The +3 is for '\N{'; -4 for that, plus '}' */
9154 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9158 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9159 (int)(type ? typelen : len),
9160 (type ? type: s), why1, why2, why3);
9163 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9164 return SvREFCNT_inc_simple_NN(sv);
9169 pv = newSVpvn_flags(s, len, SVs_TEMP);
9171 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9173 typesv = &PL_sv_undef;
9175 PUSHSTACKi(PERLSI_OVERLOAD);
9187 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9191 /* Check the eval first */
9192 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9194 const char * errstr;
9195 sv_catpvs(errsv, "Propagated");
9196 errstr = SvPV_const(errsv, errlen);
9197 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9199 res = SvREFCNT_inc_simple_NN(sv);
9203 SvREFCNT_inc_simple_void_NN(res);
9212 why1 = "Call to &{$^H{";
9214 why3 = "}} did not return a defined value";
9216 (void)sv_2mortal(sv);
9223 PERL_STATIC_INLINE void
9224 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
9226 PERL_ARGS_ASSERT_PARSE_IDENT;
9230 Perl_croak(aTHX_ "%s", ident_too_long);
9231 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
9232 /* The UTF-8 case must come first, otherwise things
9233 * like c\N{COMBINING TILDE} would start failing, as the
9234 * isWORDCHAR_A case below would gobble the 'c' up.
9237 char *t = *s + UTF8SKIP(*s);
9238 while (isIDCONT_utf8((U8*)t))
9240 if (*d + (t - *s) > e)
9241 Perl_croak(aTHX_ "%s", ident_too_long);
9242 Copy(*s, *d, t - *s, char);
9246 else if ( isWORDCHAR_A(**s) ) {
9249 } while isWORDCHAR_A(**s);
9251 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
9256 else if (allow_package && **s == ':' && (*s)[1] == ':'
9257 /* Disallow things like Foo::$bar. For the curious, this is
9258 * the code path that triggers the "Bad name after" warning
9259 * when looking for barewords.
9261 && (*s)[2] != '$') {
9271 /* Returns a NUL terminated string, with the length of the string written to
9275 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9279 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9280 bool is_utf8 = cBOOL(UTF);
9282 PERL_ARGS_ASSERT_SCAN_WORD;
9284 parse_ident(&s, &d, e, allow_package, is_utf8);
9291 S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9294 char *bracket = NULL;
9297 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9298 bool is_utf8 = cBOOL(UTF);
9300 PERL_ARGS_ASSERT_SCAN_IDENT;
9305 while (isDIGIT(*s)) {
9307 Perl_croak(aTHX_ "%s", ident_too_long);
9312 parse_ident(&s, &d, e, 1, is_utf8);
9317 /* Either a digit variable, or parse_ident() found an identifier
9318 (anything valid as a bareword), so job done and return. */
9319 if (PL_lex_state != LEX_NORMAL)
9320 PL_lex_state = LEX_INTERPENDMAYBE;
9323 if (*s == '$' && s[1] &&
9324 (isIDFIRST_lazy_if(s+1,is_utf8)
9325 || isDIGIT_A((U8)s[1])
9328 || strnEQ(s+1,"::",2)) )
9330 /* Dereferencing a value in a scalar variable.
9331 The alternatives are different syntaxes for a scalar variable.
9332 Using ' as a leading package separator isn't allowed. :: is. */
9335 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9339 while (s < send && SPACE_OR_TAB(*s))
9343 #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
9344 || isCNTRL_A((U8)(d)) \
9345 || isDIGIT_A((U8)(d)) \
9346 || (!(u) && !UTF8_IS_INVARIANT((U8)(d))))
9348 && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
9351 const STRLEN skip = UTF8SKIP(s);
9354 for ( i = 0; i < skip; i++ )
9362 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9363 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9367 /* Warn about ambiguous code after unary operators if {...} notation isn't
9368 used. There's no difference in ambiguity; it's merely a heuristic
9369 about when not to warn. */
9370 else if (ck_uni && !bracket)
9373 /* If we were processing {...} notation then... */
9374 if (isIDFIRST_lazy_if(d,is_utf8)) {
9375 /* if it starts as a valid identifier, assume that it is one.
9376 (the later check for } being at the expected point will trap
9377 cases where this doesn't pan out.) */
9378 d += is_utf8 ? UTF8SKIP(d) : 1;
9379 parse_ident(&s, &d, e, 1, is_utf8);
9381 while (s < send && SPACE_OR_TAB(*s))
9383 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9384 /* ${foo[0]} and ${foo{bar}} notation. */
9385 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9386 const char * const brack =
9388 ((*s == '[') ? "[...]" : "{...}");
9389 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9390 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9391 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9392 funny, dest, brack, funny, dest, brack);
9395 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9396 PL_lex_allbrackets++;
9400 /* Handle extended ${^Foo} variables
9401 * 1999-02-27 mjd-perl-patch@plover.com */
9402 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9406 while (isWORDCHAR(*s) && d < e) {
9410 Perl_croak(aTHX_ "%s", ident_too_long);
9414 while (s < send && SPACE_OR_TAB(*s))
9417 /* Expect to find a closing } after consuming any trailing whitespace.
9421 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9422 PL_lex_state = LEX_INTERPEND;
9425 if (PL_lex_state == LEX_NORMAL) {
9426 if (ckWARN(WARN_AMBIGUOUS) &&
9427 (keyword(dest, d - dest, 0)
9428 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
9430 SV *tmp = newSVpvn_flags( dest, d - dest,
9431 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9434 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9435 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9436 funny, tmp, funny, tmp);
9441 /* Didn't find the closing } at the point we expected, so restore
9442 state such that the next thing to process is the opening { and */
9443 s = bracket; /* let the parser handle it */
9447 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9448 PL_lex_state = LEX_INTERPEND;
9453 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
9455 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
9456 * the parse starting at 's', based on the subset that are valid in this
9457 * context input to this routine in 'valid_flags'. Advances s. Returns
9458 * TRUE if the input should be treated as a valid flag, so the next char
9459 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
9460 * first call on the current regex. This routine will set it to any
9461 * charset modifier found. The caller shouldn't change it. This way,
9462 * another charset modifier encountered in the parse can be detected as an
9463 * error, as we have decided to allow only one */
9466 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9468 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9469 if (isWORDCHAR_lazy_if(*s, UTF)) {
9470 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9471 UTF ? SVf_UTF8 : 0);
9473 /* Pretend that it worked, so will continue processing before
9482 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
9483 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9484 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9485 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9486 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9487 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9488 case LOCALE_PAT_MOD:
9490 goto multiple_charsets;
9492 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9495 case UNICODE_PAT_MOD:
9497 goto multiple_charsets;
9499 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9502 case ASCII_RESTRICT_PAT_MOD:
9504 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9508 /* Error if previous modifier wasn't an 'a', but if it was, see
9509 * if, and accept, a second occurrence (only) */
9511 || get_regex_charset(*pmfl)
9512 != REGEX_ASCII_RESTRICTED_CHARSET)
9514 goto multiple_charsets;
9516 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9520 case DEPENDS_PAT_MOD:
9522 goto multiple_charsets;
9524 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9533 if (*charset != c) {
9534 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9536 else if (c == 'a') {
9537 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9540 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9543 /* Pretend that it worked, so will continue processing before dieing */
9549 S_scan_pat(pTHX_ char *start, I32 type)
9554 const char * const valid_flags =
9555 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9556 char charset = '\0'; /* character set modifier */
9561 PERL_ARGS_ASSERT_SCAN_PAT;
9563 s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
9564 TRUE /* look for escaped bracketed metas */ );
9567 const char * const delimiter = skipspace(start);
9571 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9572 : "Search pattern not terminated" ));
9575 pm = (PMOP*)newPMOP(type, 0);
9576 if (PL_multi_open == '?') {
9577 /* This is the only point in the code that sets PMf_ONCE: */
9578 pm->op_pmflags |= PMf_ONCE;
9580 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9581 allows us to restrict the list needed by reset to just the ??
9583 assert(type != OP_TRANS);
9585 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9588 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9591 elements = mg->mg_len / sizeof(PMOP**);
9592 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9593 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9594 mg->mg_len = elements * sizeof(PMOP**);
9595 PmopSTASH_set(pm,PL_curstash);
9602 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9603 * anon CV. False positives like qr/[(?{]/ are harmless */
9605 if (type == OP_QR) {
9607 char *e, *p = SvPV(PL_lex_stuff, len);
9609 for (; p < e; p++) {
9610 if (p[0] == '(' && p[1] == '?'
9611 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9613 pm->op_pmflags |= PMf_HAS_CV;
9617 pm->op_pmflags |= PMf_IS_QR;
9620 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9622 if (PL_madskills && modstart != s) {
9623 SV* tmptoken = newSVpvn(modstart, s - modstart);
9624 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9627 /* issue a warning if /c is specified,but /g is not */
9628 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9630 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9631 "Use of /c modifier is meaningless without /g" );
9634 PL_lex_op = (OP*)pm;
9635 pl_yylval.ival = OP_MATCH;
9640 S_scan_subst(pTHX_ char *start)
9647 char charset = '\0'; /* character set modifier */
9652 PERL_ARGS_ASSERT_SCAN_SUBST;
9654 pl_yylval.ival = OP_NULL;
9656 s = scan_str(start,!!PL_madskills,FALSE,FALSE,
9657 TRUE /* look for escaped bracketed metas */ );
9660 Perl_croak(aTHX_ "Substitution pattern not terminated");
9662 if (s[-1] == PL_multi_open)
9666 CURMAD('q', PL_thisopen);
9667 CURMAD('_', PL_thiswhite);
9668 CURMAD('E', PL_thisstuff);
9669 CURMAD('Q', PL_thisclose);
9670 PL_realtokenstart = s - SvPVX(PL_linestr);
9674 first_start = PL_multi_start;
9675 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9678 SvREFCNT_dec(PL_lex_stuff);
9679 PL_lex_stuff = NULL;
9681 Perl_croak(aTHX_ "Substitution replacement not terminated");
9683 PL_multi_start = first_start; /* so whole substitution is taken together */
9685 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9689 CURMAD('z', PL_thisopen);
9690 CURMAD('R', PL_thisstuff);
9691 CURMAD('Z', PL_thisclose);
9697 if (*s == EXEC_PAT_MOD) {
9701 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9710 curmad('m', newSVpvn(modstart, s - modstart));
9711 append_madprops(PL_thismad, (OP*)pm, 0);
9715 if ((pm->op_pmflags & PMf_CONTINUE)) {
9716 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9720 SV * const repl = newSVpvs("");
9723 pm->op_pmflags |= PMf_EVAL;
9726 sv_catpvs(repl, "eval ");
9728 sv_catpvs(repl, "do ");
9730 sv_catpvs(repl, "{");
9731 sv_catsv(repl, PL_sublex_info.repl);
9732 sv_catpvs(repl, "}");
9734 SvREFCNT_dec(PL_sublex_info.repl);
9735 PL_sublex_info.repl = repl;
9738 PL_lex_op = (OP*)pm;
9739 pl_yylval.ival = OP_SUBST;
9744 S_scan_trans(pTHX_ char *start)
9752 bool nondestruct = 0;
9757 PERL_ARGS_ASSERT_SCAN_TRANS;
9759 pl_yylval.ival = OP_NULL;
9761 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
9763 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9765 if (s[-1] == PL_multi_open)
9769 CURMAD('q', PL_thisopen);
9770 CURMAD('_', PL_thiswhite);
9771 CURMAD('E', PL_thisstuff);
9772 CURMAD('Q', PL_thisclose);
9773 PL_realtokenstart = s - SvPVX(PL_linestr);
9777 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9780 SvREFCNT_dec(PL_lex_stuff);
9781 PL_lex_stuff = NULL;
9783 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9786 CURMAD('z', PL_thisopen);
9787 CURMAD('R', PL_thisstuff);
9788 CURMAD('Z', PL_thisclose);
9791 complement = del = squash = 0;
9798 complement = OPpTRANS_COMPLEMENT;
9801 del = OPpTRANS_DELETE;
9804 squash = OPpTRANS_SQUASH;
9816 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9817 o->op_private &= ~OPpTRANS_ALL;
9818 o->op_private |= del|squash|complement|
9819 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9820 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9823 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9828 curmad('m', newSVpvn(modstart, s - modstart));
9829 append_madprops(PL_thismad, o, 0);
9838 Takes a pointer to the first < in <<FOO.
9839 Returns a pointer to the byte following <<FOO.
9841 This function scans a heredoc, which involves different methods
9842 depending on whether we are in a string eval, quoted construct, etc.
9843 This is because PL_linestr could containing a single line of input, or
9844 a whole string being evalled, or the contents of the current quote-
9847 The two basic methods are:
9848 - Steal lines from the input stream
9849 - Scan the heredoc in PL_linestr and remove it therefrom
9851 In a file scope or filtered eval, the first method is used; in a
9852 string eval, the second.
9854 In a quote-like operator, we have to choose between the two,
9855 depending on where we can find a newline. We peek into outer lex-
9856 ing scopes until we find one with a newline in it. If we reach the
9857 outermost lexing scope and it is a file, we use the stream method.
9858 Otherwise it is treated as an eval.
9862 S_scan_heredoc(pTHX_ char *s)
9865 I32 op_type = OP_SCALAR;
9872 const bool infile = PL_rsfp || PL_parser->filtered;
9873 LEXSHARED *shared = PL_parser->lex_shared;
9875 I32 stuffstart = s - SvPVX(PL_linestr);
9878 PL_realtokenstart = -1;
9881 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9884 d = PL_tokenbuf + 1;
9885 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9886 *PL_tokenbuf = '\n';
9888 while (SPACE_OR_TAB(*peek))
9890 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9893 s = delimcpy(d, e, s, PL_bufend, term, &len);
9895 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9901 /* <<\FOO is equivalent to <<'FOO' */
9905 if (!isWORDCHAR_lazy_if(s,UTF))
9906 deprecate("bare << to mean <<\"\"");
9907 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9912 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9913 Perl_croak(aTHX_ "Delimiter for here document is too long");
9916 len = d - PL_tokenbuf;
9920 tstart = PL_tokenbuf + 1;
9921 PL_thisclose = newSVpvn(tstart, len - 1);
9922 tstart = SvPVX(PL_linestr) + stuffstart;
9923 PL_thisopen = newSVpvn(tstart, s - tstart);
9924 stuffstart = s - SvPVX(PL_linestr);
9927 #ifndef PERL_STRICT_CR
9928 d = strchr(s, '\r');
9930 char * const olds = s;
9932 while (s < PL_bufend) {
9938 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9947 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9953 tstart = SvPVX(PL_linestr) + stuffstart;
9955 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9957 PL_thisstuff = newSVpvn(tstart, s - tstart);
9960 stuffstart = s - SvPVX(PL_linestr);
9963 tmpstr = newSV_type(SVt_PVIV);
9967 SvIV_set(tmpstr, -1);
9969 else if (term == '`') {
9970 op_type = OP_BACKTICK;
9971 SvIV_set(tmpstr, '\\');
9974 PL_multi_start = CopLINE(PL_curcop) + 1;
9975 PL_multi_open = PL_multi_close = '<';
9976 /* inside a string eval or quote-like operator */
9977 if (!infile || PL_lex_inwhat) {
9980 char * const olds = s;
9981 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9982 /* These two fields are not set until an inner lexing scope is
9983 entered. But we need them set here. */
9984 shared->ls_bufptr = s;
9985 shared->ls_linestr = PL_linestr;
9987 /* Look for a newline. If the current buffer does not have one,
9988 peek into the line buffer of the parent lexing scope, going
9989 up as many levels as necessary to find one with a newline
9992 while (!(s = (char *)memchr(
9993 (void *)shared->ls_bufptr, '\n',
9994 SvEND(shared->ls_linestr)-shared->ls_bufptr
9996 shared = shared->ls_prev;
9997 /* shared is only null if we have gone beyond the outermost
9998 lexing scope. In a file, we will have broken out of the
9999 loop in the previous iteration. In an eval, the string buf-
10000 fer ends with "\n;", so the while condition below will have
10001 evaluated to false. So shared can never be null. */
10003 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10004 most lexing scope. In a file, shared->ls_linestr at that
10005 level is just one line, so there is no body to steal. */
10006 if (infile && !shared->ls_prev) {
10012 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10015 linestr = shared->ls_linestr;
10016 bufend = SvEND(linestr);
10018 while (s < bufend - len + 1 &&
10019 memNE(s,PL_tokenbuf,len) ) {
10021 ++shared->herelines;
10023 if (s >= bufend - len + 1) {
10026 sv_setpvn(tmpstr,d+1,s-d);
10028 if (PL_madskills) {
10030 sv_catpvn(PL_thisstuff, d + 1, s - d);
10032 PL_thisstuff = newSVpvn(d + 1, s - d);
10033 stuffstart = s - SvPVX(PL_linestr);
10037 /* the preceding stmt passes a newline */
10038 shared->herelines++;
10040 /* s now points to the newline after the heredoc terminator.
10041 d points to the newline before the body of the heredoc.
10044 /* We are going to modify linestr in place here, so set
10045 aside copies of the string if necessary for re-evals or
10047 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10048 check shared->re_eval_str. */
10049 if (shared->re_eval_start || shared->re_eval_str) {
10050 /* Set aside the rest of the regexp */
10051 if (!shared->re_eval_str)
10052 shared->re_eval_str =
10053 newSVpvn(shared->re_eval_start,
10054 bufend - shared->re_eval_start);
10055 shared->re_eval_start -= s-d;
10057 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
10058 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
10059 cx->blk_eval.cur_text == linestr)
10061 cx->blk_eval.cur_text = newSVsv(linestr);
10062 SvSCREAM_on(cx->blk_eval.cur_text);
10064 /* Copy everything from s onwards back to d. */
10065 Move(s,d,bufend-s + 1,char);
10066 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10067 /* Setting PL_bufend only applies when we have not dug deeper
10068 into other scopes, because sublex_done sets PL_bufend to
10069 SvEND(PL_linestr). */
10070 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10077 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
10078 term = PL_tokenbuf[1];
10080 linestr_save = PL_linestr; /* must restore this afterwards */
10081 d = s; /* and this */
10082 PL_linestr = newSVpvs("");
10083 PL_bufend = SvPVX(PL_linestr);
10086 if (PL_madskills) {
10087 tstart = SvPVX(PL_linestr) + stuffstart;
10089 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10091 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10094 PL_bufptr = PL_bufend;
10095 CopLINE_set(PL_curcop,
10096 PL_multi_start + shared->herelines);
10097 if (!lex_next_chunk(LEX_NO_TERM)
10098 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10099 SvREFCNT_dec(linestr_save);
10102 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10103 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10104 lex_grow_linestr(SvCUR(PL_linestr) + 2);
10105 sv_catpvs(PL_linestr, "\n\0");
10109 stuffstart = s - SvPVX(PL_linestr);
10111 shared->herelines++;
10112 PL_last_lop = PL_last_uni = NULL;
10113 #ifndef PERL_STRICT_CR
10114 if (PL_bufend - PL_linestart >= 2) {
10115 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
10116 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10118 PL_bufend[-2] = '\n';
10120 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10122 else if (PL_bufend[-1] == '\r')
10123 PL_bufend[-1] = '\n';
10125 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10126 PL_bufend[-1] = '\n';
10128 if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
10129 SvREFCNT_dec(PL_linestr);
10130 PL_linestr = linestr_save;
10131 PL_linestart = SvPVX(linestr_save);
10132 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10137 sv_catsv(tmpstr,PL_linestr);
10141 PL_multi_end = CopLINE(PL_curcop);
10142 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10143 SvPV_shrink_to_cur(tmpstr);
10146 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10148 else if (PL_encoding)
10149 sv_recode_to_utf8(tmpstr, PL_encoding);
10151 PL_lex_stuff = tmpstr;
10152 pl_yylval.ival = op_type;
10156 SvREFCNT_dec(tmpstr);
10157 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10158 missingterm(PL_tokenbuf + 1);
10161 /* scan_inputsymbol
10162 takes: current position in input buffer
10163 returns: new position in input buffer
10164 side-effects: pl_yylval and lex_op are set.
10169 <FH> read from filehandle
10170 <pkg::FH> read from package qualified filehandle
10171 <pkg'FH> read from package qualified filehandle
10172 <$fh> read from filehandle in $fh
10173 <*.h> filename glob
10178 S_scan_inputsymbol(pTHX_ char *start)
10181 char *s = start; /* current position in buffer */
10184 char *d = PL_tokenbuf; /* start of temp holding space */
10185 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10187 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10189 end = strchr(s, '\n');
10192 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10194 /* die if we didn't have space for the contents of the <>,
10195 or if it didn't end, or if we see a newline
10198 if (len >= (I32)sizeof PL_tokenbuf)
10199 Perl_croak(aTHX_ "Excessively long <> operator");
10201 Perl_croak(aTHX_ "Unterminated <> operator");
10206 Remember, only scalar variables are interpreted as filehandles by
10207 this code. Anything more complex (e.g., <$fh{$num}>) will be
10208 treated as a glob() call.
10209 This code makes use of the fact that except for the $ at the front,
10210 a scalar variable and a filehandle look the same.
10212 if (*d == '$' && d[1]) d++;
10214 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10215 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
10216 d += UTF ? UTF8SKIP(d) : 1;
10218 /* If we've tried to read what we allow filehandles to look like, and
10219 there's still text left, then it must be a glob() and not a getline.
10220 Use scan_str to pull out the stuff between the <> and treat it
10221 as nothing more than a string.
10224 if (d - PL_tokenbuf != len) {
10225 pl_yylval.ival = OP_GLOB;
10226 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
10228 Perl_croak(aTHX_ "Glob not terminated");
10232 bool readline_overriden = FALSE;
10235 /* we're in a filehandle read situation */
10238 /* turn <> into <ARGV> */
10240 Copy("ARGV",d,5,char);
10242 /* Check whether readline() is overriden */
10243 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
10245 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
10247 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
10248 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
10249 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
10250 readline_overriden = TRUE;
10252 /* if <$fh>, create the ops to turn the variable into a
10256 /* try to find it in the pad for this block, otherwise find
10257 add symbol table ops
10259 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
10260 if (tmp != NOT_IN_PAD) {
10261 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10262 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10263 HEK * const stashname = HvNAME_HEK(stash);
10264 SV * const sym = sv_2mortal(newSVhek(stashname));
10265 sv_catpvs(sym, "::");
10266 sv_catpv(sym, d+1);
10271 OP * const o = newOP(OP_PADSV, 0);
10273 PL_lex_op = readline_overriden
10274 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10275 op_append_elem(OP_LIST, o,
10276 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10277 : (OP*)newUNOP(OP_READLINE, 0, o);
10286 ? (GV_ADDMULTI | GV_ADDINEVAL)
10287 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
10289 PL_lex_op = readline_overriden
10290 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10291 op_append_elem(OP_LIST,
10292 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10293 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10294 : (OP*)newUNOP(OP_READLINE, 0,
10295 newUNOP(OP_RV2SV, 0,
10296 newGVOP(OP_GV, 0, gv)));
10298 if (!readline_overriden)
10299 PL_lex_op->op_flags |= OPf_SPECIAL;
10300 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10301 pl_yylval.ival = OP_NULL;
10304 /* If it's none of the above, it must be a literal filehandle
10305 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10307 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10308 PL_lex_op = readline_overriden
10309 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10310 op_append_elem(OP_LIST,
10311 newGVOP(OP_GV, 0, gv),
10312 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10313 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10314 pl_yylval.ival = OP_NULL;
10323 takes: start position in buffer
10324 keep_quoted preserve \ on the embedded delimiter(s)
10325 keep_delims preserve the delimiters around the string
10326 re_reparse compiling a run-time /(?{})/:
10327 collapse // to /, and skip encoding src
10328 returns: position to continue reading from buffer
10329 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10330 updates the read buffer.
10332 This subroutine pulls a string out of the input. It is called for:
10333 q single quotes q(literal text)
10334 ' single quotes 'literal text'
10335 qq double quotes qq(interpolate $here please)
10336 " double quotes "interpolate $here please"
10337 qx backticks qx(/bin/ls -l)
10338 ` backticks `/bin/ls -l`
10339 qw quote words @EXPORT_OK = qw( func() $spam )
10340 m// regexp match m/this/
10341 s/// regexp substitute s/this/that/
10342 tr/// string transliterate tr/this/that/
10343 y/// string transliterate y/this/that/
10344 ($*@) sub prototypes sub foo ($)
10345 (stuff) sub attr parameters sub foo : attr(stuff)
10346 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10348 In most of these cases (all but <>, patterns and transliterate)
10349 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10350 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10351 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10354 It skips whitespace before the string starts, and treats the first
10355 character as the delimiter. If the delimiter is one of ([{< then
10356 the corresponding "close" character )]}> is used as the closing
10357 delimiter. It allows quoting of delimiters, and if the string has
10358 balanced delimiters ([{<>}]) it allows nesting.
10360 On success, the SV with the resulting string is put into lex_stuff or,
10361 if that is already non-NULL, into lex_repl. The second case occurs only
10362 when parsing the RHS of the special constructs s/// and tr/// (y///).
10363 For convenience, the terminating delimiter character is stuffed into
10368 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
10369 bool deprecate_escaped_meta /* Should we issue a deprecation warning
10370 for certain paired metacharacters that
10371 appear escaped within it */
10375 SV *sv; /* scalar value: string */
10376 const char *tmps; /* temp string, used for delimiter matching */
10377 char *s = start; /* current position in the buffer */
10378 char term; /* terminating character */
10379 char *to; /* current position in the sv's data */
10380 I32 brackets = 1; /* bracket nesting level */
10381 bool has_utf8 = FALSE; /* is there any utf8 content? */
10382 I32 termcode; /* terminating char. code */
10383 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10384 STRLEN termlen; /* length of terminating string */
10385 int last_off = 0; /* last position for nesting bracket */
10386 char *escaped_open = NULL;
10392 PERL_ARGS_ASSERT_SCAN_STR;
10394 /* skip space before the delimiter */
10400 if (PL_realtokenstart >= 0) {
10401 stuffstart = PL_realtokenstart;
10402 PL_realtokenstart = -1;
10405 stuffstart = start - SvPVX(PL_linestr);
10407 /* mark where we are, in case we need to report errors */
10410 /* after skipping whitespace, the next character is the terminator */
10413 termcode = termstr[0] = term;
10417 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10418 Copy(s, termstr, termlen, U8);
10419 if (!UTF8_IS_INVARIANT(term))
10423 /* mark where we are */
10424 PL_multi_start = CopLINE(PL_curcop);
10425 PL_multi_open = term;
10427 /* find corresponding closing delimiter */
10428 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10429 termcode = termstr[0] = term = tmps[5];
10431 PL_multi_close = term;
10433 /* A warning is raised if the input parameter requires it for escaped (by a
10434 * backslash) paired metacharacters {} [] and () when the delimiters are
10435 * those same characters, and the backslash is ineffective. This doesn't
10436 * happen for <>, as they aren't metas. */
10437 if (deprecate_escaped_meta
10438 && (PL_multi_open == PL_multi_close
10439 || ! ckWARN_d(WARN_DEPRECATED)
10440 || PL_multi_open == '<'))
10442 deprecate_escaped_meta = FALSE;
10445 /* create a new SV to hold the contents. 79 is the SV's initial length.
10446 What a random number. */
10447 sv = newSV_type(SVt_PVIV);
10449 SvIV_set(sv, termcode);
10450 (void)SvPOK_only(sv); /* validate pointer */
10452 /* move past delimiter and try to read a complete string */
10454 sv_catpvn(sv, s, termlen);
10457 tstart = SvPVX(PL_linestr) + stuffstart;
10458 if (PL_madskills && !PL_thisopen && !keep_delims) {
10459 PL_thisopen = newSVpvn(tstart, s - tstart);
10460 stuffstart = s - SvPVX(PL_linestr);
10464 if (PL_encoding && !UTF && !re_reparse) {
10468 int offset = s - SvPVX_const(PL_linestr);
10469 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10470 &offset, (char*)termstr, termlen);
10471 const char * const ns = SvPVX_const(PL_linestr) + offset;
10472 char * const svlast = SvEND(sv) - 1;
10474 for (; s < ns; s++) {
10475 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10476 COPLINE_INC_WITH_HERELINES;
10479 goto read_more_line;
10481 /* handle quoted delimiters */
10482 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10484 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10486 if ((svlast-1 - t) % 2) {
10487 if (!keep_quoted) {
10488 *(svlast-1) = term;
10490 SvCUR_set(sv, SvCUR(sv) - 1);
10495 if (PL_multi_open == PL_multi_close) {
10501 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10502 /* At here, all closes are "was quoted" one,
10503 so we don't check PL_multi_close. */
10505 if (!keep_quoted && *(t+1) == PL_multi_open)
10510 else if (*t == PL_multi_open)
10518 SvCUR_set(sv, w - SvPVX_const(sv));
10520 last_off = w - SvPVX(sv);
10521 if (--brackets <= 0)
10526 if (!keep_delims) {
10527 SvCUR_set(sv, SvCUR(sv) - 1);
10533 /* extend sv if need be */
10534 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10535 /* set 'to' to the next character in the sv's string */
10536 to = SvPVX(sv)+SvCUR(sv);
10538 /* if open delimiter is the close delimiter read unbridle */
10539 if (PL_multi_open == PL_multi_close) {
10540 for (; s < PL_bufend; s++,to++) {
10541 /* embedded newlines increment the current line number */
10542 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10543 COPLINE_INC_WITH_HERELINES;
10544 /* handle quoted delimiters */
10545 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10548 || (re_reparse && s[1] == '\\'))
10551 /* any other quotes are simply copied straight through */
10555 /* terminate when run out of buffer (the for() condition), or
10556 have found the terminator */
10557 else if (*s == term) {
10560 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10563 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10569 /* if the terminator isn't the same as the start character (e.g.,
10570 matched brackets), we have to allow more in the quoting, and
10571 be prepared for nested brackets.
10574 /* read until we run out of string, or we find the terminator */
10575 for (; s < PL_bufend; s++,to++) {
10576 /* embedded newlines increment the line count */
10577 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10578 COPLINE_INC_WITH_HERELINES;
10579 /* backslashes can escape the open or closing characters */
10580 if (*s == '\\' && s+1 < PL_bufend) {
10581 if (!keep_quoted &&
10582 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10586 /* Here, 'deprecate_escaped_meta' is true iff the
10587 * delimiters are paired metacharacters, and 's' points
10588 * to an occurrence of one of them within the string,
10589 * which was preceded by a backslash. If this is a
10590 * context where the delimiter is also a metacharacter,
10591 * the backslash is useless, and deprecated. () and []
10592 * are meta in any context. {} are meta only when
10593 * appearing in a quantifier or in things like '\p{'.
10594 * They also aren't meta unless there is a matching
10595 * closed, escaped char later on within the string.
10596 * If 's' points to an open, set a flag; if to a close,
10597 * test that flag, and raise a warning if it was set */
10599 if (deprecate_escaped_meta) {
10600 if (*s == PL_multi_open) {
10604 else if (regcurly(s,
10605 TRUE /* Look for a closing
10607 || (s - start > 2 /* Look for e.g.
10609 && _generic_isCC(*(s-2), _CC_BACKSLASH_FOO_LBRACE_IS_META)))
10614 else if (escaped_open) {
10615 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10616 "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open);
10617 escaped_open = NULL;
10624 /* allow nested opens and closes */
10625 else if (*s == PL_multi_close && --brackets <= 0)
10627 else if (*s == PL_multi_open)
10629 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10634 /* terminate the copied string and update the sv's end-of-string */
10636 SvCUR_set(sv, to - SvPVX_const(sv));
10639 * this next chunk reads more into the buffer if we're not done yet
10643 break; /* handle case where we are done yet :-) */
10645 #ifndef PERL_STRICT_CR
10646 if (to - SvPVX_const(sv) >= 2) {
10647 if ((to[-2] == '\r' && to[-1] == '\n') ||
10648 (to[-2] == '\n' && to[-1] == '\r'))
10652 SvCUR_set(sv, to - SvPVX_const(sv));
10654 else if (to[-1] == '\r')
10657 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10662 /* if we're out of file, or a read fails, bail and reset the current
10663 line marker so we can report where the unterminated string began
10666 if (PL_madskills) {
10667 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10669 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10671 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10674 COPLINE_INC_WITH_HERELINES;
10675 PL_bufptr = PL_bufend;
10676 if (!lex_next_chunk(0)) {
10678 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10687 /* at this point, we have successfully read the delimited string */
10689 if (!PL_encoding || UTF || re_reparse) {
10691 if (PL_madskills) {
10692 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10693 const int len = s - tstart;
10695 sv_catpvn(PL_thisstuff, tstart, len);
10697 PL_thisstuff = newSVpvn(tstart, len);
10698 if (!PL_thisclose && !keep_delims)
10699 PL_thisclose = newSVpvn(s,termlen);
10704 sv_catpvn(sv, s, termlen);
10709 if (PL_madskills) {
10710 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10711 const int len = s - tstart - termlen;
10713 sv_catpvn(PL_thisstuff, tstart, len);
10715 PL_thisstuff = newSVpvn(tstart, len);
10716 if (!PL_thisclose && !keep_delims)
10717 PL_thisclose = newSVpvn(s - termlen,termlen);
10721 if (has_utf8 || (PL_encoding && !re_reparse))
10724 PL_multi_end = CopLINE(PL_curcop);
10726 /* if we allocated too much space, give some back */
10727 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10728 SvLEN_set(sv, SvCUR(sv) + 1);
10729 SvPV_renew(sv, SvLEN(sv));
10732 /* decide whether this is the first or second quoted string we've read
10737 PL_sublex_info.repl = sv;
10745 takes: pointer to position in buffer
10746 returns: pointer to new position in buffer
10747 side-effects: builds ops for the constant in pl_yylval.op
10749 Read a number in any of the formats that Perl accepts:
10751 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10752 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10755 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10757 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10760 If it reads a number without a decimal point or an exponent, it will
10761 try converting the number to an integer and see if it can do so
10762 without loss of precision.
10766 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10769 const char *s = start; /* current position in buffer */
10770 char *d; /* destination in temp buffer */
10771 char *e; /* end of temp buffer */
10772 NV nv; /* number read, as a double */
10773 SV *sv = NULL; /* place to put the converted number */
10774 bool floatit; /* boolean: int or float? */
10775 const char *lastub = NULL; /* position of last underbar */
10776 static const char* const number_too_long = "Number too long";
10778 PERL_ARGS_ASSERT_SCAN_NUM;
10780 /* We use the first character to decide what type of number this is */
10784 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10786 /* if it starts with a 0, it could be an octal number, a decimal in
10787 0.13 disguise, or a hexadecimal number, or a binary number. */
10791 u holds the "number so far"
10792 shift the power of 2 of the base
10793 (hex == 4, octal == 3, binary == 1)
10794 overflowed was the number more than we can hold?
10796 Shift is used when we add a digit. It also serves as an "are
10797 we in octal/hex/binary?" indicator to disallow hex characters
10798 when in octal mode.
10803 bool overflowed = FALSE;
10804 bool just_zero = TRUE; /* just plain 0 or binary number? */
10805 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10806 static const char* const bases[5] =
10807 { "", "binary", "", "octal", "hexadecimal" };
10808 static const char* const Bases[5] =
10809 { "", "Binary", "", "Octal", "Hexadecimal" };
10810 static const char* const maxima[5] =
10812 "0b11111111111111111111111111111111",
10816 const char *base, *Base, *max;
10818 /* check for hex */
10819 if (s[1] == 'x' || s[1] == 'X') {
10823 } else if (s[1] == 'b' || s[1] == 'B') {
10828 /* check for a decimal in disguise */
10829 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10831 /* so it must be octal */
10838 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10839 "Misplaced _ in number");
10843 base = bases[shift];
10844 Base = Bases[shift];
10845 max = maxima[shift];
10847 /* read the rest of the number */
10849 /* x is used in the overflow test,
10850 b is the digit we're adding on. */
10855 /* if we don't mention it, we're done */
10859 /* _ are ignored -- but warned about if consecutive */
10861 if (lastub && s == lastub + 1)
10862 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10863 "Misplaced _ in number");
10867 /* 8 and 9 are not octal */
10868 case '8': case '9':
10870 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10874 case '2': case '3': case '4':
10875 case '5': case '6': case '7':
10877 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10880 case '0': case '1':
10881 b = *s++ & 15; /* ASCII digit -> value of digit */
10885 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10886 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10887 /* make sure they said 0x */
10890 b = (*s++ & 7) + 9;
10892 /* Prepare to put the digit we have onto the end
10893 of the number so far. We check for overflows.
10899 x = u << shift; /* make room for the digit */
10901 if ((x >> shift) != u
10902 && !(PL_hints & HINT_NEW_BINARY)) {
10905 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10906 "Integer overflow in %s number",
10909 u = x | b; /* add the digit to the end */
10912 n *= nvshift[shift];
10913 /* If an NV has not enough bits in its
10914 * mantissa to represent an UV this summing of
10915 * small low-order numbers is a waste of time
10916 * (because the NV cannot preserve the
10917 * low-order bits anyway): we could just
10918 * remember when did we overflow and in the
10919 * end just multiply n by the right
10927 /* if we get here, we had success: make a scalar value from
10932 /* final misplaced underbar check */
10933 if (s[-1] == '_') {
10934 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10938 if (n > 4294967295.0)
10939 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10940 "%s number > %s non-portable",
10946 if (u > 0xffffffff)
10947 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10948 "%s number > %s non-portable",
10953 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10954 sv = new_constant(start, s - start, "integer",
10955 sv, NULL, NULL, 0);
10956 else if (PL_hints & HINT_NEW_BINARY)
10957 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10962 handle decimal numbers.
10963 we're also sent here when we read a 0 as the first digit
10965 case '1': case '2': case '3': case '4': case '5':
10966 case '6': case '7': case '8': case '9': case '.':
10969 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10972 /* read next group of digits and _ and copy into d */
10973 while (isDIGIT(*s) || *s == '_') {
10974 /* skip underscores, checking for misplaced ones
10978 if (lastub && s == lastub + 1)
10979 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10980 "Misplaced _ in number");
10984 /* check for end of fixed-length buffer */
10986 Perl_croak(aTHX_ "%s", number_too_long);
10987 /* if we're ok, copy the character */
10992 /* final misplaced underbar check */
10993 if (lastub && s == lastub + 1) {
10994 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10997 /* read a decimal portion if there is one. avoid
10998 3..5 being interpreted as the number 3. followed
11001 if (*s == '.' && s[1] != '.') {
11006 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11007 "Misplaced _ in number");
11011 /* copy, ignoring underbars, until we run out of digits.
11013 for (; isDIGIT(*s) || *s == '_'; s++) {
11014 /* fixed length buffer check */
11016 Perl_croak(aTHX_ "%s", number_too_long);
11018 if (lastub && s == lastub + 1)
11019 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11020 "Misplaced _ in number");
11026 /* fractional part ending in underbar? */
11027 if (s[-1] == '_') {
11028 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11029 "Misplaced _ in number");
11031 if (*s == '.' && isDIGIT(s[1])) {
11032 /* oops, it's really a v-string, but without the "v" */
11038 /* read exponent part, if present */
11039 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
11043 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
11044 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
11046 /* stray preinitial _ */
11048 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11049 "Misplaced _ in number");
11053 /* allow positive or negative exponent */
11054 if (*s == '+' || *s == '-')
11057 /* stray initial _ */
11059 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11060 "Misplaced _ in number");
11064 /* read digits of exponent */
11065 while (isDIGIT(*s) || *s == '_') {
11068 Perl_croak(aTHX_ "%s", number_too_long);
11072 if (((lastub && s == lastub + 1) ||
11073 (!isDIGIT(s[1]) && s[1] != '_')))
11074 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11075 "Misplaced _ in number");
11083 We try to do an integer conversion first if no characters
11084 indicating "float" have been found.
11089 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11091 if (flags == IS_NUMBER_IN_UV) {
11093 sv = newSViv(uv); /* Prefer IVs over UVs. */
11096 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11097 if (uv <= (UV) IV_MIN)
11098 sv = newSViv(-(IV)uv);
11105 /* terminate the string */
11107 nv = Atof(PL_tokenbuf);
11112 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11113 const char *const key = floatit ? "float" : "integer";
11114 const STRLEN keylen = floatit ? 5 : 7;
11115 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11116 key, keylen, sv, NULL, NULL, 0);
11120 /* if it starts with a v, it could be a v-string */
11123 sv = newSV(5); /* preallocate storage space */
11124 ENTER_with_name("scan_vstring");
11126 s = scan_vstring(s, PL_bufend, sv);
11127 SvREFCNT_inc_simple_void_NN(sv);
11128 LEAVE_with_name("scan_vstring");
11132 /* make the op for the constant and return */
11135 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11137 lvalp->opval = NULL;
11143 S_scan_formline(pTHX_ char *s)
11148 SV * const stuff = newSVpvs("");
11149 bool needargs = FALSE;
11150 bool eofmt = FALSE;
11152 char *tokenstart = s;
11153 SV* savewhite = NULL;
11155 if (PL_madskills) {
11156 savewhite = PL_thiswhite;
11161 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11163 while (!needargs) {
11166 #ifdef PERL_STRICT_CR
11167 while (SPACE_OR_TAB(*t))
11170 while (SPACE_OR_TAB(*t) || *t == '\r')
11173 if (*t == '\n' || t == PL_bufend) {
11178 eol = (char *) memchr(s,'\n',PL_bufend-s);
11182 for (t = s; t < eol; t++) {
11183 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11185 goto enough; /* ~~ must be first line in formline */
11187 if (*t == '@' || *t == '^')
11191 sv_catpvn(stuff, s, eol-s);
11192 #ifndef PERL_STRICT_CR
11193 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11194 char *end = SvPVX(stuff) + SvCUR(stuff);
11197 SvCUR_set(stuff, SvCUR(stuff) - 1);
11205 if ((PL_rsfp || PL_parser->filtered)
11206 && PL_parser->form_lex_state == LEX_NORMAL) {
11209 if (PL_madskills) {
11211 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
11213 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
11216 PL_bufptr = PL_bufend;
11217 COPLINE_INC_WITH_HERELINES;
11218 got_some = lex_next_chunk(0);
11219 CopLINE_dec(PL_curcop);
11222 tokenstart = PL_bufptr;
11230 if (!SvCUR(stuff) || needargs)
11231 PL_lex_state = PL_parser->form_lex_state;
11232 if (SvCUR(stuff)) {
11233 PL_expect = XSTATE;
11235 start_force(PL_curforce);
11236 NEXTVAL_NEXTTOKE.ival = 0;
11237 force_next(FORMLBRACK);
11240 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11242 else if (PL_encoding)
11243 sv_recode_to_utf8(stuff, PL_encoding);
11245 start_force(PL_curforce);
11246 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
11250 SvREFCNT_dec(stuff);
11252 PL_lex_formbrack = 0;
11255 if (PL_madskills) {
11257 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
11259 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
11260 PL_thiswhite = savewhite;
11267 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11270 const I32 oldsavestack_ix = PL_savestack_ix;
11271 CV* const outsidecv = PL_compcv;
11273 SAVEI32(PL_subline);
11274 save_item(PL_subname);
11275 SAVESPTR(PL_compcv);
11277 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11278 CvFLAGS(PL_compcv) |= flags;
11280 PL_subline = CopLINE(PL_curcop);
11281 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11282 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11283 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11284 if (outsidecv && CvPADLIST(outsidecv))
11285 CvPADLIST(PL_compcv)->xpadl_outid =
11286 PadlistNAMES(CvPADLIST(outsidecv));
11288 return oldsavestack_ix;
11292 #pragma segment Perl_yylex
11295 S_yywarn(pTHX_ const char *const s, U32 flags)
11299 PERL_ARGS_ASSERT_YYWARN;
11301 PL_in_eval |= EVAL_WARNONLY;
11302 yyerror_pv(s, flags);
11303 PL_in_eval &= ~EVAL_WARNONLY;
11308 Perl_yyerror(pTHX_ const char *const s)
11310 PERL_ARGS_ASSERT_YYERROR;
11311 return yyerror_pvn(s, strlen(s), 0);
11315 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11317 PERL_ARGS_ASSERT_YYERROR_PV;
11318 return yyerror_pvn(s, strlen(s), flags);
11322 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11325 const char *context = NULL;
11328 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11329 int yychar = PL_parser->yychar;
11331 PERL_ARGS_ASSERT_YYERROR_PVN;
11333 if (!yychar || (yychar == ';' && !PL_rsfp))
11334 sv_catpvs(where_sv, "at EOF");
11335 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
11336 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
11337 PL_oldbufptr != PL_bufptr) {
11340 The code below is removed for NetWare because it abends/crashes on NetWare
11341 when the script has error such as not having the closing quotes like:
11342 if ($var eq "value)
11343 Checking of white spaces is anyway done in NetWare code.
11346 while (isSPACE(*PL_oldoldbufptr))
11349 context = PL_oldoldbufptr;
11350 contlen = PL_bufptr - PL_oldoldbufptr;
11352 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
11353 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
11356 The code below is removed for NetWare because it abends/crashes on NetWare
11357 when the script has error such as not having the closing quotes like:
11358 if ($var eq "value)
11359 Checking of white spaces is anyway done in NetWare code.
11362 while (isSPACE(*PL_oldbufptr))
11365 context = PL_oldbufptr;
11366 contlen = PL_bufptr - PL_oldbufptr;
11368 else if (yychar > 255)
11369 sv_catpvs(where_sv, "next token ???");
11370 else if (yychar == -2) { /* YYEMPTY */
11371 if (PL_lex_state == LEX_NORMAL ||
11372 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11373 sv_catpvs(where_sv, "at end of line");
11374 else if (PL_lex_inpat)
11375 sv_catpvs(where_sv, "within pattern");
11377 sv_catpvs(where_sv, "within string");
11380 sv_catpvs(where_sv, "next char ");
11382 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11383 else if (isPRINT_LC(yychar)) {
11384 const char string = yychar;
11385 sv_catpvn(where_sv, &string, 1);
11388 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11390 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11391 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11392 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11394 Perl_sv_catpvf(aTHX_ msg, "near \"%"SVf"\"\n",
11395 SVfARG(newSVpvn_flags(context, contlen,
11396 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
11398 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
11399 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
11400 Perl_sv_catpvf(aTHX_ msg,
11401 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11402 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11405 if (PL_in_eval & EVAL_WARNONLY) {
11406 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
11410 if (PL_error_count >= 10) {
11412 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
11413 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11414 SVfARG(errsv), OutCopFILE(PL_curcop));
11416 Perl_croak(aTHX_ "%s has too many errors.\n",
11417 OutCopFILE(PL_curcop));
11420 PL_in_my_stash = NULL;
11424 #pragma segment Main
11428 S_swallow_bom(pTHX_ U8 *s)
11431 const STRLEN slen = SvCUR(PL_linestr);
11433 PERL_ARGS_ASSERT_SWALLOW_BOM;
11437 if (s[1] == 0xFE) {
11438 /* UTF-16 little-endian? (or UTF-32LE?) */
11439 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11440 /* diag_listed_as: Unsupported script encoding %s */
11441 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11442 #ifndef PERL_NO_UTF16_FILTER
11443 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11445 if (PL_bufend > (char*)s) {
11446 s = add_utf16_textfilter(s, TRUE);
11449 /* diag_listed_as: Unsupported script encoding %s */
11450 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11455 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11456 #ifndef PERL_NO_UTF16_FILTER
11457 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11459 if (PL_bufend > (char *)s) {
11460 s = add_utf16_textfilter(s, FALSE);
11463 /* diag_listed_as: Unsupported script encoding %s */
11464 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11469 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11470 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11471 s += 3; /* UTF-8 */
11477 if (s[2] == 0xFE && s[3] == 0xFF) {
11478 /* UTF-32 big-endian */
11479 /* diag_listed_as: Unsupported script encoding %s */
11480 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11483 else if (s[2] == 0 && s[3] != 0) {
11486 * are a good indicator of UTF-16BE. */
11487 #ifndef PERL_NO_UTF16_FILTER
11488 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11489 s = add_utf16_textfilter(s, FALSE);
11491 /* diag_listed_as: Unsupported script encoding %s */
11492 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11498 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
11499 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11500 s += 4; /* UTF-8 */
11506 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11509 * are a good indicator of UTF-16LE. */
11510 #ifndef PERL_NO_UTF16_FILTER
11511 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11512 s = add_utf16_textfilter(s, TRUE);
11514 /* diag_listed_as: Unsupported script encoding %s */
11515 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11523 #ifndef PERL_NO_UTF16_FILTER
11525 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11528 SV *const filter = FILTER_DATA(idx);
11529 /* We re-use this each time round, throwing the contents away before we
11531 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11532 SV *const utf8_buffer = filter;
11533 IV status = IoPAGE(filter);
11534 const bool reverse = cBOOL(IoLINES(filter));
11537 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11539 /* As we're automatically added, at the lowest level, and hence only called
11540 from this file, we can be sure that we're not called in block mode. Hence
11541 don't bother writing code to deal with block mode. */
11543 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11546 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11548 DEBUG_P(PerlIO_printf(Perl_debug_log,
11549 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11550 FPTR2DPTR(void *, S_utf16_textfilter),
11551 reverse ? 'l' : 'b', idx, maxlen, status,
11552 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11559 /* First, look in our buffer of existing UTF-8 data: */
11560 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11564 } else if (status == 0) {
11566 IoPAGE(filter) = 0;
11567 nl = SvEND(utf8_buffer);
11570 STRLEN got = nl - SvPVX(utf8_buffer);
11571 /* Did we have anything to append? */
11573 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11574 /* Everything else in this code works just fine if SVp_POK isn't
11575 set. This, however, needs it, and we need it to work, else
11576 we loop infinitely because the buffer is never consumed. */
11577 sv_chop(utf8_buffer, nl);
11581 /* OK, not a complete line there, so need to read some more UTF-16.
11582 Read an extra octect if the buffer currently has an odd number. */
11586 if (SvCUR(utf16_buffer) >= 2) {
11587 /* Location of the high octet of the last complete code point.
11588 Gosh, UTF-16 is a pain. All the benefits of variable length,
11589 *coupled* with all the benefits of partial reads and
11591 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11592 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11594 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11598 /* We have the first half of a surrogate. Read more. */
11599 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11602 status = FILTER_READ(idx + 1, utf16_buffer,
11603 160 + (SvCUR(utf16_buffer) & 1));
11604 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11605 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11608 IoPAGE(filter) = status;
11613 chars = SvCUR(utf16_buffer) >> 1;
11614 have = SvCUR(utf8_buffer);
11615 SvGROW(utf8_buffer, have + chars * 3 + 1);
11618 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11619 (U8*)SvPVX_const(utf8_buffer) + have,
11620 chars * 2, &newlen);
11622 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11623 (U8*)SvPVX_const(utf8_buffer) + have,
11624 chars * 2, &newlen);
11626 SvCUR_set(utf8_buffer, have + newlen);
11629 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11630 it's private to us, and utf16_to_utf8{,reversed} take a
11631 (pointer,length) pair, rather than a NUL-terminated string. */
11632 if(SvCUR(utf16_buffer) & 1) {
11633 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11634 SvCUR_set(utf16_buffer, 1);
11636 SvCUR_set(utf16_buffer, 0);
11639 DEBUG_P(PerlIO_printf(Perl_debug_log,
11640 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11642 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11643 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11648 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11650 SV *filter = filter_add(S_utf16_textfilter, NULL);
11652 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11654 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11655 sv_setpvs(filter, "");
11656 IoLINES(filter) = reversed;
11657 IoPAGE(filter) = 1; /* Not EOF */
11659 /* Sadly, we have to return a valid pointer, come what may, so we have to
11660 ignore any error return from this. */
11661 SvCUR_set(PL_linestr, 0);
11662 if (FILTER_READ(0, PL_linestr, 0)) {
11663 SvUTF8_on(PL_linestr);
11665 SvUTF8_on(PL_linestr);
11667 PL_bufend = SvEND(PL_linestr);
11668 return (U8*)SvPVX(PL_linestr);
11673 Returns a pointer to the next character after the parsed
11674 vstring, as well as updating the passed in sv.
11676 Function must be called like
11678 sv = sv_2mortal(newSV(5));
11679 s = scan_vstring(s,e,sv);
11681 where s and e are the start and end of the string.
11682 The sv should already be large enough to store the vstring
11683 passed in, for performance reasons.
11685 This function may croak if fatal warnings are enabled in the
11686 calling scope, hence the sv_2mortal in the example (to prevent
11687 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11693 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11696 const char *pos = s;
11697 const char *start = s;
11699 PERL_ARGS_ASSERT_SCAN_VSTRING;
11701 if (*pos == 'v') pos++; /* get past 'v' */
11702 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11704 if ( *pos != '.') {
11705 /* this may not be a v-string if followed by => */
11706 const char *next = pos;
11707 while (next < e && isSPACE(*next))
11709 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11710 /* return string not v-string */
11711 sv_setpvn(sv,(char *)s,pos-s);
11712 return (char *)pos;
11716 if (!isALPHA(*pos)) {
11717 U8 tmpbuf[UTF8_MAXBYTES+1];
11720 s++; /* get past 'v' */
11725 /* this is atoi() that tolerates underscores */
11728 const char *end = pos;
11730 while (--end >= s) {
11732 const UV orev = rev;
11733 rev += (*end - '0') * mult;
11736 /* diag_listed_as: Integer overflow in %s number */
11737 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11738 "Integer overflow in decimal number");
11742 if (rev > 0x7FFFFFFF)
11743 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11745 /* Append native character for the rev point */
11746 tmpend = uvchr_to_utf8(tmpbuf, rev);
11747 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11748 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11750 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11756 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11760 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11767 Perl_keyword_plugin_standard(pTHX_
11768 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11770 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11771 PERL_UNUSED_CONTEXT;
11772 PERL_UNUSED_ARG(keyword_ptr);
11773 PERL_UNUSED_ARG(keyword_len);
11774 PERL_UNUSED_ARG(op_ptr);
11775 return KEYWORD_PLUGIN_DECLINE;
11778 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11780 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11782 SAVEI32(PL_lex_brackets);
11783 if (PL_lex_brackets > 100)
11784 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11785 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11786 SAVEI32(PL_lex_allbrackets);
11787 PL_lex_allbrackets = 0;
11788 SAVEI8(PL_lex_fakeeof);
11789 PL_lex_fakeeof = (U8)fakeeof;
11790 if(yyparse(gramtype) && !PL_parser->error_count)
11791 qerror(Perl_mess(aTHX_ "Parse error"));
11794 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11796 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11800 SAVEVPTR(PL_eval_root);
11801 PL_eval_root = NULL;
11802 parse_recdescent(gramtype, fakeeof);
11808 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11810 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11813 if (flags & ~PARSE_OPTIONAL)
11814 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11815 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11816 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11817 if (!PL_parser->error_count)
11818 qerror(Perl_mess(aTHX_ "Parse error"));
11819 exprop = newOP(OP_NULL, 0);
11825 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11827 Parse a Perl arithmetic expression. This may contain operators of precedence
11828 down to the bit shift operators. The expression must be followed (and thus
11829 terminated) either by a comparison or lower-precedence operator or by
11830 something that would normally terminate an expression such as semicolon.
11831 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11832 otherwise it is mandatory. It is up to the caller to ensure that the
11833 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11834 the source of the code to be parsed and the lexical context for the
11837 The op tree representing the expression is returned. If an optional
11838 expression is absent, a null pointer is returned, otherwise the pointer
11841 If an error occurs in parsing or compilation, in most cases a valid op
11842 tree is returned anyway. The error is reflected in the parser state,
11843 normally resulting in a single exception at the top level of parsing
11844 which covers all the compilation errors that occurred. Some compilation
11845 errors, however, will throw an exception immediately.
11851 Perl_parse_arithexpr(pTHX_ U32 flags)
11853 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11857 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11859 Parse a Perl term expression. This may contain operators of precedence
11860 down to the assignment operators. The expression must be followed (and thus
11861 terminated) either by a comma or lower-precedence operator or by
11862 something that would normally terminate an expression such as semicolon.
11863 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11864 otherwise it is mandatory. It is up to the caller to ensure that the
11865 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11866 the source of the code to be parsed and the lexical context for the
11869 The op tree representing the expression is returned. If an optional
11870 expression is absent, a null pointer is returned, otherwise the pointer
11873 If an error occurs in parsing or compilation, in most cases a valid op
11874 tree is returned anyway. The error is reflected in the parser state,
11875 normally resulting in a single exception at the top level of parsing
11876 which covers all the compilation errors that occurred. Some compilation
11877 errors, however, will throw an exception immediately.
11883 Perl_parse_termexpr(pTHX_ U32 flags)
11885 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11889 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11891 Parse a Perl list expression. This may contain operators of precedence
11892 down to the comma operator. The expression must be followed (and thus
11893 terminated) either by a low-precedence logic operator such as C<or> or by
11894 something that would normally terminate an expression such as semicolon.
11895 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11896 otherwise it is mandatory. It is up to the caller to ensure that the
11897 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11898 the source of the code to be parsed and the lexical context for the
11901 The op tree representing the expression is returned. If an optional
11902 expression is absent, a null pointer is returned, otherwise the pointer
11905 If an error occurs in parsing or compilation, in most cases a valid op
11906 tree is returned anyway. The error is reflected in the parser state,
11907 normally resulting in a single exception at the top level of parsing
11908 which covers all the compilation errors that occurred. Some compilation
11909 errors, however, will throw an exception immediately.
11915 Perl_parse_listexpr(pTHX_ U32 flags)
11917 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11921 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11923 Parse a single complete Perl expression. This allows the full
11924 expression grammar, including the lowest-precedence operators such
11925 as C<or>. The expression must be followed (and thus terminated) by a
11926 token that an expression would normally be terminated by: end-of-file,
11927 closing bracketing punctuation, semicolon, or one of the keywords that
11928 signals a postfix expression-statement modifier. If I<flags> includes
11929 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11930 mandatory. It is up to the caller to ensure that the dynamic parser
11931 state (L</PL_parser> et al) is correctly set to reflect the source of
11932 the code to be parsed and the lexical context for the expression.
11934 The op tree representing the expression is returned. If an optional
11935 expression is absent, a null pointer is returned, otherwise the pointer
11938 If an error occurs in parsing or compilation, in most cases a valid op
11939 tree is returned anyway. The error is reflected in the parser state,
11940 normally resulting in a single exception at the top level of parsing
11941 which covers all the compilation errors that occurred. Some compilation
11942 errors, however, will throw an exception immediately.
11948 Perl_parse_fullexpr(pTHX_ U32 flags)
11950 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11954 =for apidoc Amx|OP *|parse_block|U32 flags
11956 Parse a single complete Perl code block. This consists of an opening
11957 brace, a sequence of statements, and a closing brace. The block
11958 constitutes a lexical scope, so C<my> variables and various compile-time
11959 effects can be contained within it. It is up to the caller to ensure
11960 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11961 reflect the source of the code to be parsed and the lexical context for
11964 The op tree representing the code block is returned. This is always a
11965 real op, never a null pointer. It will normally be a C<lineseq> list,
11966 including C<nextstate> or equivalent ops. No ops to construct any kind
11967 of runtime scope are included by virtue of it being a block.
11969 If an error occurs in parsing or compilation, in most cases a valid op
11970 tree (most likely null) is returned anyway. The error is reflected in
11971 the parser state, normally resulting in a single exception at the top
11972 level of parsing which covers all the compilation errors that occurred.
11973 Some compilation errors, however, will throw an exception immediately.
11975 The I<flags> parameter is reserved for future use, and must always
11982 Perl_parse_block(pTHX_ U32 flags)
11985 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11986 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11990 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11992 Parse a single unadorned Perl statement. This may be a normal imperative
11993 statement or a declaration that has compile-time effect. It does not
11994 include any label or other affixture. It is up to the caller to ensure
11995 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11996 reflect the source of the code to be parsed and the lexical context for
11999 The op tree representing the statement is returned. This may be a
12000 null pointer if the statement is null, for example if it was actually
12001 a subroutine definition (which has compile-time side effects). If not
12002 null, it will be ops directly implementing the statement, suitable to
12003 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12004 equivalent op (except for those embedded in a scope contained entirely
12005 within the statement).
12007 If an error occurs in parsing or compilation, in most cases a valid op
12008 tree (most likely null) is returned anyway. The error is reflected in
12009 the parser state, normally resulting in a single exception at the top
12010 level of parsing which covers all the compilation errors that occurred.
12011 Some compilation errors, however, will throw an exception immediately.
12013 The I<flags> parameter is reserved for future use, and must always
12020 Perl_parse_barestmt(pTHX_ U32 flags)
12023 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12024 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12028 =for apidoc Amx|SV *|parse_label|U32 flags
12030 Parse a single label, possibly optional, of the type that may prefix a
12031 Perl statement. It is up to the caller to ensure that the dynamic parser
12032 state (L</PL_parser> et al) is correctly set to reflect the source of
12033 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
12034 label is optional, otherwise it is mandatory.
12036 The name of the label is returned in the form of a fresh scalar. If an
12037 optional label is absent, a null pointer is returned.
12039 If an error occurs in parsing, which can only occur if the label is
12040 mandatory, a valid label is returned anyway. The error is reflected in
12041 the parser state, normally resulting in a single exception at the top
12042 level of parsing which covers all the compilation errors that occurred.
12048 Perl_parse_label(pTHX_ U32 flags)
12050 if (flags & ~PARSE_OPTIONAL)
12051 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12052 if (PL_lex_state == LEX_KNOWNEXT) {
12053 PL_parser->yychar = yylex();
12054 if (PL_parser->yychar == LABEL) {
12055 char * const lpv = pl_yylval.pval;
12056 STRLEN llen = strlen(lpv);
12057 PL_parser->yychar = YYEMPTY;
12058 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12065 STRLEN wlen, bufptr_pos;
12068 if (!isIDFIRST_lazy_if(s, UTF))
12070 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12071 if (word_takes_any_delimeter(s, wlen))
12073 bufptr_pos = s - SvPVX(PL_linestr);
12075 lex_read_space(LEX_KEEP_PREVIOUS);
12077 s = SvPVX(PL_linestr) + bufptr_pos;
12078 if (t[0] == ':' && t[1] != ':') {
12079 PL_oldoldbufptr = PL_oldbufptr;
12082 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12086 if (flags & PARSE_OPTIONAL) {
12089 qerror(Perl_mess(aTHX_ "Parse error"));
12090 return newSVpvs("x");
12097 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12099 Parse a single complete Perl statement. This may be a normal imperative
12100 statement or a declaration that has compile-time effect, and may include
12101 optional labels. It is up to the caller to ensure that the dynamic
12102 parser state (L</PL_parser> et al) is correctly set to reflect the source
12103 of the code to be parsed and the lexical context for the statement.
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 the result of a L</newSTATEOP> call, normally including
12109 a C<nextstate> or equivalent op.
12111 If an error occurs in parsing or compilation, in most cases a valid op
12112 tree (most likely null) is returned anyway. The error is reflected in
12113 the parser state, normally resulting in a single exception at the top
12114 level of parsing which covers all the compilation errors that occurred.
12115 Some compilation errors, however, will throw an exception immediately.
12117 The I<flags> parameter is reserved for future use, and must always
12124 Perl_parse_fullstmt(pTHX_ U32 flags)
12127 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12128 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12132 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12134 Parse a sequence of zero or more Perl statements. These may be normal
12135 imperative statements, including optional labels, or declarations
12136 that have compile-time effect, or any mixture thereof. The statement
12137 sequence ends when a closing brace or end-of-file is encountered in a
12138 place where a new statement could have validly started. It is up to
12139 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12140 is correctly set to reflect the source of the code to be parsed and the
12141 lexical context for the statements.
12143 The op tree representing the statement sequence is returned. This may
12144 be a null pointer if the statements were all null, for example if there
12145 were no statements or if there were only subroutine definitions (which
12146 have compile-time side effects). If not null, it will be a C<lineseq>
12147 list, normally including C<nextstate> or equivalent ops.
12149 If an error occurs in parsing or compilation, in most cases a valid op
12150 tree is returned anyway. The error is reflected in the parser state,
12151 normally resulting in a single exception at the top level of parsing
12152 which covers all the compilation errors that occurred. Some compilation
12153 errors, however, will throw an exception immediately.
12155 The I<flags> parameter is reserved for future use, and must always
12162 Perl_parse_stmtseq(pTHX_ U32 flags)
12167 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12168 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12169 c = lex_peek_unichar(0);
12170 if (c != -1 && c != /*{*/'}')
12171 qerror(Perl_mess(aTHX_ "Parse error"));
12177 * c-indentation-style: bsd
12178 * c-basic-offset: 4
12179 * indent-tabs-mode: nil
12182 * ex: set ts=8 sts=4 sw=4 et: