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 bad_proto_after_underscore = FALSE;
1613 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1619 for (; len--; p++) {
1622 proto_after_greedy_proto = TRUE;
1624 if (!strchr(";@%", *p))
1625 bad_proto_after_underscore = TRUE;
1628 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1635 in_brackets = FALSE;
1636 else if ((*p == '@' || *p == '%') &&
1639 must_be_last = TRUE;
1648 after_slash = FALSE;
1653 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1656 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1657 origlen, UNI_DISPLAY_ISPRINT)
1658 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1660 if (proto_after_greedy_proto)
1661 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1662 "Prototype after '%c' for %"SVf" : %s",
1663 greedy_proto, SVfARG(name), p);
1665 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1666 "Missing ']' in prototype for %"SVf" : %s",
1669 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1670 "Illegal character in prototype for %"SVf" : %s",
1672 if (bad_proto_after_underscore)
1673 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1674 "Illegal character after '_' in prototype for %"SVf" : %s",
1678 return (! (proto_after_greedy_proto || bad_proto) );
1683 * This subroutine has nothing to do with tilting, whether at windmills
1684 * or pinball tables. Its name is short for "increment line". It
1685 * increments the current line number in CopLINE(PL_curcop) and checks
1686 * to see whether the line starts with a comment of the form
1687 * # line 500 "foo.pm"
1688 * If so, it sets the current line number and file to the values in the comment.
1692 S_incline(pTHX_ const char *s)
1700 PERL_ARGS_ASSERT_INCLINE;
1702 COPLINE_INC_WITH_HERELINES;
1703 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1704 && s+1 == PL_bufend && *s == ';') {
1705 /* fake newline in string eval */
1706 CopLINE_dec(PL_curcop);
1711 while (SPACE_OR_TAB(*s))
1713 if (strnEQ(s, "line", 4))
1717 if (SPACE_OR_TAB(*s))
1721 while (SPACE_OR_TAB(*s))
1729 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1731 while (SPACE_OR_TAB(*s))
1733 if (*s == '"' && (t = strchr(s+1, '"'))) {
1739 while (!isSPACE(*t))
1743 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1745 if (*e != '\n' && *e != '\0')
1746 return; /* false alarm */
1748 line_num = atoi(n)-1;
1751 const STRLEN len = t - s;
1752 SV *const temp_sv = CopFILESV(PL_curcop);
1757 cf = SvPVX(temp_sv);
1758 tmplen = SvCUR(temp_sv);
1764 if (!PL_rsfp && !PL_parser->filtered) {
1765 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1766 * to *{"::_<newfilename"} */
1767 /* However, the long form of evals is only turned on by the
1768 debugger - usually they're "(eval %lu)" */
1772 STRLEN tmplen2 = len;
1773 if (tmplen + 2 <= sizeof smallbuf)
1776 Newx(tmpbuf, tmplen + 2, char);
1779 memcpy(tmpbuf + 2, cf, tmplen);
1781 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1786 if (tmplen2 + 2 <= sizeof smallbuf)
1789 Newx(tmpbuf2, tmplen2 + 2, char);
1791 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1792 /* Either they malloc'd it, or we malloc'd it,
1793 so no prefix is present in ours. */
1798 memcpy(tmpbuf2 + 2, s, tmplen2);
1801 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1803 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1804 /* adjust ${"::_<newfilename"} to store the new file name */
1805 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1806 /* The line number may differ. If that is the case,
1807 alias the saved lines that are in the array.
1808 Otherwise alias the whole array. */
1809 if (CopLINE(PL_curcop) == line_num) {
1810 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1811 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1813 else if (GvAV(*gvp)) {
1814 AV * const av = GvAV(*gvp);
1815 const I32 start = CopLINE(PL_curcop)+1;
1816 I32 items = AvFILLp(av) - start;
1818 AV * const av2 = GvAVn(gv2);
1819 SV **svp = AvARRAY(av) + start;
1820 I32 l = (I32)line_num+1;
1822 av_store(av2, l++, SvREFCNT_inc(*svp++));
1827 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1829 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1831 CopFILE_free(PL_curcop);
1832 CopFILE_setn(PL_curcop, s, len);
1834 CopLINE_set(PL_curcop, line_num);
1838 /* skip space before PL_thistoken */
1841 S_skipspace0(pTHX_ char *s)
1843 PERL_ARGS_ASSERT_SKIPSPACE0;
1850 PL_thiswhite = newSVpvs("");
1851 sv_catsv(PL_thiswhite, PL_skipwhite);
1852 sv_free(PL_skipwhite);
1855 PL_realtokenstart = s - SvPVX(PL_linestr);
1859 /* skip space after PL_thistoken */
1862 S_skipspace1(pTHX_ char *s)
1864 const char *start = s;
1865 I32 startoff = start - SvPVX(PL_linestr);
1867 PERL_ARGS_ASSERT_SKIPSPACE1;
1872 start = SvPVX(PL_linestr) + startoff;
1873 if (!PL_thistoken && PL_realtokenstart >= 0) {
1874 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1875 PL_thistoken = newSVpvn(tstart, start - tstart);
1877 PL_realtokenstart = -1;
1880 PL_nextwhite = newSVpvs("");
1881 sv_catsv(PL_nextwhite, PL_skipwhite);
1882 sv_free(PL_skipwhite);
1889 S_skipspace2(pTHX_ char *s, SV **svp)
1892 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1893 const I32 startoff = s - SvPVX(PL_linestr);
1895 PERL_ARGS_ASSERT_SKIPSPACE2;
1898 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1899 if (!PL_madskills || !svp)
1901 start = SvPVX(PL_linestr) + startoff;
1902 if (!PL_thistoken && PL_realtokenstart >= 0) {
1903 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1904 PL_thistoken = newSVpvn(tstart, start - tstart);
1905 PL_realtokenstart = -1;
1909 *svp = newSVpvs("");
1910 sv_setsv(*svp, PL_skipwhite);
1911 sv_free(PL_skipwhite);
1920 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1922 AV *av = CopFILEAVx(PL_curcop);
1924 SV * const sv = newSV_type(SVt_PVMG);
1926 sv_setsv_flags(sv, orig_sv, 0); /* no cow */
1928 sv_setpvn(sv, buf, len);
1931 av_store(av, (I32)CopLINE(PL_curcop), sv);
1937 * Called to gobble the appropriate amount and type of whitespace.
1938 * Skips comments as well.
1942 S_skipspace(pTHX_ char *s)
1946 #endif /* PERL_MAD */
1947 PERL_ARGS_ASSERT_SKIPSPACE;
1950 sv_free(PL_skipwhite);
1951 PL_skipwhite = NULL;
1953 #endif /* PERL_MAD */
1954 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1955 while (s < PL_bufend && SPACE_OR_TAB(*s))
1958 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1960 lex_read_space(LEX_KEEP_PREVIOUS |
1961 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1962 LEX_NO_NEXT_CHUNK : 0));
1964 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1965 if (PL_linestart > PL_bufptr)
1966 PL_bufptr = PL_linestart;
1971 PL_skipwhite = newSVpvn(start, s-start);
1972 #endif /* PERL_MAD */
1978 * Check the unary operators to ensure there's no ambiguity in how they're
1979 * used. An ambiguous piece of code would be:
1981 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1982 * the +5 is its argument.
1992 if (PL_oldoldbufptr != PL_last_uni)
1994 while (isSPACE(*PL_last_uni))
1997 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1999 if ((t = strchr(s, '(')) && t < PL_bufptr)
2002 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
2003 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
2004 (int)(s - PL_last_uni), PL_last_uni);
2008 * LOP : macro to build a list operator. Its behaviour has been replaced
2009 * with a subroutine, S_lop() for which LOP is just another name.
2012 #define LOP(f,x) return lop(f,x,s)
2016 * Build a list operator (or something that might be one). The rules:
2017 * - if we have a next token, then it's a list operator [why?]
2018 * - if the next thing is an opening paren, then it's a function
2019 * - else it's a list operator
2023 S_lop(pTHX_ I32 f, int x, char *s)
2027 PERL_ARGS_ASSERT_LOP;
2033 PL_last_lop = PL_oldbufptr;
2034 PL_last_lop_op = (OPCODE)f;
2043 return REPORT(FUNC);
2046 return REPORT(FUNC);
2049 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
2050 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
2051 return REPORT(LSTOP);
2058 * Sets up for an eventual force_next(). start_force(0) basically does
2059 * an unshift, while start_force(-1) does a push. yylex removes items
2064 S_start_force(pTHX_ int where)
2068 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
2069 where = PL_lasttoke;
2070 assert(PL_curforce < 0 || PL_curforce == where);
2071 if (PL_curforce != where) {
2072 for (i = PL_lasttoke; i > where; --i) {
2073 PL_nexttoke[i] = PL_nexttoke[i-1];
2077 if (PL_curforce < 0) /* in case of duplicate start_force() */
2078 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
2079 PL_curforce = where;
2082 curmad('^', newSVpvs(""));
2083 CURMAD('_', PL_nextwhite);
2088 S_curmad(pTHX_ char slot, SV *sv)
2094 if (PL_curforce < 0)
2095 where = &PL_thismad;
2097 where = &PL_nexttoke[PL_curforce].next_mad;
2103 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2105 else if (PL_encoding) {
2106 sv_recode_to_utf8(sv, PL_encoding);
2111 /* keep a slot open for the head of the list? */
2112 if (slot != '_' && *where && (*where)->mad_key == '^') {
2113 (*where)->mad_key = slot;
2114 sv_free(MUTABLE_SV(((*where)->mad_val)));
2115 (*where)->mad_val = (void*)sv;
2118 addmad(newMADsv(slot, sv), where, 0);
2121 # define start_force(where) NOOP
2122 # define curmad(slot, sv) NOOP
2127 * When the lexer realizes it knows the next token (for instance,
2128 * it is reordering tokens for the parser) then it can call S_force_next
2129 * to know what token to return the next time the lexer is called. Caller
2130 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2131 * and possibly PL_expect to ensure the lexer handles the token correctly.
2135 S_force_next(pTHX_ I32 type)
2140 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2141 tokereport(type, &NEXTVAL_NEXTTOKE);
2145 if (PL_curforce < 0)
2146 start_force(PL_lasttoke);
2147 PL_nexttoke[PL_curforce].next_type = type;
2148 if (PL_lex_state != LEX_KNOWNEXT)
2149 PL_lex_defer = PL_lex_state;
2150 PL_lex_state = LEX_KNOWNEXT;
2151 PL_lex_expect = PL_expect;
2154 PL_nexttype[PL_nexttoke] = type;
2156 if (PL_lex_state != LEX_KNOWNEXT) {
2157 PL_lex_defer = PL_lex_state;
2158 PL_lex_expect = PL_expect;
2159 PL_lex_state = LEX_KNOWNEXT;
2167 int yyc = PL_parser->yychar;
2168 if (yyc != YYEMPTY) {
2171 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2172 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2173 PL_lex_allbrackets--;
2175 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2176 } else if (yyc == '('/*)*/) {
2177 PL_lex_allbrackets--;
2182 PL_parser->yychar = YYEMPTY;
2187 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2190 SV * const sv = newSVpvn_utf8(start, len,
2193 && !is_ascii_string((const U8*)start, len)
2194 && is_utf8_string((const U8*)start, len));
2200 * When the lexer knows the next thing is a word (for instance, it has
2201 * just seen -> and it knows that the next char is a word char, then
2202 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2206 * char *start : buffer position (must be within PL_linestr)
2207 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2208 * int check_keyword : if true, Perl checks to make sure the word isn't
2209 * a keyword (do this if the word is a label, e.g. goto FOO)
2210 * int allow_pack : if true, : characters will also be allowed (require,
2211 * use, etc. do this)
2212 * int allow_initial_tick : used by the "sub" lexer only.
2216 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2222 PERL_ARGS_ASSERT_FORCE_WORD;
2224 start = SKIPSPACE1(start);
2226 if (isIDFIRST_lazy_if(s,UTF) ||
2227 (allow_pack && *s == ':') )
2229 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2230 if (check_keyword) {
2231 char *s2 = PL_tokenbuf;
2232 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2234 if (keyword(s2, len, 0))
2237 start_force(PL_curforce);
2239 curmad('X', newSVpvn(start,s-start));
2240 if (token == METHOD) {
2245 PL_expect = XOPERATOR;
2249 curmad('g', newSVpvs( "forced" ));
2250 NEXTVAL_NEXTTOKE.opval
2251 = (OP*)newSVOP(OP_CONST,0,
2252 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2253 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2261 * Called when the lexer wants $foo *foo &foo etc, but the program
2262 * text only contains the "foo" portion. The first argument is a pointer
2263 * to the "foo", and the second argument is the type symbol to prefix.
2264 * Forces the next token to be a "WORD".
2265 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2269 S_force_ident(pTHX_ const char *s, int kind)
2273 PERL_ARGS_ASSERT_FORCE_IDENT;
2276 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2277 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2278 UTF ? SVf_UTF8 : 0));
2279 start_force(PL_curforce);
2280 NEXTVAL_NEXTTOKE.opval = o;
2283 o->op_private = OPpCONST_ENTERED;
2284 /* XXX see note in pp_entereval() for why we forgo typo
2285 warnings if the symbol must be introduced in an eval.
2287 gv_fetchpvn_flags(s, len,
2288 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2289 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2290 kind == '$' ? SVt_PV :
2291 kind == '@' ? SVt_PVAV :
2292 kind == '%' ? SVt_PVHV :
2300 S_force_ident_maybe_lex(pTHX_ char pit)
2302 start_force(PL_curforce);
2303 NEXTVAL_NEXTTOKE.ival = pit;
2308 Perl_str_to_version(pTHX_ SV *sv)
2313 const char *start = SvPV_const(sv,len);
2314 const char * const end = start + len;
2315 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2317 PERL_ARGS_ASSERT_STR_TO_VERSION;
2319 while (start < end) {
2323 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2328 retval += ((NV)n)/nshift;
2337 * Forces the next token to be a version number.
2338 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2339 * and if "guessing" is TRUE, then no new token is created (and the caller
2340 * must use an alternative parsing method).
2344 S_force_version(pTHX_ char *s, int guessing)
2350 I32 startoff = s - SvPVX(PL_linestr);
2353 PERL_ARGS_ASSERT_FORCE_VERSION;
2361 while (isDIGIT(*d) || *d == '_' || *d == '.')
2365 start_force(PL_curforce);
2366 curmad('X', newSVpvn(s,d-s));
2369 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2371 #ifdef USE_LOCALE_NUMERIC
2372 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2373 setlocale(LC_NUMERIC, "C");
2375 s = scan_num(s, &pl_yylval);
2376 #ifdef USE_LOCALE_NUMERIC
2377 setlocale(LC_NUMERIC, loc);
2380 version = pl_yylval.opval;
2381 ver = cSVOPx(version)->op_sv;
2382 if (SvPOK(ver) && !SvNIOK(ver)) {
2383 SvUPGRADE(ver, SVt_PVNV);
2384 SvNV_set(ver, str_to_version(ver));
2385 SvNOK_on(ver); /* hint that it is a version */
2388 else if (guessing) {
2391 sv_free(PL_nextwhite); /* let next token collect whitespace */
2393 s = SvPVX(PL_linestr) + startoff;
2401 if (PL_madskills && !version) {
2402 sv_free(PL_nextwhite); /* let next token collect whitespace */
2404 s = SvPVX(PL_linestr) + startoff;
2407 /* NOTE: The parser sees the package name and the VERSION swapped */
2408 start_force(PL_curforce);
2409 NEXTVAL_NEXTTOKE.opval = version;
2416 * S_force_strict_version
2417 * Forces the next token to be a version number using strict syntax rules.
2421 S_force_strict_version(pTHX_ char *s)
2426 I32 startoff = s - SvPVX(PL_linestr);
2428 const char *errstr = NULL;
2430 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2432 while (isSPACE(*s)) /* leading whitespace */
2435 if (is_STRICT_VERSION(s,&errstr)) {
2437 s = (char *)scan_version(s, ver, 0);
2438 version = newSVOP(OP_CONST, 0, ver);
2440 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2441 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2445 yyerror(errstr); /* version required */
2450 if (PL_madskills && !version) {
2451 sv_free(PL_nextwhite); /* let next token collect whitespace */
2453 s = SvPVX(PL_linestr) + startoff;
2456 /* NOTE: The parser sees the package name and the VERSION swapped */
2457 start_force(PL_curforce);
2458 NEXTVAL_NEXTTOKE.opval = version;
2466 * Tokenize a quoted string passed in as an SV. It finds the next
2467 * chunk, up to end of string or a backslash. It may make a new
2468 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2473 S_tokeq(pTHX_ SV *sv)
2482 PERL_ARGS_ASSERT_TOKEQ;
2487 s = SvPV_force(sv, len);
2488 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2491 /* This is relying on the SV being "well formed" with a trailing '\0' */
2492 while (s < send && !(*s == '\\' && s[1] == '\\'))
2497 if ( PL_hints & HINT_NEW_STRING ) {
2498 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2502 if (s + 1 < send && (s[1] == '\\'))
2503 s++; /* all that, just for this */
2508 SvCUR_set(sv, d - SvPVX_const(sv));
2510 if ( PL_hints & HINT_NEW_STRING )
2511 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2516 * Now come three functions related to double-quote context,
2517 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2518 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2519 * interact with PL_lex_state, and create fake ( ... ) argument lists
2520 * to handle functions and concatenation.
2524 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2529 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2531 * Pattern matching will set PL_lex_op to the pattern-matching op to
2532 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2534 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2536 * Everything else becomes a FUNC.
2538 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2539 * had an OP_CONST or OP_READLINE). This just sets us up for a
2540 * call to S_sublex_push().
2544 S_sublex_start(pTHX)
2547 const I32 op_type = pl_yylval.ival;
2549 if (op_type == OP_NULL) {
2550 pl_yylval.opval = PL_lex_op;
2554 if (op_type == OP_CONST || op_type == OP_READLINE) {
2555 SV *sv = tokeq(PL_lex_stuff);
2557 if (SvTYPE(sv) == SVt_PVIV) {
2558 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2560 const char * const p = SvPV_const(sv, len);
2561 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2565 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2566 PL_lex_stuff = NULL;
2567 /* Allow <FH> // "foo" */
2568 if (op_type == OP_READLINE)
2569 PL_expect = XTERMORDORDOR;
2572 else if (op_type == OP_BACKTICK && PL_lex_op) {
2573 /* readpipe() vas overriden */
2574 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2575 pl_yylval.opval = PL_lex_op;
2577 PL_lex_stuff = NULL;
2581 PL_sublex_info.super_state = PL_lex_state;
2582 PL_sublex_info.sub_inwhat = (U16)op_type;
2583 PL_sublex_info.sub_op = PL_lex_op;
2584 PL_lex_state = LEX_INTERPPUSH;
2588 pl_yylval.opval = PL_lex_op;
2598 * Create a new scope to save the lexing state. The scope will be
2599 * ended in S_sublex_done. Returns a '(', starting the function arguments
2600 * to the uc, lc, etc. found before.
2601 * Sets PL_lex_state to LEX_INTERPCONCAT.
2611 PL_lex_state = PL_sublex_info.super_state;
2612 SAVEBOOL(PL_lex_dojoin);
2613 SAVEI32(PL_lex_brackets);
2614 SAVEI32(PL_lex_allbrackets);
2615 SAVEI32(PL_lex_formbrack);
2616 SAVEI8(PL_lex_fakeeof);
2617 SAVEI32(PL_lex_casemods);
2618 SAVEI32(PL_lex_starts);
2619 SAVEI8(PL_lex_state);
2620 SAVESPTR(PL_lex_repl);
2621 SAVEVPTR(PL_lex_inpat);
2622 SAVEI16(PL_lex_inwhat);
2623 SAVECOPLINE(PL_curcop);
2624 SAVEPPTR(PL_bufptr);
2625 SAVEPPTR(PL_bufend);
2626 SAVEPPTR(PL_oldbufptr);
2627 SAVEPPTR(PL_oldoldbufptr);
2628 SAVEPPTR(PL_last_lop);
2629 SAVEPPTR(PL_last_uni);
2630 SAVEPPTR(PL_linestart);
2631 SAVESPTR(PL_linestr);
2632 SAVEGENERICPV(PL_lex_brackstack);
2633 SAVEGENERICPV(PL_lex_casestack);
2634 SAVEGENERICPV(PL_parser->lex_shared);
2635 SAVEBOOL(PL_parser->lex_re_reparsing);
2637 /* The here-doc parser needs to be able to peek into outer lexing
2638 scopes to find the body of the here-doc. So we put PL_linestr and
2639 PL_bufptr into lex_shared, to ‘share’ those values.
2641 PL_parser->lex_shared->ls_linestr = PL_linestr;
2642 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2644 PL_linestr = PL_lex_stuff;
2645 PL_lex_repl = PL_sublex_info.repl;
2646 PL_lex_stuff = NULL;
2647 PL_sublex_info.repl = NULL;
2649 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2650 = SvPVX(PL_linestr);
2651 PL_bufend += SvCUR(PL_linestr);
2652 PL_last_lop = PL_last_uni = NULL;
2653 SAVEFREESV(PL_linestr);
2654 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2656 PL_lex_dojoin = FALSE;
2657 PL_lex_brackets = PL_lex_formbrack = 0;
2658 PL_lex_allbrackets = 0;
2659 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2660 Newx(PL_lex_brackstack, 120, char);
2661 Newx(PL_lex_casestack, 12, char);
2662 PL_lex_casemods = 0;
2663 *PL_lex_casestack = '\0';
2665 PL_lex_state = LEX_INTERPCONCAT;
2666 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2668 Newxz(shared, 1, LEXSHARED);
2669 shared->ls_prev = PL_parser->lex_shared;
2670 PL_parser->lex_shared = shared;
2672 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2673 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2674 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2675 PL_lex_inpat = PL_sublex_info.sub_op;
2677 PL_lex_inpat = NULL;
2679 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2680 PL_in_eval &= ~EVAL_RE_REPARSING;
2687 * Restores lexer state after a S_sublex_push.
2694 if (!PL_lex_starts++) {
2695 SV * const sv = newSVpvs("");
2696 if (SvUTF8(PL_linestr))
2698 PL_expect = XOPERATOR;
2699 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2703 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2704 PL_lex_state = LEX_INTERPCASEMOD;
2708 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2709 assert(PL_lex_inwhat != OP_TRANSR);
2710 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2711 PL_linestr = PL_lex_repl;
2713 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2714 PL_bufend += SvCUR(PL_linestr);
2715 PL_last_lop = PL_last_uni = NULL;
2716 PL_lex_dojoin = FALSE;
2717 PL_lex_brackets = 0;
2718 PL_lex_allbrackets = 0;
2719 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2720 PL_lex_casemods = 0;
2721 *PL_lex_casestack = '\0';
2723 if (SvEVALED(PL_lex_repl)) {
2724 PL_lex_state = LEX_INTERPNORMAL;
2726 /* we don't clear PL_lex_repl here, so that we can check later
2727 whether this is an evalled subst; that means we rely on the
2728 logic to ensure sublex_done() is called again only via the
2729 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2732 PL_lex_state = LEX_INTERPCONCAT;
2742 PL_endwhite = newSVpvs("");
2743 sv_catsv(PL_endwhite, PL_thiswhite);
2747 sv_setpvs(PL_thistoken,"");
2749 PL_realtokenstart = -1;
2753 PL_bufend = SvPVX(PL_linestr);
2754 PL_bufend += SvCUR(PL_linestr);
2755 PL_expect = XOPERATOR;
2756 PL_sublex_info.sub_inwhat = 0;
2761 PERL_STATIC_INLINE SV*
2762 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2764 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2765 * interior, hence to the "}". Finds what the name resolves to, returning
2766 * an SV* containing it; NULL if no valid one found */
2768 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2775 const U8* first_bad_char_loc;
2776 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2778 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2780 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2782 &first_bad_char_loc))
2784 /* If warnings are on, this will print a more detailed analysis of what
2785 * is wrong than the error message below */
2786 utf8n_to_uvuni(first_bad_char_loc,
2787 e - ((char *) first_bad_char_loc),
2790 /* We deliberately don't try to print the malformed character, which
2791 * might not print very well; it also may be just the first of many
2792 * malformations, so don't print what comes after it */
2793 yyerror(Perl_form(aTHX_
2794 "Malformed UTF-8 character immediately after '%.*s'",
2795 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2799 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2800 /* include the <}> */
2801 e - backslash_ptr + 1);
2803 SvREFCNT_dec_NN(res);
2807 /* See if the charnames handler is the Perl core's, and if so, we can skip
2808 * the validation needed for a user-supplied one, as Perl's does its own
2810 table = GvHV(PL_hintgv); /* ^H */
2811 cvp = hv_fetchs(table, "charnames", FALSE);
2812 if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
2813 && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
2815 const char * const name = HvNAME(stash);
2816 if strEQ(name, "_charnames") {
2821 /* Here, it isn't Perl's charname handler. We can't rely on a
2822 * user-supplied handler to validate the input name. For non-ut8 input,
2823 * look to see that the first character is legal. Then loop through the
2824 * rest checking that each is a continuation */
2826 /* This code needs to be sync'ed with a regex in _charnames.pm which does
2830 if (! isALPHAU(*s)) {
2835 if (! isCHARNAME_CONT(*s)) {
2838 if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2839 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2840 "A sequence of multiple spaces in a charnames "
2841 "alias definition is deprecated");
2845 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2846 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2847 "Trailing white-space in a charnames alias "
2848 "definition is deprecated");
2852 /* Similarly for utf8. For invariants can check directly; for other
2853 * Latin1, can calculate their code point and check; otherwise use a
2855 if (UTF8_IS_INVARIANT(*s)) {
2856 if (! isALPHAU(*s)) {
2860 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2861 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
2867 if (! PL_utf8_charname_begin) {
2868 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2869 PL_utf8_charname_begin = _core_swash_init("utf8",
2870 "_Perl_Charname_Begin",
2872 1, 0, NULL, &flags);
2874 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2881 if (UTF8_IS_INVARIANT(*s)) {
2882 if (! isCHARNAME_CONT(*s)) {
2885 if (*s == ' ' && *(s-1) == ' '
2886 && ckWARN_d(WARN_DEPRECATED)) {
2887 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2888 "A sequence of multiple spaces in a charnam"
2889 "es alias definition is deprecated");
2893 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2894 if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
2902 if (! PL_utf8_charname_continue) {
2903 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2904 PL_utf8_charname_continue = _core_swash_init("utf8",
2905 "_Perl_Charname_Continue",
2907 1, 0, NULL, &flags);
2909 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2915 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2916 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2917 "Trailing white-space in a charnames alias "
2918 "definition is deprecated");
2922 if (SvUTF8(res)) { /* Don't accept malformed input */
2923 const U8* first_bad_char_loc;
2925 const char* const str = SvPV_const(res, len);
2926 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2927 /* If warnings are on, this will print a more detailed analysis of
2928 * what is wrong than the error message below */
2929 utf8n_to_uvuni(first_bad_char_loc,
2930 (char *) first_bad_char_loc - str,
2933 /* We deliberately don't try to print the malformed character,
2934 * which might not print very well; it also may be just the first
2935 * of many malformations, so don't print what comes after it */
2938 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2939 (int) (e - backslash_ptr + 1), backslash_ptr,
2940 (int) ((char *) first_bad_char_loc - str), str
2950 int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
2952 /* The final %.*s makes sure that should the trailing NUL be missing
2953 * that this print won't run off the end of the string */
2956 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2957 (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2958 (int)(e - s + bad_char_size), s + bad_char_size
2960 UTF ? SVf_UTF8 : 0);
2968 Extracts the next constant part of a pattern, double-quoted string,
2969 or transliteration. This is terrifying code.
2971 For example, in parsing the double-quoted string "ab\x63$d", it would
2972 stop at the '$' and return an OP_CONST containing 'abc'.
2974 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2975 processing a pattern (PL_lex_inpat is true), a transliteration
2976 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2978 Returns a pointer to the character scanned up to. If this is
2979 advanced from the start pointer supplied (i.e. if anything was
2980 successfully parsed), will leave an OP_CONST for the substring scanned
2981 in pl_yylval. Caller must intuit reason for not parsing further
2982 by looking at the next characters herself.
2986 \N{FOO} => \N{U+hex_for_character_FOO}
2987 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2990 all other \-char, including \N and \N{ apart from \N{ABC}
2993 @ and $ where it appears to be a var, but not for $ as tail anchor
2998 In transliterations:
2999 characters are VERY literal, except for - not at the start or end
3000 of the string, which indicates a range. If the range is in bytes,
3001 scan_const expands the range to the full set of intermediate
3002 characters. If the range is in utf8, the hyphen is replaced with
3003 a certain range mark which will be handled by pmtrans() in op.c.
3005 In double-quoted strings:
3007 double-quoted style: \r and \n
3008 constants: \x31, etc.
3009 deprecated backrefs: \1 (in substitution replacements)
3010 case and quoting: \U \Q \E
3013 scan_const does *not* construct ops to handle interpolated strings.
3014 It stops processing as soon as it finds an embedded $ or @ variable
3015 and leaves it to the caller to work out what's going on.
3017 embedded arrays (whether in pattern or not) could be:
3018 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
3020 $ in double-quoted strings must be the symbol of an embedded scalar.
3022 $ in pattern could be $foo or could be tail anchor. Assumption:
3023 it's a tail anchor if $ is the last thing in the string, or if it's
3024 followed by one of "()| \r\n\t"
3026 \1 (backreferences) are turned into $1 in substitutions
3028 The structure of the code is
3029 while (there's a character to process) {
3030 handle transliteration ranges
3031 skip regexp comments /(?#comment)/ and codes /(?{code})/
3032 skip #-initiated comments in //x patterns
3033 check for embedded arrays
3034 check for embedded scalars
3036 deprecate \1 in substitution replacements
3037 handle string-changing backslashes \l \U \Q \E, etc.
3038 switch (what was escaped) {
3039 handle \- in a transliteration (becomes a literal -)
3040 if a pattern and not \N{, go treat as regular character
3041 handle \132 (octal characters)
3042 handle \x15 and \x{1234} (hex characters)
3043 handle \N{name} (named characters, also \N{3,5} in a pattern)
3044 handle \cV (control characters)
3045 handle printf-style backslashes (\f, \r, \n, etc)
3048 } (end if backslash)
3049 handle regular character
3050 } (end while character to read)
3055 S_scan_const(pTHX_ char *start)
3058 char *send = PL_bufend; /* end of the constant */
3059 SV *sv = newSV(send - start); /* sv for the constant. See
3060 note below on sizing. */
3061 char *s = start; /* start of the constant */
3062 char *d = SvPVX(sv); /* destination for copies */
3063 bool dorange = FALSE; /* are we in a translit range? */
3064 bool didrange = FALSE; /* did we just finish a range? */
3065 bool in_charclass = FALSE; /* within /[...]/ */
3066 bool has_utf8 = FALSE; /* Output constant is UTF8 */
3067 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
3068 to be UTF8? But, this can
3069 show as true when the source
3070 isn't utf8, as for example
3071 when it is entirely composed
3073 SV *res; /* result from charnames */
3075 /* Note on sizing: The scanned constant is placed into sv, which is
3076 * initialized by newSV() assuming one byte of output for every byte of
3077 * input. This routine expects newSV() to allocate an extra byte for a
3078 * trailing NUL, which this routine will append if it gets to the end of
3079 * the input. There may be more bytes of input than output (eg., \N{LATIN
3080 * CAPITAL LETTER A}), or more output than input if the constant ends up
3081 * recoded to utf8, but each time a construct is found that might increase
3082 * the needed size, SvGROW() is called. Its size parameter each time is
3083 * based on the best guess estimate at the time, namely the length used so
3084 * far, plus the length the current construct will occupy, plus room for
3085 * the trailing NUL, plus one byte for every input byte still unscanned */
3087 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
3090 UV literal_endpoint = 0;
3091 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
3094 PERL_ARGS_ASSERT_SCAN_CONST;
3096 assert(PL_lex_inwhat != OP_TRANSR);
3097 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3098 /* If we are doing a trans and we know we want UTF8 set expectation */
3099 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
3100 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3103 /* Protect sv from errors and fatal warnings. */
3104 ENTER_with_name("scan_const");
3107 while (s < send || dorange) {
3109 /* get transliterations out of the way (they're most literal) */
3110 if (PL_lex_inwhat == OP_TRANS) {
3111 /* expand a range A-Z to the full set of characters. AIE! */
3113 I32 i; /* current expanded character */
3114 I32 min; /* first character in range */
3115 I32 max; /* last character in range */
3126 char * const c = (char*)utf8_hop((U8*)d, -1);
3130 *c = (char)UTF_TO_NATIVE(0xff);
3131 /* mark the range as done, and continue */
3137 i = d - SvPVX_const(sv); /* remember current offset */
3140 SvLEN(sv) + (has_utf8 ?
3141 (512 - UTF_CONTINUATION_MARK +
3144 /* How many two-byte within 0..255: 128 in UTF-8,
3145 * 96 in UTF-8-mod. */
3147 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
3149 d = SvPVX(sv) + i; /* refresh d after realloc */
3153 for (j = 0; j <= 1; j++) {
3154 char * const c = (char*)utf8_hop((U8*)d, -1);
3155 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3161 max = (U8)0xff; /* only to \xff */
3162 uvmax = uv; /* \x{100} to uvmax */
3164 d = c; /* eat endpoint chars */
3169 d -= 2; /* eat the first char and the - */
3170 min = (U8)*d; /* first char in range */
3171 max = (U8)d[1]; /* last char in range */
3178 "Invalid range \"%c-%c\" in transliteration operator",
3179 (char)min, (char)max);
3183 if (literal_endpoint == 2 &&
3184 ((isLOWER(min) && isLOWER(max)) ||
3185 (isUPPER(min) && isUPPER(max)))) {
3187 for (i = min; i <= max; i++)
3189 *d++ = NATIVE_TO_NEED(has_utf8,i);
3191 for (i = min; i <= max; i++)
3193 *d++ = NATIVE_TO_NEED(has_utf8,i);
3198 for (i = min; i <= max; i++)
3201 const U8 ch = (U8)NATIVE_TO_UTF(i);
3202 if (UNI_IS_INVARIANT(ch))
3205 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
3206 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
3215 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3217 *d++ = (char)UTF_TO_NATIVE(0xff);
3219 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3223 /* mark the range as done, and continue */
3227 literal_endpoint = 0;
3232 /* range begins (ignore - as first or last char) */
3233 else if (*s == '-' && s+1 < send && s != start) {
3235 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3242 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
3252 literal_endpoint = 0;
3253 native_range = TRUE;
3258 /* if we get here, we're not doing a transliteration */
3260 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3263 while (s1 >= start && *s1-- == '\\')
3266 in_charclass = TRUE;
3269 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3272 while (s1 >= start && *s1-- == '\\')
3275 in_charclass = FALSE;
3278 /* skip for regexp comments /(?#comment)/, except for the last
3279 * char, which will be done separately.
3280 * Stop on (?{..}) and friends */
3282 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
3284 while (s+1 < send && *s != ')')
3285 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3287 else if (!PL_lex_casemods && !in_charclass &&
3288 ( s[2] == '{' /* This should match regcomp.c */
3289 || (s[2] == '?' && s[3] == '{')))
3295 /* likewise skip #-initiated comments in //x patterns */
3296 else if (*s == '#' && PL_lex_inpat &&
3297 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3298 while (s+1 < send && *s != '\n')
3299 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3302 /* no further processing of single-quoted regex */
3303 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3304 goto default_action;
3306 /* check for embedded arrays
3307 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3309 else if (*s == '@' && s[1]) {
3310 if (isWORDCHAR_lazy_if(s+1,UTF))
3312 if (strchr(":'{$", s[1]))
3314 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3315 break; /* in regexp, neither @+ nor @- are interpolated */
3318 /* check for embedded scalars. only stop if we're sure it's a
3321 else if (*s == '$') {
3322 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3324 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3326 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3327 "Possible unintended interpolation of $\\ in regex");
3329 break; /* in regexp, $ might be tail anchor */
3333 /* End of else if chain - OP_TRANS rejoin rest */
3336 if (*s == '\\' && s+1 < send) {
3337 char* e; /* Can be used for ending '}', etc. */
3341 /* warn on \1 - \9 in substitution replacements, but note that \11
3342 * is an octal; and \19 is \1 followed by '9' */
3343 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3344 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3346 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3351 /* string-change backslash escapes */
3352 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3356 /* In a pattern, process \N, but skip any other backslash escapes.
3357 * This is because we don't want to translate an escape sequence
3358 * into a meta symbol and have the regex compiler use the meta
3359 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3360 * in spite of this, we do have to process \N here while the proper
3361 * charnames handler is in scope. See bugs #56444 and #62056.
3362 * There is a complication because \N in a pattern may also stand
3363 * for 'match a non-nl', and not mean a charname, in which case its
3364 * processing should be deferred to the regex compiler. To be a
3365 * charname it must be followed immediately by a '{', and not look
3366 * like \N followed by a curly quantifier, i.e., not something like
3367 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3369 else if (PL_lex_inpat
3372 || regcurly(s + 1, FALSE)))
3374 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
3375 goto default_action;
3380 /* quoted - in transliterations */
3382 if (PL_lex_inwhat == OP_TRANS) {
3389 if ((isALPHANUMERIC(*s)))
3390 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3391 "Unrecognized escape \\%c passed through",
3393 /* default action is to copy the quoted character */
3394 goto default_action;
3397 /* eg. \132 indicates the octal constant 0132 */
3398 case '0': case '1': case '2': case '3':
3399 case '4': case '5': case '6': case '7':
3401 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3403 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
3405 if (len < 3 && s < send && isDIGIT(*s)
3406 && ckWARN(WARN_MISC))
3408 Perl_warner(aTHX_ packWARN(WARN_MISC),
3409 "%s", form_short_octal_warning(s, len));
3412 goto NUM_ESCAPE_INSERT;
3414 /* eg. \o{24} indicates the octal constant \024 */
3419 bool valid = grok_bslash_o(&s, &uv, &error,
3420 TRUE, /* Output warning */
3421 FALSE, /* Not strict */
3422 TRUE, /* Output warnings for
3429 goto NUM_ESCAPE_INSERT;
3432 /* eg. \x24 indicates the hex constant 0x24 */
3437 bool valid = grok_bslash_x(&s, &uv, &error,
3438 TRUE, /* Output warning */
3439 FALSE, /* Not strict */
3440 TRUE, /* Output warnings for
3450 /* Insert oct or hex escaped character. There will always be
3451 * enough room in sv since such escapes will be longer than any
3452 * UTF-8 sequence they can end up as, except if they force us
3453 * to recode the rest of the string into utf8 */
3455 /* Here uv is the ordinal of the next character being added in
3456 * unicode (converted from native). */
3457 if (!UNI_IS_INVARIANT(uv)) {
3458 if (!has_utf8 && uv > 255) {
3459 /* Might need to recode whatever we have accumulated so
3460 * far if it contains any chars variant in utf8 or
3463 SvCUR_set(sv, d - SvPVX_const(sv));
3466 /* See Note on sizing above. */
3467 sv_utf8_upgrade_flags_grow(sv,
3468 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3469 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3470 d = SvPVX(sv) + SvCUR(sv);
3475 d = (char*)uvuni_to_utf8((U8*)d, uv);
3476 if (PL_lex_inwhat == OP_TRANS &&
3477 PL_sublex_info.sub_op) {
3478 PL_sublex_info.sub_op->op_private |=
3479 (PL_lex_repl ? OPpTRANS_FROM_UTF
3483 if (uv > 255 && !dorange)
3484 native_range = FALSE;
3497 /* In a non-pattern \N must be a named character, like \N{LATIN
3498 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3499 * mean to match a non-newline. For non-patterns, named
3500 * characters are converted to their string equivalents. In
3501 * patterns, named characters are not converted to their
3502 * ultimate forms for the same reasons that other escapes
3503 * aren't. Instead, they are converted to the \N{U+...} form
3504 * to get the value from the charnames that is in effect right
3505 * now, while preserving the fact that it was a named character
3506 * so that the regex compiler knows this */
3508 /* This section of code doesn't generally use the
3509 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3510 * a close examination of this macro and determined it is a
3511 * no-op except on utfebcdic variant characters. Every
3512 * character generated by this that would normally need to be
3513 * enclosed by this macro is invariant, so the macro is not
3514 * needed, and would complicate use of copy(). XXX There are
3515 * other parts of this file where the macro is used
3516 * inconsistently, but are saved by it being a no-op */
3518 /* The structure of this section of code (besides checking for
3519 * errors and upgrading to utf8) is:
3520 * Further disambiguate between the two meanings of \N, and if
3521 * not a charname, go process it elsewhere
3522 * If of form \N{U+...}, pass it through if a pattern;
3523 * otherwise convert to utf8
3524 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3525 * pattern; otherwise convert to utf8 */
3527 /* Here, s points to the 'N'; the test below is guaranteed to
3528 * succeed if we are being called on a pattern as we already
3529 * know from a test above that the next character is a '{'.
3530 * On a non-pattern \N must mean 'named sequence, which
3531 * requires braces */
3534 yyerror("Missing braces on \\N{}");
3539 /* If there is no matching '}', it is an error. */
3540 if (! (e = strchr(s, '}'))) {
3541 if (! PL_lex_inpat) {
3542 yyerror("Missing right brace on \\N{}");
3544 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3549 /* Here it looks like a named character */
3551 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3552 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3553 | PERL_SCAN_DISALLOW_PREFIX;
3556 /* For \N{U+...}, the '...' is a unicode value even on
3557 * EBCDIC machines */
3558 s += 2; /* Skip to next char after the 'U+' */
3560 uv = grok_hex(s, &len, &flags, NULL);
3561 if (len == 0 || len != (STRLEN)(e - s)) {
3562 yyerror("Invalid hexadecimal number in \\N{U+...}");
3569 /* On non-EBCDIC platforms, pass through to the regex
3570 * compiler unchanged. The reason we evaluated the
3571 * number above is to make sure there wasn't a syntax
3572 * error. But on EBCDIC we convert to native so
3573 * downstream code can continue to assume it's native
3575 s -= 5; /* Include the '\N{U+' */
3577 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3580 (unsigned int) UNI_TO_NATIVE(uv));
3582 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3586 else { /* Not a pattern: convert the hex to string */
3588 /* If destination is not in utf8, unconditionally
3589 * recode it to be so. This is because \N{} implies
3590 * Unicode semantics, and scalars have to be in utf8
3591 * to guarantee those semantics */
3593 SvCUR_set(sv, d - SvPVX_const(sv));
3596 /* See Note on sizing above. */
3597 sv_utf8_upgrade_flags_grow(
3599 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3600 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3601 d = SvPVX(sv) + SvCUR(sv);
3605 /* Add the string to the output */
3606 if (UNI_IS_INVARIANT(uv)) {
3609 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3612 else /* Here is \N{NAME} but not \N{U+...}. */
3613 if ((res = get_and_check_backslash_N_name(s, e)))
3616 const char *str = SvPV_const(res, len);
3619 if (! len) { /* The name resolved to an empty string */
3620 Copy("\\N{}", d, 4, char);
3624 /* In order to not lose information for the regex
3625 * compiler, pass the result in the specially made
3626 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3627 * the code points in hex of each character
3628 * returned by charnames */
3630 const char *str_end = str + len;
3631 const STRLEN off = d - SvPVX_const(sv);
3633 if (! SvUTF8(res)) {
3634 /* For the non-UTF-8 case, we can determine the
3635 * exact length needed without having to parse
3636 * through the string. Each character takes up
3637 * 2 hex digits plus either a trailing dot or
3639 d = off + SvGROW(sv, off
3641 + 6 /* For the "\N{U+", and
3643 + (STRLEN)(send - e));
3644 Copy("\\N{U+", d, 5, char);
3646 while (str < str_end) {
3648 my_snprintf(hex_string, sizeof(hex_string),
3649 "%02X.", (U8) *str);
3650 Copy(hex_string, d, 3, char);
3654 d--; /* We will overwrite below the final
3655 dot with a right brace */
3658 STRLEN char_length; /* cur char's byte length */
3660 /* and the number of bytes after this is
3661 * translated into hex digits */
3662 STRLEN output_length;
3664 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3665 * for max('U+', '.'); and 1 for NUL */
3666 char hex_string[2 * UTF8_MAXBYTES + 5];
3668 /* Get the first character of the result. */
3669 U32 uv = utf8n_to_uvuni((U8 *) str,
3673 /* Convert first code point to hex, including
3674 * the boiler plate before it. For all these,
3675 * we convert to native format so that
3676 * downstream code can continue to assume the
3677 * input is native */
3679 my_snprintf(hex_string, sizeof(hex_string),
3681 (unsigned int) UNI_TO_NATIVE(uv));
3683 /* Make sure there is enough space to hold it */
3684 d = off + SvGROW(sv, off
3686 + (STRLEN)(send - e)
3687 + 2); /* '}' + NUL */
3689 Copy(hex_string, d, output_length, char);
3692 /* For each subsequent character, append dot and
3693 * its ordinal in hex */
3694 while ((str += char_length) < str_end) {
3695 const STRLEN off = d - SvPVX_const(sv);
3696 U32 uv = utf8n_to_uvuni((U8 *) str,
3701 my_snprintf(hex_string,
3704 (unsigned int) UNI_TO_NATIVE(uv));
3706 d = off + SvGROW(sv, off
3708 + (STRLEN)(send - e)
3709 + 2); /* '}' + NUL */
3710 Copy(hex_string, d, output_length, char);
3715 *d++ = '}'; /* Done. Add the trailing brace */
3718 else { /* Here, not in a pattern. Convert the name to a
3721 /* If destination is not in utf8, unconditionally
3722 * recode it to be so. This is because \N{} implies
3723 * Unicode semantics, and scalars have to be in utf8
3724 * to guarantee those semantics */
3726 SvCUR_set(sv, d - SvPVX_const(sv));
3729 /* See Note on sizing above. */
3730 sv_utf8_upgrade_flags_grow(sv,
3731 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3732 len + (STRLEN)(send - s) + 1);
3733 d = SvPVX(sv) + SvCUR(sv);
3735 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3737 /* See Note on sizing above. (NOTE: SvCUR() is not
3738 * set correctly here). */
3739 const STRLEN off = d - SvPVX_const(sv);
3740 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3742 Copy(str, d, len, char);
3748 } /* End \N{NAME} */
3751 native_range = FALSE; /* \N{} is defined to be Unicode */
3753 s = e + 1; /* Point to just after the '}' */
3756 /* \c is a control character */
3760 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3763 yyerror("Missing control char name in \\c");
3767 /* printf-style backslashes, formfeeds, newlines, etc */
3769 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3772 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3775 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3778 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3781 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3784 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3787 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3793 } /* end if (backslash) */
3800 /* If we started with encoded form, or already know we want it,
3801 then encode the next character */
3802 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3806 /* One might think that it is wasted effort in the case of the
3807 * source being utf8 (this_utf8 == TRUE) to take the next character
3808 * in the source, convert it to an unsigned value, and then convert
3809 * it back again. But the source has not been validated here. The
3810 * routine that does the conversion checks for errors like
3813 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3814 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3816 SvCUR_set(sv, d - SvPVX_const(sv));
3819 /* See Note on sizing above. */
3820 sv_utf8_upgrade_flags_grow(sv,
3821 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3822 need + (STRLEN)(send - s) + 1);
3823 d = SvPVX(sv) + SvCUR(sv);
3825 } else if (need > len) {
3826 /* encoded value larger than old, may need extra space (NOTE:
3827 * SvCUR() is not set correctly here). See Note on sizing
3829 const STRLEN off = d - SvPVX_const(sv);
3830 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3834 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3836 if (uv > 255 && !dorange)
3837 native_range = FALSE;
3841 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3843 } /* while loop to process each character */
3845 /* terminate the string and set up the sv */
3847 SvCUR_set(sv, d - SvPVX_const(sv));
3848 if (SvCUR(sv) >= SvLEN(sv))
3849 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3850 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3853 if (PL_encoding && !has_utf8) {
3854 sv_recode_to_utf8(sv, PL_encoding);
3860 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3861 PL_sublex_info.sub_op->op_private |=
3862 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3866 /* shrink the sv if we allocated more than we used */
3867 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3868 SvPV_shrink_to_cur(sv);
3871 /* return the substring (via pl_yylval) only if we parsed anything */
3872 if (s > PL_bufptr) {
3873 SvREFCNT_inc_simple_void_NN(sv);
3874 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3875 && ! PL_parser->lex_re_reparsing)
3877 const char *const key = PL_lex_inpat ? "qr" : "q";
3878 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3882 if (PL_lex_inwhat == OP_TRANS) {
3885 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3888 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3896 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3899 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3901 LEAVE_with_name("scan_const");
3906 * Returns TRUE if there's more to the expression (e.g., a subscript),
3909 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3911 * ->[ and ->{ return TRUE
3912 * { and [ outside a pattern are always subscripts, so return TRUE
3913 * if we're outside a pattern and it's not { or [, then return FALSE
3914 * if we're in a pattern and the first char is a {
3915 * {4,5} (any digits around the comma) returns FALSE
3916 * if we're in a pattern and the first char is a [
3918 * [SOMETHING] has a funky algorithm to decide whether it's a
3919 * character class or not. It has to deal with things like
3920 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3921 * anything else returns TRUE
3924 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3927 S_intuit_more(pTHX_ char *s)
3931 PERL_ARGS_ASSERT_INTUIT_MORE;
3933 if (PL_lex_brackets)
3935 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3937 if (*s != '{' && *s != '[')
3942 /* In a pattern, so maybe we have {n,m}. */
3944 if (regcurly(s, FALSE)) {
3950 /* On the other hand, maybe we have a character class */
3953 if (*s == ']' || *s == '^')
3956 /* this is terrifying, and it works */
3959 const char * const send = strchr(s,']');
3960 unsigned char un_char, last_un_char;
3961 char tmpbuf[sizeof PL_tokenbuf * 4];
3963 if (!send) /* has to be an expression */
3965 weight = 2; /* let's weigh the evidence */
3969 else if (isDIGIT(*s)) {
3971 if (isDIGIT(s[1]) && s[2] == ']')
3977 Zero(seen,256,char);
3979 for (; s < send; s++) {
3980 last_un_char = un_char;
3981 un_char = (unsigned char)*s;
3986 weight -= seen[un_char] * 10;
3987 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3989 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3990 len = (int)strlen(tmpbuf);
3991 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3992 UTF ? SVf_UTF8 : 0, SVt_PV))
3997 else if (*s == '$' && s[1] &&
3998 strchr("[#!%*<>()-=",s[1])) {
3999 if (/*{*/ strchr("])} =",s[2]))
4008 if (strchr("wds]",s[1]))
4010 else if (seen[(U8)'\''] || seen[(U8)'"'])
4012 else if (strchr("rnftbxcav",s[1]))
4014 else if (isDIGIT(s[1])) {
4016 while (s[1] && isDIGIT(s[1]))
4026 if (strchr("aA01! ",last_un_char))
4028 if (strchr("zZ79~",s[1]))
4030 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4031 weight -= 5; /* cope with negative subscript */
4034 if (!isWORDCHAR(last_un_char)
4035 && !(last_un_char == '$' || last_un_char == '@'
4036 || last_un_char == '&')
4037 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4042 if (keyword(tmpbuf, d - tmpbuf, 0))
4045 if (un_char == last_un_char + 1)
4047 weight -= seen[un_char];
4052 if (weight >= 0) /* probably a character class */
4062 * Does all the checking to disambiguate
4064 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4065 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4067 * First argument is the stuff after the first token, e.g. "bar".
4069 * Not a method if foo is a filehandle.
4070 * Not a method if foo is a subroutine prototyped to take a filehandle.
4071 * Not a method if it's really "Foo $bar"
4072 * Method if it's "foo $bar"
4073 * Not a method if it's really "print foo $bar"
4074 * Method if it's really "foo package::" (interpreted as package->foo)
4075 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4076 * Not a method if bar is a filehandle or package, but is quoted with
4081 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
4084 char *s = start + (*start == '$');
4085 char tmpbuf[sizeof PL_tokenbuf];
4092 PERL_ARGS_ASSERT_INTUIT_METHOD;
4094 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4096 if (cv && SvPOK(cv)) {
4097 const char *proto = CvPROTO(cv);
4099 while (*proto && (isSPACE(*proto) || *proto == ';'))
4106 if (*start == '$') {
4107 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
4108 isUPPER(*PL_tokenbuf))
4111 len = start - SvPVX(PL_linestr);
4115 start = SvPVX(PL_linestr) + len;
4119 return *s == '(' ? FUNCMETH : METHOD;
4122 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4123 /* start is the beginning of the possible filehandle/object,
4124 * and s is the end of it
4125 * tmpbuf is a copy of it (but with single quotes as double colons)
4128 if (!keyword(tmpbuf, len, 0)) {
4129 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4133 soff = s - SvPVX(PL_linestr);
4137 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4138 if (indirgv && GvCVu(indirgv))
4140 /* filehandle or package name makes it a method */
4141 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4143 soff = s - SvPVX(PL_linestr);
4146 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4147 return 0; /* no assumptions -- "=>" quotes bareword */
4149 start_force(PL_curforce);
4150 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4151 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4152 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4154 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4155 ( UTF ? SVf_UTF8 : 0 )));
4160 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4162 return *s == '(' ? FUNCMETH : METHOD;
4168 /* Encoded script support. filter_add() effectively inserts a
4169 * 'pre-processing' function into the current source input stream.
4170 * Note that the filter function only applies to the current source file
4171 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4173 * The datasv parameter (which may be NULL) can be used to pass
4174 * private data to this instance of the filter. The filter function
4175 * can recover the SV using the FILTER_DATA macro and use it to
4176 * store private buffers and state information.
4178 * The supplied datasv parameter is upgraded to a PVIO type
4179 * and the IoDIRP/IoANY field is used to store the function pointer,
4180 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4181 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4182 * private use must be set using malloc'd pointers.
4186 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4195 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4196 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4198 if (!PL_rsfp_filters)
4199 PL_rsfp_filters = newAV();
4202 SvUPGRADE(datasv, SVt_PVIO);
4203 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4204 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4205 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4206 FPTR2DPTR(void *, IoANY(datasv)),
4207 SvPV_nolen(datasv)));
4208 av_unshift(PL_rsfp_filters, 1);
4209 av_store(PL_rsfp_filters, 0, datasv) ;
4211 !PL_parser->filtered
4212 && PL_parser->lex_flags & LEX_EVALBYTES
4213 && PL_bufptr < PL_bufend
4215 const char *s = PL_bufptr;
4216 while (s < PL_bufend) {
4218 SV *linestr = PL_parser->linestr;
4219 char *buf = SvPVX(linestr);
4220 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4221 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4222 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4223 STRLEN const linestart_pos = PL_parser->linestart - buf;
4224 STRLEN const last_uni_pos =
4225 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4226 STRLEN const last_lop_pos =
4227 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4228 av_push(PL_rsfp_filters, linestr);
4229 PL_parser->linestr =
4230 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4231 buf = SvPVX(PL_parser->linestr);
4232 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4233 PL_parser->bufptr = buf + bufptr_pos;
4234 PL_parser->oldbufptr = buf + oldbufptr_pos;
4235 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4236 PL_parser->linestart = buf + linestart_pos;
4237 if (PL_parser->last_uni)
4238 PL_parser->last_uni = buf + last_uni_pos;
4239 if (PL_parser->last_lop)
4240 PL_parser->last_lop = buf + last_lop_pos;
4241 SvLEN(linestr) = SvCUR(linestr);
4242 SvCUR(linestr) = s-SvPVX(linestr);
4243 PL_parser->filtered = 1;
4253 /* Delete most recently added instance of this filter function. */
4255 Perl_filter_del(pTHX_ filter_t funcp)
4260 PERL_ARGS_ASSERT_FILTER_DEL;
4263 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4264 FPTR2DPTR(void*, funcp)));
4266 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4268 /* if filter is on top of stack (usual case) just pop it off */
4269 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4270 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4271 sv_free(av_pop(PL_rsfp_filters));
4275 /* we need to search for the correct entry and clear it */
4276 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4280 /* Invoke the idxth filter function for the current rsfp. */
4281 /* maxlen 0 = read one text line */
4283 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4288 /* This API is bad. It should have been using unsigned int for maxlen.
4289 Not sure if we want to change the API, but if not we should sanity
4290 check the value here. */
4291 unsigned int correct_length
4300 PERL_ARGS_ASSERT_FILTER_READ;
4302 if (!PL_parser || !PL_rsfp_filters)
4304 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4305 /* Provide a default input filter to make life easy. */
4306 /* Note that we append to the line. This is handy. */
4307 DEBUG_P(PerlIO_printf(Perl_debug_log,
4308 "filter_read %d: from rsfp\n", idx));
4309 if (correct_length) {
4312 const int old_len = SvCUR(buf_sv);
4314 /* ensure buf_sv is large enough */
4315 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4316 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4317 correct_length)) <= 0) {
4318 if (PerlIO_error(PL_rsfp))
4319 return -1; /* error */
4321 return 0 ; /* end of file */
4323 SvCUR_set(buf_sv, old_len + len) ;
4324 SvPVX(buf_sv)[old_len + len] = '\0';
4327 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4328 if (PerlIO_error(PL_rsfp))
4329 return -1; /* error */
4331 return 0 ; /* end of file */
4334 return SvCUR(buf_sv);
4336 /* Skip this filter slot if filter has been deleted */
4337 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4338 DEBUG_P(PerlIO_printf(Perl_debug_log,
4339 "filter_read %d: skipped (filter deleted)\n",
4341 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4343 if (SvTYPE(datasv) != SVt_PVIO) {
4344 if (correct_length) {
4346 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4347 if (!remainder) return 0; /* eof */
4348 if (correct_length > remainder) correct_length = remainder;
4349 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4350 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4353 const char *s = SvEND(datasv);
4354 const char *send = SvPVX(datasv) + SvLEN(datasv);
4362 if (s == send) return 0; /* eof */
4363 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4364 SvCUR_set(datasv, s-SvPVX(datasv));
4366 return SvCUR(buf_sv);
4368 /* Get function pointer hidden within datasv */
4369 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4370 DEBUG_P(PerlIO_printf(Perl_debug_log,
4371 "filter_read %d: via function %p (%s)\n",
4372 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4373 /* Call function. The function is expected to */
4374 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4375 /* Return: <0:error, =0:eof, >0:not eof */
4376 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4380 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4384 PERL_ARGS_ASSERT_FILTER_GETS;
4386 #ifdef PERL_CR_FILTER
4387 if (!PL_rsfp_filters) {
4388 filter_add(S_cr_textfilter,NULL);
4391 if (PL_rsfp_filters) {
4393 SvCUR_set(sv, 0); /* start with empty line */
4394 if (FILTER_READ(0, sv, 0) > 0)
4395 return ( SvPVX(sv) ) ;
4400 return (sv_gets(sv, PL_rsfp, append));
4404 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4409 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4411 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4415 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4416 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4418 return GvHV(gv); /* Foo:: */
4421 /* use constant CLASS => 'MyClass' */
4422 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4423 if (gv && GvCV(gv)) {
4424 SV * const sv = cv_const_sv(GvCV(gv));
4426 pkgname = SvPV_const(sv, len);
4429 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4433 * S_readpipe_override
4434 * Check whether readpipe() is overridden, and generates the appropriate
4435 * optree, provided sublex_start() is called afterwards.
4438 S_readpipe_override(pTHX)
4441 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4442 pl_yylval.ival = OP_BACKTICK;
4444 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4446 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4447 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4448 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4450 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4451 op_append_elem(OP_LIST,
4452 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4453 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4460 * The intent of this yylex wrapper is to minimize the changes to the
4461 * tokener when we aren't interested in collecting madprops. It remains
4462 * to be seen how successful this strategy will be...
4469 char *s = PL_bufptr;
4471 /* make sure PL_thiswhite is initialized */
4475 /* previous token ate up our whitespace? */
4476 if (!PL_lasttoke && PL_nextwhite) {
4477 PL_thiswhite = PL_nextwhite;
4481 /* isolate the token, and figure out where it is without whitespace */
4482 PL_realtokenstart = -1;
4486 assert(PL_curforce < 0);
4488 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4489 if (!PL_thistoken) {
4490 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4491 PL_thistoken = newSVpvs("");
4493 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4494 PL_thistoken = newSVpvn(tstart, s - tstart);
4497 if (PL_thismad) /* install head */
4498 CURMAD('X', PL_thistoken);
4501 /* last whitespace of a sublex? */
4502 if (optype == ')' && PL_endwhite) {
4503 CURMAD('X', PL_endwhite);
4508 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4509 if (!PL_thiswhite && !PL_endwhite && !optype) {
4510 sv_free(PL_thistoken);
4515 /* put off final whitespace till peg */
4516 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4517 PL_nextwhite = PL_thiswhite;
4520 else if (PL_thisopen) {
4521 CURMAD('q', PL_thisopen);
4523 sv_free(PL_thistoken);
4527 /* Store actual token text as madprop X */
4528 CURMAD('X', PL_thistoken);
4532 /* add preceding whitespace as madprop _ */
4533 CURMAD('_', PL_thiswhite);
4537 /* add quoted material as madprop = */
4538 CURMAD('=', PL_thisstuff);
4542 /* add terminating quote as madprop Q */
4543 CURMAD('Q', PL_thisclose);
4547 /* special processing based on optype */
4551 /* opval doesn't need a TOKEN since it can already store mp */
4561 if (pl_yylval.opval)
4562 append_madprops(PL_thismad, pl_yylval.opval, 0);
4570 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4583 /* remember any fake bracket that lexer is about to discard */
4584 if (PL_lex_brackets == 1 &&
4585 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4588 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4591 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4592 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4595 break; /* don't bother looking for trailing comment */
4604 /* attach a trailing comment to its statement instead of next token */
4608 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4610 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4612 if (*s == '\n' || *s == '#') {
4613 while (s < PL_bufend && *s != '\n')
4617 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4618 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4631 /* Create new token struct. Note: opvals return early above. */
4632 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4639 S_tokenize_use(pTHX_ int is_use, char *s) {
4642 PERL_ARGS_ASSERT_TOKENIZE_USE;
4644 if (PL_expect != XSTATE)
4645 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4646 is_use ? "use" : "no"));
4649 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4650 s = force_version(s, TRUE);
4651 if (*s == ';' || *s == '}'
4652 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4653 start_force(PL_curforce);
4654 NEXTVAL_NEXTTOKE.opval = NULL;
4657 else if (*s == 'v') {
4658 s = force_word(s,WORD,FALSE,TRUE);
4659 s = force_version(s, FALSE);
4663 s = force_word(s,WORD,FALSE,TRUE);
4664 s = force_version(s, FALSE);
4666 pl_yylval.ival = is_use;
4670 static const char* const exp_name[] =
4671 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4672 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4676 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4678 S_word_takes_any_delimeter(char *p, STRLEN len)
4680 return (len == 1 && strchr("msyq", p[0])) ||
4682 (p[0] == 't' && p[1] == 'r') ||
4683 (p[0] == 'q' && strchr("qwxr", p[1]))));
4689 Works out what to call the token just pulled out of the input
4690 stream. The yacc parser takes care of taking the ops we return and
4691 stitching them into a tree.
4694 The type of the next token
4697 Switch based on the current state:
4698 - if we already built the token before, use it
4699 - if we have a case modifier in a string, deal with that
4700 - handle other cases of interpolation inside a string
4701 - scan the next line if we are inside a format
4702 In the normal state switch on the next character:
4704 if alphabetic, go to key lookup
4705 unrecoginized character - croak
4706 - 0/4/26: handle end-of-line or EOF
4707 - cases for whitespace
4708 - \n and #: handle comments and line numbers
4709 - various operators, brackets and sigils
4712 - 'v': vstrings (or go to key lookup)
4713 - 'x' repetition operator (or go to key lookup)
4714 - other ASCII alphanumerics (key lookup begins here):
4717 scan built-in keyword (but do nothing with it yet)
4718 check for statement label
4719 check for lexical subs
4720 goto just_a_word if there is one
4721 see whether built-in keyword is overridden
4722 switch on keyword number:
4723 - default: just_a_word:
4724 not a built-in keyword; handle bareword lookup
4725 disambiguate between method and sub call
4726 fall back to bareword
4727 - cases for built-in keywords
4732 #pragma segment Perl_yylex
4738 char *s = PL_bufptr;
4742 const bool saw_infix_sigil = PL_parser->saw_infix_sigil;
4746 /* orig_keyword, gvp, and gv are initialized here because
4747 * jump to the label just_a_word_zero can bypass their
4748 * initialization later. */
4749 I32 orig_keyword = 0;
4754 SV* tmp = newSVpvs("");
4755 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4756 (IV)CopLINE(PL_curcop),
4757 lex_state_names[PL_lex_state],
4758 exp_name[PL_expect],
4759 pv_display(tmp, s, strlen(s), 0, 60));
4763 switch (PL_lex_state) {
4765 case LEX_NORMAL: /* Some compilers will produce faster */
4766 case LEX_INTERPNORMAL: /* code if we comment these out. */
4770 /* when we've already built the next token, just pull it out of the queue */
4774 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4776 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4777 PL_nexttoke[PL_lasttoke].next_mad = 0;
4778 if (PL_thismad && PL_thismad->mad_key == '_') {
4779 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4780 PL_thismad->mad_val = 0;
4781 mad_free(PL_thismad);
4786 PL_lex_state = PL_lex_defer;
4787 PL_expect = PL_lex_expect;
4788 PL_lex_defer = LEX_NORMAL;
4789 if (!PL_nexttoke[PL_lasttoke].next_type)
4794 pl_yylval = PL_nextval[PL_nexttoke];
4796 PL_lex_state = PL_lex_defer;
4797 PL_expect = PL_lex_expect;
4798 PL_lex_defer = LEX_NORMAL;
4804 next_type = PL_nexttoke[PL_lasttoke].next_type;
4806 next_type = PL_nexttype[PL_nexttoke];
4808 if (next_type & (7<<24)) {
4809 if (next_type & (1<<24)) {
4810 if (PL_lex_brackets > 100)
4811 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4812 PL_lex_brackstack[PL_lex_brackets++] =
4813 (char) ((next_type >> 16) & 0xff);
4815 if (next_type & (2<<24))
4816 PL_lex_allbrackets++;
4817 if (next_type & (4<<24))
4818 PL_lex_allbrackets--;
4819 next_type &= 0xffff;
4821 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4824 /* interpolated case modifiers like \L \U, including \Q and \E.
4825 when we get here, PL_bufptr is at the \
4827 case LEX_INTERPCASEMOD:
4829 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4831 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4832 PL_bufptr, PL_bufend, *PL_bufptr);
4834 /* handle \E or end of string */
4835 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4837 if (PL_lex_casemods) {
4838 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4839 PL_lex_casestack[PL_lex_casemods] = '\0';
4841 if (PL_bufptr != PL_bufend
4842 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4843 || oldmod == 'F')) {
4845 PL_lex_state = LEX_INTERPCONCAT;
4848 PL_thistoken = newSVpvs("\\E");
4851 PL_lex_allbrackets--;
4854 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4855 /* Got an unpaired \E */
4856 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4857 "Useless use of \\E");
4860 while (PL_bufptr != PL_bufend &&
4861 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4864 PL_thiswhite = newSVpvs("");
4865 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4870 if (PL_bufptr != PL_bufend)
4873 PL_lex_state = LEX_INTERPCONCAT;
4877 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4878 "### Saw case modifier\n"); });
4880 if (s[1] == '\\' && s[2] == 'E') {
4884 PL_thiswhite = newSVpvs("");
4885 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4889 PL_lex_state = LEX_INTERPCONCAT;
4894 if (!PL_madskills) /* when just compiling don't need correct */
4895 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4896 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4897 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4898 (strchr(PL_lex_casestack, 'L')
4899 || strchr(PL_lex_casestack, 'U')
4900 || strchr(PL_lex_casestack, 'F'))) {
4901 PL_lex_casestack[--PL_lex_casemods] = '\0';
4902 PL_lex_allbrackets--;
4905 if (PL_lex_casemods > 10)
4906 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4907 PL_lex_casestack[PL_lex_casemods++] = *s;
4908 PL_lex_casestack[PL_lex_casemods] = '\0';
4909 PL_lex_state = LEX_INTERPCONCAT;
4910 start_force(PL_curforce);
4911 NEXTVAL_NEXTTOKE.ival = 0;
4912 force_next((2<<24)|'(');
4913 start_force(PL_curforce);
4915 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4917 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4919 NEXTVAL_NEXTTOKE.ival = OP_LC;
4921 NEXTVAL_NEXTTOKE.ival = OP_UC;
4923 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4925 NEXTVAL_NEXTTOKE.ival = OP_FC;
4927 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4929 SV* const tmpsv = newSVpvs("\\ ");
4930 /* replace the space with the character we want to escape
4932 SvPVX(tmpsv)[1] = *s;
4938 if (PL_lex_starts) {
4944 sv_free(PL_thistoken);
4945 PL_thistoken = newSVpvs("");
4948 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4949 if (PL_lex_casemods == 1 && PL_lex_inpat)
4958 case LEX_INTERPPUSH:
4959 return REPORT(sublex_push());
4961 case LEX_INTERPSTART:
4962 if (PL_bufptr == PL_bufend)
4963 return REPORT(sublex_done());
4964 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4965 "### Interpolated variable\n"); });
4967 /* for /@a/, we leave the joining for the regex engine to do
4968 * (unless we're within \Q etc) */
4969 PL_lex_dojoin = (*PL_bufptr == '@'
4970 && (!PL_lex_inpat || PL_lex_casemods));
4971 PL_lex_state = LEX_INTERPNORMAL;
4972 if (PL_lex_dojoin) {
4973 start_force(PL_curforce);
4974 NEXTVAL_NEXTTOKE.ival = 0;
4976 start_force(PL_curforce);
4977 force_ident("\"", '$');
4978 start_force(PL_curforce);
4979 NEXTVAL_NEXTTOKE.ival = 0;
4981 start_force(PL_curforce);
4982 NEXTVAL_NEXTTOKE.ival = 0;
4983 force_next((2<<24)|'(');
4984 start_force(PL_curforce);
4985 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4988 /* Convert (?{...}) and friends to 'do {...}' */
4989 if (PL_lex_inpat && *PL_bufptr == '(') {
4990 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4992 if (*PL_bufptr != '{')
4994 start_force(PL_curforce);
4995 /* XXX probably need a CURMAD(something) here */
4996 PL_expect = XTERMBLOCK;
5000 if (PL_lex_starts++) {
5005 sv_free(PL_thistoken);
5006 PL_thistoken = newSVpvs("");
5009 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5010 if (!PL_lex_casemods && PL_lex_inpat)
5017 case LEX_INTERPENDMAYBE:
5018 if (intuit_more(PL_bufptr)) {
5019 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
5025 if (PL_lex_dojoin) {
5026 PL_lex_dojoin = FALSE;
5027 PL_lex_state = LEX_INTERPCONCAT;
5031 sv_free(PL_thistoken);
5032 PL_thistoken = newSVpvs("");
5035 PL_lex_allbrackets--;
5038 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
5039 && SvEVALED(PL_lex_repl))
5041 if (PL_bufptr != PL_bufend)
5042 Perl_croak(aTHX_ "Bad evalled substitution pattern");
5045 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
5046 re_eval_str. If the here-doc body’s length equals the previous
5047 value of re_eval_start, re_eval_start will now be null. So
5048 check re_eval_str as well. */
5049 if (PL_parser->lex_shared->re_eval_start
5050 || PL_parser->lex_shared->re_eval_str) {
5052 if (*PL_bufptr != ')')
5053 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5055 /* having compiled a (?{..}) expression, return the original
5056 * text too, as a const */
5057 if (PL_parser->lex_shared->re_eval_str) {
5058 sv = PL_parser->lex_shared->re_eval_str;
5059 PL_parser->lex_shared->re_eval_str = NULL;
5061 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5062 SvPV_shrink_to_cur(sv);
5064 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5065 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5066 start_force(PL_curforce);
5067 /* XXX probably need a CURMAD(something) here */
5068 NEXTVAL_NEXTTOKE.opval =
5069 (OP*)newSVOP(OP_CONST, 0,
5072 PL_parser->lex_shared->re_eval_start = NULL;
5078 case LEX_INTERPCONCAT:
5080 if (PL_lex_brackets)
5081 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5082 (long) PL_lex_brackets);
5084 if (PL_bufptr == PL_bufend)
5085 return REPORT(sublex_done());
5087 /* m'foo' still needs to be parsed for possible (?{...}) */
5088 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5089 SV *sv = newSVsv(PL_linestr);
5091 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5095 s = scan_const(PL_bufptr);
5097 PL_lex_state = LEX_INTERPCASEMOD;
5099 PL_lex_state = LEX_INTERPSTART;
5102 if (s != PL_bufptr) {
5103 start_force(PL_curforce);
5105 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
5107 NEXTVAL_NEXTTOKE = pl_yylval;
5110 if (PL_lex_starts++) {
5114 sv_free(PL_thistoken);
5115 PL_thistoken = newSVpvs("");
5118 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5119 if (!PL_lex_casemods && PL_lex_inpat)
5132 s = scan_formline(PL_bufptr);
5133 if (!PL_lex_formbrack)
5143 PL_oldoldbufptr = PL_oldbufptr;
5145 PL_parser->saw_infix_sigil = 0;
5150 sv_free(PL_thistoken);
5153 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
5157 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
5160 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5161 const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
5163 SVs_TEMP | SVf_UTF8),
5164 10, UNI_DISPLAY_ISPRINT))
5165 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5166 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
5167 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5168 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
5176 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
5180 goto fake_eof; /* emulate EOF on ^D or ^Z */
5186 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
5189 if (PL_lex_brackets &&
5190 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
5191 yyerror((const char *)
5193 ? "Format not terminated"
5194 : "Missing right curly or square bracket"));
5196 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5197 "### Tokener got EOF\n");
5201 if (s++ < PL_bufend)
5202 goto retry; /* ignore stray nulls */
5205 if (!PL_in_eval && !PL_preambled) {
5206 PL_preambled = TRUE;
5212 /* Generate a string of Perl code to load the debugger.
5213 * If PERL5DB is set, it will return the contents of that,
5214 * otherwise a compile-time require of perl5db.pl. */
5216 const char * const pdb = PerlEnv_getenv("PERL5DB");
5219 sv_setpv(PL_linestr, pdb);
5220 sv_catpvs(PL_linestr,";");
5222 SETERRNO(0,SS_NORMAL);
5223 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5226 sv_setpvs(PL_linestr,"");
5227 if (PL_preambleav) {
5228 SV **svp = AvARRAY(PL_preambleav);
5229 SV **const end = svp + AvFILLp(PL_preambleav);
5231 sv_catsv(PL_linestr, *svp);
5233 sv_catpvs(PL_linestr, ";");
5235 sv_free(MUTABLE_SV(PL_preambleav));
5236 PL_preambleav = NULL;
5239 sv_catpvs(PL_linestr,
5240 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5241 if (PL_minus_n || PL_minus_p) {
5242 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5244 sv_catpvs(PL_linestr,"chomp;");
5247 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
5248 || *PL_splitstr == '"')
5249 && strchr(PL_splitstr + 1, *PL_splitstr))
5250 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5252 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5253 bytes can be used as quoting characters. :-) */
5254 const char *splits = PL_splitstr;
5255 sv_catpvs(PL_linestr, "our @F=split(q\0");
5258 if (*splits == '\\')
5259 sv_catpvn(PL_linestr, splits, 1);
5260 sv_catpvn(PL_linestr, splits, 1);
5261 } while (*splits++);
5262 /* This loop will embed the trailing NUL of
5263 PL_linestr as the last thing it does before
5265 sv_catpvs(PL_linestr, ");");
5269 sv_catpvs(PL_linestr,"our @F=split(' ');");
5272 sv_catpvs(PL_linestr, "\n");
5273 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5274 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5275 PL_last_lop = PL_last_uni = NULL;
5276 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
5277 update_debugger_info(PL_linestr, NULL, 0);
5282 bof = PL_rsfp ? TRUE : FALSE;
5285 fake_eof = LEX_FAKE_EOF;
5287 PL_bufptr = PL_bufend;
5288 COPLINE_INC_WITH_HERELINES;
5289 if (!lex_next_chunk(fake_eof)) {
5290 CopLINE_dec(PL_curcop);
5292 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5294 CopLINE_dec(PL_curcop);
5297 PL_realtokenstart = -1;
5300 /* If it looks like the start of a BOM or raw UTF-16,
5301 * check if it in fact is. */
5302 if (bof && PL_rsfp &&
5307 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5308 bof = (offset == (Off_t)SvCUR(PL_linestr));
5309 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5310 /* offset may include swallowed CR */
5312 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5315 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5316 s = swallow_bom((U8*)s);
5319 if (PL_parser->in_pod) {
5320 /* Incest with pod. */
5323 sv_catsv(PL_thiswhite, PL_linestr);
5325 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
5326 sv_setpvs(PL_linestr, "");
5327 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5328 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5329 PL_last_lop = PL_last_uni = NULL;
5330 PL_parser->in_pod = 0;
5333 if (PL_rsfp || PL_parser->filtered)
5335 } while (PL_parser->in_pod);
5336 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5337 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5338 PL_last_lop = PL_last_uni = NULL;
5339 if (CopLINE(PL_curcop) == 1) {
5340 while (s < PL_bufend && isSPACE(*s))
5342 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5346 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
5350 if (*s == '#' && *(s+1) == '!')
5352 #ifdef ALTERNATE_SHEBANG
5354 static char const as[] = ALTERNATE_SHEBANG;
5355 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5356 d = s + (sizeof(as) - 1);
5358 #endif /* ALTERNATE_SHEBANG */
5367 while (*d && !isSPACE(*d))
5371 #ifdef ARG_ZERO_IS_SCRIPT
5372 if (ipathend > ipath) {
5374 * HP-UX (at least) sets argv[0] to the script name,
5375 * which makes $^X incorrect. And Digital UNIX and Linux,
5376 * at least, set argv[0] to the basename of the Perl
5377 * interpreter. So, having found "#!", we'll set it right.
5379 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5381 assert(SvPOK(x) || SvGMAGICAL(x));
5382 if (sv_eq(x, CopFILESV(PL_curcop))) {
5383 sv_setpvn(x, ipath, ipathend - ipath);
5389 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
5390 const char * const lstart = SvPV_const(x,llen);
5392 bstart += blen - llen;
5393 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5394 sv_setpvn(x, ipath, ipathend - ipath);
5399 TAINT_NOT; /* $^X is always tainted, but that's OK */
5401 #endif /* ARG_ZERO_IS_SCRIPT */
5406 d = instr(s,"perl -");
5408 d = instr(s,"perl");
5410 /* avoid getting into infinite loops when shebang
5411 * line contains "Perl" rather than "perl" */
5413 for (d = ipathend-4; d >= ipath; --d) {
5414 if ((*d == 'p' || *d == 'P')
5415 && !ibcmp(d, "perl", 4))
5425 #ifdef ALTERNATE_SHEBANG
5427 * If the ALTERNATE_SHEBANG on this system starts with a
5428 * character that can be part of a Perl expression, then if
5429 * we see it but not "perl", we're probably looking at the
5430 * start of Perl code, not a request to hand off to some
5431 * other interpreter. Similarly, if "perl" is there, but
5432 * not in the first 'word' of the line, we assume the line
5433 * contains the start of the Perl program.
5435 if (d && *s != '#') {
5436 const char *c = ipath;
5437 while (*c && !strchr("; \t\r\n\f\v#", *c))
5440 d = NULL; /* "perl" not in first word; ignore */
5442 *s = '#'; /* Don't try to parse shebang line */
5444 #endif /* ALTERNATE_SHEBANG */
5449 !instr(s,"indir") &&
5450 instr(PL_origargv[0],"perl"))
5457 while (s < PL_bufend && isSPACE(*s))
5459 if (s < PL_bufend) {
5460 Newx(newargv,PL_origargc+3,char*);
5462 while (s < PL_bufend && !isSPACE(*s))
5465 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5468 newargv = PL_origargv;
5471 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5473 Perl_croak(aTHX_ "Can't exec %s", ipath);
5476 while (*d && !isSPACE(*d))
5478 while (SPACE_OR_TAB(*d))
5482 const bool switches_done = PL_doswitches;
5483 const U32 oldpdb = PL_perldb;
5484 const bool oldn = PL_minus_n;
5485 const bool oldp = PL_minus_p;
5489 bool baduni = FALSE;
5491 const char *d2 = d1 + 1;
5492 if (parse_unicode_opts((const char **)&d2)
5496 if (baduni || *d1 == 'M' || *d1 == 'm') {
5497 const char * const m = d1;
5498 while (*d1 && !isSPACE(*d1))
5500 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5503 d1 = moreswitches(d1);
5505 if (PL_doswitches && !switches_done) {
5506 int argc = PL_origargc;
5507 char **argv = PL_origargv;
5510 } while (argc && argv[0][0] == '-' && argv[0][1]);
5511 init_argv_symbols(argc,argv);
5513 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5514 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5515 /* if we have already added "LINE: while (<>) {",
5516 we must not do it again */
5518 sv_setpvs(PL_linestr, "");
5519 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5520 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5521 PL_last_lop = PL_last_uni = NULL;
5522 PL_preambled = FALSE;
5523 if (PERLDB_LINE || PERLDB_SAVESRC)
5524 (void)gv_fetchfile(PL_origfilename);
5531 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5532 PL_lex_state = LEX_FORMLINE;
5533 start_force(PL_curforce);
5534 NEXTVAL_NEXTTOKE.ival = 0;
5535 force_next(FORMRBRACK);
5540 #ifdef PERL_STRICT_CR
5541 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5543 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5545 case ' ': case '\t': case '\f': case 013:
5547 PL_realtokenstart = -1;
5550 PL_thiswhite = newSVpvs("");
5551 sv_catpvn(PL_thiswhite, s, 1);
5559 PL_realtokenstart = -1;
5563 if (PL_lex_state != LEX_NORMAL ||
5564 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
5565 if (*s == '#' && s == PL_linestart && PL_in_eval
5566 && !PL_rsfp && !PL_parser->filtered) {
5567 /* handle eval qq[#line 1 "foo"\n ...] */
5568 CopLINE_dec(PL_curcop);
5571 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5573 if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
5577 const bool in_comment = *s == '#';
5579 while (d < PL_bufend && *d != '\n')
5583 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5584 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5588 PL_thiswhite = newSVpvn(s, d - s);
5591 if (in_comment && d == PL_bufend
5592 && PL_lex_state == LEX_INTERPNORMAL
5593 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5594 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5597 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5598 PL_lex_state = LEX_FORMLINE;
5599 start_force(PL_curforce);
5600 NEXTVAL_NEXTTOKE.ival = 0;
5601 force_next(FORMRBRACK);
5607 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5608 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5611 TOKEN(PEG); /* make sure any #! line is accessible */
5616 /* if (PL_madskills && PL_lex_formbrack) { */
5618 while (d < PL_bufend && *d != '\n')
5622 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5623 Perl_croak(aTHX_ "panic: input overflow");
5624 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5626 PL_thiswhite = newSVpvs("");
5627 if (CopLINE(PL_curcop) == 1) {
5628 sv_setpvs(PL_thiswhite, "");
5631 sv_catpvn(PL_thiswhite, s, d - s);
5645 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5653 while (s < PL_bufend && SPACE_OR_TAB(*s))
5656 if (strnEQ(s,"=>",2)) {
5657 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5658 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5659 OPERATOR('-'); /* unary minus */
5661 PL_last_uni = PL_oldbufptr;
5663 case 'r': ftst = OP_FTEREAD; break;
5664 case 'w': ftst = OP_FTEWRITE; break;
5665 case 'x': ftst = OP_FTEEXEC; break;
5666 case 'o': ftst = OP_FTEOWNED; break;
5667 case 'R': ftst = OP_FTRREAD; break;
5668 case 'W': ftst = OP_FTRWRITE; break;
5669 case 'X': ftst = OP_FTREXEC; break;
5670 case 'O': ftst = OP_FTROWNED; break;
5671 case 'e': ftst = OP_FTIS; break;
5672 case 'z': ftst = OP_FTZERO; break;
5673 case 's': ftst = OP_FTSIZE; break;
5674 case 'f': ftst = OP_FTFILE; break;
5675 case 'd': ftst = OP_FTDIR; break;
5676 case 'l': ftst = OP_FTLINK; break;
5677 case 'p': ftst = OP_FTPIPE; break;
5678 case 'S': ftst = OP_FTSOCK; break;
5679 case 'u': ftst = OP_FTSUID; break;
5680 case 'g': ftst = OP_FTSGID; break;
5681 case 'k': ftst = OP_FTSVTX; break;
5682 case 'b': ftst = OP_FTBLK; break;
5683 case 'c': ftst = OP_FTCHR; break;
5684 case 't': ftst = OP_FTTTY; break;
5685 case 'T': ftst = OP_FTTEXT; break;
5686 case 'B': ftst = OP_FTBINARY; break;
5687 case 'M': case 'A': case 'C':
5688 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5690 case 'M': ftst = OP_FTMTIME; break;
5691 case 'A': ftst = OP_FTATIME; break;
5692 case 'C': ftst = OP_FTCTIME; break;
5700 PL_last_lop_op = (OPCODE)ftst;
5701 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5702 "### Saw file test %c\n", (int)tmp);
5707 /* Assume it was a minus followed by a one-letter named
5708 * subroutine call (or a -bareword), then. */
5709 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5710 "### '-%c' looked like a file test but was not\n",
5717 const char tmp = *s++;
5720 if (PL_expect == XOPERATOR)
5725 else if (*s == '>') {
5728 if (isIDFIRST_lazy_if(s,UTF)) {
5729 s = force_word(s,METHOD,FALSE,TRUE);
5737 if (PL_expect == XOPERATOR) {
5738 if (*s == '=' && !PL_lex_allbrackets &&
5739 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5746 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5748 OPERATOR('-'); /* unary minus */
5754 const char tmp = *s++;
5757 if (PL_expect == XOPERATOR)
5762 if (PL_expect == XOPERATOR) {
5763 if (*s == '=' && !PL_lex_allbrackets &&
5764 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5771 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5778 if (PL_expect != XOPERATOR) {
5779 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5780 PL_expect = XOPERATOR;
5781 force_ident(PL_tokenbuf, '*');
5789 if (*s == '=' && !PL_lex_allbrackets &&
5790 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5796 if (*s == '=' && !PL_lex_allbrackets &&
5797 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5801 PL_parser->saw_infix_sigil = 1;
5805 if (PL_expect == XOPERATOR) {
5806 if (s[1] == '=' && !PL_lex_allbrackets &&
5807 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5810 PL_parser->saw_infix_sigil = 1;
5813 PL_tokenbuf[0] = '%';
5814 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5815 sizeof PL_tokenbuf - 1, FALSE);
5816 if (!PL_tokenbuf[1]) {
5819 PL_expect = XOPERATOR;
5820 force_ident_maybe_lex('%');
5824 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5825 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5830 if (PL_lex_brackets > 100)
5831 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5832 PL_lex_brackstack[PL_lex_brackets++] = 0;
5833 PL_lex_allbrackets++;
5835 const char tmp = *s++;
5840 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5842 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5845 Perl_ck_warner_d(aTHX_
5846 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5847 "Smartmatch is experimental");
5853 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5860 goto just_a_word_zero_gv;
5863 switch (PL_expect) {
5869 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5871 PL_bufptr = s; /* update in case we back off */
5874 "Use of := for an empty attribute list is not allowed");
5881 PL_expect = XTERMBLOCK;
5884 stuffstart = s - SvPVX(PL_linestr) - 1;
5888 while (isIDFIRST_lazy_if(s,UTF)) {
5891 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5892 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5893 if (tmp < 0) tmp = -tmp;
5908 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5910 d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
5912 /* MUST advance bufptr here to avoid bogus
5913 "at end of line" context messages from yyerror().
5915 PL_bufptr = s + len;
5916 yyerror("Unterminated attribute parameter in attribute list");
5920 return REPORT(0); /* EOF indicator */
5924 sv_catsv(sv, PL_lex_stuff);
5925 attrs = op_append_elem(OP_LIST, attrs,
5926 newSVOP(OP_CONST, 0, sv));
5927 SvREFCNT_dec(PL_lex_stuff);
5928 PL_lex_stuff = NULL;
5931 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5933 if (PL_in_my == KEY_our) {
5934 deprecate(":unique");
5937 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5940 /* NOTE: any CV attrs applied here need to be part of
5941 the CVf_BUILTIN_ATTRS define in cv.h! */
5942 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5944 CvLVALUE_on(PL_compcv);
5946 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5948 deprecate(":locked");
5950 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5952 CvMETHOD_on(PL_compcv);
5954 /* After we've set the flags, it could be argued that
5955 we don't need to do the attributes.pm-based setting
5956 process, and shouldn't bother appending recognized
5957 flags. To experiment with that, uncomment the
5958 following "else". (Note that's already been
5959 uncommented. That keeps the above-applied built-in
5960 attributes from being intercepted (and possibly
5961 rejected) by a package's attribute routines, but is
5962 justified by the performance win for the common case
5963 of applying only built-in attributes.) */
5965 attrs = op_append_elem(OP_LIST, attrs,
5966 newSVOP(OP_CONST, 0,
5970 if (*s == ':' && s[1] != ':')
5973 break; /* require real whitespace or :'s */
5974 /* XXX losing whitespace on sequential attributes here */
5978 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5979 if (*s != ';' && *s != '}' && *s != tmp
5980 && (tmp != '=' || *s != ')')) {
5981 const char q = ((*s == '\'') ? '"' : '\'');
5982 /* If here for an expression, and parsed no attrs, back
5984 if (tmp == '=' && !attrs) {
5988 /* MUST advance bufptr here to avoid bogus "at end of line"
5989 context messages from yyerror().
5992 yyerror( (const char *)
5994 ? Perl_form(aTHX_ "Invalid separator character "
5995 "%c%c%c in attribute list", q, *s, q)
5996 : "Unterminated attribute list" ) );
6004 start_force(PL_curforce);
6005 NEXTVAL_NEXTTOKE.opval = attrs;
6006 CURMAD('_', PL_nextwhite);
6011 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
6012 (s - SvPVX(PL_linestr)) - stuffstart);
6017 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6021 PL_lex_allbrackets--;
6025 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6026 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6030 PL_lex_allbrackets++;
6033 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6039 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6042 PL_lex_allbrackets--;
6048 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6051 if (PL_lex_brackets <= 0)
6052 yyerror("Unmatched right square bracket");
6055 PL_lex_allbrackets--;
6056 if (PL_lex_state == LEX_INTERPNORMAL) {
6057 if (PL_lex_brackets == 0) {
6058 if (*s == '-' && s[1] == '>')
6059 PL_lex_state = LEX_INTERPENDMAYBE;
6060 else if (*s != '[' && *s != '{')
6061 PL_lex_state = LEX_INTERPEND;
6068 if (PL_lex_brackets > 100) {
6069 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6071 switch (PL_expect) {
6073 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6074 PL_lex_allbrackets++;
6075 OPERATOR(HASHBRACK);
6077 while (s < PL_bufend && SPACE_OR_TAB(*s))
6080 PL_tokenbuf[0] = '\0';
6081 if (d < PL_bufend && *d == '-') {
6082 PL_tokenbuf[0] = '-';
6084 while (d < PL_bufend && SPACE_OR_TAB(*d))
6087 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
6088 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6090 while (d < PL_bufend && SPACE_OR_TAB(*d))
6093 const char minus = (PL_tokenbuf[0] == '-');
6094 s = force_word(s + minus, WORD, FALSE, TRUE);
6102 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6103 PL_lex_allbrackets++;
6108 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6109 PL_lex_allbrackets++;
6114 if (PL_oldoldbufptr == PL_last_lop)
6115 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6117 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6118 PL_lex_allbrackets++;
6121 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6123 /* This hack is to get the ${} in the message. */
6125 yyerror("syntax error");
6128 OPERATOR(HASHBRACK);
6130 /* This hack serves to disambiguate a pair of curlies
6131 * as being a block or an anon hash. Normally, expectation
6132 * determines that, but in cases where we're not in a
6133 * position to expect anything in particular (like inside
6134 * eval"") we have to resolve the ambiguity. This code
6135 * covers the case where the first term in the curlies is a
6136 * quoted string. Most other cases need to be explicitly
6137 * disambiguated by prepending a "+" before the opening
6138 * curly in order to force resolution as an anon hash.
6140 * XXX should probably propagate the outer expectation
6141 * into eval"" to rely less on this hack, but that could
6142 * potentially break current behavior of eval"".
6146 if (*s == '\'' || *s == '"' || *s == '`') {
6147 /* common case: get past first string, handling escapes */
6148 for (t++; t < PL_bufend && *t != *s;)
6149 if (*t++ == '\\' && (*t == '\\' || *t == *s))
6153 else if (*s == 'q') {
6156 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6157 && !isWORDCHAR(*t))))
6159 /* skip q//-like construct */
6161 char open, close, term;
6164 while (t < PL_bufend && isSPACE(*t))
6166 /* check for q => */
6167 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6168 OPERATOR(HASHBRACK);
6172 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6176 for (t++; t < PL_bufend; t++) {
6177 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6179 else if (*t == open)
6183 for (t++; t < PL_bufend; t++) {
6184 if (*t == '\\' && t+1 < PL_bufend)
6186 else if (*t == close && --brackets <= 0)
6188 else if (*t == open)
6195 /* skip plain q word */
6196 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6199 else if (isWORDCHAR_lazy_if(t,UTF)) {
6201 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6204 while (t < PL_bufend && isSPACE(*t))
6206 /* if comma follows first term, call it an anon hash */
6207 /* XXX it could be a comma expression with loop modifiers */
6208 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6209 || (*t == '=' && t[1] == '>')))
6210 OPERATOR(HASHBRACK);
6211 if (PL_expect == XREF)
6214 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6220 pl_yylval.ival = CopLINE(PL_curcop);
6221 if (isSPACE(*s) || *s == '#')
6222 PL_copline = NOLINE; /* invalidate current command line number */
6223 TOKEN(formbrack ? '=' : '{');
6225 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6229 if (PL_lex_brackets <= 0)
6230 yyerror("Unmatched right curly bracket");
6232 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6233 PL_lex_allbrackets--;
6234 if (PL_lex_state == LEX_INTERPNORMAL) {
6235 if (PL_lex_brackets == 0) {
6236 if (PL_expect & XFAKEBRACK) {
6237 PL_expect &= XENUMMASK;
6238 PL_lex_state = LEX_INTERPEND;
6243 PL_thiswhite = newSVpvs("");
6244 sv_catpvs(PL_thiswhite,"}");
6247 return yylex(); /* ignore fake brackets */
6249 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6250 && SvEVALED(PL_lex_repl))
6251 PL_lex_state = LEX_INTERPEND;
6252 else if (*s == '-' && s[1] == '>')
6253 PL_lex_state = LEX_INTERPENDMAYBE;
6254 else if (*s != '[' && *s != '{')
6255 PL_lex_state = LEX_INTERPEND;
6258 if (PL_expect & XFAKEBRACK) {
6259 PL_expect &= XENUMMASK;
6261 return yylex(); /* ignore fake brackets */
6263 start_force(PL_curforce);
6265 curmad('X', newSVpvn(s-1,1));
6266 CURMAD('_', PL_thiswhite);
6268 force_next(formbrack ? '.' : '}');
6269 if (formbrack) LEAVE;
6271 if (PL_madskills && !PL_thistoken)
6272 PL_thistoken = newSVpvs("");
6274 if (formbrack == 2) { /* means . where arguments were expected */
6275 start_force(PL_curforce);
6283 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6284 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6291 if (PL_expect == XOPERATOR) {
6292 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
6293 && isIDFIRST_lazy_if(s,UTF))
6295 CopLINE_dec(PL_curcop);
6296 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6297 CopLINE_inc(PL_curcop);
6299 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6300 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6304 PL_parser->saw_infix_sigil = 1;
6308 PL_tokenbuf[0] = '&';
6309 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
6310 sizeof PL_tokenbuf - 1, TRUE);
6311 if (PL_tokenbuf[1]) {
6312 PL_expect = XOPERATOR;
6313 force_ident_maybe_lex('&');
6317 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6323 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6324 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6331 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6332 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6340 const char tmp = *s++;
6342 if (!PL_lex_allbrackets &&
6343 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6350 if (!PL_lex_allbrackets &&
6351 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
6359 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6360 && strchr("+-*/%.^&|<",tmp))
6361 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6362 "Reversed %c= operator",(int)tmp);
6364 if (PL_expect == XSTATE && isALPHA(tmp) &&
6365 (s == PL_linestart+1 || s[-2] == '\n') )
6367 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6368 || PL_lex_state != LEX_NORMAL) {
6373 if (strnEQ(s,"=cut",4)) {
6389 PL_thiswhite = newSVpvs("");
6390 sv_catpvn(PL_thiswhite, PL_linestart,
6391 PL_bufend - PL_linestart);
6395 PL_parser->in_pod = 1;
6399 if (PL_expect == XBLOCK) {
6401 #ifdef PERL_STRICT_CR
6402 while (SPACE_OR_TAB(*t))
6404 while (SPACE_OR_TAB(*t) || *t == '\r')
6407 if (*t == '\n' || *t == '#') {
6410 SAVEI8(PL_parser->form_lex_state);
6411 SAVEI32(PL_lex_formbrack);
6412 PL_parser->form_lex_state = PL_lex_state;
6413 PL_lex_formbrack = PL_lex_brackets + 1;
6417 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6426 const char tmp = *s++;
6428 /* was this !=~ where !~ was meant?
6429 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6431 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6432 const char *t = s+1;
6434 while (t < PL_bufend && isSPACE(*t))
6437 if (*t == '/' || *t == '?' ||
6438 ((*t == 'm' || *t == 's' || *t == 'y')
6439 && !isWORDCHAR(t[1])) ||
6440 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6441 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6442 "!=~ should be !~");
6444 if (!PL_lex_allbrackets &&
6445 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6457 if (PL_expect != XOPERATOR) {
6458 if (s[1] != '<' && !strchr(s,'>'))
6461 s = scan_heredoc(s);
6463 s = scan_inputsymbol(s);
6464 PL_expect = XOPERATOR;
6465 TOKEN(sublex_start());
6471 if (*s == '=' && !PL_lex_allbrackets &&
6472 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6476 SHop(OP_LEFT_SHIFT);
6481 if (!PL_lex_allbrackets &&
6482 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6489 if (!PL_lex_allbrackets &&
6490 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6498 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6506 const char tmp = *s++;
6508 if (*s == '=' && !PL_lex_allbrackets &&
6509 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6513 SHop(OP_RIGHT_SHIFT);
6515 else if (tmp == '=') {
6516 if (!PL_lex_allbrackets &&
6517 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6525 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6534 if (PL_expect == XOPERATOR) {
6535 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6536 return deprecate_commaless_var_list();
6540 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6541 PL_tokenbuf[0] = '@';
6542 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6543 sizeof PL_tokenbuf - 1, FALSE);
6544 if (PL_expect == XOPERATOR)
6545 no_op("Array length", s);
6546 if (!PL_tokenbuf[1])
6548 PL_expect = XOPERATOR;
6549 force_ident_maybe_lex('#');
6553 PL_tokenbuf[0] = '$';
6554 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6555 sizeof PL_tokenbuf - 1, FALSE);
6556 if (PL_expect == XOPERATOR)
6558 if (!PL_tokenbuf[1]) {
6560 yyerror("Final $ should be \\$ or $name");
6566 const char tmp = *s;
6567 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6570 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6571 && intuit_more(s)) {
6573 PL_tokenbuf[0] = '@';
6574 if (ckWARN(WARN_SYNTAX)) {
6577 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6580 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6581 while (t < PL_bufend && *t != ']')
6583 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6584 "Multidimensional syntax %.*s not supported",
6585 (int)((t - PL_bufptr) + 1), PL_bufptr);
6589 else if (*s == '{') {
6591 PL_tokenbuf[0] = '%';
6592 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6593 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6595 char tmpbuf[sizeof PL_tokenbuf];
6598 } while (isSPACE(*t));
6599 if (isIDFIRST_lazy_if(t,UTF)) {
6601 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6606 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6607 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6608 "You need to quote \"%"UTF8f"\"",
6609 UTF8fARG(UTF, len, tmpbuf));
6615 PL_expect = XOPERATOR;
6616 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6617 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6618 if (!islop || PL_last_lop_op == OP_GREPSTART)
6619 PL_expect = XOPERATOR;
6620 else if (strchr("$@\"'`q", *s))
6621 PL_expect = XTERM; /* e.g. print $fh "foo" */
6622 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6623 PL_expect = XTERM; /* e.g. print $fh &sub */
6624 else if (isIDFIRST_lazy_if(s,UTF)) {
6625 char tmpbuf[sizeof PL_tokenbuf];
6627 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6628 if ((t2 = keyword(tmpbuf, len, 0))) {
6629 /* binary operators exclude handle interpretations */
6641 PL_expect = XTERM; /* e.g. print $fh length() */
6646 PL_expect = XTERM; /* e.g. print $fh subr() */
6649 else if (isDIGIT(*s))
6650 PL_expect = XTERM; /* e.g. print $fh 3 */
6651 else if (*s == '.' && isDIGIT(s[1]))
6652 PL_expect = XTERM; /* e.g. print $fh .3 */
6653 else if ((*s == '?' || *s == '-' || *s == '+')
6654 && !isSPACE(s[1]) && s[1] != '=')
6655 PL_expect = XTERM; /* e.g. print $fh -1 */
6656 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6658 PL_expect = XTERM; /* e.g. print $fh /.../
6659 XXX except DORDOR operator
6661 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6663 PL_expect = XTERM; /* print $fh <<"EOF" */
6666 force_ident_maybe_lex('$');
6670 if (PL_expect == XOPERATOR)
6672 PL_tokenbuf[0] = '@';
6673 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6674 if (!PL_tokenbuf[1]) {
6677 if (PL_lex_state == LEX_NORMAL)
6679 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6681 PL_tokenbuf[0] = '%';
6683 /* Warn about @ where they meant $. */
6684 if (*s == '[' || *s == '{') {
6685 if (ckWARN(WARN_SYNTAX)) {
6686 const char *t = s + 1;
6687 while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6688 t += UTF ? UTF8SKIP(t) : 1;
6689 if (*t == '}' || *t == ']') {
6691 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6692 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
6693 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6694 "Scalar value %"UTF8f" better written as $%"UTF8f,
6695 UTF8fARG(UTF, t-PL_bufptr, PL_bufptr),
6696 UTF8fARG(UTF, t-PL_bufptr-1, PL_bufptr+1));
6701 PL_expect = XOPERATOR;
6702 force_ident_maybe_lex('@');
6705 case '/': /* may be division, defined-or, or pattern */
6706 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6707 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6708 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6713 case '?': /* may either be conditional or pattern */
6714 if (PL_expect == XOPERATOR) {
6717 if (!PL_lex_allbrackets &&
6718 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6722 PL_lex_allbrackets++;
6728 /* A // operator. */
6729 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6730 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6731 LEX_FAKEEOF_LOGIC)) {
6739 if (*s == '=' && !PL_lex_allbrackets &&
6740 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6749 /* Disable warning on "study /blah/" */
6750 if (PL_oldoldbufptr == PL_last_uni
6751 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6752 || memNE(PL_last_uni, "study", 5)
6753 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6757 deprecate("?PATTERN? without explicit operator");
6758 s = scan_pat(s,OP_MATCH);
6759 TERM(sublex_start());
6763 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6764 #ifdef PERL_STRICT_CR
6767 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6769 && (s == PL_linestart || s[-1] == '\n') )
6772 formbrack = 2; /* dot seen where arguments expected */
6775 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6779 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6782 if (!PL_lex_allbrackets &&
6783 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6790 pl_yylval.ival = OPf_SPECIAL;
6796 if (*s == '=' && !PL_lex_allbrackets &&
6797 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6804 case '0': case '1': case '2': case '3': case '4':
6805 case '5': case '6': case '7': case '8': case '9':
6806 s = scan_num(s, &pl_yylval);
6807 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6808 if (PL_expect == XOPERATOR)
6813 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6814 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6815 if (PL_expect == XOPERATOR) {
6816 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6817 return deprecate_commaless_var_list();
6824 pl_yylval.ival = OP_CONST;
6825 TERM(sublex_start());
6828 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6829 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6830 if (PL_expect == XOPERATOR) {
6831 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6832 return deprecate_commaless_var_list();
6839 pl_yylval.ival = OP_CONST;
6840 /* FIXME. I think that this can be const if char *d is replaced by
6841 more localised variables. */
6842 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6843 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6844 pl_yylval.ival = OP_STRINGIFY;
6848 TERM(sublex_start());
6851 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6852 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6853 if (PL_expect == XOPERATOR)
6854 no_op("Backticks",s);
6857 readpipe_override();
6858 TERM(sublex_start());
6862 if (PL_lex_inwhat && isDIGIT(*s))
6863 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6865 if (PL_expect == XOPERATOR)
6866 no_op("Backslash",s);
6870 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6871 char *start = s + 2;
6872 while (isDIGIT(*start) || *start == '_')
6874 if (*start == '.' && isDIGIT(start[1])) {
6875 s = scan_num(s, &pl_yylval);
6878 else if ((*start == ':' && start[1] == ':')
6879 || (PL_expect == XSTATE && *start == ':'))
6881 else if (PL_expect == XSTATE) {
6883 while (d < PL_bufend && isSPACE(*d)) d++;
6884 if (*d == ':') goto keylookup;
6886 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6887 if (!isALPHA(*start) && (PL_expect == XTERM
6888 || PL_expect == XREF || PL_expect == XSTATE
6889 || PL_expect == XTERMORDORDOR)) {
6890 GV *const gv = gv_fetchpvn_flags(s, start - s,
6891 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6893 s = scan_num(s, &pl_yylval);
6900 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6953 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6955 /* Some keywords can be followed by any delimiter, including ':' */
6956 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6958 /* x::* is just a word, unless x is "CORE" */
6959 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6963 while (d < PL_bufend && isSPACE(*d))
6964 d++; /* no comments skipped here, or s### is misparsed */
6966 /* Is this a word before a => operator? */
6967 if (*d == '=' && d[1] == '>') {
6970 = (OP*)newSVOP(OP_CONST, 0,
6971 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6972 pl_yylval.opval->op_private = OPpCONST_BARE;
6976 /* Check for plugged-in keyword */
6980 char *saved_bufptr = PL_bufptr;
6982 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6984 if (result == KEYWORD_PLUGIN_DECLINE) {
6985 /* not a plugged-in keyword */
6986 PL_bufptr = saved_bufptr;
6987 } else if (result == KEYWORD_PLUGIN_STMT) {
6988 pl_yylval.opval = o;
6991 return REPORT(PLUGSTMT);
6992 } else if (result == KEYWORD_PLUGIN_EXPR) {
6993 pl_yylval.opval = o;
6995 PL_expect = XOPERATOR;
6996 return REPORT(PLUGEXPR);
6998 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
7003 /* Check for built-in keyword */
7004 tmp = keyword(PL_tokenbuf, len, 0);
7006 /* Is this a label? */
7007 if (!anydelim && PL_expect == XSTATE
7008 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
7010 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
7011 pl_yylval.pval[len] = '\0';
7012 pl_yylval.pval[len+1] = UTF ? 1 : 0;
7017 /* Check for lexical sub */
7018 if (PL_expect != XOPERATOR) {
7019 char tmpbuf[sizeof PL_tokenbuf + 1];
7021 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7022 off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
7023 if (off != NOT_IN_PAD) {
7024 assert(off); /* we assume this is boolean-true below */
7025 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7026 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7027 HEK * const stashname = HvNAME_HEK(stash);
7028 sv = newSVhek(stashname);
7029 sv_catpvs(sv, "::");
7030 sv_catpvn_flags(sv, PL_tokenbuf, len,
7031 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7032 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7042 rv2cv_op = newOP(OP_PADANY, 0);
7043 rv2cv_op->op_targ = off;
7044 cv = find_lexical_cv(off);
7052 if (tmp < 0) { /* second-class keyword? */
7053 GV *ogv = NULL; /* override (winner) */
7054 GV *hgv = NULL; /* hidden (loser) */
7055 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7057 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7058 UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
7061 if (GvIMPORTED_CV(gv))
7063 else if (! CvMETHOD(cv))
7067 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7068 UTF ? -(I32)len : (I32)len, FALSE)) &&
7069 (gv = *gvp) && isGV_with_GP(gv) &&
7070 GvCVu(gv) && GvIMPORTED_CV(gv))
7077 tmp = 0; /* overridden by import or by GLOBAL */
7080 && -tmp==KEY_lock /* XXX generalizable kludge */
7083 tmp = 0; /* any sub overrides "weak" keyword */
7085 else { /* no override */
7087 if (tmp == KEY_dump) {
7088 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
7089 "dump() better written as CORE::dump()");
7093 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
7094 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7095 "Ambiguous call resolved as CORE::%s(), "
7096 "qualify as such or use &",
7104 default: /* not a keyword */
7105 /* Trade off - by using this evil construction we can pull the
7106 variable gv into the block labelled keylookup. If not, then
7107 we have to give it function scope so that the goto from the
7108 earlier ':' case doesn't bypass the initialisation. */
7110 just_a_word_zero_gv:
7122 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7123 const char penultchar =
7124 lastchar && PL_bufptr - 2 >= PL_linestart
7128 SV *nextPL_nextwhite = 0;
7132 /* Get the rest if it looks like a package qualifier */
7134 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7136 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7139 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
7140 UTF8fARG(UTF, len, PL_tokenbuf),
7141 *s == '\'' ? "'" : "::");
7146 if (PL_expect == XOPERATOR) {
7147 if (PL_bufptr == PL_linestart) {
7148 CopLINE_dec(PL_curcop);
7149 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7150 CopLINE_inc(PL_curcop);
7153 no_op("Bareword",s);
7156 /* Look for a subroutine with this name in current package,
7157 unless this is a lexical sub, or name is "Foo::",
7158 in which case Foo is a bareword
7159 (and a package name). */
7161 if (len > 2 && !PL_madskills &&
7162 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
7164 if (ckWARN(WARN_BAREWORD)
7165 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7166 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7167 "Bareword \"%"UTF8f"\" refers to nonexistent package",
7168 UTF8fARG(UTF, len, PL_tokenbuf));
7170 PL_tokenbuf[len] = '\0';
7176 /* Mustn't actually add anything to a symbol table.
7177 But also don't want to "initialise" any placeholder
7178 constants that might already be there into full
7179 blown PVGVs with attached PVCV. */
7180 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7181 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
7187 /* if we saw a global override before, get the right name */
7190 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7191 len ? len : strlen(PL_tokenbuf));
7193 SV * const tmp_sv = sv;
7194 sv = newSVpvs("CORE::GLOBAL::");
7195 sv_catsv(sv, tmp_sv);
7196 SvREFCNT_dec(tmp_sv);
7200 if (PL_madskills && !PL_thistoken) {
7201 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
7202 PL_thistoken = newSVpvn(start,s - start);
7203 PL_realtokenstart = s - SvPVX(PL_linestr);
7207 /* Presume this is going to be a bareword of some sort. */
7209 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
7210 pl_yylval.opval->op_private = OPpCONST_BARE;
7212 /* And if "Foo::", then that's what it certainly is. */
7218 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7219 const_op->op_private = OPpCONST_BARE;
7220 rv2cv_op = newCVREF(0, const_op);
7221 cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
7224 /* See if it's the indirect object for a list operator. */
7226 if (PL_oldoldbufptr &&
7227 PL_oldoldbufptr < PL_bufptr &&
7228 (PL_oldoldbufptr == PL_last_lop
7229 || PL_oldoldbufptr == PL_last_uni) &&
7230 /* NO SKIPSPACE BEFORE HERE! */
7231 (PL_expect == XREF ||
7232 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
7234 bool immediate_paren = *s == '(';
7236 /* (Now we can afford to cross potential line boundary.) */
7237 s = SKIPSPACE2(s,nextPL_nextwhite);
7239 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
7242 /* Two barewords in a row may indicate method call. */
7244 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
7245 (tmp = intuit_method(s, gv, cv))) {
7247 if (tmp == METHOD && !PL_lex_allbrackets &&
7248 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7249 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7253 /* If not a declared subroutine, it's an indirect object. */
7254 /* (But it's an indir obj regardless for sort.) */
7255 /* Also, if "_" follows a filetest operator, it's a bareword */
7258 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
7260 (PL_last_lop_op != OP_MAPSTART &&
7261 PL_last_lop_op != OP_GREPSTART))))
7262 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7263 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
7266 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7271 PL_expect = XOPERATOR;
7274 s = SKIPSPACE2(s,nextPL_nextwhite);
7275 PL_nextwhite = nextPL_nextwhite;
7280 /* Is this a word before a => operator? */
7281 if (*s == '=' && s[1] == '>' && !pkgname) {
7284 /* This is our own scalar, created a few lines above,
7286 SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv);
7287 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
7288 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
7289 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
7290 SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv);
7294 /* If followed by a paren, it's certainly a subroutine. */
7299 while (SPACE_OR_TAB(*d))
7301 if (*d == ')' && (sv = cv_const_sv(cv))) {
7308 PL_nextwhite = PL_thiswhite;
7311 start_force(PL_curforce);
7313 NEXTVAL_NEXTTOKE.opval =
7314 off ? rv2cv_op : pl_yylval.opval;
7315 PL_expect = XOPERATOR;
7318 PL_nextwhite = nextPL_nextwhite;
7319 curmad('X', PL_thistoken);
7320 PL_thistoken = newSVpvs("");
7324 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7325 else op_free(rv2cv_op), force_next(WORD);
7330 /* If followed by var or block, call it a method (unless sub) */
7332 if ((*s == '$' || *s == '{') && !cv) {
7334 PL_last_lop = PL_oldbufptr;
7335 PL_last_lop_op = OP_METHOD;
7336 if (!PL_lex_allbrackets &&
7337 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7338 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7342 /* If followed by a bareword, see if it looks like indir obj. */
7345 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
7346 && (tmp = intuit_method(s, gv, cv))) {
7348 if (tmp == METHOD && !PL_lex_allbrackets &&
7349 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7350 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7354 /* Not a method, so call it a subroutine (if defined) */
7357 if (lastchar == '-' && penultchar != '-') {
7358 const STRLEN l = len ? len : strlen(PL_tokenbuf);
7359 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7360 "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()",
7361 UTF8fARG(UTF, l, PL_tokenbuf),
7362 UTF8fARG(UTF, l, PL_tokenbuf));
7364 /* Check for a constant sub */
7365 if ((sv = cv_const_sv(cv))) {
7368 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7369 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7370 pl_yylval.opval->op_private = OPpCONST_FOLDED;
7371 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7375 op_free(pl_yylval.opval);
7377 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7378 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7379 PL_last_lop = PL_oldbufptr;
7380 PL_last_lop_op = OP_ENTERSUB;
7381 /* Is there a prototype? */
7388 STRLEN protolen = CvPROTOLEN(cv);
7389 const char *proto = CvPROTO(cv);
7391 proto = S_strip_spaces(aTHX_ proto, &protolen);
7394 if ((optional = *proto == ';'))
7397 while (*proto == ';');
7401 *proto == '$' || *proto == '_'
7402 || *proto == '*' || *proto == '+'
7407 *proto == '\\' && proto[1] && proto[2] == '\0'
7410 UNIPROTO(UNIOPSUB,optional);
7411 if (*proto == '\\' && proto[1] == '[') {
7412 const char *p = proto + 2;
7413 while(*p && *p != ']')
7415 if(*p == ']' && !p[1])
7416 UNIPROTO(UNIOPSUB,optional);
7418 if (*proto == '&' && *s == '{') {
7420 sv_setpvs(PL_subname, "__ANON__");
7422 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7423 if (!PL_lex_allbrackets &&
7424 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7425 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7432 PL_nextwhite = PL_thiswhite;
7435 start_force(PL_curforce);
7436 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7439 PL_nextwhite = nextPL_nextwhite;
7440 curmad('X', PL_thistoken);
7441 PL_thistoken = newSVpvs("");
7443 force_next(off ? PRIVATEREF : WORD);
7444 if (!PL_lex_allbrackets &&
7445 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7446 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7451 /* Guess harder when madskills require "best effort". */
7452 if (PL_madskills && (!gv || !GvCVu(gv))) {
7453 int probable_sub = 0;
7454 if (strchr("\"'`$@%0123456789!*+{[<", *s))
7456 else if (isALPHA(*s)) {
7460 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
7461 if (!keyword(tmpbuf, tmplen, 0))
7464 while (d < PL_bufend && isSPACE(*d))
7466 if (*d == '=' && d[1] == '>')
7471 gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
7473 op_free(pl_yylval.opval);
7475 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7476 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7477 PL_last_lop = PL_oldbufptr;
7478 PL_last_lop_op = OP_ENTERSUB;
7479 PL_nextwhite = PL_thiswhite;
7481 start_force(PL_curforce);
7482 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7484 PL_nextwhite = nextPL_nextwhite;
7485 curmad('X', PL_thistoken);
7486 PL_thistoken = newSVpvs("");
7487 force_next(off ? PRIVATEREF : WORD);
7488 if (!PL_lex_allbrackets &&
7489 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7490 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7494 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7496 force_next(off ? PRIVATEREF : WORD);
7497 if (!PL_lex_allbrackets &&
7498 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7499 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7504 /* Call it a bare word */
7506 if (PL_hints & HINT_STRICT_SUBS)
7507 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7510 /* after "print" and similar functions (corresponding to
7511 * "F? L" in opcode.pl), whatever wasn't already parsed as
7512 * a filehandle should be subject to "strict subs".
7513 * Likewise for the optional indirect-object argument to system
7514 * or exec, which can't be a bareword */
7515 if ((PL_last_lop_op == OP_PRINT
7516 || PL_last_lop_op == OP_PRTF
7517 || PL_last_lop_op == OP_SAY
7518 || PL_last_lop_op == OP_SYSTEM
7519 || PL_last_lop_op == OP_EXEC)
7520 && (PL_hints & HINT_STRICT_SUBS))
7521 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7522 if (lastchar != '-') {
7523 if (ckWARN(WARN_RESERVED)) {
7527 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7528 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7536 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7537 && saw_infix_sigil) {
7538 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7539 "Operator or semicolon missing before %c%"UTF8f,
7541 UTF8fARG(UTF, strlen(PL_tokenbuf),
7543 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7544 "Ambiguous use of %c resolved as operator %c",
7545 lastchar, lastchar);
7552 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7557 (OP*)newSVOP(OP_CONST, 0,
7558 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7561 case KEY___PACKAGE__:
7563 (OP*)newSVOP(OP_CONST, 0,
7565 ? newSVhek(HvNAME_HEK(PL_curstash))
7572 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7573 const char *pname = "main";
7576 if (PL_tokenbuf[2] == 'D')
7579 PL_curstash ? PL_curstash : PL_defstash;
7580 pname = HvNAME_get(stash);
7581 plen = HvNAMELEN (stash);
7582 if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
7584 gv = gv_fetchpvn_flags(
7585 Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
7586 plen+6, GV_ADD|putf8, SVt_PVIO
7590 GvIOp(gv) = newIO();
7591 IoIFP(GvIOp(gv)) = PL_rsfp;
7592 #if defined(HAS_FCNTL) && defined(F_SETFD)
7594 const int fd = PerlIO_fileno(PL_rsfp);
7595 fcntl(fd,F_SETFD,fd >= 3);
7598 /* Mark this internal pseudo-handle as clean */
7599 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7600 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7601 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7603 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7604 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7605 /* if the script was opened in binmode, we need to revert
7606 * it to text mode for compatibility; but only iff it has CRs
7607 * XXX this is a questionable hack at best. */
7608 if (PL_bufend-PL_bufptr > 2
7609 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7612 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7613 loc = PerlIO_tell(PL_rsfp);
7614 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7617 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7619 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7620 #endif /* NETWARE */
7622 PerlIO_seek(PL_rsfp, loc, 0);
7626 #ifdef PERLIO_LAYERS
7629 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7630 else if (PL_encoding) {
7637 XPUSHs(PL_encoding);
7639 call_method("name", G_SCALAR);
7643 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7644 Perl_form(aTHX_ ":encoding(%"SVf")",
7653 if (PL_realtokenstart >= 0) {
7654 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7656 PL_endwhite = newSVpvs("");
7657 sv_catsv(PL_endwhite, PL_thiswhite);
7659 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7660 PL_realtokenstart = -1;
7662 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7672 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
7681 if (PL_expect == XSTATE) {
7688 if (*s == ':' && s[1] == ':') {
7692 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7693 if ((*s == ':' && s[1] == ':')
7694 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7698 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7702 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7703 UTF8fARG(UTF, len, PL_tokenbuf));
7706 else if (tmp == KEY_require || tmp == KEY_do
7708 /* that's a way to remember we saw "CORE::" */
7721 LOP(OP_ACCEPT,XTERM);
7724 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7729 LOP(OP_ATAN2,XTERM);
7735 LOP(OP_BINMODE,XTERM);
7738 LOP(OP_BLESS,XTERM);
7747 /* We have to disambiguate the two senses of
7748 "continue". If the next token is a '{' then
7749 treat it as the start of a continue block;
7750 otherwise treat it as a control operator.
7760 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7770 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7779 if (!PL_cryptseen) {
7780 PL_cryptseen = TRUE;
7784 LOP(OP_CRYPT,XTERM);
7787 LOP(OP_CHMOD,XTERM);
7790 LOP(OP_CHOWN,XTERM);
7793 LOP(OP_CONNECT,XTERM);
7813 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7815 if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
7818 force_ident_maybe_lex('&');
7823 if (orig_keyword == KEY_do) {
7832 PL_hints |= HINT_BLOCK_SCOPE;
7842 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7843 STR_WITH_LEN("NDBM_File::"),
7844 STR_WITH_LEN("DB_File::"),
7845 STR_WITH_LEN("GDBM_File::"),
7846 STR_WITH_LEN("SDBM_File::"),
7847 STR_WITH_LEN("ODBM_File::"),
7849 LOP(OP_DBMOPEN,XTERM);
7855 PL_expect = XOPERATOR;
7856 s = force_word(s,WORD,TRUE,FALSE);
7863 pl_yylval.ival = CopLINE(PL_curcop);
7867 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7881 if (*s == '{') { /* block eval */
7882 PL_expect = XTERMBLOCK;
7883 UNIBRACK(OP_ENTERTRY);
7885 else { /* string eval */
7887 UNIBRACK(OP_ENTEREVAL);
7892 UNIBRACK(-OP_ENTEREVAL);
7906 case KEY_endhostent:
7912 case KEY_endservent:
7915 case KEY_endprotoent:
7926 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7928 pl_yylval.ival = CopLINE(PL_curcop);
7930 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7933 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7936 if ((PL_bufend - p) >= 3 &&
7937 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7939 else if ((PL_bufend - p) >= 4 &&
7940 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7943 if (isIDFIRST_lazy_if(p,UTF)) {
7944 p = scan_ident(p, PL_bufend,
7945 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7949 Perl_croak(aTHX_ "Missing $ on loop variable");
7951 s = SvPVX(PL_linestr) + soff;
7957 LOP(OP_FORMLINE,XTERM);
7966 LOP(OP_FCNTL,XTERM);
7972 LOP(OP_FLOCK,XTERM);
7975 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7980 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7985 LOP(OP_GREPSTART, XREF);
7988 PL_expect = XOPERATOR;
7989 s = force_word(s,WORD,TRUE,FALSE);
8004 case KEY_getpriority:
8005 LOP(OP_GETPRIORITY,XTERM);
8007 case KEY_getprotobyname:
8010 case KEY_getprotobynumber:
8011 LOP(OP_GPBYNUMBER,XTERM);
8013 case KEY_getprotoent:
8025 case KEY_getpeername:
8026 UNI(OP_GETPEERNAME);
8028 case KEY_gethostbyname:
8031 case KEY_gethostbyaddr:
8032 LOP(OP_GHBYADDR,XTERM);
8034 case KEY_gethostent:
8037 case KEY_getnetbyname:
8040 case KEY_getnetbyaddr:
8041 LOP(OP_GNBYADDR,XTERM);
8046 case KEY_getservbyname:
8047 LOP(OP_GSBYNAME,XTERM);
8049 case KEY_getservbyport:
8050 LOP(OP_GSBYPORT,XTERM);
8052 case KEY_getservent:
8055 case KEY_getsockname:
8056 UNI(OP_GETSOCKNAME);
8058 case KEY_getsockopt:
8059 LOP(OP_GSOCKOPT,XTERM);
8074 pl_yylval.ival = CopLINE(PL_curcop);
8075 Perl_ck_warner_d(aTHX_
8076 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8077 "given is experimental");
8082 orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
8090 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8092 pl_yylval.ival = CopLINE(PL_curcop);
8096 LOP(OP_INDEX,XTERM);
8102 LOP(OP_IOCTL,XTERM);
8114 PL_expect = XOPERATOR;
8115 s = force_word(s,WORD,TRUE,FALSE);
8132 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8137 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8151 LOP(OP_LISTEN,XTERM);
8160 s = scan_pat(s,OP_MATCH);
8161 TERM(sublex_start());
8164 LOP(OP_MAPSTART, XREF);
8167 LOP(OP_MKDIR,XTERM);
8170 LOP(OP_MSGCTL,XTERM);
8173 LOP(OP_MSGGET,XTERM);
8176 LOP(OP_MSGRCV,XTERM);
8179 LOP(OP_MSGSND,XTERM);
8184 PL_in_my = (U16)tmp;
8186 if (isIDFIRST_lazy_if(s,UTF)) {
8190 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8191 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
8193 if (!FEATURE_LEXSUBS_IS_ENABLED)
8195 "Experimental \"%s\" subs not enabled",
8196 tmp == KEY_my ? "my" :
8197 tmp == KEY_state ? "state" : "our");
8198 Perl_ck_warner_d(aTHX_
8199 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
8200 "The lexical_subs feature is experimental");
8203 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8204 if (!PL_in_my_stash) {
8207 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8208 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8211 if (PL_madskills) { /* just add type to declarator token */
8212 sv_catsv(PL_thistoken, PL_nextwhite);
8214 sv_catpvn(PL_thistoken, start, s - start);
8222 PL_expect = XOPERATOR;
8223 s = force_word(s,WORD,TRUE,FALSE);
8227 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8232 s = tokenize_use(0, s);
8236 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
8239 if (!PL_lex_allbrackets &&
8240 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8241 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8247 if (isIDFIRST_lazy_if(s,UTF)) {
8249 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8251 for (t=d; isSPACE(*t);)
8253 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8255 && !(t[0] == '=' && t[1] == '>')
8256 && !(t[0] == ':' && t[1] == ':')
8257 && !keyword(s, d-s, 0)
8259 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8260 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
8261 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8267 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8269 pl_yylval.ival = OP_OR;
8279 LOP(OP_OPEN_DIR,XTERM);
8282 checkcomma(s,PL_tokenbuf,"filehandle");
8286 checkcomma(s,PL_tokenbuf,"filehandle");
8305 s = force_word(s,WORD,FALSE,TRUE);
8307 s = force_strict_version(s);
8308 PL_lex_expect = XBLOCK;
8312 LOP(OP_PIPE_OP,XTERM);
8315 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8318 pl_yylval.ival = OP_CONST;
8319 TERM(sublex_start());
8326 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8329 PL_expect = XOPERATOR;
8330 if (SvCUR(PL_lex_stuff)) {
8331 int warned_comma = !ckWARN(WARN_QW);
8332 int warned_comment = warned_comma;
8333 d = SvPV_force(PL_lex_stuff, len);
8335 for (; isSPACE(*d) && len; --len, ++d)
8340 if (!warned_comma || !warned_comment) {
8341 for (; !isSPACE(*d) && len; --len, ++d) {
8342 if (!warned_comma && *d == ',') {
8343 Perl_warner(aTHX_ packWARN(WARN_QW),
8344 "Possible attempt to separate words with commas");
8347 else if (!warned_comment && *d == '#') {
8348 Perl_warner(aTHX_ packWARN(WARN_QW),
8349 "Possible attempt to put comments in qw() list");
8355 for (; !isSPACE(*d) && len; --len, ++d)
8358 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8359 words = op_append_elem(OP_LIST, words,
8360 newSVOP(OP_CONST, 0, tokeq(sv)));
8365 words = newNULLLIST();
8367 SvREFCNT_dec(PL_lex_stuff);
8368 PL_lex_stuff = NULL;
8370 PL_expect = XOPERATOR;
8371 pl_yylval.opval = sawparens(words);
8376 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8379 pl_yylval.ival = OP_STRINGIFY;
8380 if (SvIVX(PL_lex_stuff) == '\'')
8381 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8382 TERM(sublex_start());
8385 s = scan_pat(s,OP_QR);
8386 TERM(sublex_start());
8389 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8392 readpipe_override();
8393 TERM(sublex_start());
8400 PL_expect = XOPERATOR;
8402 s = force_version(s, FALSE);
8404 else if (*s != 'v' || !isDIGIT(s[1])
8405 || (s = force_version(s, TRUE), *s == 'v'))
8407 *PL_tokenbuf = '\0';
8408 s = force_word(s,WORD,TRUE,TRUE);
8409 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
8410 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8411 GV_ADD | (UTF ? SVf_UTF8 : 0));
8413 yyerror("<> should be quotes");
8415 if (orig_keyword == KEY_require) {
8423 PL_last_uni = PL_oldbufptr;
8424 PL_last_lop_op = OP_REQUIRE;
8426 return REPORT( (int)REQUIRE );
8432 PL_expect = XOPERATOR;
8433 s = force_word(s,WORD,TRUE,FALSE);
8437 LOP(OP_RENAME,XTERM);
8446 LOP(OP_RINDEX,XTERM);
8455 UNIDOR(OP_READLINE);
8458 UNIDOR(OP_BACKTICK);
8467 LOP(OP_REVERSE,XTERM);
8470 UNIDOR(OP_READLINK);
8477 if (pl_yylval.opval)
8478 TERM(sublex_start());
8480 TOKEN(1); /* force error */
8483 checkcomma(s,PL_tokenbuf,"filehandle");
8493 LOP(OP_SELECT,XTERM);
8499 LOP(OP_SEMCTL,XTERM);
8502 LOP(OP_SEMGET,XTERM);
8505 LOP(OP_SEMOP,XTERM);
8511 LOP(OP_SETPGRP,XTERM);
8513 case KEY_setpriority:
8514 LOP(OP_SETPRIORITY,XTERM);
8516 case KEY_sethostent:
8522 case KEY_setservent:
8525 case KEY_setprotoent:
8535 LOP(OP_SEEKDIR,XTERM);
8537 case KEY_setsockopt:
8538 LOP(OP_SSOCKOPT,XTERM);
8544 LOP(OP_SHMCTL,XTERM);
8547 LOP(OP_SHMGET,XTERM);
8550 LOP(OP_SHMREAD,XTERM);
8553 LOP(OP_SHMWRITE,XTERM);
8556 LOP(OP_SHUTDOWN,XTERM);
8565 LOP(OP_SOCKET,XTERM);
8567 case KEY_socketpair:
8568 LOP(OP_SOCKPAIR,XTERM);
8571 checkcomma(s,PL_tokenbuf,"subroutine name");
8574 s = force_word(s,WORD,TRUE,TRUE);
8578 LOP(OP_SPLIT,XTERM);
8581 LOP(OP_SPRINTF,XTERM);
8584 LOP(OP_SPLICE,XTERM);
8599 LOP(OP_SUBSTR,XTERM);
8605 char * const tmpbuf = PL_tokenbuf + 1;
8606 expectation attrful;
8607 bool have_name, have_proto;
8608 const int key = tmp;
8610 SV *format_name = NULL;
8616 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
8617 SV *subtoken = PL_madskills
8618 ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr))
8623 s = SKIPSPACE2(s,tmpwhite);
8629 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
8630 (*s == ':' && s[1] == ':'))
8633 SV *nametoke = NULL;
8637 attrful = XATTRBLOCK;
8638 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8642 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
8644 if (key == KEY_format)
8645 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8648 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8650 PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
8652 sv_setpvn(PL_subname, tmpbuf, len);
8654 sv_setsv(PL_subname,PL_curstname);
8655 sv_catpvs(PL_subname,"::");
8656 sv_catpvn(PL_subname,tmpbuf,len);
8658 if (SvUTF8(PL_linestr))
8659 SvUTF8_on(PL_subname);
8665 CURMAD('X', nametoke);
8666 CURMAD('_', tmpwhite);
8667 force_ident_maybe_lex('&');
8669 s = SKIPSPACE2(d,tmpwhite);
8675 if (key == KEY_my || key == KEY_our || key==KEY_state)
8678 /* diag_listed_as: Missing name in "%s sub" */
8680 "Missing name in \"%s\"", PL_bufptr);
8682 PL_expect = XTERMBLOCK;
8683 attrful = XATTRTERM;
8684 sv_setpvs(PL_subname,"?");
8688 if (key == KEY_format) {
8690 PL_thistoken = subtoken;
8694 start_force(PL_curforce);
8695 NEXTVAL_NEXTTOKE.opval
8696 = (OP*)newSVOP(OP_CONST,0, format_name);
8697 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8704 /* Look for a prototype */
8706 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8708 Perl_croak(aTHX_ "Prototype not terminated");
8709 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8714 CURMAD('q', PL_thisopen);
8715 CURMAD('_', tmpwhite);
8716 CURMAD('=', PL_thisstuff);
8717 CURMAD('Q', PL_thisclose);
8718 NEXTVAL_NEXTTOKE.opval =
8719 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8720 PL_lex_stuff = NULL;
8723 s = SKIPSPACE2(s,tmpwhite);
8731 if (*s == ':' && s[1] != ':')
8732 PL_expect = attrful;
8733 else if (*s != '{' && key == KEY_sub) {
8735 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8736 else if (*s != ';' && *s != '}')
8737 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8744 curmad('^', newSVpvs(""));
8745 CURMAD('_', tmpwhite);
8749 PL_thistoken = subtoken;
8750 PERL_UNUSED_VAR(have_proto);
8753 NEXTVAL_NEXTTOKE.opval =
8754 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8755 PL_lex_stuff = NULL;
8761 sv_setpvs(PL_subname, "__ANON__");
8763 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8767 force_ident_maybe_lex('&');
8773 LOP(OP_SYSTEM,XREF);
8776 LOP(OP_SYMLINK,XTERM);
8779 LOP(OP_SYSCALL,XTERM);
8782 LOP(OP_SYSOPEN,XTERM);
8785 LOP(OP_SYSSEEK,XTERM);
8788 LOP(OP_SYSREAD,XTERM);
8791 LOP(OP_SYSWRITE,XTERM);
8796 TERM(sublex_start());
8817 LOP(OP_TRUNCATE,XTERM);
8829 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8831 pl_yylval.ival = CopLINE(PL_curcop);
8835 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8837 pl_yylval.ival = CopLINE(PL_curcop);
8841 LOP(OP_UNLINK,XTERM);
8847 LOP(OP_UNPACK,XTERM);
8850 LOP(OP_UTIME,XTERM);
8856 LOP(OP_UNSHIFT,XTERM);
8859 s = tokenize_use(1, s);
8869 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8871 pl_yylval.ival = CopLINE(PL_curcop);
8872 Perl_ck_warner_d(aTHX_
8873 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8874 "when is experimental");
8878 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8880 pl_yylval.ival = CopLINE(PL_curcop);
8884 PL_hints |= HINT_BLOCK_SCOPE;
8891 LOP(OP_WAITPID,XTERM);
8900 ctl_l[0] = toCTRL('L');
8902 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8905 /* Make sure $^L is defined */
8906 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8911 if (PL_expect == XOPERATOR) {
8912 if (*s == '=' && !PL_lex_allbrackets &&
8913 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8921 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8923 pl_yylval.ival = OP_XOR;
8929 #pragma segment Main
8935 Looks up an identifier in the pad or in a package
8938 PRIVATEREF if this is a lexical name.
8939 WORD if this belongs to a package.
8942 if we're in a my declaration
8943 croak if they tried to say my($foo::bar)
8944 build the ops for a my() declaration
8945 if it's an access to a my() variable
8946 build ops for access to a my() variable
8947 if in a dq string, and they've said @foo and we can't find @foo
8949 build ops for a bareword
8953 S_pending_ident(pTHX)
8957 const char pit = (char)pl_yylval.ival;
8958 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8959 /* All routes through this function want to know if there is a colon. */
8960 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8962 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8963 "### Pending identifier '%s'\n", PL_tokenbuf); });
8965 /* if we're in a my(), we can't allow dynamics here.
8966 $foo'bar has already been turned into $foo::bar, so
8967 just check for colons.
8969 if it's a legal name, the OP is a PADANY.
8972 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8974 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8975 "variable %s in \"our\"",
8976 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8977 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8981 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8982 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8983 UTF ? SVf_UTF8 : 0);
8985 pl_yylval.opval = newOP(OP_PADANY, 0);
8986 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8987 UTF ? SVf_UTF8 : 0);
8993 build the ops for accesses to a my() variable.
8998 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8999 UTF ? SVf_UTF8 : 0);
9000 if (tmp != NOT_IN_PAD) {
9001 /* might be an "our" variable" */
9002 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9003 /* build ops for a bareword */
9004 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9005 HEK * const stashname = HvNAME_HEK(stash);
9006 SV * const sym = newSVhek(stashname);
9007 sv_catpvs(sym, "::");
9008 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9009 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
9010 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9014 ? (GV_ADDMULTI | GV_ADDINEVAL)
9017 ((PL_tokenbuf[0] == '$') ? SVt_PV
9018 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9023 pl_yylval.opval = newOP(OP_PADANY, 0);
9024 pl_yylval.opval->op_targ = tmp;
9030 Whine if they've said @foo in a doublequoted string,
9031 and @foo isn't a variable we can find in the symbol
9034 if (ckWARN(WARN_AMBIGUOUS) &&
9035 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
9036 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
9037 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
9038 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9039 /* DO NOT warn for @- and @+ */
9040 && !( PL_tokenbuf[2] == '\0' &&
9041 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
9044 /* Downgraded from fatal to warning 20000522 mjd */
9045 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9046 "Possible unintended interpolation of %"UTF8f
9048 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9052 /* build ops for a bareword */
9053 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
9054 newSVpvn_flags(PL_tokenbuf + 1,
9056 UTF ? SVf_UTF8 : 0 ));
9057 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9059 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
9060 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
9061 | ( UTF ? SVf_UTF8 : 0 ),
9062 ((PL_tokenbuf[0] == '$') ? SVt_PV
9063 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9069 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9073 PERL_ARGS_ASSERT_CHECKCOMMA;
9075 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9076 if (ckWARN(WARN_SYNTAX)) {
9079 for (w = s+2; *w && level; w++) {
9087 /* the list of chars below is for end of statements or
9088 * block / parens, boolean operators (&&, ||, //) and branch
9089 * constructs (or, and, if, until, unless, while, err, for).
9090 * Not a very solid hack... */
9091 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9092 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9093 "%s (...) interpreted as function",name);
9096 while (s < PL_bufend && isSPACE(*s))
9100 while (s < PL_bufend && isSPACE(*s))
9102 if (isIDFIRST_lazy_if(s,UTF)) {
9103 const char * const w = s;
9104 s += UTF ? UTF8SKIP(s) : 1;
9105 while (isWORDCHAR_lazy_if(s,UTF))
9106 s += UTF ? UTF8SKIP(s) : 1;
9107 while (s < PL_bufend && isSPACE(*s))
9111 if (keyword(w, s - w, 0))
9114 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9115 if (gv && GvCVu(gv))
9117 Perl_croak(aTHX_ "No comma allowed after %s", what);
9122 /* S_new_constant(): do any overload::constant lookup.
9124 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9125 Best used as sv=new_constant(..., sv, ...).
9126 If s, pv are NULL, calls subroutine with one argument,
9127 and <type> is used with error messages only.
9128 <type> is assumed to be well formed UTF-8 */
9131 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9132 SV *sv, SV *pv, const char *type, STRLEN typelen)
9135 HV * table = GvHV(PL_hintgv); /* ^H */
9140 const char *why1 = "", *why2 = "", *why3 = "";
9142 PERL_ARGS_ASSERT_NEW_CONSTANT;
9143 /* We assume that this is true: */
9144 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9147 /* charnames doesn't work well if there have been errors found */
9148 if (PL_error_count > 0 && *key == 'c')
9150 SvREFCNT_dec_NN(sv);
9151 return &PL_sv_undef;
9154 sv_2mortal(sv); /* Parent created it permanently */
9156 || ! (PL_hints & HINT_LOCALIZE_HH)
9157 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9162 /* Here haven't found what we're looking for. If it is charnames,
9163 * perhaps it needs to be loaded. Try doing that before giving up */
9165 Perl_load_module(aTHX_
9167 newSVpvs("_charnames"),
9168 /* version parameter; no need to specify it, as if
9169 * we get too early a version, will fail anyway,
9170 * not being able to find '_charnames' */
9176 table = GvHV(PL_hintgv);
9178 && (PL_hints & HINT_LOCALIZE_HH)
9179 && (cvp = hv_fetch(table, key, keylen, FALSE))
9185 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9186 msg = Perl_form(aTHX_
9187 "Constant(%.*s) unknown",
9188 (int)(type ? typelen : len),
9194 why3 = "} is not defined";
9197 msg = Perl_form(aTHX_
9198 /* The +3 is for '\N{'; -4 for that, plus '}' */
9199 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9203 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9204 (int)(type ? typelen : len),
9205 (type ? type: s), why1, why2, why3);
9208 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9209 return SvREFCNT_inc_simple_NN(sv);
9214 pv = newSVpvn_flags(s, len, SVs_TEMP);
9216 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9218 typesv = &PL_sv_undef;
9220 PUSHSTACKi(PERLSI_OVERLOAD);
9232 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9236 /* Check the eval first */
9237 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9239 const char * errstr;
9240 sv_catpvs(errsv, "Propagated");
9241 errstr = SvPV_const(errsv, errlen);
9242 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9244 res = SvREFCNT_inc_simple_NN(sv);
9248 SvREFCNT_inc_simple_void_NN(res);
9257 why1 = "Call to &{$^H{";
9259 why3 = "}} did not return a defined value";
9261 (void)sv_2mortal(sv);
9268 PERL_STATIC_INLINE void
9269 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
9271 PERL_ARGS_ASSERT_PARSE_IDENT;
9275 Perl_croak(aTHX_ "%s", ident_too_long);
9276 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
9277 /* The UTF-8 case must come first, otherwise things
9278 * like c\N{COMBINING TILDE} would start failing, as the
9279 * isWORDCHAR_A case below would gobble the 'c' up.
9282 char *t = *s + UTF8SKIP(*s);
9283 while (isIDCONT_utf8((U8*)t))
9285 if (*d + (t - *s) > e)
9286 Perl_croak(aTHX_ "%s", ident_too_long);
9287 Copy(*s, *d, t - *s, char);
9291 else if ( isWORDCHAR_A(**s) ) {
9294 } while isWORDCHAR_A(**s);
9296 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
9301 else if (allow_package && **s == ':' && (*s)[1] == ':'
9302 /* Disallow things like Foo::$bar. For the curious, this is
9303 * the code path that triggers the "Bad name after" warning
9304 * when looking for barewords.
9306 && (*s)[2] != '$') {
9316 /* Returns a NUL terminated string, with the length of the string written to
9320 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9324 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9325 bool is_utf8 = cBOOL(UTF);
9327 PERL_ARGS_ASSERT_SCAN_WORD;
9329 parse_ident(&s, &d, e, allow_package, is_utf8);
9336 S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9339 char *bracket = NULL;
9342 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9343 bool is_utf8 = cBOOL(UTF);
9345 PERL_ARGS_ASSERT_SCAN_IDENT;
9350 while (isDIGIT(*s)) {
9352 Perl_croak(aTHX_ "%s", ident_too_long);
9357 parse_ident(&s, &d, e, 1, is_utf8);
9362 /* Either a digit variable, or parse_ident() found an identifier
9363 (anything valid as a bareword), so job done and return. */
9364 if (PL_lex_state != LEX_NORMAL)
9365 PL_lex_state = LEX_INTERPENDMAYBE;
9368 if (*s == '$' && s[1] &&
9369 (isIDFIRST_lazy_if(s+1,is_utf8)
9370 || isDIGIT_A((U8)s[1])
9373 || strnEQ(s+1,"::",2)) )
9375 /* Dereferencing a value in a scalar variable.
9376 The alternatives are different syntaxes for a scalar variable.
9377 Using ' as a leading package separator isn't allowed. :: is. */
9380 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9384 while (s < send && SPACE_OR_TAB(*s))
9388 #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
9389 || isCNTRL_A((U8)(d)) \
9390 || isDIGIT_A((U8)(d)) \
9391 || (!(u) && !UTF8_IS_INVARIANT((U8)(d))))
9393 && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
9396 const STRLEN skip = UTF8SKIP(s);
9399 for ( i = 0; i < skip; i++ )
9407 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9408 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9412 /* Warn about ambiguous code after unary operators if {...} notation isn't
9413 used. There's no difference in ambiguity; it's merely a heuristic
9414 about when not to warn. */
9415 else if (ck_uni && !bracket)
9418 /* If we were processing {...} notation then... */
9419 if (isIDFIRST_lazy_if(d,is_utf8)) {
9420 /* if it starts as a valid identifier, assume that it is one.
9421 (the later check for } being at the expected point will trap
9422 cases where this doesn't pan out.) */
9423 d += is_utf8 ? UTF8SKIP(d) : 1;
9424 parse_ident(&s, &d, e, 1, is_utf8);
9426 while (s < send && SPACE_OR_TAB(*s))
9428 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9429 /* ${foo[0]} and ${foo{bar}} notation. */
9430 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9431 const char * const brack =
9433 ((*s == '[') ? "[...]" : "{...}");
9434 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9435 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9436 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9437 funny, dest, brack, funny, dest, brack);
9440 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9441 PL_lex_allbrackets++;
9445 /* Handle extended ${^Foo} variables
9446 * 1999-02-27 mjd-perl-patch@plover.com */
9447 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9451 while (isWORDCHAR(*s) && d < e) {
9455 Perl_croak(aTHX_ "%s", ident_too_long);
9459 while (s < send && SPACE_OR_TAB(*s))
9462 /* Expect to find a closing } after consuming any trailing whitespace.
9466 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9467 PL_lex_state = LEX_INTERPEND;
9470 if (PL_lex_state == LEX_NORMAL) {
9471 if (ckWARN(WARN_AMBIGUOUS) &&
9472 (keyword(dest, d - dest, 0)
9473 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
9475 SV *tmp = newSVpvn_flags( dest, d - dest,
9476 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9479 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9480 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9481 funny, tmp, funny, tmp);
9486 /* Didn't find the closing } at the point we expected, so restore
9487 state such that the next thing to process is the opening { and */
9488 s = bracket; /* let the parser handle it */
9492 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9493 PL_lex_state = LEX_INTERPEND;
9498 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
9500 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
9501 * the parse starting at 's', based on the subset that are valid in this
9502 * context input to this routine in 'valid_flags'. Advances s. Returns
9503 * TRUE if the input should be treated as a valid flag, so the next char
9504 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
9505 * first call on the current regex. This routine will set it to any
9506 * charset modifier found. The caller shouldn't change it. This way,
9507 * another charset modifier encountered in the parse can be detected as an
9508 * error, as we have decided to allow only one */
9511 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9513 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9514 if (isWORDCHAR_lazy_if(*s, UTF)) {
9515 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9516 UTF ? SVf_UTF8 : 0);
9518 /* Pretend that it worked, so will continue processing before
9527 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
9528 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9529 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9530 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9531 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9532 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9533 case LOCALE_PAT_MOD:
9535 goto multiple_charsets;
9537 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9540 case UNICODE_PAT_MOD:
9542 goto multiple_charsets;
9544 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9547 case ASCII_RESTRICT_PAT_MOD:
9549 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9553 /* Error if previous modifier wasn't an 'a', but if it was, see
9554 * if, and accept, a second occurrence (only) */
9556 || get_regex_charset(*pmfl)
9557 != REGEX_ASCII_RESTRICTED_CHARSET)
9559 goto multiple_charsets;
9561 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9565 case DEPENDS_PAT_MOD:
9567 goto multiple_charsets;
9569 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9578 if (*charset != c) {
9579 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9581 else if (c == 'a') {
9582 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9585 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9588 /* Pretend that it worked, so will continue processing before dieing */
9594 S_scan_pat(pTHX_ char *start, I32 type)
9599 const char * const valid_flags =
9600 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9601 char charset = '\0'; /* character set modifier */
9606 PERL_ARGS_ASSERT_SCAN_PAT;
9608 s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
9609 TRUE /* look for escaped bracketed metas */ );
9612 const char * const delimiter = skipspace(start);
9616 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9617 : "Search pattern not terminated" ));
9620 pm = (PMOP*)newPMOP(type, 0);
9621 if (PL_multi_open == '?') {
9622 /* This is the only point in the code that sets PMf_ONCE: */
9623 pm->op_pmflags |= PMf_ONCE;
9625 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9626 allows us to restrict the list needed by reset to just the ??
9628 assert(type != OP_TRANS);
9630 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9633 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9636 elements = mg->mg_len / sizeof(PMOP**);
9637 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9638 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9639 mg->mg_len = elements * sizeof(PMOP**);
9640 PmopSTASH_set(pm,PL_curstash);
9647 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9648 * anon CV. False positives like qr/[(?{]/ are harmless */
9650 if (type == OP_QR) {
9652 char *e, *p = SvPV(PL_lex_stuff, len);
9654 for (; p < e; p++) {
9655 if (p[0] == '(' && p[1] == '?'
9656 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9658 pm->op_pmflags |= PMf_HAS_CV;
9662 pm->op_pmflags |= PMf_IS_QR;
9665 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9667 if (PL_madskills && modstart != s) {
9668 SV* tmptoken = newSVpvn(modstart, s - modstart);
9669 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9672 /* issue a warning if /c is specified,but /g is not */
9673 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9675 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9676 "Use of /c modifier is meaningless without /g" );
9679 PL_lex_op = (OP*)pm;
9680 pl_yylval.ival = OP_MATCH;
9685 S_scan_subst(pTHX_ char *start)
9692 char charset = '\0'; /* character set modifier */
9697 PERL_ARGS_ASSERT_SCAN_SUBST;
9699 pl_yylval.ival = OP_NULL;
9701 s = scan_str(start,!!PL_madskills,FALSE,FALSE,
9702 TRUE /* look for escaped bracketed metas */ );
9705 Perl_croak(aTHX_ "Substitution pattern not terminated");
9707 if (s[-1] == PL_multi_open)
9711 CURMAD('q', PL_thisopen);
9712 CURMAD('_', PL_thiswhite);
9713 CURMAD('E', PL_thisstuff);
9714 CURMAD('Q', PL_thisclose);
9715 PL_realtokenstart = s - SvPVX(PL_linestr);
9719 first_start = PL_multi_start;
9720 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9723 SvREFCNT_dec(PL_lex_stuff);
9724 PL_lex_stuff = NULL;
9726 Perl_croak(aTHX_ "Substitution replacement not terminated");
9728 PL_multi_start = first_start; /* so whole substitution is taken together */
9730 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9734 CURMAD('z', PL_thisopen);
9735 CURMAD('R', PL_thisstuff);
9736 CURMAD('Z', PL_thisclose);
9742 if (*s == EXEC_PAT_MOD) {
9746 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9755 curmad('m', newSVpvn(modstart, s - modstart));
9756 append_madprops(PL_thismad, (OP*)pm, 0);
9760 if ((pm->op_pmflags & PMf_CONTINUE)) {
9761 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9765 SV * const repl = newSVpvs("");
9768 pm->op_pmflags |= PMf_EVAL;
9771 sv_catpvs(repl, "eval ");
9773 sv_catpvs(repl, "do ");
9775 sv_catpvs(repl, "{");
9776 sv_catsv(repl, PL_sublex_info.repl);
9777 sv_catpvs(repl, "}");
9779 SvREFCNT_dec(PL_sublex_info.repl);
9780 PL_sublex_info.repl = repl;
9783 PL_lex_op = (OP*)pm;
9784 pl_yylval.ival = OP_SUBST;
9789 S_scan_trans(pTHX_ char *start)
9797 bool nondestruct = 0;
9802 PERL_ARGS_ASSERT_SCAN_TRANS;
9804 pl_yylval.ival = OP_NULL;
9806 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
9808 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9810 if (s[-1] == PL_multi_open)
9814 CURMAD('q', PL_thisopen);
9815 CURMAD('_', PL_thiswhite);
9816 CURMAD('E', PL_thisstuff);
9817 CURMAD('Q', PL_thisclose);
9818 PL_realtokenstart = s - SvPVX(PL_linestr);
9822 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9825 SvREFCNT_dec(PL_lex_stuff);
9826 PL_lex_stuff = NULL;
9828 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9831 CURMAD('z', PL_thisopen);
9832 CURMAD('R', PL_thisstuff);
9833 CURMAD('Z', PL_thisclose);
9836 complement = del = squash = 0;
9843 complement = OPpTRANS_COMPLEMENT;
9846 del = OPpTRANS_DELETE;
9849 squash = OPpTRANS_SQUASH;
9861 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9862 o->op_private &= ~OPpTRANS_ALL;
9863 o->op_private |= del|squash|complement|
9864 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9865 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9868 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9873 curmad('m', newSVpvn(modstart, s - modstart));
9874 append_madprops(PL_thismad, o, 0);
9883 Takes a pointer to the first < in <<FOO.
9884 Returns a pointer to the byte following <<FOO.
9886 This function scans a heredoc, which involves different methods
9887 depending on whether we are in a string eval, quoted construct, etc.
9888 This is because PL_linestr could containing a single line of input, or
9889 a whole string being evalled, or the contents of the current quote-
9892 The two basic methods are:
9893 - Steal lines from the input stream
9894 - Scan the heredoc in PL_linestr and remove it therefrom
9896 In a file scope or filtered eval, the first method is used; in a
9897 string eval, the second.
9899 In a quote-like operator, we have to choose between the two,
9900 depending on where we can find a newline. We peek into outer lex-
9901 ing scopes until we find one with a newline in it. If we reach the
9902 outermost lexing scope and it is a file, we use the stream method.
9903 Otherwise it is treated as an eval.
9907 S_scan_heredoc(pTHX_ char *s)
9910 I32 op_type = OP_SCALAR;
9917 const bool infile = PL_rsfp || PL_parser->filtered;
9918 LEXSHARED *shared = PL_parser->lex_shared;
9920 I32 stuffstart = s - SvPVX(PL_linestr);
9923 PL_realtokenstart = -1;
9926 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9929 d = PL_tokenbuf + 1;
9930 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9931 *PL_tokenbuf = '\n';
9933 while (SPACE_OR_TAB(*peek))
9935 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9938 s = delimcpy(d, e, s, PL_bufend, term, &len);
9940 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9946 /* <<\FOO is equivalent to <<'FOO' */
9950 if (!isWORDCHAR_lazy_if(s,UTF))
9951 deprecate("bare << to mean <<\"\"");
9952 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9957 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9958 Perl_croak(aTHX_ "Delimiter for here document is too long");
9961 len = d - PL_tokenbuf;
9965 tstart = PL_tokenbuf + 1;
9966 PL_thisclose = newSVpvn(tstart, len - 1);
9967 tstart = SvPVX(PL_linestr) + stuffstart;
9968 PL_thisopen = newSVpvn(tstart, s - tstart);
9969 stuffstart = s - SvPVX(PL_linestr);
9972 #ifndef PERL_STRICT_CR
9973 d = strchr(s, '\r');
9975 char * const olds = s;
9977 while (s < PL_bufend) {
9983 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9992 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9998 tstart = SvPVX(PL_linestr) + stuffstart;
10000 sv_catpvn(PL_thisstuff, tstart, s - tstart);
10002 PL_thisstuff = newSVpvn(tstart, s - tstart);
10005 stuffstart = s - SvPVX(PL_linestr);
10008 tmpstr = newSV_type(SVt_PVIV);
10009 SvGROW(tmpstr, 80);
10010 if (term == '\'') {
10011 op_type = OP_CONST;
10012 SvIV_set(tmpstr, -1);
10014 else if (term == '`') {
10015 op_type = OP_BACKTICK;
10016 SvIV_set(tmpstr, '\\');
10019 PL_multi_start = CopLINE(PL_curcop) + 1;
10020 PL_multi_open = PL_multi_close = '<';
10021 /* inside a string eval or quote-like operator */
10022 if (!infile || PL_lex_inwhat) {
10025 char * const olds = s;
10026 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
10027 /* These two fields are not set until an inner lexing scope is
10028 entered. But we need them set here. */
10029 shared->ls_bufptr = s;
10030 shared->ls_linestr = PL_linestr;
10032 /* Look for a newline. If the current buffer does not have one,
10033 peek into the line buffer of the parent lexing scope, going
10034 up as many levels as necessary to find one with a newline
10037 while (!(s = (char *)memchr(
10038 (void *)shared->ls_bufptr, '\n',
10039 SvEND(shared->ls_linestr)-shared->ls_bufptr
10041 shared = shared->ls_prev;
10042 /* shared is only null if we have gone beyond the outermost
10043 lexing scope. In a file, we will have broken out of the
10044 loop in the previous iteration. In an eval, the string buf-
10045 fer ends with "\n;", so the while condition below will have
10046 evaluated to false. So shared can never be null. */
10048 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10049 most lexing scope. In a file, shared->ls_linestr at that
10050 level is just one line, so there is no body to steal. */
10051 if (infile && !shared->ls_prev) {
10057 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10060 linestr = shared->ls_linestr;
10061 bufend = SvEND(linestr);
10063 while (s < bufend - len + 1 &&
10064 memNE(s,PL_tokenbuf,len) ) {
10066 ++shared->herelines;
10068 if (s >= bufend - len + 1) {
10071 sv_setpvn(tmpstr,d+1,s-d);
10073 if (PL_madskills) {
10075 sv_catpvn(PL_thisstuff, d + 1, s - d);
10077 PL_thisstuff = newSVpvn(d + 1, s - d);
10078 stuffstart = s - SvPVX(PL_linestr);
10082 /* the preceding stmt passes a newline */
10083 shared->herelines++;
10085 /* s now points to the newline after the heredoc terminator.
10086 d points to the newline before the body of the heredoc.
10089 /* We are going to modify linestr in place here, so set
10090 aside copies of the string if necessary for re-evals or
10092 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10093 check shared->re_eval_str. */
10094 if (shared->re_eval_start || shared->re_eval_str) {
10095 /* Set aside the rest of the regexp */
10096 if (!shared->re_eval_str)
10097 shared->re_eval_str =
10098 newSVpvn(shared->re_eval_start,
10099 bufend - shared->re_eval_start);
10100 shared->re_eval_start -= s-d;
10102 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
10103 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
10104 cx->blk_eval.cur_text == linestr)
10106 cx->blk_eval.cur_text = newSVsv(linestr);
10107 SvSCREAM_on(cx->blk_eval.cur_text);
10109 /* Copy everything from s onwards back to d. */
10110 Move(s,d,bufend-s + 1,char);
10111 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10112 /* Setting PL_bufend only applies when we have not dug deeper
10113 into other scopes, because sublex_done sets PL_bufend to
10114 SvEND(PL_linestr). */
10115 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10122 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
10123 term = PL_tokenbuf[1];
10125 linestr_save = PL_linestr; /* must restore this afterwards */
10126 d = s; /* and this */
10127 PL_linestr = newSVpvs("");
10128 PL_bufend = SvPVX(PL_linestr);
10131 if (PL_madskills) {
10132 tstart = SvPVX(PL_linestr) + stuffstart;
10134 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10136 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10139 PL_bufptr = PL_bufend;
10140 CopLINE_set(PL_curcop,
10141 PL_multi_start + shared->herelines);
10142 if (!lex_next_chunk(LEX_NO_TERM)
10143 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10144 SvREFCNT_dec(linestr_save);
10147 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10148 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10149 lex_grow_linestr(SvCUR(PL_linestr) + 2);
10150 sv_catpvs(PL_linestr, "\n\0");
10154 stuffstart = s - SvPVX(PL_linestr);
10156 shared->herelines++;
10157 PL_last_lop = PL_last_uni = NULL;
10158 #ifndef PERL_STRICT_CR
10159 if (PL_bufend - PL_linestart >= 2) {
10160 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
10161 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10163 PL_bufend[-2] = '\n';
10165 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10167 else if (PL_bufend[-1] == '\r')
10168 PL_bufend[-1] = '\n';
10170 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10171 PL_bufend[-1] = '\n';
10173 if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
10174 SvREFCNT_dec(PL_linestr);
10175 PL_linestr = linestr_save;
10176 PL_linestart = SvPVX(linestr_save);
10177 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10182 sv_catsv(tmpstr,PL_linestr);
10186 PL_multi_end = CopLINE(PL_curcop);
10187 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10188 SvPV_shrink_to_cur(tmpstr);
10191 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10193 else if (PL_encoding)
10194 sv_recode_to_utf8(tmpstr, PL_encoding);
10196 PL_lex_stuff = tmpstr;
10197 pl_yylval.ival = op_type;
10201 SvREFCNT_dec(tmpstr);
10202 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10203 missingterm(PL_tokenbuf + 1);
10206 /* scan_inputsymbol
10207 takes: current position in input buffer
10208 returns: new position in input buffer
10209 side-effects: pl_yylval and lex_op are set.
10214 <FH> read from filehandle
10215 <pkg::FH> read from package qualified filehandle
10216 <pkg'FH> read from package qualified filehandle
10217 <$fh> read from filehandle in $fh
10218 <*.h> filename glob
10223 S_scan_inputsymbol(pTHX_ char *start)
10226 char *s = start; /* current position in buffer */
10229 char *d = PL_tokenbuf; /* start of temp holding space */
10230 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10232 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10234 end = strchr(s, '\n');
10237 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10239 /* die if we didn't have space for the contents of the <>,
10240 or if it didn't end, or if we see a newline
10243 if (len >= (I32)sizeof PL_tokenbuf)
10244 Perl_croak(aTHX_ "Excessively long <> operator");
10246 Perl_croak(aTHX_ "Unterminated <> operator");
10251 Remember, only scalar variables are interpreted as filehandles by
10252 this code. Anything more complex (e.g., <$fh{$num}>) will be
10253 treated as a glob() call.
10254 This code makes use of the fact that except for the $ at the front,
10255 a scalar variable and a filehandle look the same.
10257 if (*d == '$' && d[1]) d++;
10259 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10260 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
10261 d += UTF ? UTF8SKIP(d) : 1;
10263 /* If we've tried to read what we allow filehandles to look like, and
10264 there's still text left, then it must be a glob() and not a getline.
10265 Use scan_str to pull out the stuff between the <> and treat it
10266 as nothing more than a string.
10269 if (d - PL_tokenbuf != len) {
10270 pl_yylval.ival = OP_GLOB;
10271 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
10273 Perl_croak(aTHX_ "Glob not terminated");
10277 bool readline_overriden = FALSE;
10280 /* we're in a filehandle read situation */
10283 /* turn <> into <ARGV> */
10285 Copy("ARGV",d,5,char);
10287 /* Check whether readline() is overriden */
10288 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
10290 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
10292 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
10293 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
10294 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
10295 readline_overriden = TRUE;
10297 /* if <$fh>, create the ops to turn the variable into a
10301 /* try to find it in the pad for this block, otherwise find
10302 add symbol table ops
10304 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
10305 if (tmp != NOT_IN_PAD) {
10306 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10307 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10308 HEK * const stashname = HvNAME_HEK(stash);
10309 SV * const sym = sv_2mortal(newSVhek(stashname));
10310 sv_catpvs(sym, "::");
10311 sv_catpv(sym, d+1);
10316 OP * const o = newOP(OP_PADSV, 0);
10318 PL_lex_op = readline_overriden
10319 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10320 op_append_elem(OP_LIST, o,
10321 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10322 : (OP*)newUNOP(OP_READLINE, 0, o);
10331 ? (GV_ADDMULTI | GV_ADDINEVAL)
10332 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
10334 PL_lex_op = readline_overriden
10335 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10336 op_append_elem(OP_LIST,
10337 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10338 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10339 : (OP*)newUNOP(OP_READLINE, 0,
10340 newUNOP(OP_RV2SV, 0,
10341 newGVOP(OP_GV, 0, gv)));
10343 if (!readline_overriden)
10344 PL_lex_op->op_flags |= OPf_SPECIAL;
10345 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10346 pl_yylval.ival = OP_NULL;
10349 /* If it's none of the above, it must be a literal filehandle
10350 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10352 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10353 PL_lex_op = readline_overriden
10354 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10355 op_append_elem(OP_LIST,
10356 newGVOP(OP_GV, 0, gv),
10357 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10358 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10359 pl_yylval.ival = OP_NULL;
10368 takes: start position in buffer
10369 keep_quoted preserve \ on the embedded delimiter(s)
10370 keep_delims preserve the delimiters around the string
10371 re_reparse compiling a run-time /(?{})/:
10372 collapse // to /, and skip encoding src
10373 returns: position to continue reading from buffer
10374 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10375 updates the read buffer.
10377 This subroutine pulls a string out of the input. It is called for:
10378 q single quotes q(literal text)
10379 ' single quotes 'literal text'
10380 qq double quotes qq(interpolate $here please)
10381 " double quotes "interpolate $here please"
10382 qx backticks qx(/bin/ls -l)
10383 ` backticks `/bin/ls -l`
10384 qw quote words @EXPORT_OK = qw( func() $spam )
10385 m// regexp match m/this/
10386 s/// regexp substitute s/this/that/
10387 tr/// string transliterate tr/this/that/
10388 y/// string transliterate y/this/that/
10389 ($*@) sub prototypes sub foo ($)
10390 (stuff) sub attr parameters sub foo : attr(stuff)
10391 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10393 In most of these cases (all but <>, patterns and transliterate)
10394 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10395 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10396 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10399 It skips whitespace before the string starts, and treats the first
10400 character as the delimiter. If the delimiter is one of ([{< then
10401 the corresponding "close" character )]}> is used as the closing
10402 delimiter. It allows quoting of delimiters, and if the string has
10403 balanced delimiters ([{<>}]) it allows nesting.
10405 On success, the SV with the resulting string is put into lex_stuff or,
10406 if that is already non-NULL, into lex_repl. The second case occurs only
10407 when parsing the RHS of the special constructs s/// and tr/// (y///).
10408 For convenience, the terminating delimiter character is stuffed into
10413 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
10414 bool deprecate_escaped_meta /* Should we issue a deprecation warning
10415 for certain paired metacharacters that
10416 appear escaped within it */
10420 SV *sv; /* scalar value: string */
10421 const char *tmps; /* temp string, used for delimiter matching */
10422 char *s = start; /* current position in the buffer */
10423 char term; /* terminating character */
10424 char *to; /* current position in the sv's data */
10425 I32 brackets = 1; /* bracket nesting level */
10426 bool has_utf8 = FALSE; /* is there any utf8 content? */
10427 I32 termcode; /* terminating char. code */
10428 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10429 STRLEN termlen; /* length of terminating string */
10430 int last_off = 0; /* last position for nesting bracket */
10431 char *escaped_open = NULL;
10437 PERL_ARGS_ASSERT_SCAN_STR;
10439 /* skip space before the delimiter */
10445 if (PL_realtokenstart >= 0) {
10446 stuffstart = PL_realtokenstart;
10447 PL_realtokenstart = -1;
10450 stuffstart = start - SvPVX(PL_linestr);
10452 /* mark where we are, in case we need to report errors */
10455 /* after skipping whitespace, the next character is the terminator */
10458 termcode = termstr[0] = term;
10462 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10463 Copy(s, termstr, termlen, U8);
10464 if (!UTF8_IS_INVARIANT(term))
10468 /* mark where we are */
10469 PL_multi_start = CopLINE(PL_curcop);
10470 PL_multi_open = term;
10472 /* find corresponding closing delimiter */
10473 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10474 termcode = termstr[0] = term = tmps[5];
10476 PL_multi_close = term;
10478 /* A warning is raised if the input parameter requires it for escaped (by a
10479 * backslash) paired metacharacters {} [] and () when the delimiters are
10480 * those same characters, and the backslash is ineffective. This doesn't
10481 * happen for <>, as they aren't metas. */
10482 if (deprecate_escaped_meta
10483 && (PL_multi_open == PL_multi_close
10484 || ! ckWARN_d(WARN_DEPRECATED)
10485 || PL_multi_open == '<'))
10487 deprecate_escaped_meta = FALSE;
10490 /* create a new SV to hold the contents. 79 is the SV's initial length.
10491 What a random number. */
10492 sv = newSV_type(SVt_PVIV);
10494 SvIV_set(sv, termcode);
10495 (void)SvPOK_only(sv); /* validate pointer */
10497 /* move past delimiter and try to read a complete string */
10499 sv_catpvn(sv, s, termlen);
10502 tstart = SvPVX(PL_linestr) + stuffstart;
10503 if (PL_madskills && !PL_thisopen && !keep_delims) {
10504 PL_thisopen = newSVpvn(tstart, s - tstart);
10505 stuffstart = s - SvPVX(PL_linestr);
10509 if (PL_encoding && !UTF && !re_reparse) {
10513 int offset = s - SvPVX_const(PL_linestr);
10514 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10515 &offset, (char*)termstr, termlen);
10516 const char * const ns = SvPVX_const(PL_linestr) + offset;
10517 char * const svlast = SvEND(sv) - 1;
10519 for (; s < ns; s++) {
10520 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10521 COPLINE_INC_WITH_HERELINES;
10524 goto read_more_line;
10526 /* handle quoted delimiters */
10527 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10529 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10531 if ((svlast-1 - t) % 2) {
10532 if (!keep_quoted) {
10533 *(svlast-1) = term;
10535 SvCUR_set(sv, SvCUR(sv) - 1);
10540 if (PL_multi_open == PL_multi_close) {
10546 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10547 /* At here, all closes are "was quoted" one,
10548 so we don't check PL_multi_close. */
10550 if (!keep_quoted && *(t+1) == PL_multi_open)
10555 else if (*t == PL_multi_open)
10563 SvCUR_set(sv, w - SvPVX_const(sv));
10565 last_off = w - SvPVX(sv);
10566 if (--brackets <= 0)
10571 if (!keep_delims) {
10572 SvCUR_set(sv, SvCUR(sv) - 1);
10578 /* extend sv if need be */
10579 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10580 /* set 'to' to the next character in the sv's string */
10581 to = SvPVX(sv)+SvCUR(sv);
10583 /* if open delimiter is the close delimiter read unbridle */
10584 if (PL_multi_open == PL_multi_close) {
10585 for (; s < PL_bufend; s++,to++) {
10586 /* embedded newlines increment the current line number */
10587 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10588 COPLINE_INC_WITH_HERELINES;
10589 /* handle quoted delimiters */
10590 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10593 || (re_reparse && s[1] == '\\'))
10596 /* any other quotes are simply copied straight through */
10600 /* terminate when run out of buffer (the for() condition), or
10601 have found the terminator */
10602 else if (*s == term) {
10605 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10608 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10614 /* if the terminator isn't the same as the start character (e.g.,
10615 matched brackets), we have to allow more in the quoting, and
10616 be prepared for nested brackets.
10619 /* read until we run out of string, or we find the terminator */
10620 for (; s < PL_bufend; s++,to++) {
10621 /* embedded newlines increment the line count */
10622 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10623 COPLINE_INC_WITH_HERELINES;
10624 /* backslashes can escape the open or closing characters */
10625 if (*s == '\\' && s+1 < PL_bufend) {
10626 if (!keep_quoted &&
10627 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10631 /* Here, 'deprecate_escaped_meta' is true iff the
10632 * delimiters are paired metacharacters, and 's' points
10633 * to an occurrence of one of them within the string,
10634 * which was preceded by a backslash. If this is a
10635 * context where the delimiter is also a metacharacter,
10636 * the backslash is useless, and deprecated. () and []
10637 * are meta in any context. {} are meta only when
10638 * appearing in a quantifier or in things like '\p{'.
10639 * They also aren't meta unless there is a matching
10640 * closed, escaped char later on within the string.
10641 * If 's' points to an open, set a flag; if to a close,
10642 * test that flag, and raise a warning if it was set */
10644 if (deprecate_escaped_meta) {
10645 if (*s == PL_multi_open) {
10649 else if (regcurly(s,
10650 TRUE /* Look for a closing
10652 || (s - start > 2 /* Look for e.g.
10654 && _generic_isCC(*(s-2), _CC_BACKSLASH_FOO_LBRACE_IS_META)))
10659 else if (escaped_open) {
10660 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10661 "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open);
10662 escaped_open = NULL;
10669 /* allow nested opens and closes */
10670 else if (*s == PL_multi_close && --brackets <= 0)
10672 else if (*s == PL_multi_open)
10674 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10679 /* terminate the copied string and update the sv's end-of-string */
10681 SvCUR_set(sv, to - SvPVX_const(sv));
10684 * this next chunk reads more into the buffer if we're not done yet
10688 break; /* handle case where we are done yet :-) */
10690 #ifndef PERL_STRICT_CR
10691 if (to - SvPVX_const(sv) >= 2) {
10692 if ((to[-2] == '\r' && to[-1] == '\n') ||
10693 (to[-2] == '\n' && to[-1] == '\r'))
10697 SvCUR_set(sv, to - SvPVX_const(sv));
10699 else if (to[-1] == '\r')
10702 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10707 /* if we're out of file, or a read fails, bail and reset the current
10708 line marker so we can report where the unterminated string began
10711 if (PL_madskills) {
10712 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10714 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10716 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10719 COPLINE_INC_WITH_HERELINES;
10720 PL_bufptr = PL_bufend;
10721 if (!lex_next_chunk(0)) {
10723 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10732 /* at this point, we have successfully read the delimited string */
10734 if (!PL_encoding || UTF || re_reparse) {
10736 if (PL_madskills) {
10737 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10738 const int len = s - tstart;
10740 sv_catpvn(PL_thisstuff, tstart, len);
10742 PL_thisstuff = newSVpvn(tstart, len);
10743 if (!PL_thisclose && !keep_delims)
10744 PL_thisclose = newSVpvn(s,termlen);
10749 sv_catpvn(sv, s, termlen);
10754 if (PL_madskills) {
10755 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10756 const int len = s - tstart - termlen;
10758 sv_catpvn(PL_thisstuff, tstart, len);
10760 PL_thisstuff = newSVpvn(tstart, len);
10761 if (!PL_thisclose && !keep_delims)
10762 PL_thisclose = newSVpvn(s - termlen,termlen);
10766 if (has_utf8 || (PL_encoding && !re_reparse))
10769 PL_multi_end = CopLINE(PL_curcop);
10771 /* if we allocated too much space, give some back */
10772 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10773 SvLEN_set(sv, SvCUR(sv) + 1);
10774 SvPV_renew(sv, SvLEN(sv));
10777 /* decide whether this is the first or second quoted string we've read
10782 PL_sublex_info.repl = sv;
10790 takes: pointer to position in buffer
10791 returns: pointer to new position in buffer
10792 side-effects: builds ops for the constant in pl_yylval.op
10794 Read a number in any of the formats that Perl accepts:
10796 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10797 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10800 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10802 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10805 If it reads a number without a decimal point or an exponent, it will
10806 try converting the number to an integer and see if it can do so
10807 without loss of precision.
10811 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10814 const char *s = start; /* current position in buffer */
10815 char *d; /* destination in temp buffer */
10816 char *e; /* end of temp buffer */
10817 NV nv; /* number read, as a double */
10818 SV *sv = NULL; /* place to put the converted number */
10819 bool floatit; /* boolean: int or float? */
10820 const char *lastub = NULL; /* position of last underbar */
10821 static const char* const number_too_long = "Number too long";
10823 PERL_ARGS_ASSERT_SCAN_NUM;
10825 /* We use the first character to decide what type of number this is */
10829 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10831 /* if it starts with a 0, it could be an octal number, a decimal in
10832 0.13 disguise, or a hexadecimal number, or a binary number. */
10836 u holds the "number so far"
10837 shift the power of 2 of the base
10838 (hex == 4, octal == 3, binary == 1)
10839 overflowed was the number more than we can hold?
10841 Shift is used when we add a digit. It also serves as an "are
10842 we in octal/hex/binary?" indicator to disallow hex characters
10843 when in octal mode.
10848 bool overflowed = FALSE;
10849 bool just_zero = TRUE; /* just plain 0 or binary number? */
10850 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10851 static const char* const bases[5] =
10852 { "", "binary", "", "octal", "hexadecimal" };
10853 static const char* const Bases[5] =
10854 { "", "Binary", "", "Octal", "Hexadecimal" };
10855 static const char* const maxima[5] =
10857 "0b11111111111111111111111111111111",
10861 const char *base, *Base, *max;
10863 /* check for hex */
10864 if (s[1] == 'x' || s[1] == 'X') {
10868 } else if (s[1] == 'b' || s[1] == 'B') {
10873 /* check for a decimal in disguise */
10874 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10876 /* so it must be octal */
10883 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10884 "Misplaced _ in number");
10888 base = bases[shift];
10889 Base = Bases[shift];
10890 max = maxima[shift];
10892 /* read the rest of the number */
10894 /* x is used in the overflow test,
10895 b is the digit we're adding on. */
10900 /* if we don't mention it, we're done */
10904 /* _ are ignored -- but warned about if consecutive */
10906 if (lastub && s == lastub + 1)
10907 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10908 "Misplaced _ in number");
10912 /* 8 and 9 are not octal */
10913 case '8': case '9':
10915 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10919 case '2': case '3': case '4':
10920 case '5': case '6': case '7':
10922 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10925 case '0': case '1':
10926 b = *s++ & 15; /* ASCII digit -> value of digit */
10930 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10931 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10932 /* make sure they said 0x */
10935 b = (*s++ & 7) + 9;
10937 /* Prepare to put the digit we have onto the end
10938 of the number so far. We check for overflows.
10944 x = u << shift; /* make room for the digit */
10946 if ((x >> shift) != u
10947 && !(PL_hints & HINT_NEW_BINARY)) {
10950 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10951 "Integer overflow in %s number",
10954 u = x | b; /* add the digit to the end */
10957 n *= nvshift[shift];
10958 /* If an NV has not enough bits in its
10959 * mantissa to represent an UV this summing of
10960 * small low-order numbers is a waste of time
10961 * (because the NV cannot preserve the
10962 * low-order bits anyway): we could just
10963 * remember when did we overflow and in the
10964 * end just multiply n by the right
10972 /* if we get here, we had success: make a scalar value from
10977 /* final misplaced underbar check */
10978 if (s[-1] == '_') {
10979 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10983 if (n > 4294967295.0)
10984 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10985 "%s number > %s non-portable",
10991 if (u > 0xffffffff)
10992 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10993 "%s number > %s non-portable",
10998 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10999 sv = new_constant(start, s - start, "integer",
11000 sv, NULL, NULL, 0);
11001 else if (PL_hints & HINT_NEW_BINARY)
11002 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11007 handle decimal numbers.
11008 we're also sent here when we read a 0 as the first digit
11010 case '1': case '2': case '3': case '4': case '5':
11011 case '6': case '7': case '8': case '9': case '.':
11014 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11017 /* read next group of digits and _ and copy into d */
11018 while (isDIGIT(*s) || *s == '_') {
11019 /* skip underscores, checking for misplaced ones
11023 if (lastub && s == lastub + 1)
11024 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11025 "Misplaced _ in number");
11029 /* check for end of fixed-length buffer */
11031 Perl_croak(aTHX_ "%s", number_too_long);
11032 /* if we're ok, copy the character */
11037 /* final misplaced underbar check */
11038 if (lastub && s == lastub + 1) {
11039 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11042 /* read a decimal portion if there is one. avoid
11043 3..5 being interpreted as the number 3. followed
11046 if (*s == '.' && s[1] != '.') {
11051 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11052 "Misplaced _ in number");
11056 /* copy, ignoring underbars, until we run out of digits.
11058 for (; isDIGIT(*s) || *s == '_'; s++) {
11059 /* fixed length buffer check */
11061 Perl_croak(aTHX_ "%s", number_too_long);
11063 if (lastub && s == lastub + 1)
11064 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11065 "Misplaced _ in number");
11071 /* fractional part ending in underbar? */
11072 if (s[-1] == '_') {
11073 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11074 "Misplaced _ in number");
11076 if (*s == '.' && isDIGIT(s[1])) {
11077 /* oops, it's really a v-string, but without the "v" */
11083 /* read exponent part, if present */
11084 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
11088 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
11089 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
11091 /* stray preinitial _ */
11093 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11094 "Misplaced _ in number");
11098 /* allow positive or negative exponent */
11099 if (*s == '+' || *s == '-')
11102 /* stray initial _ */
11104 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11105 "Misplaced _ in number");
11109 /* read digits of exponent */
11110 while (isDIGIT(*s) || *s == '_') {
11113 Perl_croak(aTHX_ "%s", number_too_long);
11117 if (((lastub && s == lastub + 1) ||
11118 (!isDIGIT(s[1]) && s[1] != '_')))
11119 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11120 "Misplaced _ in number");
11128 We try to do an integer conversion first if no characters
11129 indicating "float" have been found.
11134 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11136 if (flags == IS_NUMBER_IN_UV) {
11138 sv = newSViv(uv); /* Prefer IVs over UVs. */
11141 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11142 if (uv <= (UV) IV_MIN)
11143 sv = newSViv(-(IV)uv);
11150 /* terminate the string */
11152 nv = Atof(PL_tokenbuf);
11157 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11158 const char *const key = floatit ? "float" : "integer";
11159 const STRLEN keylen = floatit ? 5 : 7;
11160 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11161 key, keylen, sv, NULL, NULL, 0);
11165 /* if it starts with a v, it could be a v-string */
11168 sv = newSV(5); /* preallocate storage space */
11169 ENTER_with_name("scan_vstring");
11171 s = scan_vstring(s, PL_bufend, sv);
11172 SvREFCNT_inc_simple_void_NN(sv);
11173 LEAVE_with_name("scan_vstring");
11177 /* make the op for the constant and return */
11180 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11182 lvalp->opval = NULL;
11188 S_scan_formline(pTHX_ char *s)
11193 SV * const stuff = newSVpvs("");
11194 bool needargs = FALSE;
11195 bool eofmt = FALSE;
11197 char *tokenstart = s;
11198 SV* savewhite = NULL;
11200 if (PL_madskills) {
11201 savewhite = PL_thiswhite;
11206 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11208 while (!needargs) {
11211 #ifdef PERL_STRICT_CR
11212 while (SPACE_OR_TAB(*t))
11215 while (SPACE_OR_TAB(*t) || *t == '\r')
11218 if (*t == '\n' || t == PL_bufend) {
11223 eol = (char *) memchr(s,'\n',PL_bufend-s);
11227 for (t = s; t < eol; t++) {
11228 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11230 goto enough; /* ~~ must be first line in formline */
11232 if (*t == '@' || *t == '^')
11236 sv_catpvn(stuff, s, eol-s);
11237 #ifndef PERL_STRICT_CR
11238 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11239 char *end = SvPVX(stuff) + SvCUR(stuff);
11242 SvCUR_set(stuff, SvCUR(stuff) - 1);
11250 if ((PL_rsfp || PL_parser->filtered)
11251 && PL_parser->form_lex_state == LEX_NORMAL) {
11254 if (PL_madskills) {
11256 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
11258 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
11261 PL_bufptr = PL_bufend;
11262 COPLINE_INC_WITH_HERELINES;
11263 got_some = lex_next_chunk(0);
11264 CopLINE_dec(PL_curcop);
11267 tokenstart = PL_bufptr;
11275 if (!SvCUR(stuff) || needargs)
11276 PL_lex_state = PL_parser->form_lex_state;
11277 if (SvCUR(stuff)) {
11278 PL_expect = XSTATE;
11280 start_force(PL_curforce);
11281 NEXTVAL_NEXTTOKE.ival = 0;
11282 force_next(FORMLBRACK);
11285 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11287 else if (PL_encoding)
11288 sv_recode_to_utf8(stuff, PL_encoding);
11290 start_force(PL_curforce);
11291 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
11295 SvREFCNT_dec(stuff);
11297 PL_lex_formbrack = 0;
11300 if (PL_madskills) {
11302 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
11304 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
11305 PL_thiswhite = savewhite;
11312 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11315 const I32 oldsavestack_ix = PL_savestack_ix;
11316 CV* const outsidecv = PL_compcv;
11318 SAVEI32(PL_subline);
11319 save_item(PL_subname);
11320 SAVESPTR(PL_compcv);
11322 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11323 CvFLAGS(PL_compcv) |= flags;
11325 PL_subline = CopLINE(PL_curcop);
11326 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11327 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11328 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11329 if (outsidecv && CvPADLIST(outsidecv))
11330 CvPADLIST(PL_compcv)->xpadl_outid =
11331 PadlistNAMES(CvPADLIST(outsidecv));
11333 return oldsavestack_ix;
11337 #pragma segment Perl_yylex
11340 S_yywarn(pTHX_ const char *const s, U32 flags)
11344 PERL_ARGS_ASSERT_YYWARN;
11346 PL_in_eval |= EVAL_WARNONLY;
11347 yyerror_pv(s, flags);
11348 PL_in_eval &= ~EVAL_WARNONLY;
11353 Perl_yyerror(pTHX_ const char *const s)
11355 PERL_ARGS_ASSERT_YYERROR;
11356 return yyerror_pvn(s, strlen(s), 0);
11360 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11362 PERL_ARGS_ASSERT_YYERROR_PV;
11363 return yyerror_pvn(s, strlen(s), flags);
11367 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11370 const char *context = NULL;
11373 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11374 int yychar = PL_parser->yychar;
11376 PERL_ARGS_ASSERT_YYERROR_PVN;
11378 if (!yychar || (yychar == ';' && !PL_rsfp))
11379 sv_catpvs(where_sv, "at EOF");
11380 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
11381 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
11382 PL_oldbufptr != PL_bufptr) {
11385 The code below is removed for NetWare because it abends/crashes on NetWare
11386 when the script has error such as not having the closing quotes like:
11387 if ($var eq "value)
11388 Checking of white spaces is anyway done in NetWare code.
11391 while (isSPACE(*PL_oldoldbufptr))
11394 context = PL_oldoldbufptr;
11395 contlen = PL_bufptr - PL_oldoldbufptr;
11397 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
11398 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
11401 The code below is removed for NetWare because it abends/crashes on NetWare
11402 when the script has error such as not having the closing quotes like:
11403 if ($var eq "value)
11404 Checking of white spaces is anyway done in NetWare code.
11407 while (isSPACE(*PL_oldbufptr))
11410 context = PL_oldbufptr;
11411 contlen = PL_bufptr - PL_oldbufptr;
11413 else if (yychar > 255)
11414 sv_catpvs(where_sv, "next token ???");
11415 else if (yychar == -2) { /* YYEMPTY */
11416 if (PL_lex_state == LEX_NORMAL ||
11417 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11418 sv_catpvs(where_sv, "at end of line");
11419 else if (PL_lex_inpat)
11420 sv_catpvs(where_sv, "within pattern");
11422 sv_catpvs(where_sv, "within string");
11425 sv_catpvs(where_sv, "next char ");
11427 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11428 else if (isPRINT_LC(yychar)) {
11429 const char string = yychar;
11430 sv_catpvn(where_sv, &string, 1);
11433 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11435 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11436 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11437 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11439 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
11440 UTF8fARG(UTF, contlen, context));
11442 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
11443 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
11444 Perl_sv_catpvf(aTHX_ msg,
11445 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11446 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11449 if (PL_in_eval & EVAL_WARNONLY) {
11450 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
11454 if (PL_error_count >= 10) {
11456 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
11457 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11458 SVfARG(errsv), OutCopFILE(PL_curcop));
11460 Perl_croak(aTHX_ "%s has too many errors.\n",
11461 OutCopFILE(PL_curcop));
11464 PL_in_my_stash = NULL;
11468 #pragma segment Main
11472 S_swallow_bom(pTHX_ U8 *s)
11475 const STRLEN slen = SvCUR(PL_linestr);
11477 PERL_ARGS_ASSERT_SWALLOW_BOM;
11481 if (s[1] == 0xFE) {
11482 /* UTF-16 little-endian? (or UTF-32LE?) */
11483 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11484 /* diag_listed_as: Unsupported script encoding %s */
11485 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11486 #ifndef PERL_NO_UTF16_FILTER
11487 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11489 if (PL_bufend > (char*)s) {
11490 s = add_utf16_textfilter(s, TRUE);
11493 /* diag_listed_as: Unsupported script encoding %s */
11494 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11499 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11500 #ifndef PERL_NO_UTF16_FILTER
11501 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11503 if (PL_bufend > (char *)s) {
11504 s = add_utf16_textfilter(s, FALSE);
11507 /* diag_listed_as: Unsupported script encoding %s */
11508 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11513 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11514 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11515 s += 3; /* UTF-8 */
11521 if (s[2] == 0xFE && s[3] == 0xFF) {
11522 /* UTF-32 big-endian */
11523 /* diag_listed_as: Unsupported script encoding %s */
11524 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11527 else if (s[2] == 0 && s[3] != 0) {
11530 * are a good indicator of UTF-16BE. */
11531 #ifndef PERL_NO_UTF16_FILTER
11532 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11533 s = add_utf16_textfilter(s, FALSE);
11535 /* diag_listed_as: Unsupported script encoding %s */
11536 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11542 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
11543 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11544 s += 4; /* UTF-8 */
11550 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11553 * are a good indicator of UTF-16LE. */
11554 #ifndef PERL_NO_UTF16_FILTER
11555 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11556 s = add_utf16_textfilter(s, TRUE);
11558 /* diag_listed_as: Unsupported script encoding %s */
11559 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11567 #ifndef PERL_NO_UTF16_FILTER
11569 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11572 SV *const filter = FILTER_DATA(idx);
11573 /* We re-use this each time round, throwing the contents away before we
11575 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11576 SV *const utf8_buffer = filter;
11577 IV status = IoPAGE(filter);
11578 const bool reverse = cBOOL(IoLINES(filter));
11581 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11583 /* As we're automatically added, at the lowest level, and hence only called
11584 from this file, we can be sure that we're not called in block mode. Hence
11585 don't bother writing code to deal with block mode. */
11587 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11590 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11592 DEBUG_P(PerlIO_printf(Perl_debug_log,
11593 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11594 FPTR2DPTR(void *, S_utf16_textfilter),
11595 reverse ? 'l' : 'b', idx, maxlen, status,
11596 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11603 /* First, look in our buffer of existing UTF-8 data: */
11604 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11608 } else if (status == 0) {
11610 IoPAGE(filter) = 0;
11611 nl = SvEND(utf8_buffer);
11614 STRLEN got = nl - SvPVX(utf8_buffer);
11615 /* Did we have anything to append? */
11617 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11618 /* Everything else in this code works just fine if SVp_POK isn't
11619 set. This, however, needs it, and we need it to work, else
11620 we loop infinitely because the buffer is never consumed. */
11621 sv_chop(utf8_buffer, nl);
11625 /* OK, not a complete line there, so need to read some more UTF-16.
11626 Read an extra octect if the buffer currently has an odd number. */
11630 if (SvCUR(utf16_buffer) >= 2) {
11631 /* Location of the high octet of the last complete code point.
11632 Gosh, UTF-16 is a pain. All the benefits of variable length,
11633 *coupled* with all the benefits of partial reads and
11635 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11636 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11638 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11642 /* We have the first half of a surrogate. Read more. */
11643 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11646 status = FILTER_READ(idx + 1, utf16_buffer,
11647 160 + (SvCUR(utf16_buffer) & 1));
11648 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11649 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11652 IoPAGE(filter) = status;
11657 chars = SvCUR(utf16_buffer) >> 1;
11658 have = SvCUR(utf8_buffer);
11659 SvGROW(utf8_buffer, have + chars * 3 + 1);
11662 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11663 (U8*)SvPVX_const(utf8_buffer) + have,
11664 chars * 2, &newlen);
11666 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11667 (U8*)SvPVX_const(utf8_buffer) + have,
11668 chars * 2, &newlen);
11670 SvCUR_set(utf8_buffer, have + newlen);
11673 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11674 it's private to us, and utf16_to_utf8{,reversed} take a
11675 (pointer,length) pair, rather than a NUL-terminated string. */
11676 if(SvCUR(utf16_buffer) & 1) {
11677 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11678 SvCUR_set(utf16_buffer, 1);
11680 SvCUR_set(utf16_buffer, 0);
11683 DEBUG_P(PerlIO_printf(Perl_debug_log,
11684 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11686 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11687 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11692 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11694 SV *filter = filter_add(S_utf16_textfilter, NULL);
11696 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11698 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11699 sv_setpvs(filter, "");
11700 IoLINES(filter) = reversed;
11701 IoPAGE(filter) = 1; /* Not EOF */
11703 /* Sadly, we have to return a valid pointer, come what may, so we have to
11704 ignore any error return from this. */
11705 SvCUR_set(PL_linestr, 0);
11706 if (FILTER_READ(0, PL_linestr, 0)) {
11707 SvUTF8_on(PL_linestr);
11709 SvUTF8_on(PL_linestr);
11711 PL_bufend = SvEND(PL_linestr);
11712 return (U8*)SvPVX(PL_linestr);
11717 Returns a pointer to the next character after the parsed
11718 vstring, as well as updating the passed in sv.
11720 Function must be called like
11722 sv = sv_2mortal(newSV(5));
11723 s = scan_vstring(s,e,sv);
11725 where s and e are the start and end of the string.
11726 The sv should already be large enough to store the vstring
11727 passed in, for performance reasons.
11729 This function may croak if fatal warnings are enabled in the
11730 calling scope, hence the sv_2mortal in the example (to prevent
11731 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11737 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11740 const char *pos = s;
11741 const char *start = s;
11743 PERL_ARGS_ASSERT_SCAN_VSTRING;
11745 if (*pos == 'v') pos++; /* get past 'v' */
11746 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11748 if ( *pos != '.') {
11749 /* this may not be a v-string if followed by => */
11750 const char *next = pos;
11751 while (next < e && isSPACE(*next))
11753 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11754 /* return string not v-string */
11755 sv_setpvn(sv,(char *)s,pos-s);
11756 return (char *)pos;
11760 if (!isALPHA(*pos)) {
11761 U8 tmpbuf[UTF8_MAXBYTES+1];
11764 s++; /* get past 'v' */
11769 /* this is atoi() that tolerates underscores */
11772 const char *end = pos;
11774 while (--end >= s) {
11776 const UV orev = rev;
11777 rev += (*end - '0') * mult;
11780 /* diag_listed_as: Integer overflow in %s number */
11781 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11782 "Integer overflow in decimal number");
11786 if (rev > 0x7FFFFFFF)
11787 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11789 /* Append native character for the rev point */
11790 tmpend = uvchr_to_utf8(tmpbuf, rev);
11791 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11792 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11794 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11800 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11804 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11811 Perl_keyword_plugin_standard(pTHX_
11812 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11814 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11815 PERL_UNUSED_CONTEXT;
11816 PERL_UNUSED_ARG(keyword_ptr);
11817 PERL_UNUSED_ARG(keyword_len);
11818 PERL_UNUSED_ARG(op_ptr);
11819 return KEYWORD_PLUGIN_DECLINE;
11822 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11824 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11826 SAVEI32(PL_lex_brackets);
11827 if (PL_lex_brackets > 100)
11828 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11829 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11830 SAVEI32(PL_lex_allbrackets);
11831 PL_lex_allbrackets = 0;
11832 SAVEI8(PL_lex_fakeeof);
11833 PL_lex_fakeeof = (U8)fakeeof;
11834 if(yyparse(gramtype) && !PL_parser->error_count)
11835 qerror(Perl_mess(aTHX_ "Parse error"));
11838 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11840 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11844 SAVEVPTR(PL_eval_root);
11845 PL_eval_root = NULL;
11846 parse_recdescent(gramtype, fakeeof);
11852 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11854 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11857 if (flags & ~PARSE_OPTIONAL)
11858 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11859 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11860 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11861 if (!PL_parser->error_count)
11862 qerror(Perl_mess(aTHX_ "Parse error"));
11863 exprop = newOP(OP_NULL, 0);
11869 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11871 Parse a Perl arithmetic expression. This may contain operators of precedence
11872 down to the bit shift operators. The expression must be followed (and thus
11873 terminated) either by a comparison or lower-precedence operator or by
11874 something that would normally terminate an expression such as semicolon.
11875 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11876 otherwise it is mandatory. It is up to the caller to ensure that the
11877 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11878 the source of the code to be parsed and the lexical context for the
11881 The op tree representing the expression is returned. If an optional
11882 expression is absent, a null pointer is returned, otherwise the pointer
11885 If an error occurs in parsing or compilation, in most cases a valid op
11886 tree is returned anyway. The error is reflected in the parser state,
11887 normally resulting in a single exception at the top level of parsing
11888 which covers all the compilation errors that occurred. Some compilation
11889 errors, however, will throw an exception immediately.
11895 Perl_parse_arithexpr(pTHX_ U32 flags)
11897 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11901 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11903 Parse a Perl term expression. This may contain operators of precedence
11904 down to the assignment operators. The expression must be followed (and thus
11905 terminated) either by a comma or lower-precedence operator or by
11906 something that would normally terminate an expression such as semicolon.
11907 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11908 otherwise it is mandatory. It is up to the caller to ensure that the
11909 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11910 the source of the code to be parsed and the lexical context for the
11913 The op tree representing the expression is returned. If an optional
11914 expression is absent, a null pointer is returned, otherwise the pointer
11917 If an error occurs in parsing or compilation, in most cases a valid op
11918 tree is returned anyway. The error is reflected in the parser state,
11919 normally resulting in a single exception at the top level of parsing
11920 which covers all the compilation errors that occurred. Some compilation
11921 errors, however, will throw an exception immediately.
11927 Perl_parse_termexpr(pTHX_ U32 flags)
11929 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11933 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11935 Parse a Perl list expression. This may contain operators of precedence
11936 down to the comma operator. The expression must be followed (and thus
11937 terminated) either by a low-precedence logic operator such as C<or> or by
11938 something that would normally terminate an expression such as semicolon.
11939 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11940 otherwise it is mandatory. It is up to the caller to ensure that the
11941 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11942 the source of the code to be parsed and the lexical context for the
11945 The op tree representing the expression is returned. If an optional
11946 expression is absent, a null pointer is returned, otherwise the pointer
11949 If an error occurs in parsing or compilation, in most cases a valid op
11950 tree is returned anyway. The error is reflected in the parser state,
11951 normally resulting in a single exception at the top level of parsing
11952 which covers all the compilation errors that occurred. Some compilation
11953 errors, however, will throw an exception immediately.
11959 Perl_parse_listexpr(pTHX_ U32 flags)
11961 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11965 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11967 Parse a single complete Perl expression. This allows the full
11968 expression grammar, including the lowest-precedence operators such
11969 as C<or>. The expression must be followed (and thus terminated) by a
11970 token that an expression would normally be terminated by: end-of-file,
11971 closing bracketing punctuation, semicolon, or one of the keywords that
11972 signals a postfix expression-statement modifier. If I<flags> includes
11973 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11974 mandatory. It is up to the caller to ensure that the dynamic parser
11975 state (L</PL_parser> et al) is correctly set to reflect the source of
11976 the code to be parsed and the lexical context for the expression.
11978 The op tree representing the expression is returned. If an optional
11979 expression is absent, a null pointer is returned, otherwise the pointer
11982 If an error occurs in parsing or compilation, in most cases a valid op
11983 tree is returned anyway. The error is reflected in the parser state,
11984 normally resulting in a single exception at the top level of parsing
11985 which covers all the compilation errors that occurred. Some compilation
11986 errors, however, will throw an exception immediately.
11992 Perl_parse_fullexpr(pTHX_ U32 flags)
11994 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11998 =for apidoc Amx|OP *|parse_block|U32 flags
12000 Parse a single complete Perl code block. This consists of an opening
12001 brace, a sequence of statements, and a closing brace. The block
12002 constitutes a lexical scope, so C<my> variables and various compile-time
12003 effects can be contained within it. It is up to the caller to ensure
12004 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12005 reflect the source of the code to be parsed and the lexical context for
12008 The op tree representing the code block is returned. This is always a
12009 real op, never a null pointer. It will normally be a C<lineseq> list,
12010 including C<nextstate> or equivalent ops. No ops to construct any kind
12011 of runtime scope are included by virtue of it being a block.
12013 If an error occurs in parsing or compilation, in most cases a valid op
12014 tree (most likely null) is returned anyway. The error is reflected in
12015 the parser state, normally resulting in a single exception at the top
12016 level of parsing which covers all the compilation errors that occurred.
12017 Some compilation errors, however, will throw an exception immediately.
12019 The I<flags> parameter is reserved for future use, and must always
12026 Perl_parse_block(pTHX_ U32 flags)
12029 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12030 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12034 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12036 Parse a single unadorned Perl statement. This may be a normal imperative
12037 statement or a declaration that has compile-time effect. It does not
12038 include any label or other affixture. It is up to the caller to ensure
12039 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12040 reflect the source of the code to be parsed and the lexical context for
12043 The op tree representing the statement is returned. This may be a
12044 null pointer if the statement is null, for example if it was actually
12045 a subroutine definition (which has compile-time side effects). If not
12046 null, it will be ops directly implementing the statement, suitable to
12047 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12048 equivalent op (except for those embedded in a scope contained entirely
12049 within the statement).
12051 If an error occurs in parsing or compilation, in most cases a valid op
12052 tree (most likely null) is returned anyway. The error is reflected in
12053 the parser state, normally resulting in a single exception at the top
12054 level of parsing which covers all the compilation errors that occurred.
12055 Some compilation errors, however, will throw an exception immediately.
12057 The I<flags> parameter is reserved for future use, and must always
12064 Perl_parse_barestmt(pTHX_ U32 flags)
12067 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12068 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12072 =for apidoc Amx|SV *|parse_label|U32 flags
12074 Parse a single label, possibly optional, of the type that may prefix a
12075 Perl statement. It is up to the caller to ensure that the dynamic parser
12076 state (L</PL_parser> et al) is correctly set to reflect the source of
12077 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
12078 label is optional, otherwise it is mandatory.
12080 The name of the label is returned in the form of a fresh scalar. If an
12081 optional label is absent, a null pointer is returned.
12083 If an error occurs in parsing, which can only occur if the label is
12084 mandatory, a valid label is returned anyway. The error is reflected in
12085 the parser state, normally resulting in a single exception at the top
12086 level of parsing which covers all the compilation errors that occurred.
12092 Perl_parse_label(pTHX_ U32 flags)
12094 if (flags & ~PARSE_OPTIONAL)
12095 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12096 if (PL_lex_state == LEX_KNOWNEXT) {
12097 PL_parser->yychar = yylex();
12098 if (PL_parser->yychar == LABEL) {
12099 char * const lpv = pl_yylval.pval;
12100 STRLEN llen = strlen(lpv);
12101 PL_parser->yychar = YYEMPTY;
12102 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12109 STRLEN wlen, bufptr_pos;
12112 if (!isIDFIRST_lazy_if(s, UTF))
12114 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12115 if (word_takes_any_delimeter(s, wlen))
12117 bufptr_pos = s - SvPVX(PL_linestr);
12119 lex_read_space(LEX_KEEP_PREVIOUS);
12121 s = SvPVX(PL_linestr) + bufptr_pos;
12122 if (t[0] == ':' && t[1] != ':') {
12123 PL_oldoldbufptr = PL_oldbufptr;
12126 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12130 if (flags & PARSE_OPTIONAL) {
12133 qerror(Perl_mess(aTHX_ "Parse error"));
12134 return newSVpvs("x");
12141 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12143 Parse a single complete Perl statement. This may be a normal imperative
12144 statement or a declaration that has compile-time effect, and may include
12145 optional labels. It is up to the caller to ensure that the dynamic
12146 parser state (L</PL_parser> et al) is correctly set to reflect the source
12147 of the code to be parsed and the lexical context for the statement.
12149 The op tree representing the statement is returned. This may be a
12150 null pointer if the statement is null, for example if it was actually
12151 a subroutine definition (which has compile-time side effects). If not
12152 null, it will be the result of a L</newSTATEOP> call, normally including
12153 a C<nextstate> or equivalent op.
12155 If an error occurs in parsing or compilation, in most cases a valid op
12156 tree (most likely null) is returned anyway. The error is reflected in
12157 the parser state, normally resulting in a single exception at the top
12158 level of parsing which covers all the compilation errors that occurred.
12159 Some compilation errors, however, will throw an exception immediately.
12161 The I<flags> parameter is reserved for future use, and must always
12168 Perl_parse_fullstmt(pTHX_ U32 flags)
12171 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12172 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12176 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12178 Parse a sequence of zero or more Perl statements. These may be normal
12179 imperative statements, including optional labels, or declarations
12180 that have compile-time effect, or any mixture thereof. The statement
12181 sequence ends when a closing brace or end-of-file is encountered in a
12182 place where a new statement could have validly started. It is up to
12183 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12184 is correctly set to reflect the source of the code to be parsed and the
12185 lexical context for the statements.
12187 The op tree representing the statement sequence is returned. This may
12188 be a null pointer if the statements were all null, for example if there
12189 were no statements or if there were only subroutine definitions (which
12190 have compile-time side effects). If not null, it will be a C<lineseq>
12191 list, normally including C<nextstate> or equivalent ops.
12193 If an error occurs in parsing or compilation, in most cases a valid op
12194 tree is returned anyway. The error is reflected in the parser state,
12195 normally resulting in a single exception at the top level of parsing
12196 which covers all the compilation errors that occurred. Some compilation
12197 errors, however, will throw an exception immediately.
12199 The I<flags> parameter is reserved for future use, and must always
12206 Perl_parse_stmtseq(pTHX_ U32 flags)
12211 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12212 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12213 c = lex_peek_unichar(0);
12214 if (c != -1 && c != /*{*/'}')
12215 qerror(Perl_mess(aTHX_ "Parse error"));
12221 * c-indentation-style: bsd
12222 * c-basic-offset: 4
12223 * indent-tabs-mode: nil
12226 * ex: set ts=8 sts=4 sw=4 et: