3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'It all comes from here, the stench and the peril.' --Frodo
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 =head1 Lexer interface
27 This is the lower layer of the Perl parser, managing characters and tokens.
29 =for apidoc AmU|yy_parser *|PL_parser
31 Pointer to a structure encapsulating the state of the parsing operation
32 currently in progress. The pointer can be locally changed to perform
33 a nested parse without interfering with the state of an outer parse.
34 Individual members of C<PL_parser> have their own documentation.
40 #define PERL_IN_TOKE_C
42 #include "dquote_static.c"
44 #define new_constant(a,b,c,d,e,f,g) \
45 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
47 #define pl_yylval (PL_parser->yylval)
49 /* XXX temporary backwards compatibility */
50 #define PL_lex_brackets (PL_parser->lex_brackets)
51 #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
52 #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
53 #define PL_lex_brackstack (PL_parser->lex_brackstack)
54 #define PL_lex_casemods (PL_parser->lex_casemods)
55 #define PL_lex_casestack (PL_parser->lex_casestack)
56 #define PL_lex_defer (PL_parser->lex_defer)
57 #define PL_lex_dojoin (PL_parser->lex_dojoin)
58 #define PL_lex_expect (PL_parser->lex_expect)
59 #define PL_lex_formbrack (PL_parser->lex_formbrack)
60 #define PL_lex_inpat (PL_parser->lex_inpat)
61 #define PL_lex_inwhat (PL_parser->lex_inwhat)
62 #define PL_lex_op (PL_parser->lex_op)
63 #define PL_lex_repl (PL_parser->lex_repl)
64 #define PL_lex_starts (PL_parser->lex_starts)
65 #define PL_lex_stuff (PL_parser->lex_stuff)
66 #define PL_multi_start (PL_parser->multi_start)
67 #define PL_multi_open (PL_parser->multi_open)
68 #define PL_multi_close (PL_parser->multi_close)
69 #define PL_preambled (PL_parser->preambled)
70 #define PL_sublex_info (PL_parser->sublex_info)
71 #define PL_linestr (PL_parser->linestr)
72 #define PL_expect (PL_parser->expect)
73 #define PL_copline (PL_parser->copline)
74 #define PL_bufptr (PL_parser->bufptr)
75 #define PL_oldbufptr (PL_parser->oldbufptr)
76 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
77 #define PL_linestart (PL_parser->linestart)
78 #define PL_bufend (PL_parser->bufend)
79 #define PL_last_uni (PL_parser->last_uni)
80 #define PL_last_lop (PL_parser->last_lop)
81 #define PL_last_lop_op (PL_parser->last_lop_op)
82 #define PL_lex_state (PL_parser->lex_state)
83 #define PL_rsfp (PL_parser->rsfp)
84 #define PL_rsfp_filters (PL_parser->rsfp_filters)
85 #define PL_in_my (PL_parser->in_my)
86 #define PL_in_my_stash (PL_parser->in_my_stash)
87 #define PL_tokenbuf (PL_parser->tokenbuf)
88 #define PL_multi_end (PL_parser->multi_end)
89 #define PL_error_count (PL_parser->error_count)
92 # define PL_endwhite (PL_parser->endwhite)
93 # define PL_faketokens (PL_parser->faketokens)
94 # define PL_lasttoke (PL_parser->lasttoke)
95 # define PL_nextwhite (PL_parser->nextwhite)
96 # define PL_realtokenstart (PL_parser->realtokenstart)
97 # define PL_skipwhite (PL_parser->skipwhite)
98 # define PL_thisclose (PL_parser->thisclose)
99 # define PL_thismad (PL_parser->thismad)
100 # define PL_thisopen (PL_parser->thisopen)
101 # define PL_thisstuff (PL_parser->thisstuff)
102 # define PL_thistoken (PL_parser->thistoken)
103 # define PL_thiswhite (PL_parser->thiswhite)
104 # define PL_thiswhite (PL_parser->thiswhite)
105 # define PL_nexttoke (PL_parser->nexttoke)
106 # define PL_curforce (PL_parser->curforce)
108 # define PL_nexttoke (PL_parser->nexttoke)
109 # define PL_nexttype (PL_parser->nexttype)
110 # define PL_nextval (PL_parser->nextval)
113 static const char* const ident_too_long = "Identifier too long";
116 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
117 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
119 # define CURMAD(slot,sv)
120 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
123 #define XENUMMASK 0x3f
124 #define XFAKEEOF 0x40
125 #define XFAKEBRACK 0x80
127 #ifdef USE_UTF8_SCRIPTS
128 # define UTF (!IN_BYTES)
130 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
133 /* The maximum number of characters preceding the unrecognized one to display */
134 #define UNRECOGNIZED_PRECEDE_COUNT 10
136 /* In variables named $^X, these are the legal values for X.
137 * 1999-02-27 mjd-perl-patch@plover.com */
138 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
140 #define SPACE_OR_TAB(c) isBLANK_A(c)
142 /* LEX_* are values for PL_lex_state, the state of the lexer.
143 * They are arranged oddly so that the guard on the switch statement
144 * can get by with a single comparison (if the compiler is smart enough).
146 * These values refer to the various states within a sublex parse,
147 * i.e. within a double quotish string
150 /* #define LEX_NOTPARSING 11 is done in perl.h. */
152 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
153 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
154 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
155 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
156 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
158 /* at end of code, eg "$x" followed by: */
159 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
160 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
162 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
163 string or after \E, $foo, etc */
164 #define LEX_INTERPCONST 2 /* NOT USED */
165 #define LEX_FORMLINE 1 /* expecting a format line */
166 #define LEX_KNOWNEXT 0 /* next token known; just return it */
170 static const char* const lex_state_names[] = {
189 #include "keywords.h"
191 /* CLINE is a macro that ensures PL_copline has a sane value */
196 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
199 # define SKIPSPACE0(s) skipspace0(s)
200 # define SKIPSPACE1(s) skipspace1(s)
201 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
202 # define PEEKSPACE(s) skipspace2(s,0)
204 # define SKIPSPACE0(s) skipspace(s)
205 # define SKIPSPACE1(s) skipspace(s)
206 # define SKIPSPACE2(s,tsv) skipspace(s)
207 # define PEEKSPACE(s) skipspace(s)
211 * Convenience functions to return different tokens and prime the
212 * lexer for the next token. They all take an argument.
214 * TOKEN : generic token (used for '(', DOLSHARP, etc)
215 * OPERATOR : generic operator
216 * AOPERATOR : assignment operator
217 * PREBLOCK : beginning the block after an if, while, foreach, ...
218 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
219 * PREREF : *EXPR where EXPR is not a simple identifier
220 * TERM : expression term
221 * LOOPX : loop exiting command (goto, last, dump, etc)
222 * FTST : file test operator
223 * FUN0 : zero-argument function
224 * FUN0OP : zero-argument function, with its op created in this file
225 * FUN1 : not used, except for not, which isn't a UNIOP
226 * BOop : bitwise or or xor
228 * SHop : shift operator
229 * PWop : power operator
230 * PMop : pattern-matching operator
231 * Aop : addition-level operator
232 * Mop : multiplication-level operator
233 * Eop : equality-testing operator
234 * Rop : relational operator <= != gt
236 * Also see LOP and lop() below.
239 #ifdef DEBUGGING /* Serve -DT. */
240 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
242 # define REPORT(retval) (retval)
245 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
246 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
247 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
248 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
249 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
250 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
251 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
252 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
253 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
254 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
255 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
256 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
257 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
258 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
259 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
260 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
261 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
262 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
263 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
264 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
265 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
267 /* This bit of chicanery makes a unary function followed by
268 * a parenthesis into a function with one argument, highest precedence.
269 * The UNIDOR macro is for unary functions that can be followed by the //
270 * operator (such as C<shift // 0>).
272 #define UNI3(f,x,have_x) { \
273 pl_yylval.ival = f; \
274 if (have_x) PL_expect = x; \
276 PL_last_uni = PL_oldbufptr; \
277 PL_last_lop_op = f; \
279 return REPORT( (int)FUNC1 ); \
281 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
283 #define UNI(f) UNI3(f,XTERM,1)
284 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
285 #define UNIPROTO(f,optional) { \
286 if (optional) PL_last_uni = PL_oldbufptr; \
290 #define UNIBRACK(f) UNI3(f,0,0)
292 /* grandfather return to old style */
295 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
296 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
297 pl_yylval.ival = (f); \
303 #define COPLINE_INC_WITH_HERELINES \
305 CopLINE_inc(PL_curcop); \
306 if (PL_parser->lex_shared->herelines) \
307 CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \
308 PL_parser->lex_shared->herelines = 0; \
314 /* how to interpret the pl_yylval associated with the token */
318 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
323 static struct debug_tokens {
325 enum token_type type;
327 } const debug_tokens[] =
329 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
330 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
331 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
332 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
333 { ARROW, TOKENTYPE_NONE, "ARROW" },
334 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
335 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
336 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
337 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
338 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
339 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
340 { DO, TOKENTYPE_NONE, "DO" },
341 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
342 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
343 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
344 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
345 { ELSE, TOKENTYPE_NONE, "ELSE" },
346 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
347 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
348 { FOR, TOKENTYPE_IVAL, "FOR" },
349 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
350 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
351 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
352 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
353 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
354 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
355 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
356 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
357 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
358 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
359 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
360 { IF, TOKENTYPE_IVAL, "IF" },
361 { LABEL, TOKENTYPE_PVAL, "LABEL" },
362 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
363 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
364 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
365 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
366 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
367 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
368 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
369 { MY, TOKENTYPE_IVAL, "MY" },
370 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
371 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
372 { OROP, TOKENTYPE_IVAL, "OROP" },
373 { OROR, TOKENTYPE_NONE, "OROR" },
374 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
375 { PEG, TOKENTYPE_NONE, "PEG" },
376 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
377 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
378 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
379 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
380 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
381 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
382 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
383 { PREINC, TOKENTYPE_NONE, "PREINC" },
384 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
385 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
386 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
387 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
388 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
389 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
390 { SUB, TOKENTYPE_NONE, "SUB" },
391 { THING, TOKENTYPE_OPVAL, "THING" },
392 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
393 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
394 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
395 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
396 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
397 { USE, TOKENTYPE_IVAL, "USE" },
398 { WHEN, TOKENTYPE_IVAL, "WHEN" },
399 { WHILE, TOKENTYPE_IVAL, "WHILE" },
400 { WORD, TOKENTYPE_OPVAL, "WORD" },
401 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
402 { 0, TOKENTYPE_NONE, NULL }
405 /* dump the returned token in rv, plus any optional arg in pl_yylval */
408 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
412 PERL_ARGS_ASSERT_TOKEREPORT;
415 const char *name = NULL;
416 enum token_type type = TOKENTYPE_NONE;
417 const struct debug_tokens *p;
418 SV* const report = newSVpvs("<== ");
420 for (p = debug_tokens; p->token; p++) {
421 if (p->token == (int)rv) {
428 Perl_sv_catpv(aTHX_ report, name);
429 else if ((char)rv > ' ' && (char)rv <= '~')
431 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
433 sv_catpvs(report, " (pending identifier)");
436 sv_catpvs(report, "EOF");
438 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
443 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
445 case TOKENTYPE_OPNUM:
446 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
447 PL_op_name[lvalp->ival]);
450 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
452 case TOKENTYPE_OPVAL:
454 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
455 PL_op_name[lvalp->opval->op_type]);
456 if (lvalp->opval->op_type == OP_CONST) {
457 Perl_sv_catpvf(aTHX_ report, " %s",
458 SvPEEK(cSVOPx_sv(lvalp->opval)));
463 sv_catpvs(report, "(opval=null)");
466 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
472 /* print the buffer with suitable escapes */
475 S_printbuf(pTHX_ const char *const fmt, const char *const s)
477 SV* const tmp = newSVpvs("");
479 PERL_ARGS_ASSERT_PRINTBUF;
481 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
488 S_deprecate_commaless_var_list(pTHX) {
490 deprecate("comma-less variable list");
491 return REPORT(','); /* grandfather non-comma-format format */
497 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
498 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
502 S_ao(pTHX_ int toketype)
505 if (*PL_bufptr == '=') {
507 if (toketype == ANDAND)
508 pl_yylval.ival = OP_ANDASSIGN;
509 else if (toketype == OROR)
510 pl_yylval.ival = OP_ORASSIGN;
511 else if (toketype == DORDOR)
512 pl_yylval.ival = OP_DORASSIGN;
520 * When Perl expects an operator and finds something else, no_op
521 * prints the warning. It always prints "<something> found where
522 * operator expected. It prints "Missing semicolon on previous line?"
523 * if the surprise occurs at the start of the line. "do you need to
524 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
525 * where the compiler doesn't know if foo is a method call or a function.
526 * It prints "Missing operator before end of line" if there's nothing
527 * after the missing operator, or "... before <...>" if there is something
528 * after the missing operator.
532 S_no_op(pTHX_ const char *const what, char *s)
535 char * const oldbp = PL_bufptr;
536 const bool is_first = (PL_oldbufptr == PL_linestart);
538 PERL_ARGS_ASSERT_NO_OP;
544 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
545 if (ckWARN_d(WARN_SYNTAX)) {
547 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
548 "\t(Missing semicolon on previous line?)\n");
549 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
551 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
552 t += UTF ? UTF8SKIP(t) : 1)
554 if (t < PL_bufptr && isSPACE(*t))
555 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
556 "\t(Do you need to predeclare %"UTF8f"?)\n",
557 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
561 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
562 "\t(Missing operator before %"UTF8f"?)\n",
563 UTF8fARG(UTF, s - oldbp, oldbp));
571 * Complain about missing quote/regexp/heredoc terminator.
572 * If it's called with NULL then it cauterizes the line buffer.
573 * If we're in a delimited string and the delimiter is a control
574 * character, it's reformatted into a two-char sequence like ^C.
579 S_missingterm(pTHX_ char *s)
585 char * const nl = strrchr(s,'\n');
589 else if (isCNTRL(PL_multi_close)) {
591 tmpbuf[1] = (char)toCTRL(PL_multi_close);
596 *tmpbuf = (char)PL_multi_close;
600 q = strchr(s,'"') ? '\'' : '"';
601 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
607 * Check whether the named feature is enabled.
610 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
613 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
615 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
617 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
619 if (namelen > MAX_FEATURE_LEN)
621 memcpy(&he_name[8], name, namelen);
623 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
624 REFCOUNTED_HE_EXISTS));
628 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
629 * utf16-to-utf8-reversed.
632 #ifdef PERL_CR_FILTER
636 const char *s = SvPVX_const(sv);
637 const char * const e = s + SvCUR(sv);
639 PERL_ARGS_ASSERT_STRIP_RETURN;
641 /* outer loop optimized to do nothing if there are no CR-LFs */
643 if (*s++ == '\r' && *s == '\n') {
644 /* hit a CR-LF, need to copy the rest */
648 if (*s == '\r' && s[1] == '\n')
659 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
661 const I32 count = FILTER_READ(idx+1, sv, maxlen);
662 if (count > 0 && !maxlen)
669 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
671 Creates and initialises a new lexer/parser state object, supplying
672 a context in which to lex and parse from a new source of Perl code.
673 A pointer to the new state object is placed in L</PL_parser>. An entry
674 is made on the save stack so that upon unwinding the new state object
675 will be destroyed and the former value of L</PL_parser> will be restored.
676 Nothing else need be done to clean up the parsing context.
678 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
679 non-null, provides a string (in SV form) containing code to be parsed.
680 A copy of the string is made, so subsequent modification of I<line>
681 does not affect parsing. I<rsfp>, if non-null, provides an input stream
682 from which code will be read to be parsed. If both are non-null, the
683 code in I<line> comes first and must consist of complete lines of input,
684 and I<rsfp> supplies the remainder of the source.
686 The I<flags> parameter is reserved for future use. Currently it is only
687 used by perl internally, so extensions should always pass zero.
692 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
693 can share filters with the current parser.
694 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
695 caller, hence isn't owned by the parser, so shouldn't be closed on parser
696 destruction. This is used to handle the case of defaulting to reading the
697 script from the standard input because no filename was given on the command
698 line (without getting confused by situation where STDIN has been closed, so
699 the script handle is opened on fd 0) */
702 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
705 const char *s = NULL;
706 yy_parser *parser, *oparser;
707 if (flags && flags & ~LEX_START_FLAGS)
708 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
710 /* create and initialise a parser */
712 Newxz(parser, 1, yy_parser);
713 parser->old_parser = oparser = PL_parser;
716 parser->stack = NULL;
718 parser->stack_size = 0;
720 /* on scope exit, free this parser and restore any outer one */
722 parser->saved_curcop = PL_curcop;
724 /* initialise lexer state */
727 parser->curforce = -1;
729 parser->nexttoke = 0;
731 parser->error_count = oparser ? oparser->error_count : 0;
732 parser->copline = NOLINE;
733 parser->lex_state = LEX_NORMAL;
734 parser->expect = XSTATE;
736 parser->rsfp_filters =
737 !(flags & LEX_START_SAME_FILTER) || !oparser
739 : MUTABLE_AV(SvREFCNT_inc(
740 oparser->rsfp_filters
741 ? oparser->rsfp_filters
742 : (oparser->rsfp_filters = newAV())
745 Newx(parser->lex_brackstack, 120, char);
746 Newx(parser->lex_casestack, 12, char);
747 *parser->lex_casestack = '\0';
748 Newxz(parser->lex_shared, 1, LEXSHARED);
752 s = SvPV_const(line, len);
753 parser->linestr = flags & LEX_START_COPIED
754 ? SvREFCNT_inc_simple_NN(line)
755 : newSVpvn_flags(s, len, SvUTF8(line));
756 sv_catpvs(parser->linestr, "\n;");
758 parser->linestr = newSVpvs("\n;");
760 parser->oldoldbufptr =
763 parser->linestart = SvPVX(parser->linestr);
764 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
765 parser->last_lop = parser->last_uni = NULL;
766 parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
767 |LEX_DONT_CLOSE_RSFP);
769 parser->in_pod = parser->filtered = 0;
773 /* delete a parser object */
776 Perl_parser_free(pTHX_ const yy_parser *parser)
778 PERL_ARGS_ASSERT_PARSER_FREE;
780 PL_curcop = parser->saved_curcop;
781 SvREFCNT_dec(parser->linestr);
783 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
784 PerlIO_clearerr(parser->rsfp);
785 else if (parser->rsfp && (!parser->old_parser ||
786 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
787 PerlIO_close(parser->rsfp);
788 SvREFCNT_dec(parser->rsfp_filters);
789 SvREFCNT_dec(parser->lex_stuff);
790 SvREFCNT_dec(parser->sublex_info.repl);
792 Safefree(parser->lex_brackstack);
793 Safefree(parser->lex_casestack);
794 Safefree(parser->lex_shared);
795 PL_parser = parser->old_parser;
800 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
803 I32 nexttoke = parser->lasttoke;
805 I32 nexttoke = parser->nexttoke;
807 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
810 if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
812 && parser->nexttoke[nexttoke].next_val.opval
813 && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
814 && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
815 op_free(parser->nexttoke[nexttoke].next_val.opval);
816 parser->nexttoke[nexttoke].next_val.opval = NULL;
819 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
820 && parser->nextval[nexttoke].opval
821 && parser->nextval[nexttoke].opval->op_slabbed
822 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
823 op_free(parser->nextval[nexttoke].opval);
824 parser->nextval[nexttoke].opval = NULL;
832 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
834 Buffer scalar containing the chunk currently under consideration of the
835 text currently being lexed. This is always a plain string scalar (for
836 which C<SvPOK> is true). It is not intended to be used as a scalar by
837 normal scalar means; instead refer to the buffer directly by the pointer
838 variables described below.
840 The lexer maintains various C<char*> pointers to things in the
841 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
842 reallocated, all of these pointers must be updated. Don't attempt to
843 do this manually, but rather use L</lex_grow_linestr> if you need to
844 reallocate the buffer.
846 The content of the text chunk in the buffer is commonly exactly one
847 complete line of input, up to and including a newline terminator,
848 but there are situations where it is otherwise. The octets of the
849 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
850 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
851 flag on this scalar, which may disagree with it.
853 For direct examination of the buffer, the variable
854 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
855 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
856 of these pointers is usually preferable to examination of the scalar
857 through normal scalar means.
859 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
861 Direct pointer to the end of the chunk of text currently being lexed, the
862 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
863 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
864 always located at the end of the buffer, and does not count as part of
865 the buffer's contents.
867 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
869 Points to the current position of lexing inside the lexer buffer.
870 Characters around this point may be freely examined, within
871 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
872 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
873 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
875 Lexing code (whether in the Perl core or not) moves this pointer past
876 the characters that it consumes. It is also expected to perform some
877 bookkeeping whenever a newline character is consumed. This movement
878 can be more conveniently performed by the function L</lex_read_to>,
879 which handles newlines appropriately.
881 Interpretation of the buffer's octets can be abstracted out by
882 using the slightly higher-level functions L</lex_peek_unichar> and
883 L</lex_read_unichar>.
885 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
887 Points to the start of the current line inside the lexer buffer.
888 This is useful for indicating at which column an error occurred, and
889 not much else. This must be updated by any lexing code that consumes
890 a newline; the function L</lex_read_to> handles this detail.
896 =for apidoc Amx|bool|lex_bufutf8
898 Indicates whether the octets in the lexer buffer
899 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
900 of Unicode characters. If not, they should be interpreted as Latin-1
901 characters. This is analogous to the C<SvUTF8> flag for scalars.
903 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
904 contains valid UTF-8. Lexing code must be robust in the face of invalid
907 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
908 is significant, but not the whole story regarding the input character
909 encoding. Normally, when a file is being read, the scalar contains octets
910 and its C<SvUTF8> flag is off, but the octets should be interpreted as
911 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
912 however, the scalar may have the C<SvUTF8> flag on, and in this case its
913 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
914 is in effect. This logic may change in the future; use this function
915 instead of implementing the logic yourself.
921 Perl_lex_bufutf8(pTHX)
927 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
929 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
930 at least I<len> octets (including terminating NUL). Returns a
931 pointer to the reallocated buffer. This is necessary before making
932 any direct modification of the buffer that would increase its length.
933 L</lex_stuff_pvn> provides a more convenient way to insert text into
936 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
937 this function updates all of the lexer's variables that point directly
944 Perl_lex_grow_linestr(pTHX_ STRLEN len)
948 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
949 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
950 linestr = PL_parser->linestr;
951 buf = SvPVX(linestr);
952 if (len <= SvLEN(linestr))
954 bufend_pos = PL_parser->bufend - buf;
955 bufptr_pos = PL_parser->bufptr - buf;
956 oldbufptr_pos = PL_parser->oldbufptr - buf;
957 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
958 linestart_pos = PL_parser->linestart - buf;
959 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
960 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
961 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
962 PL_parser->lex_shared->re_eval_start - buf : 0;
964 buf = sv_grow(linestr, len);
966 PL_parser->bufend = buf + bufend_pos;
967 PL_parser->bufptr = buf + bufptr_pos;
968 PL_parser->oldbufptr = buf + oldbufptr_pos;
969 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
970 PL_parser->linestart = buf + linestart_pos;
971 if (PL_parser->last_uni)
972 PL_parser->last_uni = buf + last_uni_pos;
973 if (PL_parser->last_lop)
974 PL_parser->last_lop = buf + last_lop_pos;
975 if (PL_parser->lex_shared->re_eval_start)
976 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
981 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
983 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
984 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
985 reallocating the buffer if necessary. This means that lexing code that
986 runs later will see the characters as if they had appeared in the input.
987 It is not recommended to do this as part of normal parsing, and most
988 uses of this facility run the risk of the inserted characters being
989 interpreted in an unintended manner.
991 The string to be inserted is represented by I<len> octets starting
992 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
993 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
994 The characters are recoded for the lexer buffer, according to how the
995 buffer is currently being interpreted (L</lex_bufutf8>). If a string
996 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
997 function is more convenient.
1003 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1007 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1008 if (flags & ~(LEX_STUFF_UTF8))
1009 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1011 if (flags & LEX_STUFF_UTF8) {
1014 STRLEN highhalf = 0; /* Count of variants */
1015 const char *p, *e = pv+len;
1016 for (p = pv; p != e; p++) {
1017 if (! UTF8_IS_INVARIANT(*p)) {
1023 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1024 bufptr = PL_parser->bufptr;
1025 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1026 SvCUR_set(PL_parser->linestr,
1027 SvCUR(PL_parser->linestr) + len+highhalf);
1028 PL_parser->bufend += len+highhalf;
1029 for (p = pv; p != e; p++) {
1031 if (! UTF8_IS_INVARIANT(c)) {
1032 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1033 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1035 *bufptr++ = (char)c;
1040 if (flags & LEX_STUFF_UTF8) {
1041 STRLEN highhalf = 0;
1042 const char *p, *e = pv+len;
1043 for (p = pv; p != e; p++) {
1045 if (UTF8_IS_ABOVE_LATIN1(c)) {
1046 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1047 "non-Latin-1 character into Latin-1 input");
1048 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1051 } else if (! UTF8_IS_INVARIANT(c)) {
1052 /* malformed UTF-8 */
1054 SAVESPTR(PL_warnhook);
1055 PL_warnhook = PERL_WARNHOOK_FATAL;
1056 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
1062 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1063 bufptr = PL_parser->bufptr;
1064 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1065 SvCUR_set(PL_parser->linestr,
1066 SvCUR(PL_parser->linestr) + len-highhalf);
1067 PL_parser->bufend += len-highhalf;
1070 if (UTF8_IS_INVARIANT(*p)) {
1076 *bufptr++ = TWO_BYTE_UTF8_TO_UNI(*p, *(p+1));
1082 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1083 bufptr = PL_parser->bufptr;
1084 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1085 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1086 PL_parser->bufend += len;
1087 Copy(pv, bufptr, len, char);
1093 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1095 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1096 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1097 reallocating the buffer if necessary. This means that lexing code that
1098 runs later will see the characters as if they had appeared in the input.
1099 It is not recommended to do this as part of normal parsing, and most
1100 uses of this facility run the risk of the inserted characters being
1101 interpreted in an unintended manner.
1103 The string to be inserted is represented by octets starting at I<pv>
1104 and continuing to the first nul. These octets are interpreted as either
1105 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1106 in I<flags>. The characters are recoded for the lexer buffer, according
1107 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1108 If it is not convenient to nul-terminate a string to be inserted, the
1109 L</lex_stuff_pvn> function is more appropriate.
1115 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1117 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1118 lex_stuff_pvn(pv, strlen(pv), flags);
1122 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1124 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1125 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1126 reallocating the buffer if necessary. This means that lexing code that
1127 runs later will see the characters as if they had appeared in the input.
1128 It is not recommended to do this as part of normal parsing, and most
1129 uses of this facility run the risk of the inserted characters being
1130 interpreted in an unintended manner.
1132 The string to be inserted is the string value of I<sv>. The characters
1133 are recoded for the lexer buffer, according to how the buffer is currently
1134 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1135 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1136 need to construct a scalar.
1142 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1146 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1148 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1150 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1154 =for apidoc Amx|void|lex_unstuff|char *ptr
1156 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1157 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1158 This hides the discarded text from any lexing code that runs later,
1159 as if the text had never appeared.
1161 This is not the normal way to consume lexed text. For that, use
1168 Perl_lex_unstuff(pTHX_ char *ptr)
1172 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1173 buf = PL_parser->bufptr;
1175 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1178 bufend = PL_parser->bufend;
1180 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1181 unstuff_len = ptr - buf;
1182 Move(ptr, buf, bufend+1-ptr, char);
1183 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1184 PL_parser->bufend = bufend - unstuff_len;
1188 =for apidoc Amx|void|lex_read_to|char *ptr
1190 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1191 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1192 performing the correct bookkeeping whenever a newline character is passed.
1193 This is the normal way to consume lexed text.
1195 Interpretation of the buffer's octets can be abstracted out by
1196 using the slightly higher-level functions L</lex_peek_unichar> and
1197 L</lex_read_unichar>.
1203 Perl_lex_read_to(pTHX_ char *ptr)
1206 PERL_ARGS_ASSERT_LEX_READ_TO;
1207 s = PL_parser->bufptr;
1208 if (ptr < s || ptr > PL_parser->bufend)
1209 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1210 for (; s != ptr; s++)
1212 COPLINE_INC_WITH_HERELINES;
1213 PL_parser->linestart = s+1;
1215 PL_parser->bufptr = ptr;
1219 =for apidoc Amx|void|lex_discard_to|char *ptr
1221 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1222 up to I<ptr>. The remaining content of the buffer will be moved, and
1223 all pointers into the buffer updated appropriately. I<ptr> must not
1224 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1225 it is not permitted to discard text that has yet to be lexed.
1227 Normally it is not necessarily to do this directly, because it suffices to
1228 use the implicit discarding behaviour of L</lex_next_chunk> and things
1229 based on it. However, if a token stretches across multiple lines,
1230 and the lexing code has kept multiple lines of text in the buffer for
1231 that purpose, then after completion of the token it would be wise to
1232 explicitly discard the now-unneeded earlier lines, to avoid future
1233 multi-line tokens growing the buffer without bound.
1239 Perl_lex_discard_to(pTHX_ char *ptr)
1243 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1244 buf = SvPVX(PL_parser->linestr);
1246 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1249 if (ptr > PL_parser->bufptr)
1250 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1251 discard_len = ptr - buf;
1252 if (PL_parser->oldbufptr < ptr)
1253 PL_parser->oldbufptr = ptr;
1254 if (PL_parser->oldoldbufptr < ptr)
1255 PL_parser->oldoldbufptr = ptr;
1256 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1257 PL_parser->last_uni = NULL;
1258 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1259 PL_parser->last_lop = NULL;
1260 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1261 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1262 PL_parser->bufend -= discard_len;
1263 PL_parser->bufptr -= discard_len;
1264 PL_parser->oldbufptr -= discard_len;
1265 PL_parser->oldoldbufptr -= discard_len;
1266 if (PL_parser->last_uni)
1267 PL_parser->last_uni -= discard_len;
1268 if (PL_parser->last_lop)
1269 PL_parser->last_lop -= discard_len;
1273 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1275 Reads in the next chunk of text to be lexed, appending it to
1276 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1277 looked to the end of the current chunk and wants to know more. It is
1278 usual, but not necessary, for lexing to have consumed the entirety of
1279 the current chunk at this time.
1281 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1282 chunk (i.e., the current chunk has been entirely consumed), normally the
1283 current chunk will be discarded at the same time that the new chunk is
1284 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1285 will not be discarded. If the current chunk has not been entirely
1286 consumed, then it will not be discarded regardless of the flag.
1288 Returns true if some new text was added to the buffer, or false if the
1289 buffer has reached the end of the input text.
1294 #define LEX_FAKE_EOF 0x80000000
1295 #define LEX_NO_TERM 0x40000000
1298 Perl_lex_next_chunk(pTHX_ U32 flags)
1302 STRLEN old_bufend_pos, new_bufend_pos;
1303 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1304 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1305 bool got_some_for_debugger = 0;
1307 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1308 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1309 linestr = PL_parser->linestr;
1310 buf = SvPVX(linestr);
1311 if (!(flags & LEX_KEEP_PREVIOUS) &&
1312 PL_parser->bufptr == PL_parser->bufend) {
1313 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1315 if (PL_parser->last_uni != PL_parser->bufend)
1316 PL_parser->last_uni = NULL;
1317 if (PL_parser->last_lop != PL_parser->bufend)
1318 PL_parser->last_lop = NULL;
1319 last_uni_pos = last_lop_pos = 0;
1323 old_bufend_pos = PL_parser->bufend - buf;
1324 bufptr_pos = PL_parser->bufptr - buf;
1325 oldbufptr_pos = PL_parser->oldbufptr - buf;
1326 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1327 linestart_pos = PL_parser->linestart - buf;
1328 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1329 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1331 if (flags & LEX_FAKE_EOF) {
1333 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1335 } else if (filter_gets(linestr, old_bufend_pos)) {
1337 got_some_for_debugger = 1;
1338 } else if (flags & LEX_NO_TERM) {
1341 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1342 sv_setpvs(linestr, "");
1344 /* End of real input. Close filehandle (unless it was STDIN),
1345 * then add implicit termination.
1347 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1348 PerlIO_clearerr(PL_parser->rsfp);
1349 else if (PL_parser->rsfp)
1350 (void)PerlIO_close(PL_parser->rsfp);
1351 PL_parser->rsfp = NULL;
1352 PL_parser->in_pod = PL_parser->filtered = 0;
1354 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1357 if (!PL_in_eval && PL_minus_p) {
1359 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1360 PL_minus_n = PL_minus_p = 0;
1361 } else if (!PL_in_eval && PL_minus_n) {
1362 sv_catpvs(linestr, /*{*/";}");
1365 sv_catpvs(linestr, ";");
1368 buf = SvPVX(linestr);
1369 new_bufend_pos = SvCUR(linestr);
1370 PL_parser->bufend = buf + new_bufend_pos;
1371 PL_parser->bufptr = buf + bufptr_pos;
1372 PL_parser->oldbufptr = buf + oldbufptr_pos;
1373 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1374 PL_parser->linestart = buf + linestart_pos;
1375 if (PL_parser->last_uni)
1376 PL_parser->last_uni = buf + last_uni_pos;
1377 if (PL_parser->last_lop)
1378 PL_parser->last_lop = buf + last_lop_pos;
1379 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1380 PL_curstash != PL_debstash) {
1381 /* debugger active and we're not compiling the debugger code,
1382 * so store the line into the debugger's array of lines
1384 update_debugger_info(NULL, buf+old_bufend_pos,
1385 new_bufend_pos-old_bufend_pos);
1391 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1393 Looks ahead one (Unicode) character in the text currently being lexed.
1394 Returns the codepoint (unsigned integer value) of the next character,
1395 or -1 if lexing has reached the end of the input text. To consume the
1396 peeked character, use L</lex_read_unichar>.
1398 If the next character is in (or extends into) the next chunk of input
1399 text, the next chunk will be read in. Normally the current chunk will be
1400 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1401 then the current chunk will not be discarded.
1403 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1404 is encountered, an exception is generated.
1410 Perl_lex_peek_unichar(pTHX_ U32 flags)
1414 if (flags & ~(LEX_KEEP_PREVIOUS))
1415 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1416 s = PL_parser->bufptr;
1417 bufend = PL_parser->bufend;
1423 if (!lex_next_chunk(flags))
1425 s = PL_parser->bufptr;
1426 bufend = PL_parser->bufend;
1429 if (UTF8_IS_INVARIANT(head))
1431 if (UTF8_IS_START(head)) {
1432 len = UTF8SKIP(&head);
1433 while ((STRLEN)(bufend-s) < len) {
1434 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1436 s = PL_parser->bufptr;
1437 bufend = PL_parser->bufend;
1440 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1441 if (retlen == (STRLEN)-1) {
1442 /* malformed UTF-8 */
1444 SAVESPTR(PL_warnhook);
1445 PL_warnhook = PERL_WARNHOOK_FATAL;
1446 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1452 if (!lex_next_chunk(flags))
1454 s = PL_parser->bufptr;
1461 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1463 Reads the next (Unicode) character in the text currently being lexed.
1464 Returns the codepoint (unsigned integer value) of the character read,
1465 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1466 if lexing has reached the end of the input text. To non-destructively
1467 examine the next character, use L</lex_peek_unichar> instead.
1469 If the next character is in (or extends into) the next chunk of input
1470 text, the next chunk will be read in. Normally the current chunk will be
1471 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1472 then the current chunk will not be discarded.
1474 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1475 is encountered, an exception is generated.
1481 Perl_lex_read_unichar(pTHX_ U32 flags)
1484 if (flags & ~(LEX_KEEP_PREVIOUS))
1485 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1486 c = lex_peek_unichar(flags);
1489 COPLINE_INC_WITH_HERELINES;
1491 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1493 ++(PL_parser->bufptr);
1499 =for apidoc Amx|void|lex_read_space|U32 flags
1501 Reads optional spaces, in Perl style, in the text currently being
1502 lexed. The spaces may include ordinary whitespace characters and
1503 Perl-style comments. C<#line> directives are processed if encountered.
1504 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1505 at a non-space character (or the end of the input text).
1507 If spaces extend into the next chunk of input text, the next chunk will
1508 be read in. Normally the current chunk will be discarded at the same
1509 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1510 chunk will not be discarded.
1515 #define LEX_NO_NEXT_CHUNK 0x80000000
1518 Perl_lex_read_space(pTHX_ U32 flags)
1521 bool need_incline = 0;
1522 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
1523 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1526 sv_free(PL_skipwhite);
1527 PL_skipwhite = NULL;
1530 PL_skipwhite = newSVpvs("");
1531 #endif /* PERL_MAD */
1532 s = PL_parser->bufptr;
1533 bufend = PL_parser->bufend;
1539 } while (!(c == '\n' || (c == 0 && s == bufend)));
1540 } else if (c == '\n') {
1542 PL_parser->linestart = s;
1547 } else if (isSPACE(c)) {
1549 } else if (c == 0 && s == bufend) {
1553 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1554 #endif /* PERL_MAD */
1555 if (flags & LEX_NO_NEXT_CHUNK)
1557 PL_parser->bufptr = s;
1558 COPLINE_INC_WITH_HERELINES;
1559 got_more = lex_next_chunk(flags);
1560 CopLINE_dec(PL_curcop);
1561 s = PL_parser->bufptr;
1562 bufend = PL_parser->bufend;
1565 if (need_incline && PL_parser->rsfp) {
1575 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1576 #endif /* PERL_MAD */
1577 PL_parser->bufptr = s;
1582 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1584 This function performs syntax checking on a prototype, C<proto>.
1585 If C<warn> is true, any illegal characters or mismatched brackets
1586 will trigger illegalproto warnings, declaring that they were
1587 detected in the prototype for C<name>.
1589 The return value is C<true> if this is a valid prototype, and
1590 C<false> if it is not, regardless of whether C<warn> was C<true> or
1593 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1600 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1602 STRLEN len, origlen;
1603 char *p = proto ? SvPV(proto, len) : NULL;
1604 bool bad_proto = FALSE;
1605 bool in_brackets = FALSE;
1606 bool after_slash = FALSE;
1607 char greedy_proto = ' ';
1608 bool proto_after_greedy_proto = FALSE;
1609 bool must_be_last = FALSE;
1610 bool underscore = FALSE;
1611 bool seen_underscore = FALSE;
1613 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1619 for (; len--; p++) {
1622 proto_after_greedy_proto = TRUE;
1623 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1628 if(!strchr(";@%", *p))
1636 in_brackets = FALSE;
1637 else if ((*p == '@' || *p == '%') &&
1640 must_be_last = TRUE;
1644 underscore = seen_underscore = TRUE;
1649 after_slash = FALSE;
1655 if (proto_after_greedy_proto)
1656 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1657 "Prototype after '%c' for %"SVf" : %s",
1658 greedy_proto, SVfARG(name), p);
1660 SV *dsv = newSVpvs_flags("", SVs_TEMP);
1661 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1662 "Illegal character %sin prototype for %"SVf" : %s",
1663 seen_underscore ? "after '_' " : "",
1665 SvUTF8(PL_lex_stuff)
1666 ? sv_uni_display(dsv,
1667 newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1669 UNI_DISPLAY_ISPRINT)
1670 : pv_pretty(dsv, p, origlen, 60, NULL, NULL,
1671 PERL_PV_ESCAPE_NONASCII));
1675 return (! (proto_after_greedy_proto || bad_proto) );
1680 * This subroutine has nothing to do with tilting, whether at windmills
1681 * or pinball tables. Its name is short for "increment line". It
1682 * increments the current line number in CopLINE(PL_curcop) and checks
1683 * to see whether the line starts with a comment of the form
1684 * # line 500 "foo.pm"
1685 * If so, it sets the current line number and file to the values in the comment.
1689 S_incline(pTHX_ const char *s)
1697 PERL_ARGS_ASSERT_INCLINE;
1699 COPLINE_INC_WITH_HERELINES;
1700 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1701 && s+1 == PL_bufend && *s == ';') {
1702 /* fake newline in string eval */
1703 CopLINE_dec(PL_curcop);
1708 while (SPACE_OR_TAB(*s))
1710 if (strnEQ(s, "line", 4))
1714 if (SPACE_OR_TAB(*s))
1718 while (SPACE_OR_TAB(*s))
1726 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1728 while (SPACE_OR_TAB(*s))
1730 if (*s == '"' && (t = strchr(s+1, '"'))) {
1736 while (!isSPACE(*t))
1740 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1742 if (*e != '\n' && *e != '\0')
1743 return; /* false alarm */
1745 line_num = atoi(n)-1;
1748 const STRLEN len = t - s;
1749 SV *const temp_sv = CopFILESV(PL_curcop);
1754 cf = SvPVX(temp_sv);
1755 tmplen = SvCUR(temp_sv);
1761 if (!PL_rsfp && !PL_parser->filtered) {
1762 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1763 * to *{"::_<newfilename"} */
1764 /* However, the long form of evals is only turned on by the
1765 debugger - usually they're "(eval %lu)" */
1769 STRLEN tmplen2 = len;
1770 if (tmplen + 2 <= sizeof smallbuf)
1773 Newx(tmpbuf, tmplen + 2, char);
1776 memcpy(tmpbuf + 2, cf, tmplen);
1778 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1783 if (tmplen2 + 2 <= sizeof smallbuf)
1786 Newx(tmpbuf2, tmplen2 + 2, char);
1788 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1789 /* Either they malloc'd it, or we malloc'd it,
1790 so no prefix is present in ours. */
1795 memcpy(tmpbuf2 + 2, s, tmplen2);
1798 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1800 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1801 /* adjust ${"::_<newfilename"} to store the new file name */
1802 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1803 /* The line number may differ. If that is the case,
1804 alias the saved lines that are in the array.
1805 Otherwise alias the whole array. */
1806 if (CopLINE(PL_curcop) == line_num) {
1807 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1808 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1810 else if (GvAV(*gvp)) {
1811 AV * const av = GvAV(*gvp);
1812 const I32 start = CopLINE(PL_curcop)+1;
1813 I32 items = AvFILLp(av) - start;
1815 AV * const av2 = GvAVn(gv2);
1816 SV **svp = AvARRAY(av) + start;
1817 I32 l = (I32)line_num+1;
1819 av_store(av2, l++, SvREFCNT_inc(*svp++));
1824 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1826 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1828 CopFILE_free(PL_curcop);
1829 CopFILE_setn(PL_curcop, s, len);
1831 CopLINE_set(PL_curcop, line_num);
1835 /* skip space before PL_thistoken */
1838 S_skipspace0(pTHX_ char *s)
1840 PERL_ARGS_ASSERT_SKIPSPACE0;
1847 PL_thiswhite = newSVpvs("");
1848 sv_catsv(PL_thiswhite, PL_skipwhite);
1849 sv_free(PL_skipwhite);
1852 PL_realtokenstart = s - SvPVX(PL_linestr);
1856 /* skip space after PL_thistoken */
1859 S_skipspace1(pTHX_ char *s)
1861 const char *start = s;
1862 I32 startoff = start - SvPVX(PL_linestr);
1864 PERL_ARGS_ASSERT_SKIPSPACE1;
1869 start = SvPVX(PL_linestr) + startoff;
1870 if (!PL_thistoken && PL_realtokenstart >= 0) {
1871 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1872 PL_thistoken = newSVpvn(tstart, start - tstart);
1874 PL_realtokenstart = -1;
1877 PL_nextwhite = newSVpvs("");
1878 sv_catsv(PL_nextwhite, PL_skipwhite);
1879 sv_free(PL_skipwhite);
1886 S_skipspace2(pTHX_ char *s, SV **svp)
1889 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1890 const I32 startoff = s - SvPVX(PL_linestr);
1892 PERL_ARGS_ASSERT_SKIPSPACE2;
1895 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1896 if (!PL_madskills || !svp)
1898 start = SvPVX(PL_linestr) + startoff;
1899 if (!PL_thistoken && PL_realtokenstart >= 0) {
1900 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1901 PL_thistoken = newSVpvn(tstart, start - tstart);
1902 PL_realtokenstart = -1;
1906 *svp = newSVpvs("");
1907 sv_setsv(*svp, PL_skipwhite);
1908 sv_free(PL_skipwhite);
1917 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1919 AV *av = CopFILEAVx(PL_curcop);
1921 SV * const sv = newSV_type(SVt_PVMG);
1923 sv_setsv(sv, orig_sv);
1925 sv_setpvn(sv, buf, len);
1928 av_store(av, (I32)CopLINE(PL_curcop), sv);
1934 * Called to gobble the appropriate amount and type of whitespace.
1935 * Skips comments as well.
1939 S_skipspace(pTHX_ char *s)
1943 #endif /* PERL_MAD */
1944 PERL_ARGS_ASSERT_SKIPSPACE;
1947 sv_free(PL_skipwhite);
1948 PL_skipwhite = NULL;
1950 #endif /* PERL_MAD */
1951 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1952 while (s < PL_bufend && SPACE_OR_TAB(*s))
1955 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1957 lex_read_space(LEX_KEEP_PREVIOUS |
1958 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1959 LEX_NO_NEXT_CHUNK : 0));
1961 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1962 if (PL_linestart > PL_bufptr)
1963 PL_bufptr = PL_linestart;
1968 PL_skipwhite = newSVpvn(start, s-start);
1969 #endif /* PERL_MAD */
1975 * Check the unary operators to ensure there's no ambiguity in how they're
1976 * used. An ambiguous piece of code would be:
1978 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1979 * the +5 is its argument.
1989 if (PL_oldoldbufptr != PL_last_uni)
1991 while (isSPACE(*PL_last_uni))
1994 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1996 if ((t = strchr(s, '(')) && t < PL_bufptr)
1999 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
2000 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
2001 (int)(s - PL_last_uni), PL_last_uni);
2005 * LOP : macro to build a list operator. Its behaviour has been replaced
2006 * with a subroutine, S_lop() for which LOP is just another name.
2009 #define LOP(f,x) return lop(f,x,s)
2013 * Build a list operator (or something that might be one). The rules:
2014 * - if we have a next token, then it's a list operator [why?]
2015 * - if the next thing is an opening paren, then it's a function
2016 * - else it's a list operator
2020 S_lop(pTHX_ I32 f, int x, char *s)
2024 PERL_ARGS_ASSERT_LOP;
2030 PL_last_lop = PL_oldbufptr;
2031 PL_last_lop_op = (OPCODE)f;
2040 return REPORT(FUNC);
2043 return REPORT(FUNC);
2046 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
2047 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
2048 return REPORT(LSTOP);
2055 * Sets up for an eventual force_next(). start_force(0) basically does
2056 * an unshift, while start_force(-1) does a push. yylex removes items
2061 S_start_force(pTHX_ int where)
2065 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
2066 where = PL_lasttoke;
2067 assert(PL_curforce < 0 || PL_curforce == where);
2068 if (PL_curforce != where) {
2069 for (i = PL_lasttoke; i > where; --i) {
2070 PL_nexttoke[i] = PL_nexttoke[i-1];
2074 if (PL_curforce < 0) /* in case of duplicate start_force() */
2075 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
2076 PL_curforce = where;
2079 curmad('^', newSVpvs(""));
2080 CURMAD('_', PL_nextwhite);
2085 S_curmad(pTHX_ char slot, SV *sv)
2091 if (PL_curforce < 0)
2092 where = &PL_thismad;
2094 where = &PL_nexttoke[PL_curforce].next_mad;
2100 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2102 else if (PL_encoding) {
2103 sv_recode_to_utf8(sv, PL_encoding);
2108 /* keep a slot open for the head of the list? */
2109 if (slot != '_' && *where && (*where)->mad_key == '^') {
2110 (*where)->mad_key = slot;
2111 sv_free(MUTABLE_SV(((*where)->mad_val)));
2112 (*where)->mad_val = (void*)sv;
2115 addmad(newMADsv(slot, sv), where, 0);
2118 # define start_force(where) NOOP
2119 # define curmad(slot, sv) NOOP
2124 * When the lexer realizes it knows the next token (for instance,
2125 * it is reordering tokens for the parser) then it can call S_force_next
2126 * to know what token to return the next time the lexer is called. Caller
2127 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2128 * and possibly PL_expect to ensure the lexer handles the token correctly.
2132 S_force_next(pTHX_ I32 type)
2137 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2138 tokereport(type, &NEXTVAL_NEXTTOKE);
2142 if (PL_curforce < 0)
2143 start_force(PL_lasttoke);
2144 PL_nexttoke[PL_curforce].next_type = type;
2145 if (PL_lex_state != LEX_KNOWNEXT)
2146 PL_lex_defer = PL_lex_state;
2147 PL_lex_state = LEX_KNOWNEXT;
2148 PL_lex_expect = PL_expect;
2151 PL_nexttype[PL_nexttoke] = type;
2153 if (PL_lex_state != LEX_KNOWNEXT) {
2154 PL_lex_defer = PL_lex_state;
2155 PL_lex_expect = PL_expect;
2156 PL_lex_state = LEX_KNOWNEXT;
2164 int yyc = PL_parser->yychar;
2165 if (yyc != YYEMPTY) {
2168 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2169 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2170 PL_lex_allbrackets--;
2172 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2173 } else if (yyc == '('/*)*/) {
2174 PL_lex_allbrackets--;
2179 PL_parser->yychar = YYEMPTY;
2184 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2187 SV * const sv = newSVpvn_utf8(start, len,
2190 && !is_ascii_string((const U8*)start, len)
2191 && is_utf8_string((const U8*)start, len));
2197 * When the lexer knows the next thing is a word (for instance, it has
2198 * just seen -> and it knows that the next char is a word char, then
2199 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2203 * char *start : buffer position (must be within PL_linestr)
2204 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2205 * int check_keyword : if true, Perl checks to make sure the word isn't
2206 * a keyword (do this if the word is a label, e.g. goto FOO)
2207 * int allow_pack : if true, : characters will also be allowed (require,
2208 * use, etc. do this)
2209 * int allow_initial_tick : used by the "sub" lexer only.
2213 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2219 PERL_ARGS_ASSERT_FORCE_WORD;
2221 start = SKIPSPACE1(start);
2223 if (isIDFIRST_lazy_if(s,UTF) ||
2224 (allow_pack && *s == ':') )
2226 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2227 if (check_keyword) {
2228 char *s2 = PL_tokenbuf;
2229 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2231 if (keyword(s2, len, 0))
2234 start_force(PL_curforce);
2236 curmad('X', newSVpvn(start,s-start));
2237 if (token == METHOD) {
2242 PL_expect = XOPERATOR;
2246 curmad('g', newSVpvs( "forced" ));
2247 NEXTVAL_NEXTTOKE.opval
2248 = (OP*)newSVOP(OP_CONST,0,
2249 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2250 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2258 * Called when the lexer wants $foo *foo &foo etc, but the program
2259 * text only contains the "foo" portion. The first argument is a pointer
2260 * to the "foo", and the second argument is the type symbol to prefix.
2261 * Forces the next token to be a "WORD".
2262 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2266 S_force_ident(pTHX_ const char *s, int kind)
2270 PERL_ARGS_ASSERT_FORCE_IDENT;
2273 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2274 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2275 UTF ? SVf_UTF8 : 0));
2276 start_force(PL_curforce);
2277 NEXTVAL_NEXTTOKE.opval = o;
2280 o->op_private = OPpCONST_ENTERED;
2281 /* XXX see note in pp_entereval() for why we forgo typo
2282 warnings if the symbol must be introduced in an eval.
2284 gv_fetchpvn_flags(s, len,
2285 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2286 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2287 kind == '$' ? SVt_PV :
2288 kind == '@' ? SVt_PVAV :
2289 kind == '%' ? SVt_PVHV :
2297 S_force_ident_maybe_lex(pTHX_ char pit)
2299 start_force(PL_curforce);
2300 NEXTVAL_NEXTTOKE.ival = pit;
2305 Perl_str_to_version(pTHX_ SV *sv)
2310 const char *start = SvPV_const(sv,len);
2311 const char * const end = start + len;
2312 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2314 PERL_ARGS_ASSERT_STR_TO_VERSION;
2316 while (start < end) {
2320 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2325 retval += ((NV)n)/nshift;
2334 * Forces the next token to be a version number.
2335 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2336 * and if "guessing" is TRUE, then no new token is created (and the caller
2337 * must use an alternative parsing method).
2341 S_force_version(pTHX_ char *s, int guessing)
2347 I32 startoff = s - SvPVX(PL_linestr);
2350 PERL_ARGS_ASSERT_FORCE_VERSION;
2358 while (isDIGIT(*d) || *d == '_' || *d == '.')
2362 start_force(PL_curforce);
2363 curmad('X', newSVpvn(s,d-s));
2366 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2368 #ifdef USE_LOCALE_NUMERIC
2369 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2370 setlocale(LC_NUMERIC, "C");
2372 s = scan_num(s, &pl_yylval);
2373 #ifdef USE_LOCALE_NUMERIC
2374 setlocale(LC_NUMERIC, loc);
2377 version = pl_yylval.opval;
2378 ver = cSVOPx(version)->op_sv;
2379 if (SvPOK(ver) && !SvNIOK(ver)) {
2380 SvUPGRADE(ver, SVt_PVNV);
2381 SvNV_set(ver, str_to_version(ver));
2382 SvNOK_on(ver); /* hint that it is a version */
2385 else if (guessing) {
2388 sv_free(PL_nextwhite); /* let next token collect whitespace */
2390 s = SvPVX(PL_linestr) + startoff;
2398 if (PL_madskills && !version) {
2399 sv_free(PL_nextwhite); /* let next token collect whitespace */
2401 s = SvPVX(PL_linestr) + startoff;
2404 /* NOTE: The parser sees the package name and the VERSION swapped */
2405 start_force(PL_curforce);
2406 NEXTVAL_NEXTTOKE.opval = version;
2413 * S_force_strict_version
2414 * Forces the next token to be a version number using strict syntax rules.
2418 S_force_strict_version(pTHX_ char *s)
2423 I32 startoff = s - SvPVX(PL_linestr);
2425 const char *errstr = NULL;
2427 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2429 while (isSPACE(*s)) /* leading whitespace */
2432 if (is_STRICT_VERSION(s,&errstr)) {
2434 s = (char *)scan_version(s, ver, 0);
2435 version = newSVOP(OP_CONST, 0, ver);
2437 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2438 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2442 yyerror(errstr); /* version required */
2447 if (PL_madskills && !version) {
2448 sv_free(PL_nextwhite); /* let next token collect whitespace */
2450 s = SvPVX(PL_linestr) + startoff;
2453 /* NOTE: The parser sees the package name and the VERSION swapped */
2454 start_force(PL_curforce);
2455 NEXTVAL_NEXTTOKE.opval = version;
2463 * Tokenize a quoted string passed in as an SV. It finds the next
2464 * chunk, up to end of string or a backslash. It may make a new
2465 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2470 S_tokeq(pTHX_ SV *sv)
2479 PERL_ARGS_ASSERT_TOKEQ;
2484 s = SvPV_force(sv, len);
2485 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2488 /* This is relying on the SV being "well formed" with a trailing '\0' */
2489 while (s < send && !(*s == '\\' && s[1] == '\\'))
2494 if ( PL_hints & HINT_NEW_STRING ) {
2495 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2499 if (s + 1 < send && (s[1] == '\\'))
2500 s++; /* all that, just for this */
2505 SvCUR_set(sv, d - SvPVX_const(sv));
2507 if ( PL_hints & HINT_NEW_STRING )
2508 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2513 * Now come three functions related to double-quote context,
2514 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2515 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2516 * interact with PL_lex_state, and create fake ( ... ) argument lists
2517 * to handle functions and concatenation.
2521 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2526 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2528 * Pattern matching will set PL_lex_op to the pattern-matching op to
2529 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2531 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2533 * Everything else becomes a FUNC.
2535 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2536 * had an OP_CONST or OP_READLINE). This just sets us up for a
2537 * call to S_sublex_push().
2541 S_sublex_start(pTHX)
2544 const I32 op_type = pl_yylval.ival;
2546 if (op_type == OP_NULL) {
2547 pl_yylval.opval = PL_lex_op;
2551 if (op_type == OP_CONST || op_type == OP_READLINE) {
2552 SV *sv = tokeq(PL_lex_stuff);
2554 if (SvTYPE(sv) == SVt_PVIV) {
2555 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2557 const char * const p = SvPV_const(sv, len);
2558 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2562 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2563 PL_lex_stuff = NULL;
2564 /* Allow <FH> // "foo" */
2565 if (op_type == OP_READLINE)
2566 PL_expect = XTERMORDORDOR;
2569 else if (op_type == OP_BACKTICK && PL_lex_op) {
2570 /* readpipe() vas overriden */
2571 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2572 pl_yylval.opval = PL_lex_op;
2574 PL_lex_stuff = NULL;
2578 PL_sublex_info.super_state = PL_lex_state;
2579 PL_sublex_info.sub_inwhat = (U16)op_type;
2580 PL_sublex_info.sub_op = PL_lex_op;
2581 PL_lex_state = LEX_INTERPPUSH;
2585 pl_yylval.opval = PL_lex_op;
2595 * Create a new scope to save the lexing state. The scope will be
2596 * ended in S_sublex_done. Returns a '(', starting the function arguments
2597 * to the uc, lc, etc. found before.
2598 * Sets PL_lex_state to LEX_INTERPCONCAT.
2608 PL_lex_state = PL_sublex_info.super_state;
2609 SAVEBOOL(PL_lex_dojoin);
2610 SAVEI32(PL_lex_brackets);
2611 SAVEI32(PL_lex_allbrackets);
2612 SAVEI32(PL_lex_formbrack);
2613 SAVEI8(PL_lex_fakeeof);
2614 SAVEI32(PL_lex_casemods);
2615 SAVEI32(PL_lex_starts);
2616 SAVEI8(PL_lex_state);
2617 SAVESPTR(PL_lex_repl);
2618 SAVEVPTR(PL_lex_inpat);
2619 SAVEI16(PL_lex_inwhat);
2620 SAVECOPLINE(PL_curcop);
2621 SAVEPPTR(PL_bufptr);
2622 SAVEPPTR(PL_bufend);
2623 SAVEPPTR(PL_oldbufptr);
2624 SAVEPPTR(PL_oldoldbufptr);
2625 SAVEPPTR(PL_last_lop);
2626 SAVEPPTR(PL_last_uni);
2627 SAVEPPTR(PL_linestart);
2628 SAVESPTR(PL_linestr);
2629 SAVEGENERICPV(PL_lex_brackstack);
2630 SAVEGENERICPV(PL_lex_casestack);
2631 SAVEGENERICPV(PL_parser->lex_shared);
2632 SAVEBOOL(PL_parser->lex_re_reparsing);
2634 /* The here-doc parser needs to be able to peek into outer lexing
2635 scopes to find the body of the here-doc. So we put PL_linestr and
2636 PL_bufptr into lex_shared, to ‘share’ those values.
2638 PL_parser->lex_shared->ls_linestr = PL_linestr;
2639 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2641 PL_linestr = PL_lex_stuff;
2642 PL_lex_repl = PL_sublex_info.repl;
2643 PL_lex_stuff = NULL;
2644 PL_sublex_info.repl = NULL;
2646 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2647 = SvPVX(PL_linestr);
2648 PL_bufend += SvCUR(PL_linestr);
2649 PL_last_lop = PL_last_uni = NULL;
2650 SAVEFREESV(PL_linestr);
2651 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2653 PL_lex_dojoin = FALSE;
2654 PL_lex_brackets = PL_lex_formbrack = 0;
2655 PL_lex_allbrackets = 0;
2656 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2657 Newx(PL_lex_brackstack, 120, char);
2658 Newx(PL_lex_casestack, 12, char);
2659 PL_lex_casemods = 0;
2660 *PL_lex_casestack = '\0';
2662 PL_lex_state = LEX_INTERPCONCAT;
2663 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2665 Newxz(shared, 1, LEXSHARED);
2666 shared->ls_prev = PL_parser->lex_shared;
2667 PL_parser->lex_shared = shared;
2669 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2670 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2671 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2672 PL_lex_inpat = PL_sublex_info.sub_op;
2674 PL_lex_inpat = NULL;
2676 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2677 PL_in_eval &= ~EVAL_RE_REPARSING;
2684 * Restores lexer state after a S_sublex_push.
2691 if (!PL_lex_starts++) {
2692 SV * const sv = newSVpvs("");
2693 if (SvUTF8(PL_linestr))
2695 PL_expect = XOPERATOR;
2696 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2700 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2701 PL_lex_state = LEX_INTERPCASEMOD;
2705 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2706 assert(PL_lex_inwhat != OP_TRANSR);
2707 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2708 PL_linestr = PL_lex_repl;
2710 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2711 PL_bufend += SvCUR(PL_linestr);
2712 PL_last_lop = PL_last_uni = NULL;
2713 PL_lex_dojoin = FALSE;
2714 PL_lex_brackets = 0;
2715 PL_lex_allbrackets = 0;
2716 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2717 PL_lex_casemods = 0;
2718 *PL_lex_casestack = '\0';
2720 if (SvEVALED(PL_lex_repl)) {
2721 PL_lex_state = LEX_INTERPNORMAL;
2723 /* we don't clear PL_lex_repl here, so that we can check later
2724 whether this is an evalled subst; that means we rely on the
2725 logic to ensure sublex_done() is called again only via the
2726 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2729 PL_lex_state = LEX_INTERPCONCAT;
2739 PL_endwhite = newSVpvs("");
2740 sv_catsv(PL_endwhite, PL_thiswhite);
2744 sv_setpvs(PL_thistoken,"");
2746 PL_realtokenstart = -1;
2750 PL_bufend = SvPVX(PL_linestr);
2751 PL_bufend += SvCUR(PL_linestr);
2752 PL_expect = XOPERATOR;
2753 PL_sublex_info.sub_inwhat = 0;
2758 PERL_STATIC_INLINE SV*
2759 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2761 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2762 * interior, hence to the "}". Finds what the name resolves to, returning
2763 * an SV* containing it; NULL if no valid one found */
2765 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2772 const U8* first_bad_char_loc;
2773 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2775 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2777 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2779 &first_bad_char_loc))
2781 /* If warnings are on, this will print a more detailed analysis of what
2782 * is wrong than the error message below */
2783 utf8n_to_uvuni(first_bad_char_loc,
2784 e - ((char *) first_bad_char_loc),
2787 /* We deliberately don't try to print the malformed character, which
2788 * might not print very well; it also may be just the first of many
2789 * malformations, so don't print what comes after it */
2790 yyerror(Perl_form(aTHX_
2791 "Malformed UTF-8 character immediately after '%.*s'",
2792 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2796 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2797 /* include the <}> */
2798 e - backslash_ptr + 1);
2800 SvREFCNT_dec_NN(res);
2804 /* See if the charnames handler is the Perl core's, and if so, we can skip
2805 * the validation needed for a user-supplied one, as Perl's does its own
2807 table = GvHV(PL_hintgv); /* ^H */
2808 cvp = hv_fetchs(table, "charnames", FALSE);
2809 if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
2810 && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
2812 const char * const name = HvNAME(stash);
2813 if strEQ(name, "_charnames") {
2818 /* Here, it isn't Perl's charname handler. We can't rely on a
2819 * user-supplied handler to validate the input name. For non-ut8 input,
2820 * look to see that the first character is legal. Then loop through the
2821 * rest checking that each is a continuation */
2823 /* This code needs to be sync'ed with a regex in _charnames.pm which does
2827 if (! isALPHAU(*s)) {
2832 if (! isCHARNAME_CONT(*s)) {
2835 if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2836 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2837 "A sequence of multiple spaces in a charnames "
2838 "alias definition is deprecated");
2842 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2843 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2844 "Trailing white-space in a charnames alias "
2845 "definition is deprecated");
2849 /* Similarly for utf8. For invariants can check directly; for other
2850 * Latin1, can calculate their code point and check; otherwise use a
2852 if (UTF8_IS_INVARIANT(*s)) {
2853 if (! isALPHAU(*s)) {
2857 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2858 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
2864 if (! PL_utf8_charname_begin) {
2865 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2866 PL_utf8_charname_begin = _core_swash_init("utf8",
2867 "_Perl_Charname_Begin",
2869 1, 0, NULL, &flags);
2871 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2878 if (UTF8_IS_INVARIANT(*s)) {
2879 if (! isCHARNAME_CONT(*s)) {
2882 if (*s == ' ' && *(s-1) == ' '
2883 && ckWARN_d(WARN_DEPRECATED)) {
2884 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2885 "A sequence of multiple spaces in a charnam"
2886 "es alias definition is deprecated");
2890 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2891 if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
2899 if (! PL_utf8_charname_continue) {
2900 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2901 PL_utf8_charname_continue = _core_swash_init("utf8",
2902 "_Perl_Charname_Continue",
2904 1, 0, NULL, &flags);
2906 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2912 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2913 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2914 "Trailing white-space in a charnames alias "
2915 "definition is deprecated");
2919 if (SvUTF8(res)) { /* Don't accept malformed input */
2920 const U8* first_bad_char_loc;
2922 const char* const str = SvPV_const(res, len);
2923 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2924 /* If warnings are on, this will print a more detailed analysis of
2925 * what is wrong than the error message below */
2926 utf8n_to_uvuni(first_bad_char_loc,
2927 (char *) first_bad_char_loc - str,
2930 /* We deliberately don't try to print the malformed character,
2931 * which might not print very well; it also may be just the first
2932 * of many malformations, so don't print what comes after it */
2935 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2936 (int) (e - backslash_ptr + 1), backslash_ptr,
2937 (int) ((char *) first_bad_char_loc - str), str
2947 int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
2949 /* The final %.*s makes sure that should the trailing NUL be missing
2950 * that this print won't run off the end of the string */
2953 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2954 (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2955 (int)(e - s + bad_char_size), s + bad_char_size
2957 UTF ? SVf_UTF8 : 0);
2965 Extracts the next constant part of a pattern, double-quoted string,
2966 or transliteration. This is terrifying code.
2968 For example, in parsing the double-quoted string "ab\x63$d", it would
2969 stop at the '$' and return an OP_CONST containing 'abc'.
2971 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2972 processing a pattern (PL_lex_inpat is true), a transliteration
2973 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2975 Returns a pointer to the character scanned up to. If this is
2976 advanced from the start pointer supplied (i.e. if anything was
2977 successfully parsed), will leave an OP_CONST for the substring scanned
2978 in pl_yylval. Caller must intuit reason for not parsing further
2979 by looking at the next characters herself.
2983 \N{FOO} => \N{U+hex_for_character_FOO}
2984 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2987 all other \-char, including \N and \N{ apart from \N{ABC}
2990 @ and $ where it appears to be a var, but not for $ as tail anchor
2995 In transliterations:
2996 characters are VERY literal, except for - not at the start or end
2997 of the string, which indicates a range. If the range is in bytes,
2998 scan_const expands the range to the full set of intermediate
2999 characters. If the range is in utf8, the hyphen is replaced with
3000 a certain range mark which will be handled by pmtrans() in op.c.
3002 In double-quoted strings:
3004 double-quoted style: \r and \n
3005 constants: \x31, etc.
3006 deprecated backrefs: \1 (in substitution replacements)
3007 case and quoting: \U \Q \E
3010 scan_const does *not* construct ops to handle interpolated strings.
3011 It stops processing as soon as it finds an embedded $ or @ variable
3012 and leaves it to the caller to work out what's going on.
3014 embedded arrays (whether in pattern or not) could be:
3015 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
3017 $ in double-quoted strings must be the symbol of an embedded scalar.
3019 $ in pattern could be $foo or could be tail anchor. Assumption:
3020 it's a tail anchor if $ is the last thing in the string, or if it's
3021 followed by one of "()| \r\n\t"
3023 \1 (backreferences) are turned into $1 in substitutions
3025 The structure of the code is
3026 while (there's a character to process) {
3027 handle transliteration ranges
3028 skip regexp comments /(?#comment)/ and codes /(?{code})/
3029 skip #-initiated comments in //x patterns
3030 check for embedded arrays
3031 check for embedded scalars
3033 deprecate \1 in substitution replacements
3034 handle string-changing backslashes \l \U \Q \E, etc.
3035 switch (what was escaped) {
3036 handle \- in a transliteration (becomes a literal -)
3037 if a pattern and not \N{, go treat as regular character
3038 handle \132 (octal characters)
3039 handle \x15 and \x{1234} (hex characters)
3040 handle \N{name} (named characters, also \N{3,5} in a pattern)
3041 handle \cV (control characters)
3042 handle printf-style backslashes (\f, \r, \n, etc)
3045 } (end if backslash)
3046 handle regular character
3047 } (end while character to read)
3052 S_scan_const(pTHX_ char *start)
3055 char *send = PL_bufend; /* end of the constant */
3056 SV *sv = newSV(send - start); /* sv for the constant. See
3057 note below on sizing. */
3058 char *s = start; /* start of the constant */
3059 char *d = SvPVX(sv); /* destination for copies */
3060 bool dorange = FALSE; /* are we in a translit range? */
3061 bool didrange = FALSE; /* did we just finish a range? */
3062 bool in_charclass = FALSE; /* within /[...]/ */
3063 bool has_utf8 = FALSE; /* Output constant is UTF8 */
3064 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
3065 to be UTF8? But, this can
3066 show as true when the source
3067 isn't utf8, as for example
3068 when it is entirely composed
3070 SV *res; /* result from charnames */
3072 /* Note on sizing: The scanned constant is placed into sv, which is
3073 * initialized by newSV() assuming one byte of output for every byte of
3074 * input. This routine expects newSV() to allocate an extra byte for a
3075 * trailing NUL, which this routine will append if it gets to the end of
3076 * the input. There may be more bytes of input than output (eg., \N{LATIN
3077 * CAPITAL LETTER A}), or more output than input if the constant ends up
3078 * recoded to utf8, but each time a construct is found that might increase
3079 * the needed size, SvGROW() is called. Its size parameter each time is
3080 * based on the best guess estimate at the time, namely the length used so
3081 * far, plus the length the current construct will occupy, plus room for
3082 * the trailing NUL, plus one byte for every input byte still unscanned */
3084 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
3087 UV literal_endpoint = 0;
3088 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
3091 PERL_ARGS_ASSERT_SCAN_CONST;
3093 assert(PL_lex_inwhat != OP_TRANSR);
3094 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3095 /* If we are doing a trans and we know we want UTF8 set expectation */
3096 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
3097 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3100 /* Protect sv from errors and fatal warnings. */
3101 ENTER_with_name("scan_const");
3104 while (s < send || dorange) {
3106 /* get transliterations out of the way (they're most literal) */
3107 if (PL_lex_inwhat == OP_TRANS) {
3108 /* expand a range A-Z to the full set of characters. AIE! */
3110 I32 i; /* current expanded character */
3111 I32 min; /* first character in range */
3112 I32 max; /* last character in range */
3123 char * const c = (char*)utf8_hop((U8*)d, -1);
3127 *c = (char)UTF_TO_NATIVE(0xff);
3128 /* mark the range as done, and continue */
3134 i = d - SvPVX_const(sv); /* remember current offset */
3137 SvLEN(sv) + (has_utf8 ?
3138 (512 - UTF_CONTINUATION_MARK +
3141 /* How many two-byte within 0..255: 128 in UTF-8,
3142 * 96 in UTF-8-mod. */
3144 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
3146 d = SvPVX(sv) + i; /* refresh d after realloc */
3150 for (j = 0; j <= 1; j++) {
3151 char * const c = (char*)utf8_hop((U8*)d, -1);
3152 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3158 max = (U8)0xff; /* only to \xff */
3159 uvmax = uv; /* \x{100} to uvmax */
3161 d = c; /* eat endpoint chars */
3166 d -= 2; /* eat the first char and the - */
3167 min = (U8)*d; /* first char in range */
3168 max = (U8)d[1]; /* last char in range */
3175 "Invalid range \"%c-%c\" in transliteration operator",
3176 (char)min, (char)max);
3180 if (literal_endpoint == 2 &&
3181 ((isLOWER(min) && isLOWER(max)) ||
3182 (isUPPER(min) && isUPPER(max)))) {
3184 for (i = min; i <= max; i++)
3186 *d++ = NATIVE_TO_NEED(has_utf8,i);
3188 for (i = min; i <= max; i++)
3190 *d++ = NATIVE_TO_NEED(has_utf8,i);
3195 for (i = min; i <= max; i++)
3198 const U8 ch = (U8)NATIVE_TO_UTF(i);
3199 if (UNI_IS_INVARIANT(ch))
3202 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
3203 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
3212 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3214 *d++ = (char)UTF_TO_NATIVE(0xff);
3216 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3220 /* mark the range as done, and continue */
3224 literal_endpoint = 0;
3229 /* range begins (ignore - as first or last char) */
3230 else if (*s == '-' && s+1 < send && s != start) {
3232 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3239 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
3249 literal_endpoint = 0;
3250 native_range = TRUE;
3255 /* if we get here, we're not doing a transliteration */
3257 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3260 while (s1 >= start && *s1-- == '\\')
3263 in_charclass = TRUE;
3266 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3269 while (s1 >= start && *s1-- == '\\')
3272 in_charclass = FALSE;
3275 /* skip for regexp comments /(?#comment)/, except for the last
3276 * char, which will be done separately.
3277 * Stop on (?{..}) and friends */
3279 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
3281 while (s+1 < send && *s != ')')
3282 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3284 else if (!PL_lex_casemods && !in_charclass &&
3285 ( s[2] == '{' /* This should match regcomp.c */
3286 || (s[2] == '?' && s[3] == '{')))
3292 /* likewise skip #-initiated comments in //x patterns */
3293 else if (*s == '#' && PL_lex_inpat &&
3294 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3295 while (s+1 < send && *s != '\n')
3296 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3299 /* no further processing of single-quoted regex */
3300 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3301 goto default_action;
3303 /* check for embedded arrays
3304 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3306 else if (*s == '@' && s[1]) {
3307 if (isWORDCHAR_lazy_if(s+1,UTF))
3309 if (strchr(":'{$", s[1]))
3311 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3312 break; /* in regexp, neither @+ nor @- are interpolated */
3315 /* check for embedded scalars. only stop if we're sure it's a
3318 else if (*s == '$') {
3319 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3321 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3323 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3324 "Possible unintended interpolation of $\\ in regex");
3326 break; /* in regexp, $ might be tail anchor */
3330 /* End of else if chain - OP_TRANS rejoin rest */
3333 if (*s == '\\' && s+1 < send) {
3334 char* e; /* Can be used for ending '}', etc. */
3338 /* warn on \1 - \9 in substitution replacements, but note that \11
3339 * is an octal; and \19 is \1 followed by '9' */
3340 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3341 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3343 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3348 /* string-change backslash escapes */
3349 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3353 /* In a pattern, process \N, but skip any other backslash escapes.
3354 * This is because we don't want to translate an escape sequence
3355 * into a meta symbol and have the regex compiler use the meta
3356 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3357 * in spite of this, we do have to process \N here while the proper
3358 * charnames handler is in scope. See bugs #56444 and #62056.
3359 * There is a complication because \N in a pattern may also stand
3360 * for 'match a non-nl', and not mean a charname, in which case its
3361 * processing should be deferred to the regex compiler. To be a
3362 * charname it must be followed immediately by a '{', and not look
3363 * like \N followed by a curly quantifier, i.e., not something like
3364 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3366 else if (PL_lex_inpat
3369 || regcurly(s + 1, FALSE)))
3371 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
3372 goto default_action;
3377 /* quoted - in transliterations */
3379 if (PL_lex_inwhat == OP_TRANS) {
3386 if ((isALPHANUMERIC(*s)))
3387 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3388 "Unrecognized escape \\%c passed through",
3390 /* default action is to copy the quoted character */
3391 goto default_action;
3394 /* eg. \132 indicates the octal constant 0132 */
3395 case '0': case '1': case '2': case '3':
3396 case '4': case '5': case '6': case '7':
3398 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3400 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
3402 if (len < 3 && s < send && isDIGIT(*s)
3403 && ckWARN(WARN_MISC))
3405 Perl_warner(aTHX_ packWARN(WARN_MISC),
3406 "%s", form_short_octal_warning(s, len));
3409 goto NUM_ESCAPE_INSERT;
3411 /* eg. \o{24} indicates the octal constant \024 */
3416 bool valid = grok_bslash_o(&s, &uv, &error,
3417 TRUE, /* Output warning */
3418 FALSE, /* Not strict */
3419 TRUE, /* Output warnings for
3426 goto NUM_ESCAPE_INSERT;
3429 /* eg. \x24 indicates the hex constant 0x24 */
3434 bool valid = grok_bslash_x(&s, &uv, &error,
3435 TRUE, /* Output warning */
3436 FALSE, /* Not strict */
3437 TRUE, /* Output warnings for
3447 /* Insert oct or hex escaped character. There will always be
3448 * enough room in sv since such escapes will be longer than any
3449 * UTF-8 sequence they can end up as, except if they force us
3450 * to recode the rest of the string into utf8 */
3452 /* Here uv is the ordinal of the next character being added in
3453 * unicode (converted from native). */
3454 if (!UNI_IS_INVARIANT(uv)) {
3455 if (!has_utf8 && uv > 255) {
3456 /* Might need to recode whatever we have accumulated so
3457 * far if it contains any chars variant in utf8 or
3460 SvCUR_set(sv, d - SvPVX_const(sv));
3463 /* See Note on sizing above. */
3464 sv_utf8_upgrade_flags_grow(sv,
3465 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3466 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3467 d = SvPVX(sv) + SvCUR(sv);
3472 d = (char*)uvuni_to_utf8((U8*)d, uv);
3473 if (PL_lex_inwhat == OP_TRANS &&
3474 PL_sublex_info.sub_op) {
3475 PL_sublex_info.sub_op->op_private |=
3476 (PL_lex_repl ? OPpTRANS_FROM_UTF
3480 if (uv > 255 && !dorange)
3481 native_range = FALSE;
3494 /* In a non-pattern \N must be a named character, like \N{LATIN
3495 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3496 * mean to match a non-newline. For non-patterns, named
3497 * characters are converted to their string equivalents. In
3498 * patterns, named characters are not converted to their
3499 * ultimate forms for the same reasons that other escapes
3500 * aren't. Instead, they are converted to the \N{U+...} form
3501 * to get the value from the charnames that is in effect right
3502 * now, while preserving the fact that it was a named character
3503 * so that the regex compiler knows this */
3505 /* This section of code doesn't generally use the
3506 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3507 * a close examination of this macro and determined it is a
3508 * no-op except on utfebcdic variant characters. Every
3509 * character generated by this that would normally need to be
3510 * enclosed by this macro is invariant, so the macro is not
3511 * needed, and would complicate use of copy(). XXX There are
3512 * other parts of this file where the macro is used
3513 * inconsistently, but are saved by it being a no-op */
3515 /* The structure of this section of code (besides checking for
3516 * errors and upgrading to utf8) is:
3517 * Further disambiguate between the two meanings of \N, and if
3518 * not a charname, go process it elsewhere
3519 * If of form \N{U+...}, pass it through if a pattern;
3520 * otherwise convert to utf8
3521 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3522 * pattern; otherwise convert to utf8 */
3524 /* Here, s points to the 'N'; the test below is guaranteed to
3525 * succeed if we are being called on a pattern as we already
3526 * know from a test above that the next character is a '{'.
3527 * On a non-pattern \N must mean 'named sequence, which
3528 * requires braces */
3531 yyerror("Missing braces on \\N{}");
3536 /* If there is no matching '}', it is an error. */
3537 if (! (e = strchr(s, '}'))) {
3538 if (! PL_lex_inpat) {
3539 yyerror("Missing right brace on \\N{}");
3541 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3546 /* Here it looks like a named character */
3548 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3549 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3550 | PERL_SCAN_DISALLOW_PREFIX;
3553 /* For \N{U+...}, the '...' is a unicode value even on
3554 * EBCDIC machines */
3555 s += 2; /* Skip to next char after the 'U+' */
3557 uv = grok_hex(s, &len, &flags, NULL);
3558 if (len == 0 || len != (STRLEN)(e - s)) {
3559 yyerror("Invalid hexadecimal number in \\N{U+...}");
3566 /* On non-EBCDIC platforms, pass through to the regex
3567 * compiler unchanged. The reason we evaluated the
3568 * number above is to make sure there wasn't a syntax
3569 * error. But on EBCDIC we convert to native so
3570 * downstream code can continue to assume it's native
3572 s -= 5; /* Include the '\N{U+' */
3574 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3577 (unsigned int) UNI_TO_NATIVE(uv));
3579 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3583 else { /* Not a pattern: convert the hex to string */
3585 /* If destination is not in utf8, unconditionally
3586 * recode it to be so. This is because \N{} implies
3587 * Unicode semantics, and scalars have to be in utf8
3588 * to guarantee those semantics */
3590 SvCUR_set(sv, d - SvPVX_const(sv));
3593 /* See Note on sizing above. */
3594 sv_utf8_upgrade_flags_grow(
3596 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3597 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3598 d = SvPVX(sv) + SvCUR(sv);
3602 /* Add the string to the output */
3603 if (UNI_IS_INVARIANT(uv)) {
3606 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3609 else /* Here is \N{NAME} but not \N{U+...}. */
3610 if ((res = get_and_check_backslash_N_name(s, e)))
3613 const char *str = SvPV_const(res, len);
3616 if (! len) { /* The name resolved to an empty string */
3617 Copy("\\N{}", d, 4, char);
3621 /* In order to not lose information for the regex
3622 * compiler, pass the result in the specially made
3623 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3624 * the code points in hex of each character
3625 * returned by charnames */
3627 const char *str_end = str + len;
3628 const STRLEN off = d - SvPVX_const(sv);
3630 if (! SvUTF8(res)) {
3631 /* For the non-UTF-8 case, we can determine the
3632 * exact length needed without having to parse
3633 * through the string. Each character takes up
3634 * 2 hex digits plus either a trailing dot or
3636 d = off + SvGROW(sv, off
3638 + 6 /* For the "\N{U+", and
3640 + (STRLEN)(send - e));
3641 Copy("\\N{U+", d, 5, char);
3643 while (str < str_end) {
3645 my_snprintf(hex_string, sizeof(hex_string),
3646 "%02X.", (U8) *str);
3647 Copy(hex_string, d, 3, char);
3651 d--; /* We will overwrite below the final
3652 dot with a right brace */
3655 STRLEN char_length; /* cur char's byte length */
3657 /* and the number of bytes after this is
3658 * translated into hex digits */
3659 STRLEN output_length;
3661 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3662 * for max('U+', '.'); and 1 for NUL */
3663 char hex_string[2 * UTF8_MAXBYTES + 5];
3665 /* Get the first character of the result. */
3666 U32 uv = utf8n_to_uvuni((U8 *) str,
3670 /* Convert first code point to hex, including
3671 * the boiler plate before it. For all these,
3672 * we convert to native format so that
3673 * downstream code can continue to assume the
3674 * input is native */
3676 my_snprintf(hex_string, sizeof(hex_string),
3678 (unsigned int) UNI_TO_NATIVE(uv));
3680 /* Make sure there is enough space to hold it */
3681 d = off + SvGROW(sv, off
3683 + (STRLEN)(send - e)
3684 + 2); /* '}' + NUL */
3686 Copy(hex_string, d, output_length, char);
3689 /* For each subsequent character, append dot and
3690 * its ordinal in hex */
3691 while ((str += char_length) < str_end) {
3692 const STRLEN off = d - SvPVX_const(sv);
3693 U32 uv = utf8n_to_uvuni((U8 *) str,
3698 my_snprintf(hex_string,
3701 (unsigned int) UNI_TO_NATIVE(uv));
3703 d = off + SvGROW(sv, off
3705 + (STRLEN)(send - e)
3706 + 2); /* '}' + NUL */
3707 Copy(hex_string, d, output_length, char);
3712 *d++ = '}'; /* Done. Add the trailing brace */
3715 else { /* Here, not in a pattern. Convert the name to a
3718 /* If destination is not in utf8, unconditionally
3719 * recode it to be so. This is because \N{} implies
3720 * Unicode semantics, and scalars have to be in utf8
3721 * to guarantee those semantics */
3723 SvCUR_set(sv, d - SvPVX_const(sv));
3726 /* See Note on sizing above. */
3727 sv_utf8_upgrade_flags_grow(sv,
3728 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3729 len + (STRLEN)(send - s) + 1);
3730 d = SvPVX(sv) + SvCUR(sv);
3732 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3734 /* See Note on sizing above. (NOTE: SvCUR() is not
3735 * set correctly here). */
3736 const STRLEN off = d - SvPVX_const(sv);
3737 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3739 Copy(str, d, len, char);
3745 } /* End \N{NAME} */
3748 native_range = FALSE; /* \N{} is defined to be Unicode */
3750 s = e + 1; /* Point to just after the '}' */
3753 /* \c is a control character */
3757 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3760 yyerror("Missing control char name in \\c");
3764 /* printf-style backslashes, formfeeds, newlines, etc */
3766 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3769 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3772 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3775 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3778 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3781 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3784 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3790 } /* end if (backslash) */
3797 /* If we started with encoded form, or already know we want it,
3798 then encode the next character */
3799 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3803 /* One might think that it is wasted effort in the case of the
3804 * source being utf8 (this_utf8 == TRUE) to take the next character
3805 * in the source, convert it to an unsigned value, and then convert
3806 * it back again. But the source has not been validated here. The
3807 * routine that does the conversion checks for errors like
3810 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3811 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3813 SvCUR_set(sv, d - SvPVX_const(sv));
3816 /* See Note on sizing above. */
3817 sv_utf8_upgrade_flags_grow(sv,
3818 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3819 need + (STRLEN)(send - s) + 1);
3820 d = SvPVX(sv) + SvCUR(sv);
3822 } else if (need > len) {
3823 /* encoded value larger than old, may need extra space (NOTE:
3824 * SvCUR() is not set correctly here). See Note on sizing
3826 const STRLEN off = d - SvPVX_const(sv);
3827 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3831 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3833 if (uv > 255 && !dorange)
3834 native_range = FALSE;
3838 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3840 } /* while loop to process each character */
3842 /* terminate the string and set up the sv */
3844 SvCUR_set(sv, d - SvPVX_const(sv));
3845 if (SvCUR(sv) >= SvLEN(sv))
3846 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3847 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3850 if (PL_encoding && !has_utf8) {
3851 sv_recode_to_utf8(sv, PL_encoding);
3857 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3858 PL_sublex_info.sub_op->op_private |=
3859 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3863 /* shrink the sv if we allocated more than we used */
3864 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3865 SvPV_shrink_to_cur(sv);
3868 /* return the substring (via pl_yylval) only if we parsed anything */
3869 if (s > PL_bufptr) {
3870 SvREFCNT_inc_simple_void_NN(sv);
3871 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3872 && ! PL_parser->lex_re_reparsing)
3874 const char *const key = PL_lex_inpat ? "qr" : "q";
3875 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3879 if (PL_lex_inwhat == OP_TRANS) {
3882 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3885 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3893 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3896 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3898 LEAVE_with_name("scan_const");
3903 * Returns TRUE if there's more to the expression (e.g., a subscript),
3906 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3908 * ->[ and ->{ return TRUE
3909 * { and [ outside a pattern are always subscripts, so return TRUE
3910 * if we're outside a pattern and it's not { or [, then return FALSE
3911 * if we're in a pattern and the first char is a {
3912 * {4,5} (any digits around the comma) returns FALSE
3913 * if we're in a pattern and the first char is a [
3915 * [SOMETHING] has a funky algorithm to decide whether it's a
3916 * character class or not. It has to deal with things like
3917 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3918 * anything else returns TRUE
3921 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3924 S_intuit_more(pTHX_ char *s)
3928 PERL_ARGS_ASSERT_INTUIT_MORE;
3930 if (PL_lex_brackets)
3932 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3934 if (*s != '{' && *s != '[')
3939 /* In a pattern, so maybe we have {n,m}. */
3941 if (regcurly(s, FALSE)) {
3947 /* On the other hand, maybe we have a character class */
3950 if (*s == ']' || *s == '^')
3953 /* this is terrifying, and it works */
3956 const char * const send = strchr(s,']');
3957 unsigned char un_char, last_un_char;
3958 char tmpbuf[sizeof PL_tokenbuf * 4];
3960 if (!send) /* has to be an expression */
3962 weight = 2; /* let's weigh the evidence */
3966 else if (isDIGIT(*s)) {
3968 if (isDIGIT(s[1]) && s[2] == ']')
3974 Zero(seen,256,char);
3976 for (; s < send; s++) {
3977 last_un_char = un_char;
3978 un_char = (unsigned char)*s;
3983 weight -= seen[un_char] * 10;
3984 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3986 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3987 len = (int)strlen(tmpbuf);
3988 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3989 UTF ? SVf_UTF8 : 0, SVt_PV))
3994 else if (*s == '$' && s[1] &&
3995 strchr("[#!%*<>()-=",s[1])) {
3996 if (/*{*/ strchr("])} =",s[2]))
4005 if (strchr("wds]",s[1]))
4007 else if (seen[(U8)'\''] || seen[(U8)'"'])
4009 else if (strchr("rnftbxcav",s[1]))
4011 else if (isDIGIT(s[1])) {
4013 while (s[1] && isDIGIT(s[1]))
4023 if (strchr("aA01! ",last_un_char))
4025 if (strchr("zZ79~",s[1]))
4027 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4028 weight -= 5; /* cope with negative subscript */
4031 if (!isWORDCHAR(last_un_char)
4032 && !(last_un_char == '$' || last_un_char == '@'
4033 || last_un_char == '&')
4034 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4039 if (keyword(tmpbuf, d - tmpbuf, 0))
4042 if (un_char == last_un_char + 1)
4044 weight -= seen[un_char];
4049 if (weight >= 0) /* probably a character class */
4059 * Does all the checking to disambiguate
4061 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4062 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4064 * First argument is the stuff after the first token, e.g. "bar".
4066 * Not a method if foo is a filehandle.
4067 * Not a method if foo is a subroutine prototyped to take a filehandle.
4068 * Not a method if it's really "Foo $bar"
4069 * Method if it's "foo $bar"
4070 * Not a method if it's really "print foo $bar"
4071 * Method if it's really "foo package::" (interpreted as package->foo)
4072 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4073 * Not a method if bar is a filehandle or package, but is quoted with
4078 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
4081 char *s = start + (*start == '$');
4082 char tmpbuf[sizeof PL_tokenbuf];
4089 PERL_ARGS_ASSERT_INTUIT_METHOD;
4091 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4093 if (cv && SvPOK(cv)) {
4094 const char *proto = CvPROTO(cv);
4096 while (*proto && (isSPACE(*proto) || *proto == ';'))
4103 if (*start == '$') {
4104 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
4105 isUPPER(*PL_tokenbuf))
4108 len = start - SvPVX(PL_linestr);
4112 start = SvPVX(PL_linestr) + len;
4116 return *s == '(' ? FUNCMETH : METHOD;
4119 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4120 /* start is the beginning of the possible filehandle/object,
4121 * and s is the end of it
4122 * tmpbuf is a copy of it (but with single quotes as double colons)
4125 if (!keyword(tmpbuf, len, 0)) {
4126 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4130 soff = s - SvPVX(PL_linestr);
4134 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4135 if (indirgv && GvCVu(indirgv))
4137 /* filehandle or package name makes it a method */
4138 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4140 soff = s - SvPVX(PL_linestr);
4143 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4144 return 0; /* no assumptions -- "=>" quotes bareword */
4146 start_force(PL_curforce);
4147 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4148 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4149 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4151 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4152 ( UTF ? SVf_UTF8 : 0 )));
4157 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4159 return *s == '(' ? FUNCMETH : METHOD;
4165 /* Encoded script support. filter_add() effectively inserts a
4166 * 'pre-processing' function into the current source input stream.
4167 * Note that the filter function only applies to the current source file
4168 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4170 * The datasv parameter (which may be NULL) can be used to pass
4171 * private data to this instance of the filter. The filter function
4172 * can recover the SV using the FILTER_DATA macro and use it to
4173 * store private buffers and state information.
4175 * The supplied datasv parameter is upgraded to a PVIO type
4176 * and the IoDIRP/IoANY field is used to store the function pointer,
4177 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4178 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4179 * private use must be set using malloc'd pointers.
4183 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4192 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4193 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4195 if (!PL_rsfp_filters)
4196 PL_rsfp_filters = newAV();
4199 SvUPGRADE(datasv, SVt_PVIO);
4200 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4201 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4202 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4203 FPTR2DPTR(void *, IoANY(datasv)),
4204 SvPV_nolen(datasv)));
4205 av_unshift(PL_rsfp_filters, 1);
4206 av_store(PL_rsfp_filters, 0, datasv) ;
4208 !PL_parser->filtered
4209 && PL_parser->lex_flags & LEX_EVALBYTES
4210 && PL_bufptr < PL_bufend
4212 const char *s = PL_bufptr;
4213 while (s < PL_bufend) {
4215 SV *linestr = PL_parser->linestr;
4216 char *buf = SvPVX(linestr);
4217 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4218 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4219 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4220 STRLEN const linestart_pos = PL_parser->linestart - buf;
4221 STRLEN const last_uni_pos =
4222 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4223 STRLEN const last_lop_pos =
4224 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4225 av_push(PL_rsfp_filters, linestr);
4226 PL_parser->linestr =
4227 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4228 buf = SvPVX(PL_parser->linestr);
4229 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4230 PL_parser->bufptr = buf + bufptr_pos;
4231 PL_parser->oldbufptr = buf + oldbufptr_pos;
4232 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4233 PL_parser->linestart = buf + linestart_pos;
4234 if (PL_parser->last_uni)
4235 PL_parser->last_uni = buf + last_uni_pos;
4236 if (PL_parser->last_lop)
4237 PL_parser->last_lop = buf + last_lop_pos;
4238 SvLEN(linestr) = SvCUR(linestr);
4239 SvCUR(linestr) = s-SvPVX(linestr);
4240 PL_parser->filtered = 1;
4250 /* Delete most recently added instance of this filter function. */
4252 Perl_filter_del(pTHX_ filter_t funcp)
4257 PERL_ARGS_ASSERT_FILTER_DEL;
4260 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4261 FPTR2DPTR(void*, funcp)));
4263 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4265 /* if filter is on top of stack (usual case) just pop it off */
4266 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4267 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4268 sv_free(av_pop(PL_rsfp_filters));
4272 /* we need to search for the correct entry and clear it */
4273 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4277 /* Invoke the idxth filter function for the current rsfp. */
4278 /* maxlen 0 = read one text line */
4280 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4285 /* This API is bad. It should have been using unsigned int for maxlen.
4286 Not sure if we want to change the API, but if not we should sanity
4287 check the value here. */
4288 unsigned int correct_length
4297 PERL_ARGS_ASSERT_FILTER_READ;
4299 if (!PL_parser || !PL_rsfp_filters)
4301 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4302 /* Provide a default input filter to make life easy. */
4303 /* Note that we append to the line. This is handy. */
4304 DEBUG_P(PerlIO_printf(Perl_debug_log,
4305 "filter_read %d: from rsfp\n", idx));
4306 if (correct_length) {
4309 const int old_len = SvCUR(buf_sv);
4311 /* ensure buf_sv is large enough */
4312 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4313 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4314 correct_length)) <= 0) {
4315 if (PerlIO_error(PL_rsfp))
4316 return -1; /* error */
4318 return 0 ; /* end of file */
4320 SvCUR_set(buf_sv, old_len + len) ;
4321 SvPVX(buf_sv)[old_len + len] = '\0';
4324 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4325 if (PerlIO_error(PL_rsfp))
4326 return -1; /* error */
4328 return 0 ; /* end of file */
4331 return SvCUR(buf_sv);
4333 /* Skip this filter slot if filter has been deleted */
4334 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4335 DEBUG_P(PerlIO_printf(Perl_debug_log,
4336 "filter_read %d: skipped (filter deleted)\n",
4338 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4340 if (SvTYPE(datasv) != SVt_PVIO) {
4341 if (correct_length) {
4343 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4344 if (!remainder) return 0; /* eof */
4345 if (correct_length > remainder) correct_length = remainder;
4346 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4347 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4350 const char *s = SvEND(datasv);
4351 const char *send = SvPVX(datasv) + SvLEN(datasv);
4359 if (s == send) return 0; /* eof */
4360 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4361 SvCUR_set(datasv, s-SvPVX(datasv));
4363 return SvCUR(buf_sv);
4365 /* Get function pointer hidden within datasv */
4366 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4367 DEBUG_P(PerlIO_printf(Perl_debug_log,
4368 "filter_read %d: via function %p (%s)\n",
4369 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4370 /* Call function. The function is expected to */
4371 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4372 /* Return: <0:error, =0:eof, >0:not eof */
4373 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4377 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4381 PERL_ARGS_ASSERT_FILTER_GETS;
4383 #ifdef PERL_CR_FILTER
4384 if (!PL_rsfp_filters) {
4385 filter_add(S_cr_textfilter,NULL);
4388 if (PL_rsfp_filters) {
4390 SvCUR_set(sv, 0); /* start with empty line */
4391 if (FILTER_READ(0, sv, 0) > 0)
4392 return ( SvPVX(sv) ) ;
4397 return (sv_gets(sv, PL_rsfp, append));
4401 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4406 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4408 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4412 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4413 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4415 return GvHV(gv); /* Foo:: */
4418 /* use constant CLASS => 'MyClass' */
4419 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4420 if (gv && GvCV(gv)) {
4421 SV * const sv = cv_const_sv(GvCV(gv));
4423 pkgname = SvPV_const(sv, len);
4426 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4430 * S_readpipe_override
4431 * Check whether readpipe() is overridden, and generates the appropriate
4432 * optree, provided sublex_start() is called afterwards.
4435 S_readpipe_override(pTHX)
4438 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4439 pl_yylval.ival = OP_BACKTICK;
4441 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4443 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4444 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4445 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4447 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4448 op_append_elem(OP_LIST,
4449 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4450 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4457 * The intent of this yylex wrapper is to minimize the changes to the
4458 * tokener when we aren't interested in collecting madprops. It remains
4459 * to be seen how successful this strategy will be...
4466 char *s = PL_bufptr;
4468 /* make sure PL_thiswhite is initialized */
4472 /* previous token ate up our whitespace? */
4473 if (!PL_lasttoke && PL_nextwhite) {
4474 PL_thiswhite = PL_nextwhite;
4478 /* isolate the token, and figure out where it is without whitespace */
4479 PL_realtokenstart = -1;
4483 assert(PL_curforce < 0);
4485 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4486 if (!PL_thistoken) {
4487 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4488 PL_thistoken = newSVpvs("");
4490 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4491 PL_thistoken = newSVpvn(tstart, s - tstart);
4494 if (PL_thismad) /* install head */
4495 CURMAD('X', PL_thistoken);
4498 /* last whitespace of a sublex? */
4499 if (optype == ')' && PL_endwhite) {
4500 CURMAD('X', PL_endwhite);
4505 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4506 if (!PL_thiswhite && !PL_endwhite && !optype) {
4507 sv_free(PL_thistoken);
4512 /* put off final whitespace till peg */
4513 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4514 PL_nextwhite = PL_thiswhite;
4517 else if (PL_thisopen) {
4518 CURMAD('q', PL_thisopen);
4520 sv_free(PL_thistoken);
4524 /* Store actual token text as madprop X */
4525 CURMAD('X', PL_thistoken);
4529 /* add preceding whitespace as madprop _ */
4530 CURMAD('_', PL_thiswhite);
4534 /* add quoted material as madprop = */
4535 CURMAD('=', PL_thisstuff);
4539 /* add terminating quote as madprop Q */
4540 CURMAD('Q', PL_thisclose);
4544 /* special processing based on optype */
4548 /* opval doesn't need a TOKEN since it can already store mp */
4558 if (pl_yylval.opval)
4559 append_madprops(PL_thismad, pl_yylval.opval, 0);
4567 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4580 /* remember any fake bracket that lexer is about to discard */
4581 if (PL_lex_brackets == 1 &&
4582 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4585 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4588 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4589 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4592 break; /* don't bother looking for trailing comment */
4601 /* attach a trailing comment to its statement instead of next token */
4605 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4607 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4609 if (*s == '\n' || *s == '#') {
4610 while (s < PL_bufend && *s != '\n')
4614 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4615 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4628 /* Create new token struct. Note: opvals return early above. */
4629 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4636 S_tokenize_use(pTHX_ int is_use, char *s) {
4639 PERL_ARGS_ASSERT_TOKENIZE_USE;
4641 if (PL_expect != XSTATE)
4642 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4643 is_use ? "use" : "no"));
4646 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4647 s = force_version(s, TRUE);
4648 if (*s == ';' || *s == '}'
4649 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4650 start_force(PL_curforce);
4651 NEXTVAL_NEXTTOKE.opval = NULL;
4654 else if (*s == 'v') {
4655 s = force_word(s,WORD,FALSE,TRUE);
4656 s = force_version(s, FALSE);
4660 s = force_word(s,WORD,FALSE,TRUE);
4661 s = force_version(s, FALSE);
4663 pl_yylval.ival = is_use;
4667 static const char* const exp_name[] =
4668 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4669 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4673 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4675 S_word_takes_any_delimeter(char *p, STRLEN len)
4677 return (len == 1 && strchr("msyq", p[0])) ||
4679 (p[0] == 't' && p[1] == 'r') ||
4680 (p[0] == 'q' && strchr("qwxr", p[1]))));
4686 Works out what to call the token just pulled out of the input
4687 stream. The yacc parser takes care of taking the ops we return and
4688 stitching them into a tree.
4691 The type of the next token
4694 Switch based on the current state:
4695 - if we already built the token before, use it
4696 - if we have a case modifier in a string, deal with that
4697 - handle other cases of interpolation inside a string
4698 - scan the next line if we are inside a format
4699 In the normal state switch on the next character:
4701 if alphabetic, go to key lookup
4702 unrecoginized character - croak
4703 - 0/4/26: handle end-of-line or EOF
4704 - cases for whitespace
4705 - \n and #: handle comments and line numbers
4706 - various operators, brackets and sigils
4709 - 'v': vstrings (or go to key lookup)
4710 - 'x' repetition operator (or go to key lookup)
4711 - other ASCII alphanumerics (key lookup begins here):
4714 scan built-in keyword (but do nothing with it yet)
4715 check for statement label
4716 check for lexical subs
4717 goto just_a_word if there is one
4718 see whether built-in keyword is overridden
4719 switch on keyword number:
4720 - default: just_a_word:
4721 not a built-in keyword; handle bareword lookup
4722 disambiguate between method and sub call
4723 fall back to bareword
4724 - cases for built-in keywords
4729 #pragma segment Perl_yylex
4735 char *s = PL_bufptr;
4739 const bool saw_infix_sigil = PL_parser->saw_infix_sigil;
4743 /* orig_keyword, gvp, and gv are initialized here because
4744 * jump to the label just_a_word_zero can bypass their
4745 * initialization later. */
4746 I32 orig_keyword = 0;
4751 SV* tmp = newSVpvs("");
4752 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4753 (IV)CopLINE(PL_curcop),
4754 lex_state_names[PL_lex_state],
4755 exp_name[PL_expect],
4756 pv_display(tmp, s, strlen(s), 0, 60));
4760 switch (PL_lex_state) {
4762 case LEX_NORMAL: /* Some compilers will produce faster */
4763 case LEX_INTERPNORMAL: /* code if we comment these out. */
4767 /* when we've already built the next token, just pull it out of the queue */
4771 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4773 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4774 PL_nexttoke[PL_lasttoke].next_mad = 0;
4775 if (PL_thismad && PL_thismad->mad_key == '_') {
4776 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4777 PL_thismad->mad_val = 0;
4778 mad_free(PL_thismad);
4783 PL_lex_state = PL_lex_defer;
4784 PL_expect = PL_lex_expect;
4785 PL_lex_defer = LEX_NORMAL;
4786 if (!PL_nexttoke[PL_lasttoke].next_type)
4791 pl_yylval = PL_nextval[PL_nexttoke];
4793 PL_lex_state = PL_lex_defer;
4794 PL_expect = PL_lex_expect;
4795 PL_lex_defer = LEX_NORMAL;
4801 next_type = PL_nexttoke[PL_lasttoke].next_type;
4803 next_type = PL_nexttype[PL_nexttoke];
4805 if (next_type & (7<<24)) {
4806 if (next_type & (1<<24)) {
4807 if (PL_lex_brackets > 100)
4808 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4809 PL_lex_brackstack[PL_lex_brackets++] =
4810 (char) ((next_type >> 16) & 0xff);
4812 if (next_type & (2<<24))
4813 PL_lex_allbrackets++;
4814 if (next_type & (4<<24))
4815 PL_lex_allbrackets--;
4816 next_type &= 0xffff;
4818 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4821 /* interpolated case modifiers like \L \U, including \Q and \E.
4822 when we get here, PL_bufptr is at the \
4824 case LEX_INTERPCASEMOD:
4826 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4828 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4829 PL_bufptr, PL_bufend, *PL_bufptr);
4831 /* handle \E or end of string */
4832 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4834 if (PL_lex_casemods) {
4835 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4836 PL_lex_casestack[PL_lex_casemods] = '\0';
4838 if (PL_bufptr != PL_bufend
4839 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4840 || oldmod == 'F')) {
4842 PL_lex_state = LEX_INTERPCONCAT;
4845 PL_thistoken = newSVpvs("\\E");
4848 PL_lex_allbrackets--;
4851 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4852 /* Got an unpaired \E */
4853 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4854 "Useless use of \\E");
4857 while (PL_bufptr != PL_bufend &&
4858 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4861 PL_thiswhite = newSVpvs("");
4862 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4867 if (PL_bufptr != PL_bufend)
4870 PL_lex_state = LEX_INTERPCONCAT;
4874 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4875 "### Saw case modifier\n"); });
4877 if (s[1] == '\\' && s[2] == 'E') {
4881 PL_thiswhite = newSVpvs("");
4882 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4886 PL_lex_state = LEX_INTERPCONCAT;
4891 if (!PL_madskills) /* when just compiling don't need correct */
4892 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4893 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4894 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4895 (strchr(PL_lex_casestack, 'L')
4896 || strchr(PL_lex_casestack, 'U')
4897 || strchr(PL_lex_casestack, 'F'))) {
4898 PL_lex_casestack[--PL_lex_casemods] = '\0';
4899 PL_lex_allbrackets--;
4902 if (PL_lex_casemods > 10)
4903 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4904 PL_lex_casestack[PL_lex_casemods++] = *s;
4905 PL_lex_casestack[PL_lex_casemods] = '\0';
4906 PL_lex_state = LEX_INTERPCONCAT;
4907 start_force(PL_curforce);
4908 NEXTVAL_NEXTTOKE.ival = 0;
4909 force_next((2<<24)|'(');
4910 start_force(PL_curforce);
4912 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4914 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4916 NEXTVAL_NEXTTOKE.ival = OP_LC;
4918 NEXTVAL_NEXTTOKE.ival = OP_UC;
4920 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4922 NEXTVAL_NEXTTOKE.ival = OP_FC;
4924 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4926 SV* const tmpsv = newSVpvs("\\ ");
4927 /* replace the space with the character we want to escape
4929 SvPVX(tmpsv)[1] = *s;
4935 if (PL_lex_starts) {
4941 sv_free(PL_thistoken);
4942 PL_thistoken = newSVpvs("");
4945 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4946 if (PL_lex_casemods == 1 && PL_lex_inpat)
4955 case LEX_INTERPPUSH:
4956 return REPORT(sublex_push());
4958 case LEX_INTERPSTART:
4959 if (PL_bufptr == PL_bufend)
4960 return REPORT(sublex_done());
4961 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4962 "### Interpolated variable\n"); });
4964 /* for /@a/, we leave the joining for the regex engine to do
4965 * (unless we're within \Q etc) */
4966 PL_lex_dojoin = (*PL_bufptr == '@'
4967 && (!PL_lex_inpat || PL_lex_casemods));
4968 PL_lex_state = LEX_INTERPNORMAL;
4969 if (PL_lex_dojoin) {
4970 start_force(PL_curforce);
4971 NEXTVAL_NEXTTOKE.ival = 0;
4973 start_force(PL_curforce);
4974 force_ident("\"", '$');
4975 start_force(PL_curforce);
4976 NEXTVAL_NEXTTOKE.ival = 0;
4978 start_force(PL_curforce);
4979 NEXTVAL_NEXTTOKE.ival = 0;
4980 force_next((2<<24)|'(');
4981 start_force(PL_curforce);
4982 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4985 /* Convert (?{...}) and friends to 'do {...}' */
4986 if (PL_lex_inpat && *PL_bufptr == '(') {
4987 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4989 if (*PL_bufptr != '{')
4991 start_force(PL_curforce);
4992 /* XXX probably need a CURMAD(something) here */
4993 PL_expect = XTERMBLOCK;
4997 if (PL_lex_starts++) {
5002 sv_free(PL_thistoken);
5003 PL_thistoken = newSVpvs("");
5006 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5007 if (!PL_lex_casemods && PL_lex_inpat)
5014 case LEX_INTERPENDMAYBE:
5015 if (intuit_more(PL_bufptr)) {
5016 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
5022 if (PL_lex_dojoin) {
5023 PL_lex_dojoin = FALSE;
5024 PL_lex_state = LEX_INTERPCONCAT;
5028 sv_free(PL_thistoken);
5029 PL_thistoken = newSVpvs("");
5032 PL_lex_allbrackets--;
5035 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
5036 && SvEVALED(PL_lex_repl))
5038 if (PL_bufptr != PL_bufend)
5039 Perl_croak(aTHX_ "Bad evalled substitution pattern");
5042 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
5043 re_eval_str. If the here-doc body’s length equals the previous
5044 value of re_eval_start, re_eval_start will now be null. So
5045 check re_eval_str as well. */
5046 if (PL_parser->lex_shared->re_eval_start
5047 || PL_parser->lex_shared->re_eval_str) {
5049 if (*PL_bufptr != ')')
5050 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5052 /* having compiled a (?{..}) expression, return the original
5053 * text too, as a const */
5054 if (PL_parser->lex_shared->re_eval_str) {
5055 sv = PL_parser->lex_shared->re_eval_str;
5056 PL_parser->lex_shared->re_eval_str = NULL;
5058 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5059 SvPV_shrink_to_cur(sv);
5061 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5062 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5063 start_force(PL_curforce);
5064 /* XXX probably need a CURMAD(something) here */
5065 NEXTVAL_NEXTTOKE.opval =
5066 (OP*)newSVOP(OP_CONST, 0,
5069 PL_parser->lex_shared->re_eval_start = NULL;
5075 case LEX_INTERPCONCAT:
5077 if (PL_lex_brackets)
5078 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5079 (long) PL_lex_brackets);
5081 if (PL_bufptr == PL_bufend)
5082 return REPORT(sublex_done());
5084 /* m'foo' still needs to be parsed for possible (?{...}) */
5085 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5086 SV *sv = newSVsv(PL_linestr);
5088 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5092 s = scan_const(PL_bufptr);
5094 PL_lex_state = LEX_INTERPCASEMOD;
5096 PL_lex_state = LEX_INTERPSTART;
5099 if (s != PL_bufptr) {
5100 start_force(PL_curforce);
5102 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
5104 NEXTVAL_NEXTTOKE = pl_yylval;
5107 if (PL_lex_starts++) {
5111 sv_free(PL_thistoken);
5112 PL_thistoken = newSVpvs("");
5115 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5116 if (!PL_lex_casemods && PL_lex_inpat)
5129 s = scan_formline(PL_bufptr);
5130 if (!PL_lex_formbrack)
5140 PL_oldoldbufptr = PL_oldbufptr;
5142 PL_parser->saw_infix_sigil = 0;
5147 sv_free(PL_thistoken);
5150 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
5154 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
5157 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5158 const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
5160 SVs_TEMP | SVf_UTF8),
5161 10, UNI_DISPLAY_ISPRINT))
5162 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5163 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
5164 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5165 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
5173 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
5177 goto fake_eof; /* emulate EOF on ^D or ^Z */
5183 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
5186 if (PL_lex_brackets &&
5187 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
5188 yyerror((const char *)
5190 ? "Format not terminated"
5191 : "Missing right curly or square bracket"));
5193 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5194 "### Tokener got EOF\n");
5198 if (s++ < PL_bufend)
5199 goto retry; /* ignore stray nulls */
5202 if (!PL_in_eval && !PL_preambled) {
5203 PL_preambled = TRUE;
5209 /* Generate a string of Perl code to load the debugger.
5210 * If PERL5DB is set, it will return the contents of that,
5211 * otherwise a compile-time require of perl5db.pl. */
5213 const char * const pdb = PerlEnv_getenv("PERL5DB");
5216 sv_setpv(PL_linestr, pdb);
5217 sv_catpvs(PL_linestr,";");
5219 SETERRNO(0,SS_NORMAL);
5220 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5223 sv_setpvs(PL_linestr,"");
5224 if (PL_preambleav) {
5225 SV **svp = AvARRAY(PL_preambleav);
5226 SV **const end = svp + AvFILLp(PL_preambleav);
5228 sv_catsv(PL_linestr, *svp);
5230 sv_catpvs(PL_linestr, ";");
5232 sv_free(MUTABLE_SV(PL_preambleav));
5233 PL_preambleav = NULL;
5236 sv_catpvs(PL_linestr,
5237 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5238 if (PL_minus_n || PL_minus_p) {
5239 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5241 sv_catpvs(PL_linestr,"chomp;");
5244 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
5245 || *PL_splitstr == '"')
5246 && strchr(PL_splitstr + 1, *PL_splitstr))
5247 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5249 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5250 bytes can be used as quoting characters. :-) */
5251 const char *splits = PL_splitstr;
5252 sv_catpvs(PL_linestr, "our @F=split(q\0");
5255 if (*splits == '\\')
5256 sv_catpvn(PL_linestr, splits, 1);
5257 sv_catpvn(PL_linestr, splits, 1);
5258 } while (*splits++);
5259 /* This loop will embed the trailing NUL of
5260 PL_linestr as the last thing it does before
5262 sv_catpvs(PL_linestr, ");");
5266 sv_catpvs(PL_linestr,"our @F=split(' ');");
5269 sv_catpvs(PL_linestr, "\n");
5270 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5271 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5272 PL_last_lop = PL_last_uni = NULL;
5273 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
5274 update_debugger_info(PL_linestr, NULL, 0);
5279 bof = PL_rsfp ? TRUE : FALSE;
5282 fake_eof = LEX_FAKE_EOF;
5284 PL_bufptr = PL_bufend;
5285 COPLINE_INC_WITH_HERELINES;
5286 if (!lex_next_chunk(fake_eof)) {
5287 CopLINE_dec(PL_curcop);
5289 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5291 CopLINE_dec(PL_curcop);
5294 PL_realtokenstart = -1;
5297 /* If it looks like the start of a BOM or raw UTF-16,
5298 * check if it in fact is. */
5299 if (bof && PL_rsfp &&
5304 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5305 bof = (offset == (Off_t)SvCUR(PL_linestr));
5306 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5307 /* offset may include swallowed CR */
5309 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5312 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5313 s = swallow_bom((U8*)s);
5316 if (PL_parser->in_pod) {
5317 /* Incest with pod. */
5320 sv_catsv(PL_thiswhite, PL_linestr);
5322 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
5323 sv_setpvs(PL_linestr, "");
5324 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5325 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5326 PL_last_lop = PL_last_uni = NULL;
5327 PL_parser->in_pod = 0;
5330 if (PL_rsfp || PL_parser->filtered)
5332 } while (PL_parser->in_pod);
5333 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5334 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5335 PL_last_lop = PL_last_uni = NULL;
5336 if (CopLINE(PL_curcop) == 1) {
5337 while (s < PL_bufend && isSPACE(*s))
5339 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5343 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
5347 if (*s == '#' && *(s+1) == '!')
5349 #ifdef ALTERNATE_SHEBANG
5351 static char const as[] = ALTERNATE_SHEBANG;
5352 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5353 d = s + (sizeof(as) - 1);
5355 #endif /* ALTERNATE_SHEBANG */
5364 while (*d && !isSPACE(*d))
5368 #ifdef ARG_ZERO_IS_SCRIPT
5369 if (ipathend > ipath) {
5371 * HP-UX (at least) sets argv[0] to the script name,
5372 * which makes $^X incorrect. And Digital UNIX and Linux,
5373 * at least, set argv[0] to the basename of the Perl
5374 * interpreter. So, having found "#!", we'll set it right.
5376 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5378 assert(SvPOK(x) || SvGMAGICAL(x));
5379 if (sv_eq(x, CopFILESV(PL_curcop))) {
5380 sv_setpvn(x, ipath, ipathend - ipath);
5386 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
5387 const char * const lstart = SvPV_const(x,llen);
5389 bstart += blen - llen;
5390 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5391 sv_setpvn(x, ipath, ipathend - ipath);
5396 TAINT_NOT; /* $^X is always tainted, but that's OK */
5398 #endif /* ARG_ZERO_IS_SCRIPT */
5403 d = instr(s,"perl -");
5405 d = instr(s,"perl");
5407 /* avoid getting into infinite loops when shebang
5408 * line contains "Perl" rather than "perl" */
5410 for (d = ipathend-4; d >= ipath; --d) {
5411 if ((*d == 'p' || *d == 'P')
5412 && !ibcmp(d, "perl", 4))
5422 #ifdef ALTERNATE_SHEBANG
5424 * If the ALTERNATE_SHEBANG on this system starts with a
5425 * character that can be part of a Perl expression, then if
5426 * we see it but not "perl", we're probably looking at the
5427 * start of Perl code, not a request to hand off to some
5428 * other interpreter. Similarly, if "perl" is there, but
5429 * not in the first 'word' of the line, we assume the line
5430 * contains the start of the Perl program.
5432 if (d && *s != '#') {
5433 const char *c = ipath;
5434 while (*c && !strchr("; \t\r\n\f\v#", *c))
5437 d = NULL; /* "perl" not in first word; ignore */
5439 *s = '#'; /* Don't try to parse shebang line */
5441 #endif /* ALTERNATE_SHEBANG */
5446 !instr(s,"indir") &&
5447 instr(PL_origargv[0],"perl"))
5454 while (s < PL_bufend && isSPACE(*s))
5456 if (s < PL_bufend) {
5457 Newx(newargv,PL_origargc+3,char*);
5459 while (s < PL_bufend && !isSPACE(*s))
5462 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5465 newargv = PL_origargv;
5468 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5470 Perl_croak(aTHX_ "Can't exec %s", ipath);
5473 while (*d && !isSPACE(*d))
5475 while (SPACE_OR_TAB(*d))
5479 const bool switches_done = PL_doswitches;
5480 const U32 oldpdb = PL_perldb;
5481 const bool oldn = PL_minus_n;
5482 const bool oldp = PL_minus_p;
5486 bool baduni = FALSE;
5488 const char *d2 = d1 + 1;
5489 if (parse_unicode_opts((const char **)&d2)
5493 if (baduni || *d1 == 'M' || *d1 == 'm') {
5494 const char * const m = d1;
5495 while (*d1 && !isSPACE(*d1))
5497 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5500 d1 = moreswitches(d1);
5502 if (PL_doswitches && !switches_done) {
5503 int argc = PL_origargc;
5504 char **argv = PL_origargv;
5507 } while (argc && argv[0][0] == '-' && argv[0][1]);
5508 init_argv_symbols(argc,argv);
5510 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5511 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5512 /* if we have already added "LINE: while (<>) {",
5513 we must not do it again */
5515 sv_setpvs(PL_linestr, "");
5516 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5517 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5518 PL_last_lop = PL_last_uni = NULL;
5519 PL_preambled = FALSE;
5520 if (PERLDB_LINE || PERLDB_SAVESRC)
5521 (void)gv_fetchfile(PL_origfilename);
5528 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5529 PL_lex_state = LEX_FORMLINE;
5530 start_force(PL_curforce);
5531 NEXTVAL_NEXTTOKE.ival = 0;
5532 force_next(FORMRBRACK);
5537 #ifdef PERL_STRICT_CR
5538 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5540 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5542 case ' ': case '\t': case '\f': case 013:
5544 PL_realtokenstart = -1;
5547 PL_thiswhite = newSVpvs("");
5548 sv_catpvn(PL_thiswhite, s, 1);
5556 PL_realtokenstart = -1;
5560 if (PL_lex_state != LEX_NORMAL ||
5561 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
5562 if (*s == '#' && s == PL_linestart && PL_in_eval
5563 && !PL_rsfp && !PL_parser->filtered) {
5564 /* handle eval qq[#line 1 "foo"\n ...] */
5565 CopLINE_dec(PL_curcop);
5568 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5570 if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
5574 const bool in_comment = *s == '#';
5576 while (d < PL_bufend && *d != '\n')
5580 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5581 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5585 PL_thiswhite = newSVpvn(s, d - s);
5588 if (in_comment && d == PL_bufend
5589 && PL_lex_state == LEX_INTERPNORMAL
5590 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5591 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5594 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5595 PL_lex_state = LEX_FORMLINE;
5596 start_force(PL_curforce);
5597 NEXTVAL_NEXTTOKE.ival = 0;
5598 force_next(FORMRBRACK);
5604 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5605 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5608 TOKEN(PEG); /* make sure any #! line is accessible */
5613 /* if (PL_madskills && PL_lex_formbrack) { */
5615 while (d < PL_bufend && *d != '\n')
5619 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5620 Perl_croak(aTHX_ "panic: input overflow");
5621 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5623 PL_thiswhite = newSVpvs("");
5624 if (CopLINE(PL_curcop) == 1) {
5625 sv_setpvs(PL_thiswhite, "");
5628 sv_catpvn(PL_thiswhite, s, d - s);
5642 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5650 while (s < PL_bufend && SPACE_OR_TAB(*s))
5653 if (strnEQ(s,"=>",2)) {
5654 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5655 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5656 OPERATOR('-'); /* unary minus */
5658 PL_last_uni = PL_oldbufptr;
5660 case 'r': ftst = OP_FTEREAD; break;
5661 case 'w': ftst = OP_FTEWRITE; break;
5662 case 'x': ftst = OP_FTEEXEC; break;
5663 case 'o': ftst = OP_FTEOWNED; break;
5664 case 'R': ftst = OP_FTRREAD; break;
5665 case 'W': ftst = OP_FTRWRITE; break;
5666 case 'X': ftst = OP_FTREXEC; break;
5667 case 'O': ftst = OP_FTROWNED; break;
5668 case 'e': ftst = OP_FTIS; break;
5669 case 'z': ftst = OP_FTZERO; break;
5670 case 's': ftst = OP_FTSIZE; break;
5671 case 'f': ftst = OP_FTFILE; break;
5672 case 'd': ftst = OP_FTDIR; break;
5673 case 'l': ftst = OP_FTLINK; break;
5674 case 'p': ftst = OP_FTPIPE; break;
5675 case 'S': ftst = OP_FTSOCK; break;
5676 case 'u': ftst = OP_FTSUID; break;
5677 case 'g': ftst = OP_FTSGID; break;
5678 case 'k': ftst = OP_FTSVTX; break;
5679 case 'b': ftst = OP_FTBLK; break;
5680 case 'c': ftst = OP_FTCHR; break;
5681 case 't': ftst = OP_FTTTY; break;
5682 case 'T': ftst = OP_FTTEXT; break;
5683 case 'B': ftst = OP_FTBINARY; break;
5684 case 'M': case 'A': case 'C':
5685 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5687 case 'M': ftst = OP_FTMTIME; break;
5688 case 'A': ftst = OP_FTATIME; break;
5689 case 'C': ftst = OP_FTCTIME; break;
5697 PL_last_lop_op = (OPCODE)ftst;
5698 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5699 "### Saw file test %c\n", (int)tmp);
5704 /* Assume it was a minus followed by a one-letter named
5705 * subroutine call (or a -bareword), then. */
5706 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5707 "### '-%c' looked like a file test but was not\n",
5714 const char tmp = *s++;
5717 if (PL_expect == XOPERATOR)
5722 else if (*s == '>') {
5725 if (isIDFIRST_lazy_if(s,UTF)) {
5726 s = force_word(s,METHOD,FALSE,TRUE);
5734 if (PL_expect == XOPERATOR) {
5735 if (*s == '=' && !PL_lex_allbrackets &&
5736 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5743 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5745 OPERATOR('-'); /* unary minus */
5751 const char tmp = *s++;
5754 if (PL_expect == XOPERATOR)
5759 if (PL_expect == XOPERATOR) {
5760 if (*s == '=' && !PL_lex_allbrackets &&
5761 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5768 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5775 if (PL_expect != XOPERATOR) {
5776 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5777 PL_expect = XOPERATOR;
5778 force_ident(PL_tokenbuf, '*');
5786 if (*s == '=' && !PL_lex_allbrackets &&
5787 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5793 if (*s == '=' && !PL_lex_allbrackets &&
5794 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5798 PL_parser->saw_infix_sigil = 1;
5802 if (PL_expect == XOPERATOR) {
5803 if (s[1] == '=' && !PL_lex_allbrackets &&
5804 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5807 PL_parser->saw_infix_sigil = 1;
5810 PL_tokenbuf[0] = '%';
5811 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5812 sizeof PL_tokenbuf - 1, FALSE);
5813 if (!PL_tokenbuf[1]) {
5816 PL_expect = XOPERATOR;
5817 force_ident_maybe_lex('%');
5821 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5822 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5827 if (PL_lex_brackets > 100)
5828 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5829 PL_lex_brackstack[PL_lex_brackets++] = 0;
5830 PL_lex_allbrackets++;
5832 const char tmp = *s++;
5837 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5839 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5842 Perl_ck_warner_d(aTHX_
5843 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5844 "Smartmatch is experimental");
5850 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5857 goto just_a_word_zero_gv;
5860 switch (PL_expect) {
5866 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5868 PL_bufptr = s; /* update in case we back off */
5871 "Use of := for an empty attribute list is not allowed");
5878 PL_expect = XTERMBLOCK;
5881 stuffstart = s - SvPVX(PL_linestr) - 1;
5885 while (isIDFIRST_lazy_if(s,UTF)) {
5888 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5889 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5890 if (tmp < 0) tmp = -tmp;
5905 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5907 d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
5909 /* MUST advance bufptr here to avoid bogus
5910 "at end of line" context messages from yyerror().
5912 PL_bufptr = s + len;
5913 yyerror("Unterminated attribute parameter in attribute list");
5917 return REPORT(0); /* EOF indicator */
5921 sv_catsv(sv, PL_lex_stuff);
5922 attrs = op_append_elem(OP_LIST, attrs,
5923 newSVOP(OP_CONST, 0, sv));
5924 SvREFCNT_dec(PL_lex_stuff);
5925 PL_lex_stuff = NULL;
5928 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5930 if (PL_in_my == KEY_our) {
5931 deprecate(":unique");
5934 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5937 /* NOTE: any CV attrs applied here need to be part of
5938 the CVf_BUILTIN_ATTRS define in cv.h! */
5939 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5941 CvLVALUE_on(PL_compcv);
5943 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5945 deprecate(":locked");
5947 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5949 CvMETHOD_on(PL_compcv);
5951 /* After we've set the flags, it could be argued that
5952 we don't need to do the attributes.pm-based setting
5953 process, and shouldn't bother appending recognized
5954 flags. To experiment with that, uncomment the
5955 following "else". (Note that's already been
5956 uncommented. That keeps the above-applied built-in
5957 attributes from being intercepted (and possibly
5958 rejected) by a package's attribute routines, but is
5959 justified by the performance win for the common case
5960 of applying only built-in attributes.) */
5962 attrs = op_append_elem(OP_LIST, attrs,
5963 newSVOP(OP_CONST, 0,
5967 if (*s == ':' && s[1] != ':')
5970 break; /* require real whitespace or :'s */
5971 /* XXX losing whitespace on sequential attributes here */
5975 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5976 if (*s != ';' && *s != '}' && *s != tmp
5977 && (tmp != '=' || *s != ')')) {
5978 const char q = ((*s == '\'') ? '"' : '\'');
5979 /* If here for an expression, and parsed no attrs, back
5981 if (tmp == '=' && !attrs) {
5985 /* MUST advance bufptr here to avoid bogus "at end of line"
5986 context messages from yyerror().
5989 yyerror( (const char *)
5991 ? Perl_form(aTHX_ "Invalid separator character "
5992 "%c%c%c in attribute list", q, *s, q)
5993 : "Unterminated attribute list" ) );
6001 start_force(PL_curforce);
6002 NEXTVAL_NEXTTOKE.opval = attrs;
6003 CURMAD('_', PL_nextwhite);
6008 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
6009 (s - SvPVX(PL_linestr)) - stuffstart);
6014 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6018 PL_lex_allbrackets--;
6022 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6023 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6027 PL_lex_allbrackets++;
6030 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6036 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6039 PL_lex_allbrackets--;
6045 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6048 if (PL_lex_brackets <= 0)
6049 yyerror("Unmatched right square bracket");
6052 PL_lex_allbrackets--;
6053 if (PL_lex_state == LEX_INTERPNORMAL) {
6054 if (PL_lex_brackets == 0) {
6055 if (*s == '-' && s[1] == '>')
6056 PL_lex_state = LEX_INTERPENDMAYBE;
6057 else if (*s != '[' && *s != '{')
6058 PL_lex_state = LEX_INTERPEND;
6065 if (PL_lex_brackets > 100) {
6066 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6068 switch (PL_expect) {
6070 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6071 PL_lex_allbrackets++;
6072 OPERATOR(HASHBRACK);
6074 while (s < PL_bufend && SPACE_OR_TAB(*s))
6077 PL_tokenbuf[0] = '\0';
6078 if (d < PL_bufend && *d == '-') {
6079 PL_tokenbuf[0] = '-';
6081 while (d < PL_bufend && SPACE_OR_TAB(*d))
6084 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
6085 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6087 while (d < PL_bufend && SPACE_OR_TAB(*d))
6090 const char minus = (PL_tokenbuf[0] == '-');
6091 s = force_word(s + minus, WORD, FALSE, TRUE);
6099 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6100 PL_lex_allbrackets++;
6105 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6106 PL_lex_allbrackets++;
6111 if (PL_oldoldbufptr == PL_last_lop)
6112 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6114 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6115 PL_lex_allbrackets++;
6118 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6120 /* This hack is to get the ${} in the message. */
6122 yyerror("syntax error");
6125 OPERATOR(HASHBRACK);
6127 /* This hack serves to disambiguate a pair of curlies
6128 * as being a block or an anon hash. Normally, expectation
6129 * determines that, but in cases where we're not in a
6130 * position to expect anything in particular (like inside
6131 * eval"") we have to resolve the ambiguity. This code
6132 * covers the case where the first term in the curlies is a
6133 * quoted string. Most other cases need to be explicitly
6134 * disambiguated by prepending a "+" before the opening
6135 * curly in order to force resolution as an anon hash.
6137 * XXX should probably propagate the outer expectation
6138 * into eval"" to rely less on this hack, but that could
6139 * potentially break current behavior of eval"".
6143 if (*s == '\'' || *s == '"' || *s == '`') {
6144 /* common case: get past first string, handling escapes */
6145 for (t++; t < PL_bufend && *t != *s;)
6146 if (*t++ == '\\' && (*t == '\\' || *t == *s))
6150 else if (*s == 'q') {
6153 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6154 && !isWORDCHAR(*t))))
6156 /* skip q//-like construct */
6158 char open, close, term;
6161 while (t < PL_bufend && isSPACE(*t))
6163 /* check for q => */
6164 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6165 OPERATOR(HASHBRACK);
6169 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6173 for (t++; t < PL_bufend; t++) {
6174 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6176 else if (*t == open)
6180 for (t++; t < PL_bufend; t++) {
6181 if (*t == '\\' && t+1 < PL_bufend)
6183 else if (*t == close && --brackets <= 0)
6185 else if (*t == open)
6192 /* skip plain q word */
6193 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6196 else if (isWORDCHAR_lazy_if(t,UTF)) {
6198 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6201 while (t < PL_bufend && isSPACE(*t))
6203 /* if comma follows first term, call it an anon hash */
6204 /* XXX it could be a comma expression with loop modifiers */
6205 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6206 || (*t == '=' && t[1] == '>')))
6207 OPERATOR(HASHBRACK);
6208 if (PL_expect == XREF)
6211 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6217 pl_yylval.ival = CopLINE(PL_curcop);
6218 if (isSPACE(*s) || *s == '#')
6219 PL_copline = NOLINE; /* invalidate current command line number */
6220 TOKEN(formbrack ? '=' : '{');
6222 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6226 if (PL_lex_brackets <= 0)
6227 yyerror("Unmatched right curly bracket");
6229 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6230 PL_lex_allbrackets--;
6231 if (PL_lex_state == LEX_INTERPNORMAL) {
6232 if (PL_lex_brackets == 0) {
6233 if (PL_expect & XFAKEBRACK) {
6234 PL_expect &= XENUMMASK;
6235 PL_lex_state = LEX_INTERPEND;
6240 PL_thiswhite = newSVpvs("");
6241 sv_catpvs(PL_thiswhite,"}");
6244 return yylex(); /* ignore fake brackets */
6246 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6247 && SvEVALED(PL_lex_repl))
6248 PL_lex_state = LEX_INTERPEND;
6249 else if (*s == '-' && s[1] == '>')
6250 PL_lex_state = LEX_INTERPENDMAYBE;
6251 else if (*s != '[' && *s != '{')
6252 PL_lex_state = LEX_INTERPEND;
6255 if (PL_expect & XFAKEBRACK) {
6256 PL_expect &= XENUMMASK;
6258 return yylex(); /* ignore fake brackets */
6260 start_force(PL_curforce);
6262 curmad('X', newSVpvn(s-1,1));
6263 CURMAD('_', PL_thiswhite);
6265 force_next(formbrack ? '.' : '}');
6266 if (formbrack) LEAVE;
6268 if (PL_madskills && !PL_thistoken)
6269 PL_thistoken = newSVpvs("");
6271 if (formbrack == 2) { /* means . where arguments were expected */
6272 start_force(PL_curforce);
6280 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6281 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6288 if (PL_expect == XOPERATOR) {
6289 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
6290 && isIDFIRST_lazy_if(s,UTF))
6292 CopLINE_dec(PL_curcop);
6293 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6294 CopLINE_inc(PL_curcop);
6296 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6297 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6301 PL_parser->saw_infix_sigil = 1;
6305 PL_tokenbuf[0] = '&';
6306 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
6307 sizeof PL_tokenbuf - 1, TRUE);
6308 if (PL_tokenbuf[1]) {
6309 PL_expect = XOPERATOR;
6310 force_ident_maybe_lex('&');
6314 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6320 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6321 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6328 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6329 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6337 const char tmp = *s++;
6339 if (!PL_lex_allbrackets &&
6340 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6347 if (!PL_lex_allbrackets &&
6348 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
6356 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6357 && strchr("+-*/%.^&|<",tmp))
6358 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6359 "Reversed %c= operator",(int)tmp);
6361 if (PL_expect == XSTATE && isALPHA(tmp) &&
6362 (s == PL_linestart+1 || s[-2] == '\n') )
6364 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6365 || PL_lex_state != LEX_NORMAL) {
6370 if (strnEQ(s,"=cut",4)) {
6386 PL_thiswhite = newSVpvs("");
6387 sv_catpvn(PL_thiswhite, PL_linestart,
6388 PL_bufend - PL_linestart);
6392 PL_parser->in_pod = 1;
6396 if (PL_expect == XBLOCK) {
6398 #ifdef PERL_STRICT_CR
6399 while (SPACE_OR_TAB(*t))
6401 while (SPACE_OR_TAB(*t) || *t == '\r')
6404 if (*t == '\n' || *t == '#') {
6407 SAVEI8(PL_parser->form_lex_state);
6408 SAVEI32(PL_lex_formbrack);
6409 PL_parser->form_lex_state = PL_lex_state;
6410 PL_lex_formbrack = PL_lex_brackets + 1;
6414 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6423 const char tmp = *s++;
6425 /* was this !=~ where !~ was meant?
6426 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6428 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6429 const char *t = s+1;
6431 while (t < PL_bufend && isSPACE(*t))
6434 if (*t == '/' || *t == '?' ||
6435 ((*t == 'm' || *t == 's' || *t == 'y')
6436 && !isWORDCHAR(t[1])) ||
6437 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6438 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6439 "!=~ should be !~");
6441 if (!PL_lex_allbrackets &&
6442 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6454 if (PL_expect != XOPERATOR) {
6455 if (s[1] != '<' && !strchr(s,'>'))
6458 s = scan_heredoc(s);
6460 s = scan_inputsymbol(s);
6461 PL_expect = XOPERATOR;
6462 TOKEN(sublex_start());
6468 if (*s == '=' && !PL_lex_allbrackets &&
6469 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6473 SHop(OP_LEFT_SHIFT);
6478 if (!PL_lex_allbrackets &&
6479 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6486 if (!PL_lex_allbrackets &&
6487 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6495 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6503 const char tmp = *s++;
6505 if (*s == '=' && !PL_lex_allbrackets &&
6506 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6510 SHop(OP_RIGHT_SHIFT);
6512 else if (tmp == '=') {
6513 if (!PL_lex_allbrackets &&
6514 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6522 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6531 if (PL_expect == XOPERATOR) {
6532 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6533 return deprecate_commaless_var_list();
6537 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6538 PL_tokenbuf[0] = '@';
6539 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6540 sizeof PL_tokenbuf - 1, FALSE);
6541 if (PL_expect == XOPERATOR)
6542 no_op("Array length", s);
6543 if (!PL_tokenbuf[1])
6545 PL_expect = XOPERATOR;
6546 force_ident_maybe_lex('#');
6550 PL_tokenbuf[0] = '$';
6551 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6552 sizeof PL_tokenbuf - 1, FALSE);
6553 if (PL_expect == XOPERATOR)
6555 if (!PL_tokenbuf[1]) {
6557 yyerror("Final $ should be \\$ or $name");
6563 const char tmp = *s;
6564 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6567 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6568 && intuit_more(s)) {
6570 PL_tokenbuf[0] = '@';
6571 if (ckWARN(WARN_SYNTAX)) {
6574 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6577 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6578 while (t < PL_bufend && *t != ']')
6580 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6581 "Multidimensional syntax %.*s not supported",
6582 (int)((t - PL_bufptr) + 1), PL_bufptr);
6586 else if (*s == '{') {
6588 PL_tokenbuf[0] = '%';
6589 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6590 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6592 char tmpbuf[sizeof PL_tokenbuf];
6595 } while (isSPACE(*t));
6596 if (isIDFIRST_lazy_if(t,UTF)) {
6598 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6603 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6604 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6605 "You need to quote \"%"UTF8f"\"",
6606 UTF8fARG(UTF, len, tmpbuf));
6612 PL_expect = XOPERATOR;
6613 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6614 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6615 if (!islop || PL_last_lop_op == OP_GREPSTART)
6616 PL_expect = XOPERATOR;
6617 else if (strchr("$@\"'`q", *s))
6618 PL_expect = XTERM; /* e.g. print $fh "foo" */
6619 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6620 PL_expect = XTERM; /* e.g. print $fh &sub */
6621 else if (isIDFIRST_lazy_if(s,UTF)) {
6622 char tmpbuf[sizeof PL_tokenbuf];
6624 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6625 if ((t2 = keyword(tmpbuf, len, 0))) {
6626 /* binary operators exclude handle interpretations */
6638 PL_expect = XTERM; /* e.g. print $fh length() */
6643 PL_expect = XTERM; /* e.g. print $fh subr() */
6646 else if (isDIGIT(*s))
6647 PL_expect = XTERM; /* e.g. print $fh 3 */
6648 else if (*s == '.' && isDIGIT(s[1]))
6649 PL_expect = XTERM; /* e.g. print $fh .3 */
6650 else if ((*s == '?' || *s == '-' || *s == '+')
6651 && !isSPACE(s[1]) && s[1] != '=')
6652 PL_expect = XTERM; /* e.g. print $fh -1 */
6653 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6655 PL_expect = XTERM; /* e.g. print $fh /.../
6656 XXX except DORDOR operator
6658 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6660 PL_expect = XTERM; /* print $fh <<"EOF" */
6663 force_ident_maybe_lex('$');
6667 if (PL_expect == XOPERATOR)
6669 PL_tokenbuf[0] = '@';
6670 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6671 if (!PL_tokenbuf[1]) {
6674 if (PL_lex_state == LEX_NORMAL)
6676 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6678 PL_tokenbuf[0] = '%';
6680 /* Warn about @ where they meant $. */
6681 if (*s == '[' || *s == '{') {
6682 if (ckWARN(WARN_SYNTAX)) {
6683 const char *t = s + 1;
6684 while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6685 t += UTF ? UTF8SKIP(t) : 1;
6686 if (*t == '}' || *t == ']') {
6688 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6689 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
6690 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6691 "Scalar value %"UTF8f" better written as $%"UTF8f,
6692 UTF8fARG(UTF, t-PL_bufptr, PL_bufptr),
6693 UTF8fARG(UTF, t-PL_bufptr-1, PL_bufptr+1));
6698 PL_expect = XOPERATOR;
6699 force_ident_maybe_lex('@');
6702 case '/': /* may be division, defined-or, or pattern */
6703 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6704 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6705 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6710 case '?': /* may either be conditional or pattern */
6711 if (PL_expect == XOPERATOR) {
6714 if (!PL_lex_allbrackets &&
6715 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6719 PL_lex_allbrackets++;
6725 /* A // operator. */
6726 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6727 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6728 LEX_FAKEEOF_LOGIC)) {
6736 if (*s == '=' && !PL_lex_allbrackets &&
6737 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6746 /* Disable warning on "study /blah/" */
6747 if (PL_oldoldbufptr == PL_last_uni
6748 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6749 || memNE(PL_last_uni, "study", 5)
6750 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6754 deprecate("?PATTERN? without explicit operator");
6755 s = scan_pat(s,OP_MATCH);
6756 TERM(sublex_start());
6760 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6761 #ifdef PERL_STRICT_CR
6764 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6766 && (s == PL_linestart || s[-1] == '\n') )
6769 formbrack = 2; /* dot seen where arguments expected */
6772 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6776 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6779 if (!PL_lex_allbrackets &&
6780 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6787 pl_yylval.ival = OPf_SPECIAL;
6793 if (*s == '=' && !PL_lex_allbrackets &&
6794 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6801 case '0': case '1': case '2': case '3': case '4':
6802 case '5': case '6': case '7': case '8': case '9':
6803 s = scan_num(s, &pl_yylval);
6804 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6805 if (PL_expect == XOPERATOR)
6810 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6811 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6812 if (PL_expect == XOPERATOR) {
6813 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6814 return deprecate_commaless_var_list();
6821 pl_yylval.ival = OP_CONST;
6822 TERM(sublex_start());
6825 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6826 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6827 if (PL_expect == XOPERATOR) {
6828 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6829 return deprecate_commaless_var_list();
6836 pl_yylval.ival = OP_CONST;
6837 /* FIXME. I think that this can be const if char *d is replaced by
6838 more localised variables. */
6839 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6840 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6841 pl_yylval.ival = OP_STRINGIFY;
6845 TERM(sublex_start());
6848 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6849 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6850 if (PL_expect == XOPERATOR)
6851 no_op("Backticks",s);
6854 readpipe_override();
6855 TERM(sublex_start());
6859 if (PL_lex_inwhat && isDIGIT(*s))
6860 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6862 if (PL_expect == XOPERATOR)
6863 no_op("Backslash",s);
6867 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6868 char *start = s + 2;
6869 while (isDIGIT(*start) || *start == '_')
6871 if (*start == '.' && isDIGIT(start[1])) {
6872 s = scan_num(s, &pl_yylval);
6875 else if ((*start == ':' && start[1] == ':')
6876 || (PL_expect == XSTATE && *start == ':'))
6878 else if (PL_expect == XSTATE) {
6880 while (d < PL_bufend && isSPACE(*d)) d++;
6881 if (*d == ':') goto keylookup;
6883 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6884 if (!isALPHA(*start) && (PL_expect == XTERM
6885 || PL_expect == XREF || PL_expect == XSTATE
6886 || PL_expect == XTERMORDORDOR)) {
6887 GV *const gv = gv_fetchpvn_flags(s, start - s,
6888 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6890 s = scan_num(s, &pl_yylval);
6897 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6950 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6952 /* Some keywords can be followed by any delimiter, including ':' */
6953 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6955 /* x::* is just a word, unless x is "CORE" */
6956 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6960 while (d < PL_bufend && isSPACE(*d))
6961 d++; /* no comments skipped here, or s### is misparsed */
6963 /* Is this a word before a => operator? */
6964 if (*d == '=' && d[1] == '>') {
6967 = (OP*)newSVOP(OP_CONST, 0,
6968 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6969 pl_yylval.opval->op_private = OPpCONST_BARE;
6973 /* Check for plugged-in keyword */
6977 char *saved_bufptr = PL_bufptr;
6979 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6981 if (result == KEYWORD_PLUGIN_DECLINE) {
6982 /* not a plugged-in keyword */
6983 PL_bufptr = saved_bufptr;
6984 } else if (result == KEYWORD_PLUGIN_STMT) {
6985 pl_yylval.opval = o;
6988 return REPORT(PLUGSTMT);
6989 } else if (result == KEYWORD_PLUGIN_EXPR) {
6990 pl_yylval.opval = o;
6992 PL_expect = XOPERATOR;
6993 return REPORT(PLUGEXPR);
6995 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
7000 /* Check for built-in keyword */
7001 tmp = keyword(PL_tokenbuf, len, 0);
7003 /* Is this a label? */
7004 if (!anydelim && PL_expect == XSTATE
7005 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
7007 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
7008 pl_yylval.pval[len] = '\0';
7009 pl_yylval.pval[len+1] = UTF ? 1 : 0;
7014 /* Check for lexical sub */
7015 if (PL_expect != XOPERATOR) {
7016 char tmpbuf[sizeof PL_tokenbuf + 1];
7018 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7019 off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
7020 if (off != NOT_IN_PAD) {
7021 assert(off); /* we assume this is boolean-true below */
7022 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7023 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7024 HEK * const stashname = HvNAME_HEK(stash);
7025 sv = newSVhek(stashname);
7026 sv_catpvs(sv, "::");
7027 sv_catpvn_flags(sv, PL_tokenbuf, len,
7028 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7029 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7039 rv2cv_op = newOP(OP_PADANY, 0);
7040 rv2cv_op->op_targ = off;
7041 cv = find_lexical_cv(off);
7049 if (tmp < 0) { /* second-class keyword? */
7050 GV *ogv = NULL; /* override (winner) */
7051 GV *hgv = NULL; /* hidden (loser) */
7052 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7054 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7055 UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
7058 if (GvIMPORTED_CV(gv))
7060 else if (! CvMETHOD(cv))
7064 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7065 UTF ? -(I32)len : (I32)len, FALSE)) &&
7066 (gv = *gvp) && isGV_with_GP(gv) &&
7067 GvCVu(gv) && GvIMPORTED_CV(gv))
7074 tmp = 0; /* overridden by import or by GLOBAL */
7077 && -tmp==KEY_lock /* XXX generalizable kludge */
7080 tmp = 0; /* any sub overrides "weak" keyword */
7082 else { /* no override */
7084 if (tmp == KEY_dump) {
7085 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
7086 "dump() better written as CORE::dump()");
7090 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
7091 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7092 "Ambiguous call resolved as CORE::%s(), "
7093 "qualify as such or use &",
7101 default: /* not a keyword */
7102 /* Trade off - by using this evil construction we can pull the
7103 variable gv into the block labelled keylookup. If not, then
7104 we have to give it function scope so that the goto from the
7105 earlier ':' case doesn't bypass the initialisation. */
7107 just_a_word_zero_gv:
7119 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7120 const char penultchar =
7121 lastchar && PL_bufptr - 2 >= PL_linestart
7125 SV *nextPL_nextwhite = 0;
7129 /* Get the rest if it looks like a package qualifier */
7131 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7133 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7136 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
7137 UTF8fARG(UTF, len, PL_tokenbuf),
7138 *s == '\'' ? "'" : "::");
7143 if (PL_expect == XOPERATOR) {
7144 if (PL_bufptr == PL_linestart) {
7145 CopLINE_dec(PL_curcop);
7146 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7147 CopLINE_inc(PL_curcop);
7150 no_op("Bareword",s);
7153 /* Look for a subroutine with this name in current package,
7154 unless this is a lexical sub, or name is "Foo::",
7155 in which case Foo is a bareword
7156 (and a package name). */
7158 if (len > 2 && !PL_madskills &&
7159 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
7161 if (ckWARN(WARN_BAREWORD)
7162 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7163 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7164 "Bareword \"%"UTF8f"\" refers to nonexistent package",
7165 UTF8fARG(UTF, len, PL_tokenbuf));
7167 PL_tokenbuf[len] = '\0';
7173 /* Mustn't actually add anything to a symbol table.
7174 But also don't want to "initialise" any placeholder
7175 constants that might already be there into full
7176 blown PVGVs with attached PVCV. */
7177 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7178 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
7184 /* if we saw a global override before, get the right name */
7187 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7188 len ? len : strlen(PL_tokenbuf));
7190 SV * const tmp_sv = sv;
7191 sv = newSVpvs("CORE::GLOBAL::");
7192 sv_catsv(sv, tmp_sv);
7193 SvREFCNT_dec(tmp_sv);
7197 if (PL_madskills && !PL_thistoken) {
7198 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
7199 PL_thistoken = newSVpvn(start,s - start);
7200 PL_realtokenstart = s - SvPVX(PL_linestr);
7204 /* Presume this is going to be a bareword of some sort. */
7206 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
7207 pl_yylval.opval->op_private = OPpCONST_BARE;
7209 /* And if "Foo::", then that's what it certainly is. */
7215 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7216 const_op->op_private = OPpCONST_BARE;
7217 rv2cv_op = newCVREF(0, const_op);
7218 cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
7221 /* See if it's the indirect object for a list operator. */
7223 if (PL_oldoldbufptr &&
7224 PL_oldoldbufptr < PL_bufptr &&
7225 (PL_oldoldbufptr == PL_last_lop
7226 || PL_oldoldbufptr == PL_last_uni) &&
7227 /* NO SKIPSPACE BEFORE HERE! */
7228 (PL_expect == XREF ||
7229 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
7231 bool immediate_paren = *s == '(';
7233 /* (Now we can afford to cross potential line boundary.) */
7234 s = SKIPSPACE2(s,nextPL_nextwhite);
7236 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
7239 /* Two barewords in a row may indicate method call. */
7241 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
7242 (tmp = intuit_method(s, gv, cv))) {
7244 if (tmp == METHOD && !PL_lex_allbrackets &&
7245 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7246 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7250 /* If not a declared subroutine, it's an indirect object. */
7251 /* (But it's an indir obj regardless for sort.) */
7252 /* Also, if "_" follows a filetest operator, it's a bareword */
7255 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
7257 (PL_last_lop_op != OP_MAPSTART &&
7258 PL_last_lop_op != OP_GREPSTART))))
7259 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7260 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
7263 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7268 PL_expect = XOPERATOR;
7271 s = SKIPSPACE2(s,nextPL_nextwhite);
7272 PL_nextwhite = nextPL_nextwhite;
7277 /* Is this a word before a => operator? */
7278 if (*s == '=' && s[1] == '>' && !pkgname) {
7281 /* This is our own scalar, created a few lines above,
7283 SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv);
7284 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
7285 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
7286 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
7287 SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv);
7291 /* If followed by a paren, it's certainly a subroutine. */
7296 while (SPACE_OR_TAB(*d))
7298 if (*d == ')' && (sv = cv_const_sv(cv))) {
7305 PL_nextwhite = PL_thiswhite;
7308 start_force(PL_curforce);
7310 NEXTVAL_NEXTTOKE.opval =
7311 off ? rv2cv_op : pl_yylval.opval;
7312 PL_expect = XOPERATOR;
7315 PL_nextwhite = nextPL_nextwhite;
7316 curmad('X', PL_thistoken);
7317 PL_thistoken = newSVpvs("");
7321 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7322 else op_free(rv2cv_op), force_next(WORD);
7327 /* If followed by var or block, call it a method (unless sub) */
7329 if ((*s == '$' || *s == '{') && !cv) {
7331 PL_last_lop = PL_oldbufptr;
7332 PL_last_lop_op = OP_METHOD;
7333 if (!PL_lex_allbrackets &&
7334 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7335 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7339 /* If followed by a bareword, see if it looks like indir obj. */
7342 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
7343 && (tmp = intuit_method(s, gv, cv))) {
7345 if (tmp == METHOD && !PL_lex_allbrackets &&
7346 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7347 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7351 /* Not a method, so call it a subroutine (if defined) */
7354 if (lastchar == '-' && penultchar != '-') {
7355 const STRLEN l = len ? len : strlen(PL_tokenbuf);
7356 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7357 "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()",
7358 UTF8fARG(UTF, l, PL_tokenbuf),
7359 UTF8fARG(UTF, l, PL_tokenbuf));
7361 /* Check for a constant sub */
7362 if ((sv = cv_const_sv(cv))) {
7365 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7366 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7367 pl_yylval.opval->op_private = OPpCONST_FOLDED;
7368 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7372 op_free(pl_yylval.opval);
7374 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7375 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7376 PL_last_lop = PL_oldbufptr;
7377 PL_last_lop_op = OP_ENTERSUB;
7378 /* Is there a prototype? */
7385 STRLEN protolen = CvPROTOLEN(cv);
7386 const char *proto = CvPROTO(cv);
7388 proto = S_strip_spaces(aTHX_ proto, &protolen);
7391 if ((optional = *proto == ';'))
7394 while (*proto == ';');
7398 *proto == '$' || *proto == '_'
7399 || *proto == '*' || *proto == '+'
7404 *proto == '\\' && proto[1] && proto[2] == '\0'
7407 UNIPROTO(UNIOPSUB,optional);
7408 if (*proto == '\\' && proto[1] == '[') {
7409 const char *p = proto + 2;
7410 while(*p && *p != ']')
7412 if(*p == ']' && !p[1])
7413 UNIPROTO(UNIOPSUB,optional);
7415 if (*proto == '&' && *s == '{') {
7417 sv_setpvs(PL_subname, "__ANON__");
7419 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7420 if (!PL_lex_allbrackets &&
7421 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7422 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7429 PL_nextwhite = PL_thiswhite;
7432 start_force(PL_curforce);
7433 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7436 PL_nextwhite = nextPL_nextwhite;
7437 curmad('X', PL_thistoken);
7438 PL_thistoken = newSVpvs("");
7440 force_next(off ? PRIVATEREF : WORD);
7441 if (!PL_lex_allbrackets &&
7442 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7443 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7448 /* Guess harder when madskills require "best effort". */
7449 if (PL_madskills && (!gv || !GvCVu(gv))) {
7450 int probable_sub = 0;
7451 if (strchr("\"'`$@%0123456789!*+{[<", *s))
7453 else if (isALPHA(*s)) {
7457 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
7458 if (!keyword(tmpbuf, tmplen, 0))
7461 while (d < PL_bufend && isSPACE(*d))
7463 if (*d == '=' && d[1] == '>')
7468 gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
7470 op_free(pl_yylval.opval);
7472 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7473 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7474 PL_last_lop = PL_oldbufptr;
7475 PL_last_lop_op = OP_ENTERSUB;
7476 PL_nextwhite = PL_thiswhite;
7478 start_force(PL_curforce);
7479 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7481 PL_nextwhite = nextPL_nextwhite;
7482 curmad('X', PL_thistoken);
7483 PL_thistoken = newSVpvs("");
7484 force_next(off ? PRIVATEREF : WORD);
7485 if (!PL_lex_allbrackets &&
7486 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7487 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7491 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7493 force_next(off ? PRIVATEREF : WORD);
7494 if (!PL_lex_allbrackets &&
7495 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7496 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7501 /* Call it a bare word */
7503 if (PL_hints & HINT_STRICT_SUBS)
7504 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7507 /* after "print" and similar functions (corresponding to
7508 * "F? L" in opcode.pl), whatever wasn't already parsed as
7509 * a filehandle should be subject to "strict subs".
7510 * Likewise for the optional indirect-object argument to system
7511 * or exec, which can't be a bareword */
7512 if ((PL_last_lop_op == OP_PRINT
7513 || PL_last_lop_op == OP_PRTF
7514 || PL_last_lop_op == OP_SAY
7515 || PL_last_lop_op == OP_SYSTEM
7516 || PL_last_lop_op == OP_EXEC)
7517 && (PL_hints & HINT_STRICT_SUBS))
7518 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7519 if (lastchar != '-') {
7520 if (ckWARN(WARN_RESERVED)) {
7524 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7525 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7533 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7534 && saw_infix_sigil) {
7535 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7536 "Operator or semicolon missing before %c%"UTF8f,
7538 UTF8fARG(UTF, strlen(PL_tokenbuf),
7540 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7541 "Ambiguous use of %c resolved as operator %c",
7542 lastchar, lastchar);
7549 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7554 (OP*)newSVOP(OP_CONST, 0,
7555 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7558 case KEY___PACKAGE__:
7560 (OP*)newSVOP(OP_CONST, 0,
7562 ? newSVhek(HvNAME_HEK(PL_curstash))
7569 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7570 const char *pname = "main";
7573 if (PL_tokenbuf[2] == 'D')
7576 PL_curstash ? PL_curstash : PL_defstash;
7577 pname = HvNAME_get(stash);
7578 plen = HvNAMELEN (stash);
7579 if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
7581 gv = gv_fetchpvn_flags(
7582 Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
7583 plen+6, GV_ADD|putf8, SVt_PVIO
7587 GvIOp(gv) = newIO();
7588 IoIFP(GvIOp(gv)) = PL_rsfp;
7589 #if defined(HAS_FCNTL) && defined(F_SETFD)
7591 const int fd = PerlIO_fileno(PL_rsfp);
7592 fcntl(fd,F_SETFD,fd >= 3);
7595 /* Mark this internal pseudo-handle as clean */
7596 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7597 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7598 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7600 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7601 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7602 /* if the script was opened in binmode, we need to revert
7603 * it to text mode for compatibility; but only iff it has CRs
7604 * XXX this is a questionable hack at best. */
7605 if (PL_bufend-PL_bufptr > 2
7606 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7609 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7610 loc = PerlIO_tell(PL_rsfp);
7611 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7614 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7616 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7617 #endif /* NETWARE */
7619 PerlIO_seek(PL_rsfp, loc, 0);
7623 #ifdef PERLIO_LAYERS
7626 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7627 else if (PL_encoding) {
7634 XPUSHs(PL_encoding);
7636 call_method("name", G_SCALAR);
7640 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7641 Perl_form(aTHX_ ":encoding(%"SVf")",
7650 if (PL_realtokenstart >= 0) {
7651 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7653 PL_endwhite = newSVpvs("");
7654 sv_catsv(PL_endwhite, PL_thiswhite);
7656 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7657 PL_realtokenstart = -1;
7659 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7669 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
7678 if (PL_expect == XSTATE) {
7685 if (*s == ':' && s[1] == ':') {
7689 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7690 if ((*s == ':' && s[1] == ':')
7691 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7695 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7699 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7700 UTF8fARG(UTF, len, PL_tokenbuf));
7703 else if (tmp == KEY_require || tmp == KEY_do
7705 /* that's a way to remember we saw "CORE::" */
7718 LOP(OP_ACCEPT,XTERM);
7721 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7726 LOP(OP_ATAN2,XTERM);
7732 LOP(OP_BINMODE,XTERM);
7735 LOP(OP_BLESS,XTERM);
7744 /* We have to disambiguate the two senses of
7745 "continue". If the next token is a '{' then
7746 treat it as the start of a continue block;
7747 otherwise treat it as a control operator.
7757 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7767 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7776 if (!PL_cryptseen) {
7777 PL_cryptseen = TRUE;
7781 LOP(OP_CRYPT,XTERM);
7784 LOP(OP_CHMOD,XTERM);
7787 LOP(OP_CHOWN,XTERM);
7790 LOP(OP_CONNECT,XTERM);
7810 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7812 if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
7815 force_ident_maybe_lex('&');
7820 if (orig_keyword == KEY_do) {
7829 PL_hints |= HINT_BLOCK_SCOPE;
7839 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7840 STR_WITH_LEN("NDBM_File::"),
7841 STR_WITH_LEN("DB_File::"),
7842 STR_WITH_LEN("GDBM_File::"),
7843 STR_WITH_LEN("SDBM_File::"),
7844 STR_WITH_LEN("ODBM_File::"),
7846 LOP(OP_DBMOPEN,XTERM);
7852 PL_expect = XOPERATOR;
7853 s = force_word(s,WORD,TRUE,FALSE);
7860 pl_yylval.ival = CopLINE(PL_curcop);
7864 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7878 if (*s == '{') { /* block eval */
7879 PL_expect = XTERMBLOCK;
7880 UNIBRACK(OP_ENTERTRY);
7882 else { /* string eval */
7884 UNIBRACK(OP_ENTEREVAL);
7889 UNIBRACK(-OP_ENTEREVAL);
7903 case KEY_endhostent:
7909 case KEY_endservent:
7912 case KEY_endprotoent:
7923 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7925 pl_yylval.ival = CopLINE(PL_curcop);
7927 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7930 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7933 if ((PL_bufend - p) >= 3 &&
7934 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7936 else if ((PL_bufend - p) >= 4 &&
7937 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7940 if (isIDFIRST_lazy_if(p,UTF)) {
7941 p = scan_ident(p, PL_bufend,
7942 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7946 Perl_croak(aTHX_ "Missing $ on loop variable");
7948 s = SvPVX(PL_linestr) + soff;
7954 LOP(OP_FORMLINE,XTERM);
7963 LOP(OP_FCNTL,XTERM);
7969 LOP(OP_FLOCK,XTERM);
7972 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7977 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7982 LOP(OP_GREPSTART, XREF);
7985 PL_expect = XOPERATOR;
7986 s = force_word(s,WORD,TRUE,FALSE);
8001 case KEY_getpriority:
8002 LOP(OP_GETPRIORITY,XTERM);
8004 case KEY_getprotobyname:
8007 case KEY_getprotobynumber:
8008 LOP(OP_GPBYNUMBER,XTERM);
8010 case KEY_getprotoent:
8022 case KEY_getpeername:
8023 UNI(OP_GETPEERNAME);
8025 case KEY_gethostbyname:
8028 case KEY_gethostbyaddr:
8029 LOP(OP_GHBYADDR,XTERM);
8031 case KEY_gethostent:
8034 case KEY_getnetbyname:
8037 case KEY_getnetbyaddr:
8038 LOP(OP_GNBYADDR,XTERM);
8043 case KEY_getservbyname:
8044 LOP(OP_GSBYNAME,XTERM);
8046 case KEY_getservbyport:
8047 LOP(OP_GSBYPORT,XTERM);
8049 case KEY_getservent:
8052 case KEY_getsockname:
8053 UNI(OP_GETSOCKNAME);
8055 case KEY_getsockopt:
8056 LOP(OP_GSOCKOPT,XTERM);
8071 pl_yylval.ival = CopLINE(PL_curcop);
8072 Perl_ck_warner_d(aTHX_
8073 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8074 "given is experimental");
8079 orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
8087 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8089 pl_yylval.ival = CopLINE(PL_curcop);
8093 LOP(OP_INDEX,XTERM);
8099 LOP(OP_IOCTL,XTERM);
8111 PL_expect = XOPERATOR;
8112 s = force_word(s,WORD,TRUE,FALSE);
8129 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8134 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8148 LOP(OP_LISTEN,XTERM);
8157 s = scan_pat(s,OP_MATCH);
8158 TERM(sublex_start());
8161 LOP(OP_MAPSTART, XREF);
8164 LOP(OP_MKDIR,XTERM);
8167 LOP(OP_MSGCTL,XTERM);
8170 LOP(OP_MSGGET,XTERM);
8173 LOP(OP_MSGRCV,XTERM);
8176 LOP(OP_MSGSND,XTERM);
8181 PL_in_my = (U16)tmp;
8183 if (isIDFIRST_lazy_if(s,UTF)) {
8187 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8188 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
8190 if (!FEATURE_LEXSUBS_IS_ENABLED)
8192 "Experimental \"%s\" subs not enabled",
8193 tmp == KEY_my ? "my" :
8194 tmp == KEY_state ? "state" : "our");
8195 Perl_ck_warner_d(aTHX_
8196 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
8197 "The lexical_subs feature is experimental");
8200 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8201 if (!PL_in_my_stash) {
8204 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8205 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8208 if (PL_madskills) { /* just add type to declarator token */
8209 sv_catsv(PL_thistoken, PL_nextwhite);
8211 sv_catpvn(PL_thistoken, start, s - start);
8219 PL_expect = XOPERATOR;
8220 s = force_word(s,WORD,TRUE,FALSE);
8224 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8229 s = tokenize_use(0, s);
8233 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
8236 if (!PL_lex_allbrackets &&
8237 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8238 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8244 if (isIDFIRST_lazy_if(s,UTF)) {
8246 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8248 for (t=d; isSPACE(*t);)
8250 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8252 && !(t[0] == '=' && t[1] == '>')
8253 && !(t[0] == ':' && t[1] == ':')
8254 && !keyword(s, d-s, 0)
8256 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8257 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
8258 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8264 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8266 pl_yylval.ival = OP_OR;
8276 LOP(OP_OPEN_DIR,XTERM);
8279 checkcomma(s,PL_tokenbuf,"filehandle");
8283 checkcomma(s,PL_tokenbuf,"filehandle");
8302 s = force_word(s,WORD,FALSE,TRUE);
8304 s = force_strict_version(s);
8305 PL_lex_expect = XBLOCK;
8309 LOP(OP_PIPE_OP,XTERM);
8312 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8315 pl_yylval.ival = OP_CONST;
8316 TERM(sublex_start());
8323 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8326 PL_expect = XOPERATOR;
8327 if (SvCUR(PL_lex_stuff)) {
8328 int warned_comma = !ckWARN(WARN_QW);
8329 int warned_comment = warned_comma;
8330 d = SvPV_force(PL_lex_stuff, len);
8332 for (; isSPACE(*d) && len; --len, ++d)
8337 if (!warned_comma || !warned_comment) {
8338 for (; !isSPACE(*d) && len; --len, ++d) {
8339 if (!warned_comma && *d == ',') {
8340 Perl_warner(aTHX_ packWARN(WARN_QW),
8341 "Possible attempt to separate words with commas");
8344 else if (!warned_comment && *d == '#') {
8345 Perl_warner(aTHX_ packWARN(WARN_QW),
8346 "Possible attempt to put comments in qw() list");
8352 for (; !isSPACE(*d) && len; --len, ++d)
8355 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8356 words = op_append_elem(OP_LIST, words,
8357 newSVOP(OP_CONST, 0, tokeq(sv)));
8362 words = newNULLLIST();
8364 SvREFCNT_dec(PL_lex_stuff);
8365 PL_lex_stuff = NULL;
8367 PL_expect = XOPERATOR;
8368 pl_yylval.opval = sawparens(words);
8373 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8376 pl_yylval.ival = OP_STRINGIFY;
8377 if (SvIVX(PL_lex_stuff) == '\'')
8378 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8379 TERM(sublex_start());
8382 s = scan_pat(s,OP_QR);
8383 TERM(sublex_start());
8386 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8389 readpipe_override();
8390 TERM(sublex_start());
8397 PL_expect = XOPERATOR;
8399 s = force_version(s, FALSE);
8401 else if (*s != 'v' || !isDIGIT(s[1])
8402 || (s = force_version(s, TRUE), *s == 'v'))
8404 *PL_tokenbuf = '\0';
8405 s = force_word(s,WORD,TRUE,TRUE);
8406 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
8407 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8408 GV_ADD | (UTF ? SVf_UTF8 : 0));
8410 yyerror("<> should be quotes");
8412 if (orig_keyword == KEY_require) {
8420 PL_last_uni = PL_oldbufptr;
8421 PL_last_lop_op = OP_REQUIRE;
8423 return REPORT( (int)REQUIRE );
8429 PL_expect = XOPERATOR;
8430 s = force_word(s,WORD,TRUE,FALSE);
8434 LOP(OP_RENAME,XTERM);
8443 LOP(OP_RINDEX,XTERM);
8452 UNIDOR(OP_READLINE);
8455 UNIDOR(OP_BACKTICK);
8464 LOP(OP_REVERSE,XTERM);
8467 UNIDOR(OP_READLINK);
8474 if (pl_yylval.opval)
8475 TERM(sublex_start());
8477 TOKEN(1); /* force error */
8480 checkcomma(s,PL_tokenbuf,"filehandle");
8490 LOP(OP_SELECT,XTERM);
8496 LOP(OP_SEMCTL,XTERM);
8499 LOP(OP_SEMGET,XTERM);
8502 LOP(OP_SEMOP,XTERM);
8508 LOP(OP_SETPGRP,XTERM);
8510 case KEY_setpriority:
8511 LOP(OP_SETPRIORITY,XTERM);
8513 case KEY_sethostent:
8519 case KEY_setservent:
8522 case KEY_setprotoent:
8532 LOP(OP_SEEKDIR,XTERM);
8534 case KEY_setsockopt:
8535 LOP(OP_SSOCKOPT,XTERM);
8541 LOP(OP_SHMCTL,XTERM);
8544 LOP(OP_SHMGET,XTERM);
8547 LOP(OP_SHMREAD,XTERM);
8550 LOP(OP_SHMWRITE,XTERM);
8553 LOP(OP_SHUTDOWN,XTERM);
8562 LOP(OP_SOCKET,XTERM);
8564 case KEY_socketpair:
8565 LOP(OP_SOCKPAIR,XTERM);
8568 checkcomma(s,PL_tokenbuf,"subroutine name");
8571 s = force_word(s,WORD,TRUE,TRUE);
8575 LOP(OP_SPLIT,XTERM);
8578 LOP(OP_SPRINTF,XTERM);
8581 LOP(OP_SPLICE,XTERM);
8596 LOP(OP_SUBSTR,XTERM);
8602 char * const tmpbuf = PL_tokenbuf + 1;
8603 expectation attrful;
8604 bool have_name, have_proto;
8605 const int key = tmp;
8607 SV *format_name = NULL;
8613 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
8614 SV *subtoken = PL_madskills
8615 ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr))
8620 s = SKIPSPACE2(s,tmpwhite);
8626 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
8627 (*s == ':' && s[1] == ':'))
8630 SV *nametoke = NULL;
8634 attrful = XATTRBLOCK;
8635 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8639 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
8641 if (key == KEY_format)
8642 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8645 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8647 PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
8649 sv_setpvn(PL_subname, tmpbuf, len);
8651 sv_setsv(PL_subname,PL_curstname);
8652 sv_catpvs(PL_subname,"::");
8653 sv_catpvn(PL_subname,tmpbuf,len);
8655 if (SvUTF8(PL_linestr))
8656 SvUTF8_on(PL_subname);
8662 CURMAD('X', nametoke);
8663 CURMAD('_', tmpwhite);
8664 force_ident_maybe_lex('&');
8666 s = SKIPSPACE2(d,tmpwhite);
8672 if (key == KEY_my || key == KEY_our || key==KEY_state)
8675 /* diag_listed_as: Missing name in "%s sub" */
8677 "Missing name in \"%s\"", PL_bufptr);
8679 PL_expect = XTERMBLOCK;
8680 attrful = XATTRTERM;
8681 sv_setpvs(PL_subname,"?");
8685 if (key == KEY_format) {
8687 PL_thistoken = subtoken;
8691 start_force(PL_curforce);
8692 NEXTVAL_NEXTTOKE.opval
8693 = (OP*)newSVOP(OP_CONST,0, format_name);
8694 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8701 /* Look for a prototype */
8703 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8705 Perl_croak(aTHX_ "Prototype not terminated");
8706 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8711 CURMAD('q', PL_thisopen);
8712 CURMAD('_', tmpwhite);
8713 CURMAD('=', PL_thisstuff);
8714 CURMAD('Q', PL_thisclose);
8715 NEXTVAL_NEXTTOKE.opval =
8716 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8717 PL_lex_stuff = NULL;
8720 s = SKIPSPACE2(s,tmpwhite);
8728 if (*s == ':' && s[1] != ':')
8729 PL_expect = attrful;
8730 else if (*s != '{' && key == KEY_sub) {
8732 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8733 else if (*s != ';' && *s != '}')
8734 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8741 curmad('^', newSVpvs(""));
8742 CURMAD('_', tmpwhite);
8746 PL_thistoken = subtoken;
8747 PERL_UNUSED_VAR(have_proto);
8750 NEXTVAL_NEXTTOKE.opval =
8751 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8752 PL_lex_stuff = NULL;
8758 sv_setpvs(PL_subname, "__ANON__");
8760 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8764 force_ident_maybe_lex('&');
8770 LOP(OP_SYSTEM,XREF);
8773 LOP(OP_SYMLINK,XTERM);
8776 LOP(OP_SYSCALL,XTERM);
8779 LOP(OP_SYSOPEN,XTERM);
8782 LOP(OP_SYSSEEK,XTERM);
8785 LOP(OP_SYSREAD,XTERM);
8788 LOP(OP_SYSWRITE,XTERM);
8793 TERM(sublex_start());
8814 LOP(OP_TRUNCATE,XTERM);
8826 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8828 pl_yylval.ival = CopLINE(PL_curcop);
8832 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8834 pl_yylval.ival = CopLINE(PL_curcop);
8838 LOP(OP_UNLINK,XTERM);
8844 LOP(OP_UNPACK,XTERM);
8847 LOP(OP_UTIME,XTERM);
8853 LOP(OP_UNSHIFT,XTERM);
8856 s = tokenize_use(1, s);
8866 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8868 pl_yylval.ival = CopLINE(PL_curcop);
8869 Perl_ck_warner_d(aTHX_
8870 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8871 "when is experimental");
8875 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8877 pl_yylval.ival = CopLINE(PL_curcop);
8881 PL_hints |= HINT_BLOCK_SCOPE;
8888 LOP(OP_WAITPID,XTERM);
8897 ctl_l[0] = toCTRL('L');
8899 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8902 /* Make sure $^L is defined */
8903 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8908 if (PL_expect == XOPERATOR) {
8909 if (*s == '=' && !PL_lex_allbrackets &&
8910 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8918 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8920 pl_yylval.ival = OP_XOR;
8926 #pragma segment Main
8932 Looks up an identifier in the pad or in a package
8935 PRIVATEREF if this is a lexical name.
8936 WORD if this belongs to a package.
8939 if we're in a my declaration
8940 croak if they tried to say my($foo::bar)
8941 build the ops for a my() declaration
8942 if it's an access to a my() variable
8943 build ops for access to a my() variable
8944 if in a dq string, and they've said @foo and we can't find @foo
8946 build ops for a bareword
8950 S_pending_ident(pTHX)
8954 const char pit = (char)pl_yylval.ival;
8955 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8956 /* All routes through this function want to know if there is a colon. */
8957 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8959 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8960 "### Pending identifier '%s'\n", PL_tokenbuf); });
8962 /* if we're in a my(), we can't allow dynamics here.
8963 $foo'bar has already been turned into $foo::bar, so
8964 just check for colons.
8966 if it's a legal name, the OP is a PADANY.
8969 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8971 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8972 "variable %s in \"our\"",
8973 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8974 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8978 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8979 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8980 UTF ? SVf_UTF8 : 0);
8982 pl_yylval.opval = newOP(OP_PADANY, 0);
8983 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8984 UTF ? SVf_UTF8 : 0);
8990 build the ops for accesses to a my() variable.
8995 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8996 UTF ? SVf_UTF8 : 0);
8997 if (tmp != NOT_IN_PAD) {
8998 /* might be an "our" variable" */
8999 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9000 /* build ops for a bareword */
9001 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9002 HEK * const stashname = HvNAME_HEK(stash);
9003 SV * const sym = newSVhek(stashname);
9004 sv_catpvs(sym, "::");
9005 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9006 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
9007 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9011 ? (GV_ADDMULTI | GV_ADDINEVAL)
9014 ((PL_tokenbuf[0] == '$') ? SVt_PV
9015 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9020 pl_yylval.opval = newOP(OP_PADANY, 0);
9021 pl_yylval.opval->op_targ = tmp;
9027 Whine if they've said @foo in a doublequoted string,
9028 and @foo isn't a variable we can find in the symbol
9031 if (ckWARN(WARN_AMBIGUOUS) &&
9032 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
9033 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
9034 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
9035 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9036 /* DO NOT warn for @- and @+ */
9037 && !( PL_tokenbuf[2] == '\0' &&
9038 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
9041 /* Downgraded from fatal to warning 20000522 mjd */
9042 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9043 "Possible unintended interpolation of %"UTF8f
9045 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9049 /* build ops for a bareword */
9050 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
9051 newSVpvn_flags(PL_tokenbuf + 1,
9053 UTF ? SVf_UTF8 : 0 ));
9054 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9056 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
9057 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
9058 | ( UTF ? SVf_UTF8 : 0 ),
9059 ((PL_tokenbuf[0] == '$') ? SVt_PV
9060 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9066 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9070 PERL_ARGS_ASSERT_CHECKCOMMA;
9072 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9073 if (ckWARN(WARN_SYNTAX)) {
9076 for (w = s+2; *w && level; w++) {
9084 /* the list of chars below is for end of statements or
9085 * block / parens, boolean operators (&&, ||, //) and branch
9086 * constructs (or, and, if, until, unless, while, err, for).
9087 * Not a very solid hack... */
9088 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9089 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9090 "%s (...) interpreted as function",name);
9093 while (s < PL_bufend && isSPACE(*s))
9097 while (s < PL_bufend && isSPACE(*s))
9099 if (isIDFIRST_lazy_if(s,UTF)) {
9100 const char * const w = s;
9101 s += UTF ? UTF8SKIP(s) : 1;
9102 while (isWORDCHAR_lazy_if(s,UTF))
9103 s += UTF ? UTF8SKIP(s) : 1;
9104 while (s < PL_bufend && isSPACE(*s))
9108 if (keyword(w, s - w, 0))
9111 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9112 if (gv && GvCVu(gv))
9114 Perl_croak(aTHX_ "No comma allowed after %s", what);
9119 /* S_new_constant(): do any overload::constant lookup.
9121 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9122 Best used as sv=new_constant(..., sv, ...).
9123 If s, pv are NULL, calls subroutine with one argument,
9124 and <type> is used with error messages only.
9125 <type> is assumed to be well formed UTF-8 */
9128 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9129 SV *sv, SV *pv, const char *type, STRLEN typelen)
9132 HV * table = GvHV(PL_hintgv); /* ^H */
9137 const char *why1 = "", *why2 = "", *why3 = "";
9139 PERL_ARGS_ASSERT_NEW_CONSTANT;
9140 /* We assume that this is true: */
9141 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9144 /* charnames doesn't work well if there have been errors found */
9145 if (PL_error_count > 0 && *key == 'c')
9147 SvREFCNT_dec_NN(sv);
9148 return &PL_sv_undef;
9151 sv_2mortal(sv); /* Parent created it permanently */
9153 || ! (PL_hints & HINT_LOCALIZE_HH)
9154 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9159 /* Here haven't found what we're looking for. If it is charnames,
9160 * perhaps it needs to be loaded. Try doing that before giving up */
9162 Perl_load_module(aTHX_
9164 newSVpvs("_charnames"),
9165 /* version parameter; no need to specify it, as if
9166 * we get too early a version, will fail anyway,
9167 * not being able to find '_charnames' */
9173 table = GvHV(PL_hintgv);
9175 && (PL_hints & HINT_LOCALIZE_HH)
9176 && (cvp = hv_fetch(table, key, keylen, FALSE))
9182 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9183 msg = Perl_form(aTHX_
9184 "Constant(%.*s) unknown",
9185 (int)(type ? typelen : len),
9191 why3 = "} is not defined";
9194 msg = Perl_form(aTHX_
9195 /* The +3 is for '\N{'; -4 for that, plus '}' */
9196 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9200 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9201 (int)(type ? typelen : len),
9202 (type ? type: s), why1, why2, why3);
9205 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9206 return SvREFCNT_inc_simple_NN(sv);
9211 pv = newSVpvn_flags(s, len, SVs_TEMP);
9213 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9215 typesv = &PL_sv_undef;
9217 PUSHSTACKi(PERLSI_OVERLOAD);
9229 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9233 /* Check the eval first */
9234 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9236 const char * errstr;
9237 sv_catpvs(errsv, "Propagated");
9238 errstr = SvPV_const(errsv, errlen);
9239 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9241 res = SvREFCNT_inc_simple_NN(sv);
9245 SvREFCNT_inc_simple_void_NN(res);
9254 why1 = "Call to &{$^H{";
9256 why3 = "}} did not return a defined value";
9258 (void)sv_2mortal(sv);
9265 PERL_STATIC_INLINE void
9266 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
9268 PERL_ARGS_ASSERT_PARSE_IDENT;
9272 Perl_croak(aTHX_ "%s", ident_too_long);
9273 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
9274 /* The UTF-8 case must come first, otherwise things
9275 * like c\N{COMBINING TILDE} would start failing, as the
9276 * isWORDCHAR_A case below would gobble the 'c' up.
9279 char *t = *s + UTF8SKIP(*s);
9280 while (isIDCONT_utf8((U8*)t))
9282 if (*d + (t - *s) > e)
9283 Perl_croak(aTHX_ "%s", ident_too_long);
9284 Copy(*s, *d, t - *s, char);
9288 else if ( isWORDCHAR_A(**s) ) {
9291 } while isWORDCHAR_A(**s);
9293 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
9298 else if (allow_package && **s == ':' && (*s)[1] == ':'
9299 /* Disallow things like Foo::$bar. For the curious, this is
9300 * the code path that triggers the "Bad name after" warning
9301 * when looking for barewords.
9303 && (*s)[2] != '$') {
9313 /* Returns a NUL terminated string, with the length of the string written to
9317 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9321 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9322 bool is_utf8 = cBOOL(UTF);
9324 PERL_ARGS_ASSERT_SCAN_WORD;
9326 parse_ident(&s, &d, e, allow_package, is_utf8);
9333 S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9336 char *bracket = NULL;
9339 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9340 bool is_utf8 = cBOOL(UTF);
9342 PERL_ARGS_ASSERT_SCAN_IDENT;
9347 while (isDIGIT(*s)) {
9349 Perl_croak(aTHX_ "%s", ident_too_long);
9354 parse_ident(&s, &d, e, 1, is_utf8);
9359 /* Either a digit variable, or parse_ident() found an identifier
9360 (anything valid as a bareword), so job done and return. */
9361 if (PL_lex_state != LEX_NORMAL)
9362 PL_lex_state = LEX_INTERPENDMAYBE;
9365 if (*s == '$' && s[1] &&
9366 (isIDFIRST_lazy_if(s+1,is_utf8)
9367 || isDIGIT_A((U8)s[1])
9370 || strnEQ(s+1,"::",2)) )
9372 /* Dereferencing a value in a scalar variable.
9373 The alternatives are different syntaxes for a scalar variable.
9374 Using ' as a leading package separator isn't allowed. :: is. */
9377 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9381 while (s < send && SPACE_OR_TAB(*s))
9385 #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
9386 || isCNTRL_A((U8)(d)) \
9387 || isDIGIT_A((U8)(d)) \
9388 || (!(u) && !UTF8_IS_INVARIANT((U8)(d))))
9390 && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
9393 const STRLEN skip = UTF8SKIP(s);
9396 for ( i = 0; i < skip; i++ )
9404 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9405 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9409 /* Warn about ambiguous code after unary operators if {...} notation isn't
9410 used. There's no difference in ambiguity; it's merely a heuristic
9411 about when not to warn. */
9412 else if (ck_uni && !bracket)
9415 /* If we were processing {...} notation then... */
9416 if (isIDFIRST_lazy_if(d,is_utf8)) {
9417 /* if it starts as a valid identifier, assume that it is one.
9418 (the later check for } being at the expected point will trap
9419 cases where this doesn't pan out.) */
9420 d += is_utf8 ? UTF8SKIP(d) : 1;
9421 parse_ident(&s, &d, e, 1, is_utf8);
9423 while (s < send && SPACE_OR_TAB(*s))
9425 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9426 /* ${foo[0]} and ${foo{bar}} notation. */
9427 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9428 const char * const brack =
9430 ((*s == '[') ? "[...]" : "{...}");
9431 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9432 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9433 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9434 funny, dest, brack, funny, dest, brack);
9437 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9438 PL_lex_allbrackets++;
9442 /* Handle extended ${^Foo} variables
9443 * 1999-02-27 mjd-perl-patch@plover.com */
9444 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9448 while (isWORDCHAR(*s) && d < e) {
9452 Perl_croak(aTHX_ "%s", ident_too_long);
9456 while (s < send && SPACE_OR_TAB(*s))
9459 /* Expect to find a closing } after consuming any trailing whitespace.
9463 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9464 PL_lex_state = LEX_INTERPEND;
9467 if (PL_lex_state == LEX_NORMAL) {
9468 if (ckWARN(WARN_AMBIGUOUS) &&
9469 (keyword(dest, d - dest, 0)
9470 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
9472 SV *tmp = newSVpvn_flags( dest, d - dest,
9473 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9476 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9477 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9478 funny, tmp, funny, tmp);
9483 /* Didn't find the closing } at the point we expected, so restore
9484 state such that the next thing to process is the opening { and */
9485 s = bracket; /* let the parser handle it */
9489 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9490 PL_lex_state = LEX_INTERPEND;
9495 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
9497 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
9498 * the parse starting at 's', based on the subset that are valid in this
9499 * context input to this routine in 'valid_flags'. Advances s. Returns
9500 * TRUE if the input should be treated as a valid flag, so the next char
9501 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
9502 * first call on the current regex. This routine will set it to any
9503 * charset modifier found. The caller shouldn't change it. This way,
9504 * another charset modifier encountered in the parse can be detected as an
9505 * error, as we have decided to allow only one */
9508 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9510 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9511 if (isWORDCHAR_lazy_if(*s, UTF)) {
9512 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9513 UTF ? SVf_UTF8 : 0);
9515 /* Pretend that it worked, so will continue processing before
9524 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
9525 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9526 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9527 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9528 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9529 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9530 case LOCALE_PAT_MOD:
9532 goto multiple_charsets;
9534 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9537 case UNICODE_PAT_MOD:
9539 goto multiple_charsets;
9541 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9544 case ASCII_RESTRICT_PAT_MOD:
9546 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9550 /* Error if previous modifier wasn't an 'a', but if it was, see
9551 * if, and accept, a second occurrence (only) */
9553 || get_regex_charset(*pmfl)
9554 != REGEX_ASCII_RESTRICTED_CHARSET)
9556 goto multiple_charsets;
9558 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9562 case DEPENDS_PAT_MOD:
9564 goto multiple_charsets;
9566 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9575 if (*charset != c) {
9576 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9578 else if (c == 'a') {
9579 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9582 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9585 /* Pretend that it worked, so will continue processing before dieing */
9591 S_scan_pat(pTHX_ char *start, I32 type)
9596 const char * const valid_flags =
9597 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9598 char charset = '\0'; /* character set modifier */
9603 PERL_ARGS_ASSERT_SCAN_PAT;
9605 s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
9606 TRUE /* look for escaped bracketed metas */ );
9609 const char * const delimiter = skipspace(start);
9613 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9614 : "Search pattern not terminated" ));
9617 pm = (PMOP*)newPMOP(type, 0);
9618 if (PL_multi_open == '?') {
9619 /* This is the only point in the code that sets PMf_ONCE: */
9620 pm->op_pmflags |= PMf_ONCE;
9622 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9623 allows us to restrict the list needed by reset to just the ??
9625 assert(type != OP_TRANS);
9627 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9630 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9633 elements = mg->mg_len / sizeof(PMOP**);
9634 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9635 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9636 mg->mg_len = elements * sizeof(PMOP**);
9637 PmopSTASH_set(pm,PL_curstash);
9644 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9645 * anon CV. False positives like qr/[(?{]/ are harmless */
9647 if (type == OP_QR) {
9649 char *e, *p = SvPV(PL_lex_stuff, len);
9651 for (; p < e; p++) {
9652 if (p[0] == '(' && p[1] == '?'
9653 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9655 pm->op_pmflags |= PMf_HAS_CV;
9659 pm->op_pmflags |= PMf_IS_QR;
9662 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9664 if (PL_madskills && modstart != s) {
9665 SV* tmptoken = newSVpvn(modstart, s - modstart);
9666 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9669 /* issue a warning if /c is specified,but /g is not */
9670 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9672 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9673 "Use of /c modifier is meaningless without /g" );
9676 PL_lex_op = (OP*)pm;
9677 pl_yylval.ival = OP_MATCH;
9682 S_scan_subst(pTHX_ char *start)
9689 char charset = '\0'; /* character set modifier */
9694 PERL_ARGS_ASSERT_SCAN_SUBST;
9696 pl_yylval.ival = OP_NULL;
9698 s = scan_str(start,!!PL_madskills,FALSE,FALSE,
9699 TRUE /* look for escaped bracketed metas */ );
9702 Perl_croak(aTHX_ "Substitution pattern not terminated");
9704 if (s[-1] == PL_multi_open)
9708 CURMAD('q', PL_thisopen);
9709 CURMAD('_', PL_thiswhite);
9710 CURMAD('E', PL_thisstuff);
9711 CURMAD('Q', PL_thisclose);
9712 PL_realtokenstart = s - SvPVX(PL_linestr);
9716 first_start = PL_multi_start;
9717 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9720 SvREFCNT_dec(PL_lex_stuff);
9721 PL_lex_stuff = NULL;
9723 Perl_croak(aTHX_ "Substitution replacement not terminated");
9725 PL_multi_start = first_start; /* so whole substitution is taken together */
9727 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9731 CURMAD('z', PL_thisopen);
9732 CURMAD('R', PL_thisstuff);
9733 CURMAD('Z', PL_thisclose);
9739 if (*s == EXEC_PAT_MOD) {
9743 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9752 curmad('m', newSVpvn(modstart, s - modstart));
9753 append_madprops(PL_thismad, (OP*)pm, 0);
9757 if ((pm->op_pmflags & PMf_CONTINUE)) {
9758 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9762 SV * const repl = newSVpvs("");
9765 pm->op_pmflags |= PMf_EVAL;
9768 sv_catpvs(repl, "eval ");
9770 sv_catpvs(repl, "do ");
9772 sv_catpvs(repl, "{");
9773 sv_catsv(repl, PL_sublex_info.repl);
9774 sv_catpvs(repl, "}");
9776 SvREFCNT_dec(PL_sublex_info.repl);
9777 PL_sublex_info.repl = repl;
9780 PL_lex_op = (OP*)pm;
9781 pl_yylval.ival = OP_SUBST;
9786 S_scan_trans(pTHX_ char *start)
9794 bool nondestruct = 0;
9799 PERL_ARGS_ASSERT_SCAN_TRANS;
9801 pl_yylval.ival = OP_NULL;
9803 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
9805 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9807 if (s[-1] == PL_multi_open)
9811 CURMAD('q', PL_thisopen);
9812 CURMAD('_', PL_thiswhite);
9813 CURMAD('E', PL_thisstuff);
9814 CURMAD('Q', PL_thisclose);
9815 PL_realtokenstart = s - SvPVX(PL_linestr);
9819 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9822 SvREFCNT_dec(PL_lex_stuff);
9823 PL_lex_stuff = NULL;
9825 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9828 CURMAD('z', PL_thisopen);
9829 CURMAD('R', PL_thisstuff);
9830 CURMAD('Z', PL_thisclose);
9833 complement = del = squash = 0;
9840 complement = OPpTRANS_COMPLEMENT;
9843 del = OPpTRANS_DELETE;
9846 squash = OPpTRANS_SQUASH;
9858 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9859 o->op_private &= ~OPpTRANS_ALL;
9860 o->op_private |= del|squash|complement|
9861 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9862 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9865 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9870 curmad('m', newSVpvn(modstart, s - modstart));
9871 append_madprops(PL_thismad, o, 0);
9880 Takes a pointer to the first < in <<FOO.
9881 Returns a pointer to the byte following <<FOO.
9883 This function scans a heredoc, which involves different methods
9884 depending on whether we are in a string eval, quoted construct, etc.
9885 This is because PL_linestr could containing a single line of input, or
9886 a whole string being evalled, or the contents of the current quote-
9889 The two basic methods are:
9890 - Steal lines from the input stream
9891 - Scan the heredoc in PL_linestr and remove it therefrom
9893 In a file scope or filtered eval, the first method is used; in a
9894 string eval, the second.
9896 In a quote-like operator, we have to choose between the two,
9897 depending on where we can find a newline. We peek into outer lex-
9898 ing scopes until we find one with a newline in it. If we reach the
9899 outermost lexing scope and it is a file, we use the stream method.
9900 Otherwise it is treated as an eval.
9904 S_scan_heredoc(pTHX_ char *s)
9907 I32 op_type = OP_SCALAR;
9914 const bool infile = PL_rsfp || PL_parser->filtered;
9915 LEXSHARED *shared = PL_parser->lex_shared;
9917 I32 stuffstart = s - SvPVX(PL_linestr);
9920 PL_realtokenstart = -1;
9923 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9926 d = PL_tokenbuf + 1;
9927 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9928 *PL_tokenbuf = '\n';
9930 while (SPACE_OR_TAB(*peek))
9932 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9935 s = delimcpy(d, e, s, PL_bufend, term, &len);
9937 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9943 /* <<\FOO is equivalent to <<'FOO' */
9947 if (!isWORDCHAR_lazy_if(s,UTF))
9948 deprecate("bare << to mean <<\"\"");
9949 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9954 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9955 Perl_croak(aTHX_ "Delimiter for here document is too long");
9958 len = d - PL_tokenbuf;
9962 tstart = PL_tokenbuf + 1;
9963 PL_thisclose = newSVpvn(tstart, len - 1);
9964 tstart = SvPVX(PL_linestr) + stuffstart;
9965 PL_thisopen = newSVpvn(tstart, s - tstart);
9966 stuffstart = s - SvPVX(PL_linestr);
9969 #ifndef PERL_STRICT_CR
9970 d = strchr(s, '\r');
9972 char * const olds = s;
9974 while (s < PL_bufend) {
9980 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9989 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9995 tstart = SvPVX(PL_linestr) + stuffstart;
9997 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9999 PL_thisstuff = newSVpvn(tstart, s - tstart);
10002 stuffstart = s - SvPVX(PL_linestr);
10005 tmpstr = newSV_type(SVt_PVIV);
10006 SvGROW(tmpstr, 80);
10007 if (term == '\'') {
10008 op_type = OP_CONST;
10009 SvIV_set(tmpstr, -1);
10011 else if (term == '`') {
10012 op_type = OP_BACKTICK;
10013 SvIV_set(tmpstr, '\\');
10016 PL_multi_start = CopLINE(PL_curcop) + 1;
10017 PL_multi_open = PL_multi_close = '<';
10018 /* inside a string eval or quote-like operator */
10019 if (!infile || PL_lex_inwhat) {
10022 char * const olds = s;
10023 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
10024 /* These two fields are not set until an inner lexing scope is
10025 entered. But we need them set here. */
10026 shared->ls_bufptr = s;
10027 shared->ls_linestr = PL_linestr;
10029 /* Look for a newline. If the current buffer does not have one,
10030 peek into the line buffer of the parent lexing scope, going
10031 up as many levels as necessary to find one with a newline
10034 while (!(s = (char *)memchr(
10035 (void *)shared->ls_bufptr, '\n',
10036 SvEND(shared->ls_linestr)-shared->ls_bufptr
10038 shared = shared->ls_prev;
10039 /* shared is only null if we have gone beyond the outermost
10040 lexing scope. In a file, we will have broken out of the
10041 loop in the previous iteration. In an eval, the string buf-
10042 fer ends with "\n;", so the while condition below will have
10043 evaluated to false. So shared can never be null. */
10045 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10046 most lexing scope. In a file, shared->ls_linestr at that
10047 level is just one line, so there is no body to steal. */
10048 if (infile && !shared->ls_prev) {
10054 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10057 linestr = shared->ls_linestr;
10058 bufend = SvEND(linestr);
10060 while (s < bufend - len + 1 &&
10061 memNE(s,PL_tokenbuf,len) ) {
10063 ++shared->herelines;
10065 if (s >= bufend - len + 1) {
10068 sv_setpvn(tmpstr,d+1,s-d);
10070 if (PL_madskills) {
10072 sv_catpvn(PL_thisstuff, d + 1, s - d);
10074 PL_thisstuff = newSVpvn(d + 1, s - d);
10075 stuffstart = s - SvPVX(PL_linestr);
10079 /* the preceding stmt passes a newline */
10080 shared->herelines++;
10082 /* s now points to the newline after the heredoc terminator.
10083 d points to the newline before the body of the heredoc.
10086 /* We are going to modify linestr in place here, so set
10087 aside copies of the string if necessary for re-evals or
10089 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10090 check shared->re_eval_str. */
10091 if (shared->re_eval_start || shared->re_eval_str) {
10092 /* Set aside the rest of the regexp */
10093 if (!shared->re_eval_str)
10094 shared->re_eval_str =
10095 newSVpvn(shared->re_eval_start,
10096 bufend - shared->re_eval_start);
10097 shared->re_eval_start -= s-d;
10099 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
10100 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
10101 cx->blk_eval.cur_text == linestr)
10103 cx->blk_eval.cur_text = newSVsv(linestr);
10104 SvSCREAM_on(cx->blk_eval.cur_text);
10106 /* Copy everything from s onwards back to d. */
10107 Move(s,d,bufend-s + 1,char);
10108 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10109 /* Setting PL_bufend only applies when we have not dug deeper
10110 into other scopes, because sublex_done sets PL_bufend to
10111 SvEND(PL_linestr). */
10112 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10119 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
10120 term = PL_tokenbuf[1];
10122 linestr_save = PL_linestr; /* must restore this afterwards */
10123 d = s; /* and this */
10124 PL_linestr = newSVpvs("");
10125 PL_bufend = SvPVX(PL_linestr);
10128 if (PL_madskills) {
10129 tstart = SvPVX(PL_linestr) + stuffstart;
10131 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10133 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10136 PL_bufptr = PL_bufend;
10137 CopLINE_set(PL_curcop,
10138 PL_multi_start + shared->herelines);
10139 if (!lex_next_chunk(LEX_NO_TERM)
10140 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10141 SvREFCNT_dec(linestr_save);
10144 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10145 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10146 lex_grow_linestr(SvCUR(PL_linestr) + 2);
10147 sv_catpvs(PL_linestr, "\n\0");
10151 stuffstart = s - SvPVX(PL_linestr);
10153 shared->herelines++;
10154 PL_last_lop = PL_last_uni = NULL;
10155 #ifndef PERL_STRICT_CR
10156 if (PL_bufend - PL_linestart >= 2) {
10157 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
10158 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10160 PL_bufend[-2] = '\n';
10162 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10164 else if (PL_bufend[-1] == '\r')
10165 PL_bufend[-1] = '\n';
10167 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10168 PL_bufend[-1] = '\n';
10170 if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
10171 SvREFCNT_dec(PL_linestr);
10172 PL_linestr = linestr_save;
10173 PL_linestart = SvPVX(linestr_save);
10174 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10179 sv_catsv(tmpstr,PL_linestr);
10183 PL_multi_end = CopLINE(PL_curcop);
10184 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10185 SvPV_shrink_to_cur(tmpstr);
10188 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10190 else if (PL_encoding)
10191 sv_recode_to_utf8(tmpstr, PL_encoding);
10193 PL_lex_stuff = tmpstr;
10194 pl_yylval.ival = op_type;
10198 SvREFCNT_dec(tmpstr);
10199 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10200 missingterm(PL_tokenbuf + 1);
10203 /* scan_inputsymbol
10204 takes: current position in input buffer
10205 returns: new position in input buffer
10206 side-effects: pl_yylval and lex_op are set.
10211 <FH> read from filehandle
10212 <pkg::FH> read from package qualified filehandle
10213 <pkg'FH> read from package qualified filehandle
10214 <$fh> read from filehandle in $fh
10215 <*.h> filename glob
10220 S_scan_inputsymbol(pTHX_ char *start)
10223 char *s = start; /* current position in buffer */
10226 char *d = PL_tokenbuf; /* start of temp holding space */
10227 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10229 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10231 end = strchr(s, '\n');
10234 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10236 /* die if we didn't have space for the contents of the <>,
10237 or if it didn't end, or if we see a newline
10240 if (len >= (I32)sizeof PL_tokenbuf)
10241 Perl_croak(aTHX_ "Excessively long <> operator");
10243 Perl_croak(aTHX_ "Unterminated <> operator");
10248 Remember, only scalar variables are interpreted as filehandles by
10249 this code. Anything more complex (e.g., <$fh{$num}>) will be
10250 treated as a glob() call.
10251 This code makes use of the fact that except for the $ at the front,
10252 a scalar variable and a filehandle look the same.
10254 if (*d == '$' && d[1]) d++;
10256 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10257 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
10258 d += UTF ? UTF8SKIP(d) : 1;
10260 /* If we've tried to read what we allow filehandles to look like, and
10261 there's still text left, then it must be a glob() and not a getline.
10262 Use scan_str to pull out the stuff between the <> and treat it
10263 as nothing more than a string.
10266 if (d - PL_tokenbuf != len) {
10267 pl_yylval.ival = OP_GLOB;
10268 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
10270 Perl_croak(aTHX_ "Glob not terminated");
10274 bool readline_overriden = FALSE;
10277 /* we're in a filehandle read situation */
10280 /* turn <> into <ARGV> */
10282 Copy("ARGV",d,5,char);
10284 /* Check whether readline() is overriden */
10285 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
10287 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
10289 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
10290 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
10291 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
10292 readline_overriden = TRUE;
10294 /* if <$fh>, create the ops to turn the variable into a
10298 /* try to find it in the pad for this block, otherwise find
10299 add symbol table ops
10301 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
10302 if (tmp != NOT_IN_PAD) {
10303 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10304 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10305 HEK * const stashname = HvNAME_HEK(stash);
10306 SV * const sym = sv_2mortal(newSVhek(stashname));
10307 sv_catpvs(sym, "::");
10308 sv_catpv(sym, d+1);
10313 OP * const o = newOP(OP_PADSV, 0);
10315 PL_lex_op = readline_overriden
10316 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10317 op_append_elem(OP_LIST, o,
10318 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10319 : (OP*)newUNOP(OP_READLINE, 0, o);
10328 ? (GV_ADDMULTI | GV_ADDINEVAL)
10329 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
10331 PL_lex_op = readline_overriden
10332 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10333 op_append_elem(OP_LIST,
10334 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10335 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10336 : (OP*)newUNOP(OP_READLINE, 0,
10337 newUNOP(OP_RV2SV, 0,
10338 newGVOP(OP_GV, 0, gv)));
10340 if (!readline_overriden)
10341 PL_lex_op->op_flags |= OPf_SPECIAL;
10342 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10343 pl_yylval.ival = OP_NULL;
10346 /* If it's none of the above, it must be a literal filehandle
10347 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10349 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10350 PL_lex_op = readline_overriden
10351 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10352 op_append_elem(OP_LIST,
10353 newGVOP(OP_GV, 0, gv),
10354 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10355 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10356 pl_yylval.ival = OP_NULL;
10365 takes: start position in buffer
10366 keep_quoted preserve \ on the embedded delimiter(s)
10367 keep_delims preserve the delimiters around the string
10368 re_reparse compiling a run-time /(?{})/:
10369 collapse // to /, and skip encoding src
10370 returns: position to continue reading from buffer
10371 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10372 updates the read buffer.
10374 This subroutine pulls a string out of the input. It is called for:
10375 q single quotes q(literal text)
10376 ' single quotes 'literal text'
10377 qq double quotes qq(interpolate $here please)
10378 " double quotes "interpolate $here please"
10379 qx backticks qx(/bin/ls -l)
10380 ` backticks `/bin/ls -l`
10381 qw quote words @EXPORT_OK = qw( func() $spam )
10382 m// regexp match m/this/
10383 s/// regexp substitute s/this/that/
10384 tr/// string transliterate tr/this/that/
10385 y/// string transliterate y/this/that/
10386 ($*@) sub prototypes sub foo ($)
10387 (stuff) sub attr parameters sub foo : attr(stuff)
10388 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10390 In most of these cases (all but <>, patterns and transliterate)
10391 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10392 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10393 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10396 It skips whitespace before the string starts, and treats the first
10397 character as the delimiter. If the delimiter is one of ([{< then
10398 the corresponding "close" character )]}> is used as the closing
10399 delimiter. It allows quoting of delimiters, and if the string has
10400 balanced delimiters ([{<>}]) it allows nesting.
10402 On success, the SV with the resulting string is put into lex_stuff or,
10403 if that is already non-NULL, into lex_repl. The second case occurs only
10404 when parsing the RHS of the special constructs s/// and tr/// (y///).
10405 For convenience, the terminating delimiter character is stuffed into
10410 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
10411 bool deprecate_escaped_meta /* Should we issue a deprecation warning
10412 for certain paired metacharacters that
10413 appear escaped within it */
10417 SV *sv; /* scalar value: string */
10418 const char *tmps; /* temp string, used for delimiter matching */
10419 char *s = start; /* current position in the buffer */
10420 char term; /* terminating character */
10421 char *to; /* current position in the sv's data */
10422 I32 brackets = 1; /* bracket nesting level */
10423 bool has_utf8 = FALSE; /* is there any utf8 content? */
10424 I32 termcode; /* terminating char. code */
10425 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10426 STRLEN termlen; /* length of terminating string */
10427 int last_off = 0; /* last position for nesting bracket */
10428 char *escaped_open = NULL;
10434 PERL_ARGS_ASSERT_SCAN_STR;
10436 /* skip space before the delimiter */
10442 if (PL_realtokenstart >= 0) {
10443 stuffstart = PL_realtokenstart;
10444 PL_realtokenstart = -1;
10447 stuffstart = start - SvPVX(PL_linestr);
10449 /* mark where we are, in case we need to report errors */
10452 /* after skipping whitespace, the next character is the terminator */
10455 termcode = termstr[0] = term;
10459 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10460 Copy(s, termstr, termlen, U8);
10461 if (!UTF8_IS_INVARIANT(term))
10465 /* mark where we are */
10466 PL_multi_start = CopLINE(PL_curcop);
10467 PL_multi_open = term;
10469 /* find corresponding closing delimiter */
10470 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10471 termcode = termstr[0] = term = tmps[5];
10473 PL_multi_close = term;
10475 /* A warning is raised if the input parameter requires it for escaped (by a
10476 * backslash) paired metacharacters {} [] and () when the delimiters are
10477 * those same characters, and the backslash is ineffective. This doesn't
10478 * happen for <>, as they aren't metas. */
10479 if (deprecate_escaped_meta
10480 && (PL_multi_open == PL_multi_close
10481 || ! ckWARN_d(WARN_DEPRECATED)
10482 || PL_multi_open == '<'))
10484 deprecate_escaped_meta = FALSE;
10487 /* create a new SV to hold the contents. 79 is the SV's initial length.
10488 What a random number. */
10489 sv = newSV_type(SVt_PVIV);
10491 SvIV_set(sv, termcode);
10492 (void)SvPOK_only(sv); /* validate pointer */
10494 /* move past delimiter and try to read a complete string */
10496 sv_catpvn(sv, s, termlen);
10499 tstart = SvPVX(PL_linestr) + stuffstart;
10500 if (PL_madskills && !PL_thisopen && !keep_delims) {
10501 PL_thisopen = newSVpvn(tstart, s - tstart);
10502 stuffstart = s - SvPVX(PL_linestr);
10506 if (PL_encoding && !UTF && !re_reparse) {
10510 int offset = s - SvPVX_const(PL_linestr);
10511 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10512 &offset, (char*)termstr, termlen);
10513 const char * const ns = SvPVX_const(PL_linestr) + offset;
10514 char * const svlast = SvEND(sv) - 1;
10516 for (; s < ns; s++) {
10517 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10518 COPLINE_INC_WITH_HERELINES;
10521 goto read_more_line;
10523 /* handle quoted delimiters */
10524 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10526 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10528 if ((svlast-1 - t) % 2) {
10529 if (!keep_quoted) {
10530 *(svlast-1) = term;
10532 SvCUR_set(sv, SvCUR(sv) - 1);
10537 if (PL_multi_open == PL_multi_close) {
10543 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10544 /* At here, all closes are "was quoted" one,
10545 so we don't check PL_multi_close. */
10547 if (!keep_quoted && *(t+1) == PL_multi_open)
10552 else if (*t == PL_multi_open)
10560 SvCUR_set(sv, w - SvPVX_const(sv));
10562 last_off = w - SvPVX(sv);
10563 if (--brackets <= 0)
10568 if (!keep_delims) {
10569 SvCUR_set(sv, SvCUR(sv) - 1);
10575 /* extend sv if need be */
10576 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10577 /* set 'to' to the next character in the sv's string */
10578 to = SvPVX(sv)+SvCUR(sv);
10580 /* if open delimiter is the close delimiter read unbridle */
10581 if (PL_multi_open == PL_multi_close) {
10582 for (; s < PL_bufend; s++,to++) {
10583 /* embedded newlines increment the current line number */
10584 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10585 COPLINE_INC_WITH_HERELINES;
10586 /* handle quoted delimiters */
10587 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10590 || (re_reparse && s[1] == '\\'))
10593 /* any other quotes are simply copied straight through */
10597 /* terminate when run out of buffer (the for() condition), or
10598 have found the terminator */
10599 else if (*s == term) {
10602 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10605 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10611 /* if the terminator isn't the same as the start character (e.g.,
10612 matched brackets), we have to allow more in the quoting, and
10613 be prepared for nested brackets.
10616 /* read until we run out of string, or we find the terminator */
10617 for (; s < PL_bufend; s++,to++) {
10618 /* embedded newlines increment the line count */
10619 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10620 COPLINE_INC_WITH_HERELINES;
10621 /* backslashes can escape the open or closing characters */
10622 if (*s == '\\' && s+1 < PL_bufend) {
10623 if (!keep_quoted &&
10624 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10628 /* Here, 'deprecate_escaped_meta' is true iff the
10629 * delimiters are paired metacharacters, and 's' points
10630 * to an occurrence of one of them within the string,
10631 * which was preceded by a backslash. If this is a
10632 * context where the delimiter is also a metacharacter,
10633 * the backslash is useless, and deprecated. () and []
10634 * are meta in any context. {} are meta only when
10635 * appearing in a quantifier or in things like '\p{'.
10636 * They also aren't meta unless there is a matching
10637 * closed, escaped char later on within the string.
10638 * If 's' points to an open, set a flag; if to a close,
10639 * test that flag, and raise a warning if it was set */
10641 if (deprecate_escaped_meta) {
10642 if (*s == PL_multi_open) {
10646 else if (regcurly(s,
10647 TRUE /* Look for a closing
10649 || (s - start > 2 /* Look for e.g.
10651 && _generic_isCC(*(s-2), _CC_BACKSLASH_FOO_LBRACE_IS_META)))
10656 else if (escaped_open) {
10657 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10658 "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open);
10659 escaped_open = NULL;
10666 /* allow nested opens and closes */
10667 else if (*s == PL_multi_close && --brackets <= 0)
10669 else if (*s == PL_multi_open)
10671 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10676 /* terminate the copied string and update the sv's end-of-string */
10678 SvCUR_set(sv, to - SvPVX_const(sv));
10681 * this next chunk reads more into the buffer if we're not done yet
10685 break; /* handle case where we are done yet :-) */
10687 #ifndef PERL_STRICT_CR
10688 if (to - SvPVX_const(sv) >= 2) {
10689 if ((to[-2] == '\r' && to[-1] == '\n') ||
10690 (to[-2] == '\n' && to[-1] == '\r'))
10694 SvCUR_set(sv, to - SvPVX_const(sv));
10696 else if (to[-1] == '\r')
10699 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10704 /* if we're out of file, or a read fails, bail and reset the current
10705 line marker so we can report where the unterminated string began
10708 if (PL_madskills) {
10709 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10711 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10713 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10716 COPLINE_INC_WITH_HERELINES;
10717 PL_bufptr = PL_bufend;
10718 if (!lex_next_chunk(0)) {
10720 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10729 /* at this point, we have successfully read the delimited string */
10731 if (!PL_encoding || UTF || re_reparse) {
10733 if (PL_madskills) {
10734 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10735 const int len = s - tstart;
10737 sv_catpvn(PL_thisstuff, tstart, len);
10739 PL_thisstuff = newSVpvn(tstart, len);
10740 if (!PL_thisclose && !keep_delims)
10741 PL_thisclose = newSVpvn(s,termlen);
10746 sv_catpvn(sv, s, termlen);
10751 if (PL_madskills) {
10752 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10753 const int len = s - tstart - termlen;
10755 sv_catpvn(PL_thisstuff, tstart, len);
10757 PL_thisstuff = newSVpvn(tstart, len);
10758 if (!PL_thisclose && !keep_delims)
10759 PL_thisclose = newSVpvn(s - termlen,termlen);
10763 if (has_utf8 || (PL_encoding && !re_reparse))
10766 PL_multi_end = CopLINE(PL_curcop);
10768 /* if we allocated too much space, give some back */
10769 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10770 SvLEN_set(sv, SvCUR(sv) + 1);
10771 SvPV_renew(sv, SvLEN(sv));
10774 /* decide whether this is the first or second quoted string we've read
10779 PL_sublex_info.repl = sv;
10787 takes: pointer to position in buffer
10788 returns: pointer to new position in buffer
10789 side-effects: builds ops for the constant in pl_yylval.op
10791 Read a number in any of the formats that Perl accepts:
10793 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10794 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10797 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10799 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10802 If it reads a number without a decimal point or an exponent, it will
10803 try converting the number to an integer and see if it can do so
10804 without loss of precision.
10808 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10811 const char *s = start; /* current position in buffer */
10812 char *d; /* destination in temp buffer */
10813 char *e; /* end of temp buffer */
10814 NV nv; /* number read, as a double */
10815 SV *sv = NULL; /* place to put the converted number */
10816 bool floatit; /* boolean: int or float? */
10817 const char *lastub = NULL; /* position of last underbar */
10818 static const char* const number_too_long = "Number too long";
10820 PERL_ARGS_ASSERT_SCAN_NUM;
10822 /* We use the first character to decide what type of number this is */
10826 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10828 /* if it starts with a 0, it could be an octal number, a decimal in
10829 0.13 disguise, or a hexadecimal number, or a binary number. */
10833 u holds the "number so far"
10834 shift the power of 2 of the base
10835 (hex == 4, octal == 3, binary == 1)
10836 overflowed was the number more than we can hold?
10838 Shift is used when we add a digit. It also serves as an "are
10839 we in octal/hex/binary?" indicator to disallow hex characters
10840 when in octal mode.
10845 bool overflowed = FALSE;
10846 bool just_zero = TRUE; /* just plain 0 or binary number? */
10847 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10848 static const char* const bases[5] =
10849 { "", "binary", "", "octal", "hexadecimal" };
10850 static const char* const Bases[5] =
10851 { "", "Binary", "", "Octal", "Hexadecimal" };
10852 static const char* const maxima[5] =
10854 "0b11111111111111111111111111111111",
10858 const char *base, *Base, *max;
10860 /* check for hex */
10861 if (s[1] == 'x' || s[1] == 'X') {
10865 } else if (s[1] == 'b' || s[1] == 'B') {
10870 /* check for a decimal in disguise */
10871 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10873 /* so it must be octal */
10880 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10881 "Misplaced _ in number");
10885 base = bases[shift];
10886 Base = Bases[shift];
10887 max = maxima[shift];
10889 /* read the rest of the number */
10891 /* x is used in the overflow test,
10892 b is the digit we're adding on. */
10897 /* if we don't mention it, we're done */
10901 /* _ are ignored -- but warned about if consecutive */
10903 if (lastub && s == lastub + 1)
10904 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10905 "Misplaced _ in number");
10909 /* 8 and 9 are not octal */
10910 case '8': case '9':
10912 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10916 case '2': case '3': case '4':
10917 case '5': case '6': case '7':
10919 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10922 case '0': case '1':
10923 b = *s++ & 15; /* ASCII digit -> value of digit */
10927 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10928 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10929 /* make sure they said 0x */
10932 b = (*s++ & 7) + 9;
10934 /* Prepare to put the digit we have onto the end
10935 of the number so far. We check for overflows.
10941 x = u << shift; /* make room for the digit */
10943 if ((x >> shift) != u
10944 && !(PL_hints & HINT_NEW_BINARY)) {
10947 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10948 "Integer overflow in %s number",
10951 u = x | b; /* add the digit to the end */
10954 n *= nvshift[shift];
10955 /* If an NV has not enough bits in its
10956 * mantissa to represent an UV this summing of
10957 * small low-order numbers is a waste of time
10958 * (because the NV cannot preserve the
10959 * low-order bits anyway): we could just
10960 * remember when did we overflow and in the
10961 * end just multiply n by the right
10969 /* if we get here, we had success: make a scalar value from
10974 /* final misplaced underbar check */
10975 if (s[-1] == '_') {
10976 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10980 if (n > 4294967295.0)
10981 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10982 "%s number > %s non-portable",
10988 if (u > 0xffffffff)
10989 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10990 "%s number > %s non-portable",
10995 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10996 sv = new_constant(start, s - start, "integer",
10997 sv, NULL, NULL, 0);
10998 else if (PL_hints & HINT_NEW_BINARY)
10999 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11004 handle decimal numbers.
11005 we're also sent here when we read a 0 as the first digit
11007 case '1': case '2': case '3': case '4': case '5':
11008 case '6': case '7': case '8': case '9': case '.':
11011 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11014 /* read next group of digits and _ and copy into d */
11015 while (isDIGIT(*s) || *s == '_') {
11016 /* skip underscores, checking for misplaced ones
11020 if (lastub && s == lastub + 1)
11021 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11022 "Misplaced _ in number");
11026 /* check for end of fixed-length buffer */
11028 Perl_croak(aTHX_ "%s", number_too_long);
11029 /* if we're ok, copy the character */
11034 /* final misplaced underbar check */
11035 if (lastub && s == lastub + 1) {
11036 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11039 /* read a decimal portion if there is one. avoid
11040 3..5 being interpreted as the number 3. followed
11043 if (*s == '.' && s[1] != '.') {
11048 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11049 "Misplaced _ in number");
11053 /* copy, ignoring underbars, until we run out of digits.
11055 for (; isDIGIT(*s) || *s == '_'; s++) {
11056 /* fixed length buffer check */
11058 Perl_croak(aTHX_ "%s", number_too_long);
11060 if (lastub && s == lastub + 1)
11061 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11062 "Misplaced _ in number");
11068 /* fractional part ending in underbar? */
11069 if (s[-1] == '_') {
11070 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11071 "Misplaced _ in number");
11073 if (*s == '.' && isDIGIT(s[1])) {
11074 /* oops, it's really a v-string, but without the "v" */
11080 /* read exponent part, if present */
11081 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
11085 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
11086 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
11088 /* stray preinitial _ */
11090 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11091 "Misplaced _ in number");
11095 /* allow positive or negative exponent */
11096 if (*s == '+' || *s == '-')
11099 /* stray initial _ */
11101 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11102 "Misplaced _ in number");
11106 /* read digits of exponent */
11107 while (isDIGIT(*s) || *s == '_') {
11110 Perl_croak(aTHX_ "%s", number_too_long);
11114 if (((lastub && s == lastub + 1) ||
11115 (!isDIGIT(s[1]) && s[1] != '_')))
11116 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11117 "Misplaced _ in number");
11125 We try to do an integer conversion first if no characters
11126 indicating "float" have been found.
11131 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11133 if (flags == IS_NUMBER_IN_UV) {
11135 sv = newSViv(uv); /* Prefer IVs over UVs. */
11138 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11139 if (uv <= (UV) IV_MIN)
11140 sv = newSViv(-(IV)uv);
11147 /* terminate the string */
11149 nv = Atof(PL_tokenbuf);
11154 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11155 const char *const key = floatit ? "float" : "integer";
11156 const STRLEN keylen = floatit ? 5 : 7;
11157 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11158 key, keylen, sv, NULL, NULL, 0);
11162 /* if it starts with a v, it could be a v-string */
11165 sv = newSV(5); /* preallocate storage space */
11166 ENTER_with_name("scan_vstring");
11168 s = scan_vstring(s, PL_bufend, sv);
11169 SvREFCNT_inc_simple_void_NN(sv);
11170 LEAVE_with_name("scan_vstring");
11174 /* make the op for the constant and return */
11177 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11179 lvalp->opval = NULL;
11185 S_scan_formline(pTHX_ char *s)
11190 SV * const stuff = newSVpvs("");
11191 bool needargs = FALSE;
11192 bool eofmt = FALSE;
11194 char *tokenstart = s;
11195 SV* savewhite = NULL;
11197 if (PL_madskills) {
11198 savewhite = PL_thiswhite;
11203 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11205 while (!needargs) {
11208 #ifdef PERL_STRICT_CR
11209 while (SPACE_OR_TAB(*t))
11212 while (SPACE_OR_TAB(*t) || *t == '\r')
11215 if (*t == '\n' || t == PL_bufend) {
11220 eol = (char *) memchr(s,'\n',PL_bufend-s);
11224 for (t = s; t < eol; t++) {
11225 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11227 goto enough; /* ~~ must be first line in formline */
11229 if (*t == '@' || *t == '^')
11233 sv_catpvn(stuff, s, eol-s);
11234 #ifndef PERL_STRICT_CR
11235 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11236 char *end = SvPVX(stuff) + SvCUR(stuff);
11239 SvCUR_set(stuff, SvCUR(stuff) - 1);
11247 if ((PL_rsfp || PL_parser->filtered)
11248 && PL_parser->form_lex_state == LEX_NORMAL) {
11251 if (PL_madskills) {
11253 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
11255 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
11258 PL_bufptr = PL_bufend;
11259 COPLINE_INC_WITH_HERELINES;
11260 got_some = lex_next_chunk(0);
11261 CopLINE_dec(PL_curcop);
11264 tokenstart = PL_bufptr;
11272 if (!SvCUR(stuff) || needargs)
11273 PL_lex_state = PL_parser->form_lex_state;
11274 if (SvCUR(stuff)) {
11275 PL_expect = XSTATE;
11277 start_force(PL_curforce);
11278 NEXTVAL_NEXTTOKE.ival = 0;
11279 force_next(FORMLBRACK);
11282 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11284 else if (PL_encoding)
11285 sv_recode_to_utf8(stuff, PL_encoding);
11287 start_force(PL_curforce);
11288 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
11292 SvREFCNT_dec(stuff);
11294 PL_lex_formbrack = 0;
11297 if (PL_madskills) {
11299 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
11301 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
11302 PL_thiswhite = savewhite;
11309 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11312 const I32 oldsavestack_ix = PL_savestack_ix;
11313 CV* const outsidecv = PL_compcv;
11315 SAVEI32(PL_subline);
11316 save_item(PL_subname);
11317 SAVESPTR(PL_compcv);
11319 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11320 CvFLAGS(PL_compcv) |= flags;
11322 PL_subline = CopLINE(PL_curcop);
11323 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11324 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11325 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11326 if (outsidecv && CvPADLIST(outsidecv))
11327 CvPADLIST(PL_compcv)->xpadl_outid =
11328 PadlistNAMES(CvPADLIST(outsidecv));
11330 return oldsavestack_ix;
11334 #pragma segment Perl_yylex
11337 S_yywarn(pTHX_ const char *const s, U32 flags)
11341 PERL_ARGS_ASSERT_YYWARN;
11343 PL_in_eval |= EVAL_WARNONLY;
11344 yyerror_pv(s, flags);
11345 PL_in_eval &= ~EVAL_WARNONLY;
11350 Perl_yyerror(pTHX_ const char *const s)
11352 PERL_ARGS_ASSERT_YYERROR;
11353 return yyerror_pvn(s, strlen(s), 0);
11357 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11359 PERL_ARGS_ASSERT_YYERROR_PV;
11360 return yyerror_pvn(s, strlen(s), flags);
11364 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11367 const char *context = NULL;
11370 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11371 int yychar = PL_parser->yychar;
11373 PERL_ARGS_ASSERT_YYERROR_PVN;
11375 if (!yychar || (yychar == ';' && !PL_rsfp))
11376 sv_catpvs(where_sv, "at EOF");
11377 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
11378 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
11379 PL_oldbufptr != PL_bufptr) {
11382 The code below is removed for NetWare because it abends/crashes on NetWare
11383 when the script has error such as not having the closing quotes like:
11384 if ($var eq "value)
11385 Checking of white spaces is anyway done in NetWare code.
11388 while (isSPACE(*PL_oldoldbufptr))
11391 context = PL_oldoldbufptr;
11392 contlen = PL_bufptr - PL_oldoldbufptr;
11394 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
11395 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
11398 The code below is removed for NetWare because it abends/crashes on NetWare
11399 when the script has error such as not having the closing quotes like:
11400 if ($var eq "value)
11401 Checking of white spaces is anyway done in NetWare code.
11404 while (isSPACE(*PL_oldbufptr))
11407 context = PL_oldbufptr;
11408 contlen = PL_bufptr - PL_oldbufptr;
11410 else if (yychar > 255)
11411 sv_catpvs(where_sv, "next token ???");
11412 else if (yychar == -2) { /* YYEMPTY */
11413 if (PL_lex_state == LEX_NORMAL ||
11414 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11415 sv_catpvs(where_sv, "at end of line");
11416 else if (PL_lex_inpat)
11417 sv_catpvs(where_sv, "within pattern");
11419 sv_catpvs(where_sv, "within string");
11422 sv_catpvs(where_sv, "next char ");
11424 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11425 else if (isPRINT_LC(yychar)) {
11426 const char string = yychar;
11427 sv_catpvn(where_sv, &string, 1);
11430 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11432 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11433 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11434 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11436 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
11437 UTF8fARG(UTF, contlen, context));
11439 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
11440 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
11441 Perl_sv_catpvf(aTHX_ msg,
11442 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11443 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11446 if (PL_in_eval & EVAL_WARNONLY) {
11447 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
11451 if (PL_error_count >= 10) {
11453 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
11454 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11455 SVfARG(errsv), OutCopFILE(PL_curcop));
11457 Perl_croak(aTHX_ "%s has too many errors.\n",
11458 OutCopFILE(PL_curcop));
11461 PL_in_my_stash = NULL;
11465 #pragma segment Main
11469 S_swallow_bom(pTHX_ U8 *s)
11472 const STRLEN slen = SvCUR(PL_linestr);
11474 PERL_ARGS_ASSERT_SWALLOW_BOM;
11478 if (s[1] == 0xFE) {
11479 /* UTF-16 little-endian? (or UTF-32LE?) */
11480 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11481 /* diag_listed_as: Unsupported script encoding %s */
11482 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11483 #ifndef PERL_NO_UTF16_FILTER
11484 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11486 if (PL_bufend > (char*)s) {
11487 s = add_utf16_textfilter(s, TRUE);
11490 /* diag_listed_as: Unsupported script encoding %s */
11491 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11496 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11497 #ifndef PERL_NO_UTF16_FILTER
11498 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11500 if (PL_bufend > (char *)s) {
11501 s = add_utf16_textfilter(s, FALSE);
11504 /* diag_listed_as: Unsupported script encoding %s */
11505 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11510 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11511 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11512 s += 3; /* UTF-8 */
11518 if (s[2] == 0xFE && s[3] == 0xFF) {
11519 /* UTF-32 big-endian */
11520 /* diag_listed_as: Unsupported script encoding %s */
11521 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11524 else if (s[2] == 0 && s[3] != 0) {
11527 * are a good indicator of UTF-16BE. */
11528 #ifndef PERL_NO_UTF16_FILTER
11529 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11530 s = add_utf16_textfilter(s, FALSE);
11532 /* diag_listed_as: Unsupported script encoding %s */
11533 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11539 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
11540 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11541 s += 4; /* UTF-8 */
11547 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11550 * are a good indicator of UTF-16LE. */
11551 #ifndef PERL_NO_UTF16_FILTER
11552 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11553 s = add_utf16_textfilter(s, TRUE);
11555 /* diag_listed_as: Unsupported script encoding %s */
11556 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11564 #ifndef PERL_NO_UTF16_FILTER
11566 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11569 SV *const filter = FILTER_DATA(idx);
11570 /* We re-use this each time round, throwing the contents away before we
11572 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11573 SV *const utf8_buffer = filter;
11574 IV status = IoPAGE(filter);
11575 const bool reverse = cBOOL(IoLINES(filter));
11578 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11580 /* As we're automatically added, at the lowest level, and hence only called
11581 from this file, we can be sure that we're not called in block mode. Hence
11582 don't bother writing code to deal with block mode. */
11584 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11587 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11589 DEBUG_P(PerlIO_printf(Perl_debug_log,
11590 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11591 FPTR2DPTR(void *, S_utf16_textfilter),
11592 reverse ? 'l' : 'b', idx, maxlen, status,
11593 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11600 /* First, look in our buffer of existing UTF-8 data: */
11601 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11605 } else if (status == 0) {
11607 IoPAGE(filter) = 0;
11608 nl = SvEND(utf8_buffer);
11611 STRLEN got = nl - SvPVX(utf8_buffer);
11612 /* Did we have anything to append? */
11614 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11615 /* Everything else in this code works just fine if SVp_POK isn't
11616 set. This, however, needs it, and we need it to work, else
11617 we loop infinitely because the buffer is never consumed. */
11618 sv_chop(utf8_buffer, nl);
11622 /* OK, not a complete line there, so need to read some more UTF-16.
11623 Read an extra octect if the buffer currently has an odd number. */
11627 if (SvCUR(utf16_buffer) >= 2) {
11628 /* Location of the high octet of the last complete code point.
11629 Gosh, UTF-16 is a pain. All the benefits of variable length,
11630 *coupled* with all the benefits of partial reads and
11632 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11633 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11635 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11639 /* We have the first half of a surrogate. Read more. */
11640 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11643 status = FILTER_READ(idx + 1, utf16_buffer,
11644 160 + (SvCUR(utf16_buffer) & 1));
11645 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11646 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11649 IoPAGE(filter) = status;
11654 chars = SvCUR(utf16_buffer) >> 1;
11655 have = SvCUR(utf8_buffer);
11656 SvGROW(utf8_buffer, have + chars * 3 + 1);
11659 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11660 (U8*)SvPVX_const(utf8_buffer) + have,
11661 chars * 2, &newlen);
11663 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11664 (U8*)SvPVX_const(utf8_buffer) + have,
11665 chars * 2, &newlen);
11667 SvCUR_set(utf8_buffer, have + newlen);
11670 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11671 it's private to us, and utf16_to_utf8{,reversed} take a
11672 (pointer,length) pair, rather than a NUL-terminated string. */
11673 if(SvCUR(utf16_buffer) & 1) {
11674 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11675 SvCUR_set(utf16_buffer, 1);
11677 SvCUR_set(utf16_buffer, 0);
11680 DEBUG_P(PerlIO_printf(Perl_debug_log,
11681 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11683 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11684 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11689 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11691 SV *filter = filter_add(S_utf16_textfilter, NULL);
11693 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11695 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11696 sv_setpvs(filter, "");
11697 IoLINES(filter) = reversed;
11698 IoPAGE(filter) = 1; /* Not EOF */
11700 /* Sadly, we have to return a valid pointer, come what may, so we have to
11701 ignore any error return from this. */
11702 SvCUR_set(PL_linestr, 0);
11703 if (FILTER_READ(0, PL_linestr, 0)) {
11704 SvUTF8_on(PL_linestr);
11706 SvUTF8_on(PL_linestr);
11708 PL_bufend = SvEND(PL_linestr);
11709 return (U8*)SvPVX(PL_linestr);
11714 Returns a pointer to the next character after the parsed
11715 vstring, as well as updating the passed in sv.
11717 Function must be called like
11719 sv = sv_2mortal(newSV(5));
11720 s = scan_vstring(s,e,sv);
11722 where s and e are the start and end of the string.
11723 The sv should already be large enough to store the vstring
11724 passed in, for performance reasons.
11726 This function may croak if fatal warnings are enabled in the
11727 calling scope, hence the sv_2mortal in the example (to prevent
11728 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11734 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11737 const char *pos = s;
11738 const char *start = s;
11740 PERL_ARGS_ASSERT_SCAN_VSTRING;
11742 if (*pos == 'v') pos++; /* get past 'v' */
11743 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11745 if ( *pos != '.') {
11746 /* this may not be a v-string if followed by => */
11747 const char *next = pos;
11748 while (next < e && isSPACE(*next))
11750 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11751 /* return string not v-string */
11752 sv_setpvn(sv,(char *)s,pos-s);
11753 return (char *)pos;
11757 if (!isALPHA(*pos)) {
11758 U8 tmpbuf[UTF8_MAXBYTES+1];
11761 s++; /* get past 'v' */
11766 /* this is atoi() that tolerates underscores */
11769 const char *end = pos;
11771 while (--end >= s) {
11773 const UV orev = rev;
11774 rev += (*end - '0') * mult;
11777 /* diag_listed_as: Integer overflow in %s number */
11778 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11779 "Integer overflow in decimal number");
11783 if (rev > 0x7FFFFFFF)
11784 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11786 /* Append native character for the rev point */
11787 tmpend = uvchr_to_utf8(tmpbuf, rev);
11788 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11789 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11791 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11797 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11801 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11808 Perl_keyword_plugin_standard(pTHX_
11809 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11811 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11812 PERL_UNUSED_CONTEXT;
11813 PERL_UNUSED_ARG(keyword_ptr);
11814 PERL_UNUSED_ARG(keyword_len);
11815 PERL_UNUSED_ARG(op_ptr);
11816 return KEYWORD_PLUGIN_DECLINE;
11819 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11821 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11823 SAVEI32(PL_lex_brackets);
11824 if (PL_lex_brackets > 100)
11825 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11826 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11827 SAVEI32(PL_lex_allbrackets);
11828 PL_lex_allbrackets = 0;
11829 SAVEI8(PL_lex_fakeeof);
11830 PL_lex_fakeeof = (U8)fakeeof;
11831 if(yyparse(gramtype) && !PL_parser->error_count)
11832 qerror(Perl_mess(aTHX_ "Parse error"));
11835 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11837 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11841 SAVEVPTR(PL_eval_root);
11842 PL_eval_root = NULL;
11843 parse_recdescent(gramtype, fakeeof);
11849 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11851 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11854 if (flags & ~PARSE_OPTIONAL)
11855 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11856 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11857 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11858 if (!PL_parser->error_count)
11859 qerror(Perl_mess(aTHX_ "Parse error"));
11860 exprop = newOP(OP_NULL, 0);
11866 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11868 Parse a Perl arithmetic expression. This may contain operators of precedence
11869 down to the bit shift operators. The expression must be followed (and thus
11870 terminated) either by a comparison or lower-precedence operator or by
11871 something that would normally terminate an expression such as semicolon.
11872 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11873 otherwise it is mandatory. It is up to the caller to ensure that the
11874 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11875 the source of the code to be parsed and the lexical context for the
11878 The op tree representing the expression is returned. If an optional
11879 expression is absent, a null pointer is returned, otherwise the pointer
11882 If an error occurs in parsing or compilation, in most cases a valid op
11883 tree is returned anyway. The error is reflected in the parser state,
11884 normally resulting in a single exception at the top level of parsing
11885 which covers all the compilation errors that occurred. Some compilation
11886 errors, however, will throw an exception immediately.
11892 Perl_parse_arithexpr(pTHX_ U32 flags)
11894 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11898 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11900 Parse a Perl term expression. This may contain operators of precedence
11901 down to the assignment operators. The expression must be followed (and thus
11902 terminated) either by a comma or lower-precedence operator or by
11903 something that would normally terminate an expression such as semicolon.
11904 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11905 otherwise it is mandatory. It is up to the caller to ensure that the
11906 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11907 the source of the code to be parsed and the lexical context for the
11910 The op tree representing the expression is returned. If an optional
11911 expression is absent, a null pointer is returned, otherwise the pointer
11914 If an error occurs in parsing or compilation, in most cases a valid op
11915 tree is returned anyway. The error is reflected in the parser state,
11916 normally resulting in a single exception at the top level of parsing
11917 which covers all the compilation errors that occurred. Some compilation
11918 errors, however, will throw an exception immediately.
11924 Perl_parse_termexpr(pTHX_ U32 flags)
11926 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11930 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11932 Parse a Perl list expression. This may contain operators of precedence
11933 down to the comma operator. The expression must be followed (and thus
11934 terminated) either by a low-precedence logic operator such as C<or> or by
11935 something that would normally terminate an expression such as semicolon.
11936 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11937 otherwise it is mandatory. It is up to the caller to ensure that the
11938 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11939 the source of the code to be parsed and the lexical context for the
11942 The op tree representing the expression is returned. If an optional
11943 expression is absent, a null pointer is returned, otherwise the pointer
11946 If an error occurs in parsing or compilation, in most cases a valid op
11947 tree is returned anyway. The error is reflected in the parser state,
11948 normally resulting in a single exception at the top level of parsing
11949 which covers all the compilation errors that occurred. Some compilation
11950 errors, however, will throw an exception immediately.
11956 Perl_parse_listexpr(pTHX_ U32 flags)
11958 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11962 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11964 Parse a single complete Perl expression. This allows the full
11965 expression grammar, including the lowest-precedence operators such
11966 as C<or>. The expression must be followed (and thus terminated) by a
11967 token that an expression would normally be terminated by: end-of-file,
11968 closing bracketing punctuation, semicolon, or one of the keywords that
11969 signals a postfix expression-statement modifier. If I<flags> includes
11970 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11971 mandatory. It is up to the caller to ensure that the dynamic parser
11972 state (L</PL_parser> et al) is correctly set to reflect the source of
11973 the code to be parsed and the lexical context for the expression.
11975 The op tree representing the expression is returned. If an optional
11976 expression is absent, a null pointer is returned, otherwise the pointer
11979 If an error occurs in parsing or compilation, in most cases a valid op
11980 tree is returned anyway. The error is reflected in the parser state,
11981 normally resulting in a single exception at the top level of parsing
11982 which covers all the compilation errors that occurred. Some compilation
11983 errors, however, will throw an exception immediately.
11989 Perl_parse_fullexpr(pTHX_ U32 flags)
11991 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11995 =for apidoc Amx|OP *|parse_block|U32 flags
11997 Parse a single complete Perl code block. This consists of an opening
11998 brace, a sequence of statements, and a closing brace. The block
11999 constitutes a lexical scope, so C<my> variables and various compile-time
12000 effects can be contained within it. It is up to the caller to ensure
12001 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12002 reflect the source of the code to be parsed and the lexical context for
12005 The op tree representing the code block is returned. This is always a
12006 real op, never a null pointer. It will normally be a C<lineseq> list,
12007 including C<nextstate> or equivalent ops. No ops to construct any kind
12008 of runtime scope are included by virtue of it being a block.
12010 If an error occurs in parsing or compilation, in most cases a valid op
12011 tree (most likely null) is returned anyway. The error is reflected in
12012 the parser state, normally resulting in a single exception at the top
12013 level of parsing which covers all the compilation errors that occurred.
12014 Some compilation errors, however, will throw an exception immediately.
12016 The I<flags> parameter is reserved for future use, and must always
12023 Perl_parse_block(pTHX_ U32 flags)
12026 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12027 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12031 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12033 Parse a single unadorned Perl statement. This may be a normal imperative
12034 statement or a declaration that has compile-time effect. It does not
12035 include any label or other affixture. It is up to the caller to ensure
12036 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12037 reflect the source of the code to be parsed and the lexical context for
12040 The op tree representing the statement is returned. This may be a
12041 null pointer if the statement is null, for example if it was actually
12042 a subroutine definition (which has compile-time side effects). If not
12043 null, it will be ops directly implementing the statement, suitable to
12044 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12045 equivalent op (except for those embedded in a scope contained entirely
12046 within the statement).
12048 If an error occurs in parsing or compilation, in most cases a valid op
12049 tree (most likely null) is returned anyway. The error is reflected in
12050 the parser state, normally resulting in a single exception at the top
12051 level of parsing which covers all the compilation errors that occurred.
12052 Some compilation errors, however, will throw an exception immediately.
12054 The I<flags> parameter is reserved for future use, and must always
12061 Perl_parse_barestmt(pTHX_ U32 flags)
12064 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12065 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12069 =for apidoc Amx|SV *|parse_label|U32 flags
12071 Parse a single label, possibly optional, of the type that may prefix a
12072 Perl statement. It is up to the caller to ensure that the dynamic parser
12073 state (L</PL_parser> et al) is correctly set to reflect the source of
12074 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
12075 label is optional, otherwise it is mandatory.
12077 The name of the label is returned in the form of a fresh scalar. If an
12078 optional label is absent, a null pointer is returned.
12080 If an error occurs in parsing, which can only occur if the label is
12081 mandatory, a valid label is returned anyway. The error is reflected in
12082 the parser state, normally resulting in a single exception at the top
12083 level of parsing which covers all the compilation errors that occurred.
12089 Perl_parse_label(pTHX_ U32 flags)
12091 if (flags & ~PARSE_OPTIONAL)
12092 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12093 if (PL_lex_state == LEX_KNOWNEXT) {
12094 PL_parser->yychar = yylex();
12095 if (PL_parser->yychar == LABEL) {
12096 char * const lpv = pl_yylval.pval;
12097 STRLEN llen = strlen(lpv);
12098 PL_parser->yychar = YYEMPTY;
12099 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12106 STRLEN wlen, bufptr_pos;
12109 if (!isIDFIRST_lazy_if(s, UTF))
12111 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12112 if (word_takes_any_delimeter(s, wlen))
12114 bufptr_pos = s - SvPVX(PL_linestr);
12116 lex_read_space(LEX_KEEP_PREVIOUS);
12118 s = SvPVX(PL_linestr) + bufptr_pos;
12119 if (t[0] == ':' && t[1] != ':') {
12120 PL_oldoldbufptr = PL_oldbufptr;
12123 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12127 if (flags & PARSE_OPTIONAL) {
12130 qerror(Perl_mess(aTHX_ "Parse error"));
12131 return newSVpvs("x");
12138 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12140 Parse a single complete Perl statement. This may be a normal imperative
12141 statement or a declaration that has compile-time effect, and may include
12142 optional labels. It is up to the caller to ensure that the dynamic
12143 parser state (L</PL_parser> et al) is correctly set to reflect the source
12144 of the code to be parsed and the lexical context for the statement.
12146 The op tree representing the statement is returned. This may be a
12147 null pointer if the statement is null, for example if it was actually
12148 a subroutine definition (which has compile-time side effects). If not
12149 null, it will be the result of a L</newSTATEOP> call, normally including
12150 a C<nextstate> or equivalent op.
12152 If an error occurs in parsing or compilation, in most cases a valid op
12153 tree (most likely null) is returned anyway. The error is reflected in
12154 the parser state, normally resulting in a single exception at the top
12155 level of parsing which covers all the compilation errors that occurred.
12156 Some compilation errors, however, will throw an exception immediately.
12158 The I<flags> parameter is reserved for future use, and must always
12165 Perl_parse_fullstmt(pTHX_ U32 flags)
12168 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12169 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12173 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12175 Parse a sequence of zero or more Perl statements. These may be normal
12176 imperative statements, including optional labels, or declarations
12177 that have compile-time effect, or any mixture thereof. The statement
12178 sequence ends when a closing brace or end-of-file is encountered in a
12179 place where a new statement could have validly started. It is up to
12180 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12181 is correctly set to reflect the source of the code to be parsed and the
12182 lexical context for the statements.
12184 The op tree representing the statement sequence is returned. This may
12185 be a null pointer if the statements were all null, for example if there
12186 were no statements or if there were only subroutine definitions (which
12187 have compile-time side effects). If not null, it will be a C<lineseq>
12188 list, normally including C<nextstate> or equivalent ops.
12190 If an error occurs in parsing or compilation, in most cases a valid op
12191 tree is returned anyway. The error is reflected in the parser state,
12192 normally resulting in a single exception at the top level of parsing
12193 which covers all the compilation errors that occurred. Some compilation
12194 errors, however, will throw an exception immediately.
12196 The I<flags> parameter is reserved for future use, and must always
12203 Perl_parse_stmtseq(pTHX_ U32 flags)
12208 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12209 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12210 c = lex_peek_unichar(0);
12211 if (c != -1 && c != /*{*/'}')
12212 qerror(Perl_mess(aTHX_ "Parse error"));
12218 * c-indentation-style: bsd
12219 * c-basic-offset: 4
12220 * indent-tabs-mode: nil
12223 * ex: set ts=8 sts=4 sw=4 et: