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 "Illegal character in prototype for %"SVf" : %s",
1668 if (bad_proto_after_underscore)
1669 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1670 "Illegal character after '_' in prototype for %"SVf" : %s",
1674 return (! (proto_after_greedy_proto || bad_proto) );
1679 * This subroutine has nothing to do with tilting, whether at windmills
1680 * or pinball tables. Its name is short for "increment line". It
1681 * increments the current line number in CopLINE(PL_curcop) and checks
1682 * to see whether the line starts with a comment of the form
1683 * # line 500 "foo.pm"
1684 * If so, it sets the current line number and file to the values in the comment.
1688 S_incline(pTHX_ const char *s)
1696 PERL_ARGS_ASSERT_INCLINE;
1698 COPLINE_INC_WITH_HERELINES;
1699 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1700 && s+1 == PL_bufend && *s == ';') {
1701 /* fake newline in string eval */
1702 CopLINE_dec(PL_curcop);
1707 while (SPACE_OR_TAB(*s))
1709 if (strnEQ(s, "line", 4))
1713 if (SPACE_OR_TAB(*s))
1717 while (SPACE_OR_TAB(*s))
1725 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1727 while (SPACE_OR_TAB(*s))
1729 if (*s == '"' && (t = strchr(s+1, '"'))) {
1735 while (!isSPACE(*t))
1739 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1741 if (*e != '\n' && *e != '\0')
1742 return; /* false alarm */
1744 line_num = atoi(n)-1;
1747 const STRLEN len = t - s;
1748 SV *const temp_sv = CopFILESV(PL_curcop);
1753 cf = SvPVX(temp_sv);
1754 tmplen = SvCUR(temp_sv);
1760 if (!PL_rsfp && !PL_parser->filtered) {
1761 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1762 * to *{"::_<newfilename"} */
1763 /* However, the long form of evals is only turned on by the
1764 debugger - usually they're "(eval %lu)" */
1768 STRLEN tmplen2 = len;
1769 if (tmplen + 2 <= sizeof smallbuf)
1772 Newx(tmpbuf, tmplen + 2, char);
1775 memcpy(tmpbuf + 2, cf, tmplen);
1777 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1782 if (tmplen2 + 2 <= sizeof smallbuf)
1785 Newx(tmpbuf2, tmplen2 + 2, char);
1787 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1788 /* Either they malloc'd it, or we malloc'd it,
1789 so no prefix is present in ours. */
1794 memcpy(tmpbuf2 + 2, s, tmplen2);
1797 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1799 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1800 /* adjust ${"::_<newfilename"} to store the new file name */
1801 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1802 /* The line number may differ. If that is the case,
1803 alias the saved lines that are in the array.
1804 Otherwise alias the whole array. */
1805 if (CopLINE(PL_curcop) == line_num) {
1806 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1807 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1809 else if (GvAV(*gvp)) {
1810 AV * const av = GvAV(*gvp);
1811 const I32 start = CopLINE(PL_curcop)+1;
1812 I32 items = AvFILLp(av) - start;
1814 AV * const av2 = GvAVn(gv2);
1815 SV **svp = AvARRAY(av) + start;
1816 I32 l = (I32)line_num+1;
1818 av_store(av2, l++, SvREFCNT_inc(*svp++));
1823 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1825 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1827 CopFILE_free(PL_curcop);
1828 CopFILE_setn(PL_curcop, s, len);
1830 CopLINE_set(PL_curcop, line_num);
1834 /* skip space before PL_thistoken */
1837 S_skipspace0(pTHX_ char *s)
1839 PERL_ARGS_ASSERT_SKIPSPACE0;
1846 PL_thiswhite = newSVpvs("");
1847 sv_catsv(PL_thiswhite, PL_skipwhite);
1848 sv_free(PL_skipwhite);
1851 PL_realtokenstart = s - SvPVX(PL_linestr);
1855 /* skip space after PL_thistoken */
1858 S_skipspace1(pTHX_ char *s)
1860 const char *start = s;
1861 I32 startoff = start - SvPVX(PL_linestr);
1863 PERL_ARGS_ASSERT_SKIPSPACE1;
1868 start = SvPVX(PL_linestr) + startoff;
1869 if (!PL_thistoken && PL_realtokenstart >= 0) {
1870 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1871 PL_thistoken = newSVpvn(tstart, start - tstart);
1873 PL_realtokenstart = -1;
1876 PL_nextwhite = newSVpvs("");
1877 sv_catsv(PL_nextwhite, PL_skipwhite);
1878 sv_free(PL_skipwhite);
1885 S_skipspace2(pTHX_ char *s, SV **svp)
1888 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1889 const I32 startoff = s - SvPVX(PL_linestr);
1891 PERL_ARGS_ASSERT_SKIPSPACE2;
1894 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1895 if (!PL_madskills || !svp)
1897 start = SvPVX(PL_linestr) + startoff;
1898 if (!PL_thistoken && PL_realtokenstart >= 0) {
1899 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1900 PL_thistoken = newSVpvn(tstart, start - tstart);
1901 PL_realtokenstart = -1;
1905 *svp = newSVpvs("");
1906 sv_setsv(*svp, PL_skipwhite);
1907 sv_free(PL_skipwhite);
1916 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1918 AV *av = CopFILEAVx(PL_curcop);
1920 SV * const sv = newSV_type(SVt_PVMG);
1922 sv_setsv_flags(sv, orig_sv, 0); /* no cow */
1924 sv_setpvn(sv, buf, len);
1927 av_store(av, (I32)CopLINE(PL_curcop), sv);
1933 * Called to gobble the appropriate amount and type of whitespace.
1934 * Skips comments as well.
1938 S_skipspace(pTHX_ char *s)
1942 #endif /* PERL_MAD */
1943 PERL_ARGS_ASSERT_SKIPSPACE;
1946 sv_free(PL_skipwhite);
1947 PL_skipwhite = NULL;
1949 #endif /* PERL_MAD */
1950 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1951 while (s < PL_bufend && SPACE_OR_TAB(*s))
1954 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1956 lex_read_space(LEX_KEEP_PREVIOUS |
1957 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1958 LEX_NO_NEXT_CHUNK : 0));
1960 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1961 if (PL_linestart > PL_bufptr)
1962 PL_bufptr = PL_linestart;
1967 PL_skipwhite = newSVpvn(start, s-start);
1968 #endif /* PERL_MAD */
1974 * Check the unary operators to ensure there's no ambiguity in how they're
1975 * used. An ambiguous piece of code would be:
1977 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1978 * the +5 is its argument.
1988 if (PL_oldoldbufptr != PL_last_uni)
1990 while (isSPACE(*PL_last_uni))
1993 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1995 if ((t = strchr(s, '(')) && t < PL_bufptr)
1998 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1999 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
2000 (int)(s - PL_last_uni), PL_last_uni);
2004 * LOP : macro to build a list operator. Its behaviour has been replaced
2005 * with a subroutine, S_lop() for which LOP is just another name.
2008 #define LOP(f,x) return lop(f,x,s)
2012 * Build a list operator (or something that might be one). The rules:
2013 * - if we have a next token, then it's a list operator [why?]
2014 * - if the next thing is an opening paren, then it's a function
2015 * - else it's a list operator
2019 S_lop(pTHX_ I32 f, int x, char *s)
2023 PERL_ARGS_ASSERT_LOP;
2029 PL_last_lop = PL_oldbufptr;
2030 PL_last_lop_op = (OPCODE)f;
2039 return REPORT(FUNC);
2042 return REPORT(FUNC);
2045 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
2046 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
2047 return REPORT(LSTOP);
2054 * Sets up for an eventual force_next(). start_force(0) basically does
2055 * an unshift, while start_force(-1) does a push. yylex removes items
2060 S_start_force(pTHX_ int where)
2064 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
2065 where = PL_lasttoke;
2066 assert(PL_curforce < 0 || PL_curforce == where);
2067 if (PL_curforce != where) {
2068 for (i = PL_lasttoke; i > where; --i) {
2069 PL_nexttoke[i] = PL_nexttoke[i-1];
2073 if (PL_curforce < 0) /* in case of duplicate start_force() */
2074 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
2075 PL_curforce = where;
2078 curmad('^', newSVpvs(""));
2079 CURMAD('_', PL_nextwhite);
2084 S_curmad(pTHX_ char slot, SV *sv)
2090 if (PL_curforce < 0)
2091 where = &PL_thismad;
2093 where = &PL_nexttoke[PL_curforce].next_mad;
2099 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2101 else if (PL_encoding) {
2102 sv_recode_to_utf8(sv, PL_encoding);
2107 /* keep a slot open for the head of the list? */
2108 if (slot != '_' && *where && (*where)->mad_key == '^') {
2109 (*where)->mad_key = slot;
2110 sv_free(MUTABLE_SV(((*where)->mad_val)));
2111 (*where)->mad_val = (void*)sv;
2114 addmad(newMADsv(slot, sv), where, 0);
2117 # define start_force(where) NOOP
2118 # define curmad(slot, sv) NOOP
2123 * When the lexer realizes it knows the next token (for instance,
2124 * it is reordering tokens for the parser) then it can call S_force_next
2125 * to know what token to return the next time the lexer is called. Caller
2126 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2127 * and possibly PL_expect to ensure the lexer handles the token correctly.
2131 S_force_next(pTHX_ I32 type)
2136 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2137 tokereport(type, &NEXTVAL_NEXTTOKE);
2141 if (PL_curforce < 0)
2142 start_force(PL_lasttoke);
2143 PL_nexttoke[PL_curforce].next_type = type;
2144 if (PL_lex_state != LEX_KNOWNEXT)
2145 PL_lex_defer = PL_lex_state;
2146 PL_lex_state = LEX_KNOWNEXT;
2147 PL_lex_expect = PL_expect;
2150 PL_nexttype[PL_nexttoke] = type;
2152 if (PL_lex_state != LEX_KNOWNEXT) {
2153 PL_lex_defer = PL_lex_state;
2154 PL_lex_expect = PL_expect;
2155 PL_lex_state = LEX_KNOWNEXT;
2163 int yyc = PL_parser->yychar;
2164 if (yyc != YYEMPTY) {
2167 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2168 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2169 PL_lex_allbrackets--;
2171 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2172 } else if (yyc == '('/*)*/) {
2173 PL_lex_allbrackets--;
2178 PL_parser->yychar = YYEMPTY;
2183 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2186 SV * const sv = newSVpvn_utf8(start, len,
2189 && !is_ascii_string((const U8*)start, len)
2190 && is_utf8_string((const U8*)start, len));
2196 * When the lexer knows the next thing is a word (for instance, it has
2197 * just seen -> and it knows that the next char is a word char, then
2198 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2202 * char *start : buffer position (must be within PL_linestr)
2203 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2204 * int check_keyword : if true, Perl checks to make sure the word isn't
2205 * a keyword (do this if the word is a label, e.g. goto FOO)
2206 * int allow_pack : if true, : characters will also be allowed (require,
2207 * use, etc. do this)
2208 * int allow_initial_tick : used by the "sub" lexer only.
2212 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2218 PERL_ARGS_ASSERT_FORCE_WORD;
2220 start = SKIPSPACE1(start);
2222 if (isIDFIRST_lazy_if(s,UTF) ||
2223 (allow_pack && *s == ':') )
2225 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2226 if (check_keyword) {
2227 char *s2 = PL_tokenbuf;
2228 if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2230 if (keyword(s2, len, 0))
2233 start_force(PL_curforce);
2235 curmad('X', newSVpvn(start,s-start));
2236 if (token == METHOD) {
2241 PL_expect = XOPERATOR;
2245 curmad('g', newSVpvs( "forced" ));
2246 NEXTVAL_NEXTTOKE.opval
2247 = (OP*)newSVOP(OP_CONST,0,
2248 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2249 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2257 * Called when the lexer wants $foo *foo &foo etc, but the program
2258 * text only contains the "foo" portion. The first argument is a pointer
2259 * to the "foo", and the second argument is the type symbol to prefix.
2260 * Forces the next token to be a "WORD".
2261 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2265 S_force_ident(pTHX_ const char *s, int kind)
2269 PERL_ARGS_ASSERT_FORCE_IDENT;
2272 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2273 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2274 UTF ? SVf_UTF8 : 0));
2275 start_force(PL_curforce);
2276 NEXTVAL_NEXTTOKE.opval = o;
2279 o->op_private = OPpCONST_ENTERED;
2280 /* XXX see note in pp_entereval() for why we forgo typo
2281 warnings if the symbol must be introduced in an eval.
2283 gv_fetchpvn_flags(s, len,
2284 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2285 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2286 kind == '$' ? SVt_PV :
2287 kind == '@' ? SVt_PVAV :
2288 kind == '%' ? SVt_PVHV :
2296 S_force_ident_maybe_lex(pTHX_ char pit)
2298 start_force(PL_curforce);
2299 NEXTVAL_NEXTTOKE.ival = pit;
2304 Perl_str_to_version(pTHX_ SV *sv)
2309 const char *start = SvPV_const(sv,len);
2310 const char * const end = start + len;
2311 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2313 PERL_ARGS_ASSERT_STR_TO_VERSION;
2315 while (start < end) {
2319 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2324 retval += ((NV)n)/nshift;
2333 * Forces the next token to be a version number.
2334 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2335 * and if "guessing" is TRUE, then no new token is created (and the caller
2336 * must use an alternative parsing method).
2340 S_force_version(pTHX_ char *s, int guessing)
2346 I32 startoff = s - SvPVX(PL_linestr);
2349 PERL_ARGS_ASSERT_FORCE_VERSION;
2357 while (isDIGIT(*d) || *d == '_' || *d == '.')
2361 start_force(PL_curforce);
2362 curmad('X', newSVpvn(s,d-s));
2365 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2367 #ifdef USE_LOCALE_NUMERIC
2368 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2369 setlocale(LC_NUMERIC, "C");
2371 s = scan_num(s, &pl_yylval);
2372 #ifdef USE_LOCALE_NUMERIC
2373 setlocale(LC_NUMERIC, loc);
2376 version = pl_yylval.opval;
2377 ver = cSVOPx(version)->op_sv;
2378 if (SvPOK(ver) && !SvNIOK(ver)) {
2379 SvUPGRADE(ver, SVt_PVNV);
2380 SvNV_set(ver, str_to_version(ver));
2381 SvNOK_on(ver); /* hint that it is a version */
2384 else if (guessing) {
2387 sv_free(PL_nextwhite); /* let next token collect whitespace */
2389 s = SvPVX(PL_linestr) + startoff;
2397 if (PL_madskills && !version) {
2398 sv_free(PL_nextwhite); /* let next token collect whitespace */
2400 s = SvPVX(PL_linestr) + startoff;
2403 /* NOTE: The parser sees the package name and the VERSION swapped */
2404 start_force(PL_curforce);
2405 NEXTVAL_NEXTTOKE.opval = version;
2412 * S_force_strict_version
2413 * Forces the next token to be a version number using strict syntax rules.
2417 S_force_strict_version(pTHX_ char *s)
2422 I32 startoff = s - SvPVX(PL_linestr);
2424 const char *errstr = NULL;
2426 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2428 while (isSPACE(*s)) /* leading whitespace */
2431 if (is_STRICT_VERSION(s,&errstr)) {
2433 s = (char *)scan_version(s, ver, 0);
2434 version = newSVOP(OP_CONST, 0, ver);
2436 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2437 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2441 yyerror(errstr); /* version required */
2446 if (PL_madskills && !version) {
2447 sv_free(PL_nextwhite); /* let next token collect whitespace */
2449 s = SvPVX(PL_linestr) + startoff;
2452 /* NOTE: The parser sees the package name and the VERSION swapped */
2453 start_force(PL_curforce);
2454 NEXTVAL_NEXTTOKE.opval = version;
2462 * Tokenize a quoted string passed in as an SV. It finds the next
2463 * chunk, up to end of string or a backslash. It may make a new
2464 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2469 S_tokeq(pTHX_ SV *sv)
2478 PERL_ARGS_ASSERT_TOKEQ;
2483 s = SvPV_force(sv, len);
2484 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2487 /* This is relying on the SV being "well formed" with a trailing '\0' */
2488 while (s < send && !(*s == '\\' && s[1] == '\\'))
2493 if ( PL_hints & HINT_NEW_STRING ) {
2494 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2498 if (s + 1 < send && (s[1] == '\\'))
2499 s++; /* all that, just for this */
2504 SvCUR_set(sv, d - SvPVX_const(sv));
2506 if ( PL_hints & HINT_NEW_STRING )
2507 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2512 * Now come three functions related to double-quote context,
2513 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2514 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2515 * interact with PL_lex_state, and create fake ( ... ) argument lists
2516 * to handle functions and concatenation.
2520 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2525 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2527 * Pattern matching will set PL_lex_op to the pattern-matching op to
2528 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2530 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2532 * Everything else becomes a FUNC.
2534 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2535 * had an OP_CONST or OP_READLINE). This just sets us up for a
2536 * call to S_sublex_push().
2540 S_sublex_start(pTHX)
2543 const I32 op_type = pl_yylval.ival;
2545 if (op_type == OP_NULL) {
2546 pl_yylval.opval = PL_lex_op;
2550 if (op_type == OP_CONST || op_type == OP_READLINE) {
2551 SV *sv = tokeq(PL_lex_stuff);
2553 if (SvTYPE(sv) == SVt_PVIV) {
2554 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2556 const char * const p = SvPV_const(sv, len);
2557 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2561 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2562 PL_lex_stuff = NULL;
2563 /* Allow <FH> // "foo" */
2564 if (op_type == OP_READLINE)
2565 PL_expect = XTERMORDORDOR;
2568 else if (op_type == OP_BACKTICK && PL_lex_op) {
2569 /* readpipe() vas overriden */
2570 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2571 pl_yylval.opval = PL_lex_op;
2573 PL_lex_stuff = NULL;
2577 PL_sublex_info.super_state = PL_lex_state;
2578 PL_sublex_info.sub_inwhat = (U16)op_type;
2579 PL_sublex_info.sub_op = PL_lex_op;
2580 PL_lex_state = LEX_INTERPPUSH;
2584 pl_yylval.opval = PL_lex_op;
2594 * Create a new scope to save the lexing state. The scope will be
2595 * ended in S_sublex_done. Returns a '(', starting the function arguments
2596 * to the uc, lc, etc. found before.
2597 * Sets PL_lex_state to LEX_INTERPCONCAT.
2607 PL_lex_state = PL_sublex_info.super_state;
2608 SAVEBOOL(PL_lex_dojoin);
2609 SAVEI32(PL_lex_brackets);
2610 SAVEI32(PL_lex_allbrackets);
2611 SAVEI32(PL_lex_formbrack);
2612 SAVEI8(PL_lex_fakeeof);
2613 SAVEI32(PL_lex_casemods);
2614 SAVEI32(PL_lex_starts);
2615 SAVEI8(PL_lex_state);
2616 SAVESPTR(PL_lex_repl);
2617 SAVEVPTR(PL_lex_inpat);
2618 SAVEI16(PL_lex_inwhat);
2619 SAVECOPLINE(PL_curcop);
2620 SAVEPPTR(PL_bufptr);
2621 SAVEPPTR(PL_bufend);
2622 SAVEPPTR(PL_oldbufptr);
2623 SAVEPPTR(PL_oldoldbufptr);
2624 SAVEPPTR(PL_last_lop);
2625 SAVEPPTR(PL_last_uni);
2626 SAVEPPTR(PL_linestart);
2627 SAVESPTR(PL_linestr);
2628 SAVEGENERICPV(PL_lex_brackstack);
2629 SAVEGENERICPV(PL_lex_casestack);
2630 SAVEGENERICPV(PL_parser->lex_shared);
2631 SAVEBOOL(PL_parser->lex_re_reparsing);
2633 /* The here-doc parser needs to be able to peek into outer lexing
2634 scopes to find the body of the here-doc. So we put PL_linestr and
2635 PL_bufptr into lex_shared, to ‘share’ those values.
2637 PL_parser->lex_shared->ls_linestr = PL_linestr;
2638 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2640 PL_linestr = PL_lex_stuff;
2641 PL_lex_repl = PL_sublex_info.repl;
2642 PL_lex_stuff = NULL;
2643 PL_sublex_info.repl = NULL;
2645 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2646 = SvPVX(PL_linestr);
2647 PL_bufend += SvCUR(PL_linestr);
2648 PL_last_lop = PL_last_uni = NULL;
2649 SAVEFREESV(PL_linestr);
2650 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2652 PL_lex_dojoin = FALSE;
2653 PL_lex_brackets = PL_lex_formbrack = 0;
2654 PL_lex_allbrackets = 0;
2655 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2656 Newx(PL_lex_brackstack, 120, char);
2657 Newx(PL_lex_casestack, 12, char);
2658 PL_lex_casemods = 0;
2659 *PL_lex_casestack = '\0';
2661 PL_lex_state = LEX_INTERPCONCAT;
2662 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2664 Newxz(shared, 1, LEXSHARED);
2665 shared->ls_prev = PL_parser->lex_shared;
2666 PL_parser->lex_shared = shared;
2668 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2669 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2670 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2671 PL_lex_inpat = PL_sublex_info.sub_op;
2673 PL_lex_inpat = NULL;
2675 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2676 PL_in_eval &= ~EVAL_RE_REPARSING;
2683 * Restores lexer state after a S_sublex_push.
2690 if (!PL_lex_starts++) {
2691 SV * const sv = newSVpvs("");
2692 if (SvUTF8(PL_linestr))
2694 PL_expect = XOPERATOR;
2695 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2699 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2700 PL_lex_state = LEX_INTERPCASEMOD;
2704 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2705 assert(PL_lex_inwhat != OP_TRANSR);
2706 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2707 PL_linestr = PL_lex_repl;
2709 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2710 PL_bufend += SvCUR(PL_linestr);
2711 PL_last_lop = PL_last_uni = NULL;
2712 PL_lex_dojoin = FALSE;
2713 PL_lex_brackets = 0;
2714 PL_lex_allbrackets = 0;
2715 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2716 PL_lex_casemods = 0;
2717 *PL_lex_casestack = '\0';
2719 if (SvEVALED(PL_lex_repl)) {
2720 PL_lex_state = LEX_INTERPNORMAL;
2722 /* we don't clear PL_lex_repl here, so that we can check later
2723 whether this is an evalled subst; that means we rely on the
2724 logic to ensure sublex_done() is called again only via the
2725 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2728 PL_lex_state = LEX_INTERPCONCAT;
2738 PL_endwhite = newSVpvs("");
2739 sv_catsv(PL_endwhite, PL_thiswhite);
2743 sv_setpvs(PL_thistoken,"");
2745 PL_realtokenstart = -1;
2749 PL_bufend = SvPVX(PL_linestr);
2750 PL_bufend += SvCUR(PL_linestr);
2751 PL_expect = XOPERATOR;
2752 PL_sublex_info.sub_inwhat = 0;
2757 PERL_STATIC_INLINE SV*
2758 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2760 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2761 * interior, hence to the "}". Finds what the name resolves to, returning
2762 * an SV* containing it; NULL if no valid one found */
2764 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2771 const U8* first_bad_char_loc;
2772 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2774 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2776 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2778 &first_bad_char_loc))
2780 /* If warnings are on, this will print a more detailed analysis of what
2781 * is wrong than the error message below */
2782 utf8n_to_uvuni(first_bad_char_loc,
2783 e - ((char *) first_bad_char_loc),
2786 /* We deliberately don't try to print the malformed character, which
2787 * might not print very well; it also may be just the first of many
2788 * malformations, so don't print what comes after it */
2789 yyerror(Perl_form(aTHX_
2790 "Malformed UTF-8 character immediately after '%.*s'",
2791 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2795 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2796 /* include the <}> */
2797 e - backslash_ptr + 1);
2799 SvREFCNT_dec_NN(res);
2803 /* See if the charnames handler is the Perl core's, and if so, we can skip
2804 * the validation needed for a user-supplied one, as Perl's does its own
2806 table = GvHV(PL_hintgv); /* ^H */
2807 cvp = hv_fetchs(table, "charnames", FALSE);
2808 if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
2809 && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
2811 const char * const name = HvNAME(stash);
2812 if strEQ(name, "_charnames") {
2817 /* Here, it isn't Perl's charname handler. We can't rely on a
2818 * user-supplied handler to validate the input name. For non-ut8 input,
2819 * look to see that the first character is legal. Then loop through the
2820 * rest checking that each is a continuation */
2822 /* This code needs to be sync'ed with a regex in _charnames.pm which does
2826 if (! isALPHAU(*s)) {
2831 if (! isCHARNAME_CONT(*s)) {
2834 if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2835 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2836 "A sequence of multiple spaces in a charnames "
2837 "alias definition is deprecated");
2841 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2842 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2843 "Trailing white-space in a charnames alias "
2844 "definition is deprecated");
2848 /* Similarly for utf8. For invariants can check directly; for other
2849 * Latin1, can calculate their code point and check; otherwise use a
2851 if (UTF8_IS_INVARIANT(*s)) {
2852 if (! isALPHAU(*s)) {
2856 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2857 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
2863 if (! PL_utf8_charname_begin) {
2864 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2865 PL_utf8_charname_begin = _core_swash_init("utf8",
2866 "_Perl_Charname_Begin",
2868 1, 0, NULL, &flags);
2870 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2877 if (UTF8_IS_INVARIANT(*s)) {
2878 if (! isCHARNAME_CONT(*s)) {
2881 if (*s == ' ' && *(s-1) == ' '
2882 && ckWARN_d(WARN_DEPRECATED)) {
2883 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2884 "A sequence of multiple spaces in a charnam"
2885 "es alias definition is deprecated");
2889 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2890 if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
2898 if (! PL_utf8_charname_continue) {
2899 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2900 PL_utf8_charname_continue = _core_swash_init("utf8",
2901 "_Perl_Charname_Continue",
2903 1, 0, NULL, &flags);
2905 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2911 if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2912 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2913 "Trailing white-space in a charnames alias "
2914 "definition is deprecated");
2918 if (SvUTF8(res)) { /* Don't accept malformed input */
2919 const U8* first_bad_char_loc;
2921 const char* const str = SvPV_const(res, len);
2922 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2923 /* If warnings are on, this will print a more detailed analysis of
2924 * what is wrong than the error message below */
2925 utf8n_to_uvuni(first_bad_char_loc,
2926 (char *) first_bad_char_loc - str,
2929 /* We deliberately don't try to print the malformed character,
2930 * which might not print very well; it also may be just the first
2931 * of many malformations, so don't print what comes after it */
2934 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2935 (int) (e - backslash_ptr + 1), backslash_ptr,
2936 (int) ((char *) first_bad_char_loc - str), str
2946 int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
2948 /* The final %.*s makes sure that should the trailing NUL be missing
2949 * that this print won't run off the end of the string */
2952 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2953 (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2954 (int)(e - s + bad_char_size), s + bad_char_size
2956 UTF ? SVf_UTF8 : 0);
2964 Extracts the next constant part of a pattern, double-quoted string,
2965 or transliteration. This is terrifying code.
2967 For example, in parsing the double-quoted string "ab\x63$d", it would
2968 stop at the '$' and return an OP_CONST containing 'abc'.
2970 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2971 processing a pattern (PL_lex_inpat is true), a transliteration
2972 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2974 Returns a pointer to the character scanned up to. If this is
2975 advanced from the start pointer supplied (i.e. if anything was
2976 successfully parsed), will leave an OP_CONST for the substring scanned
2977 in pl_yylval. Caller must intuit reason for not parsing further
2978 by looking at the next characters herself.
2982 \N{FOO} => \N{U+hex_for_character_FOO}
2983 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2986 all other \-char, including \N and \N{ apart from \N{ABC}
2989 @ and $ where it appears to be a var, but not for $ as tail anchor
2994 In transliterations:
2995 characters are VERY literal, except for - not at the start or end
2996 of the string, which indicates a range. If the range is in bytes,
2997 scan_const expands the range to the full set of intermediate
2998 characters. If the range is in utf8, the hyphen is replaced with
2999 a certain range mark which will be handled by pmtrans() in op.c.
3001 In double-quoted strings:
3003 double-quoted style: \r and \n
3004 constants: \x31, etc.
3005 deprecated backrefs: \1 (in substitution replacements)
3006 case and quoting: \U \Q \E
3009 scan_const does *not* construct ops to handle interpolated strings.
3010 It stops processing as soon as it finds an embedded $ or @ variable
3011 and leaves it to the caller to work out what's going on.
3013 embedded arrays (whether in pattern or not) could be:
3014 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
3016 $ in double-quoted strings must be the symbol of an embedded scalar.
3018 $ in pattern could be $foo or could be tail anchor. Assumption:
3019 it's a tail anchor if $ is the last thing in the string, or if it's
3020 followed by one of "()| \r\n\t"
3022 \1 (backreferences) are turned into $1 in substitutions
3024 The structure of the code is
3025 while (there's a character to process) {
3026 handle transliteration ranges
3027 skip regexp comments /(?#comment)/ and codes /(?{code})/
3028 skip #-initiated comments in //x patterns
3029 check for embedded arrays
3030 check for embedded scalars
3032 deprecate \1 in substitution replacements
3033 handle string-changing backslashes \l \U \Q \E, etc.
3034 switch (what was escaped) {
3035 handle \- in a transliteration (becomes a literal -)
3036 if a pattern and not \N{, go treat as regular character
3037 handle \132 (octal characters)
3038 handle \x15 and \x{1234} (hex characters)
3039 handle \N{name} (named characters, also \N{3,5} in a pattern)
3040 handle \cV (control characters)
3041 handle printf-style backslashes (\f, \r, \n, etc)
3044 } (end if backslash)
3045 handle regular character
3046 } (end while character to read)
3051 S_scan_const(pTHX_ char *start)
3054 char *send = PL_bufend; /* end of the constant */
3055 SV *sv = newSV(send - start); /* sv for the constant. See
3056 note below on sizing. */
3057 char *s = start; /* start of the constant */
3058 char *d = SvPVX(sv); /* destination for copies */
3059 bool dorange = FALSE; /* are we in a translit range? */
3060 bool didrange = FALSE; /* did we just finish a range? */
3061 bool in_charclass = FALSE; /* within /[...]/ */
3062 bool has_utf8 = FALSE; /* Output constant is UTF8 */
3063 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
3064 to be UTF8? But, this can
3065 show as true when the source
3066 isn't utf8, as for example
3067 when it is entirely composed
3069 SV *res; /* result from charnames */
3071 /* Note on sizing: The scanned constant is placed into sv, which is
3072 * initialized by newSV() assuming one byte of output for every byte of
3073 * input. This routine expects newSV() to allocate an extra byte for a
3074 * trailing NUL, which this routine will append if it gets to the end of
3075 * the input. There may be more bytes of input than output (eg., \N{LATIN
3076 * CAPITAL LETTER A}), or more output than input if the constant ends up
3077 * recoded to utf8, but each time a construct is found that might increase
3078 * the needed size, SvGROW() is called. Its size parameter each time is
3079 * based on the best guess estimate at the time, namely the length used so
3080 * far, plus the length the current construct will occupy, plus room for
3081 * the trailing NUL, plus one byte for every input byte still unscanned */
3083 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
3086 UV literal_endpoint = 0;
3087 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
3090 PERL_ARGS_ASSERT_SCAN_CONST;
3092 assert(PL_lex_inwhat != OP_TRANSR);
3093 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3094 /* If we are doing a trans and we know we want UTF8 set expectation */
3095 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
3096 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3099 /* Protect sv from errors and fatal warnings. */
3100 ENTER_with_name("scan_const");
3103 while (s < send || dorange) {
3105 /* get transliterations out of the way (they're most literal) */
3106 if (PL_lex_inwhat == OP_TRANS) {
3107 /* expand a range A-Z to the full set of characters. AIE! */
3109 I32 i; /* current expanded character */
3110 I32 min; /* first character in range */
3111 I32 max; /* last character in range */
3122 char * const c = (char*)utf8_hop((U8*)d, -1);
3126 *c = (char)UTF_TO_NATIVE(0xff);
3127 /* mark the range as done, and continue */
3133 i = d - SvPVX_const(sv); /* remember current offset */
3136 SvLEN(sv) + (has_utf8 ?
3137 (512 - UTF_CONTINUATION_MARK +
3140 /* How many two-byte within 0..255: 128 in UTF-8,
3141 * 96 in UTF-8-mod. */
3143 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
3145 d = SvPVX(sv) + i; /* refresh d after realloc */
3149 for (j = 0; j <= 1; j++) {
3150 char * const c = (char*)utf8_hop((U8*)d, -1);
3151 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3157 max = (U8)0xff; /* only to \xff */
3158 uvmax = uv; /* \x{100} to uvmax */
3160 d = c; /* eat endpoint chars */
3165 d -= 2; /* eat the first char and the - */
3166 min = (U8)*d; /* first char in range */
3167 max = (U8)d[1]; /* last char in range */
3174 "Invalid range \"%c-%c\" in transliteration operator",
3175 (char)min, (char)max);
3179 if (literal_endpoint == 2 &&
3180 ((isLOWER(min) && isLOWER(max)) ||
3181 (isUPPER(min) && isUPPER(max)))) {
3183 for (i = min; i <= max; i++)
3185 *d++ = NATIVE_TO_NEED(has_utf8,i);
3187 for (i = min; i <= max; i++)
3189 *d++ = NATIVE_TO_NEED(has_utf8,i);
3194 for (i = min; i <= max; i++)
3197 const U8 ch = (U8)NATIVE_TO_UTF(i);
3198 if (UNI_IS_INVARIANT(ch))
3201 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
3202 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
3211 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3213 *d++ = (char)UTF_TO_NATIVE(0xff);
3215 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3219 /* mark the range as done, and continue */
3223 literal_endpoint = 0;
3228 /* range begins (ignore - as first or last char) */
3229 else if (*s == '-' && s+1 < send && s != start) {
3231 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3238 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
3248 literal_endpoint = 0;
3249 native_range = TRUE;
3254 /* if we get here, we're not doing a transliteration */
3256 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3259 while (s1 >= start && *s1-- == '\\')
3262 in_charclass = TRUE;
3265 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3268 while (s1 >= start && *s1-- == '\\')
3271 in_charclass = FALSE;
3274 /* skip for regexp comments /(?#comment)/, except for the last
3275 * char, which will be done separately.
3276 * Stop on (?{..}) and friends */
3278 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
3280 while (s+1 < send && *s != ')')
3281 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3283 else if (!PL_lex_casemods && !in_charclass &&
3284 ( s[2] == '{' /* This should match regcomp.c */
3285 || (s[2] == '?' && s[3] == '{')))
3291 /* likewise skip #-initiated comments in //x patterns */
3292 else if (*s == '#' && PL_lex_inpat &&
3293 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3294 while (s+1 < send && *s != '\n')
3295 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3298 /* no further processing of single-quoted regex */
3299 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3300 goto default_action;
3302 /* check for embedded arrays
3303 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3305 else if (*s == '@' && s[1]) {
3306 if (isWORDCHAR_lazy_if(s+1,UTF))
3308 if (strchr(":'{$", s[1]))
3310 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3311 break; /* in regexp, neither @+ nor @- are interpolated */
3314 /* check for embedded scalars. only stop if we're sure it's a
3317 else if (*s == '$') {
3318 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3320 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3322 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3323 "Possible unintended interpolation of $\\ in regex");
3325 break; /* in regexp, $ might be tail anchor */
3329 /* End of else if chain - OP_TRANS rejoin rest */
3332 if (*s == '\\' && s+1 < send) {
3333 char* e; /* Can be used for ending '}', etc. */
3337 /* warn on \1 - \9 in substitution replacements, but note that \11
3338 * is an octal; and \19 is \1 followed by '9' */
3339 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3340 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3342 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3347 /* string-change backslash escapes */
3348 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3352 /* In a pattern, process \N, but skip any other backslash escapes.
3353 * This is because we don't want to translate an escape sequence
3354 * into a meta symbol and have the regex compiler use the meta
3355 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3356 * in spite of this, we do have to process \N here while the proper
3357 * charnames handler is in scope. See bugs #56444 and #62056.
3358 * There is a complication because \N in a pattern may also stand
3359 * for 'match a non-nl', and not mean a charname, in which case its
3360 * processing should be deferred to the regex compiler. To be a
3361 * charname it must be followed immediately by a '{', and not look
3362 * like \N followed by a curly quantifier, i.e., not something like
3363 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3365 else if (PL_lex_inpat
3368 || regcurly(s + 1, FALSE)))
3370 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
3371 goto default_action;
3376 /* quoted - in transliterations */
3378 if (PL_lex_inwhat == OP_TRANS) {
3385 if ((isALPHANUMERIC(*s)))
3386 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3387 "Unrecognized escape \\%c passed through",
3389 /* default action is to copy the quoted character */
3390 goto default_action;
3393 /* eg. \132 indicates the octal constant 0132 */
3394 case '0': case '1': case '2': case '3':
3395 case '4': case '5': case '6': case '7':
3397 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3399 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
3401 if (len < 3 && s < send && isDIGIT(*s)
3402 && ckWARN(WARN_MISC))
3404 Perl_warner(aTHX_ packWARN(WARN_MISC),
3405 "%s", form_short_octal_warning(s, len));
3408 goto NUM_ESCAPE_INSERT;
3410 /* eg. \o{24} indicates the octal constant \024 */
3415 bool valid = grok_bslash_o(&s, &uv, &error,
3416 TRUE, /* Output warning */
3417 FALSE, /* Not strict */
3418 TRUE, /* Output warnings for
3425 goto NUM_ESCAPE_INSERT;
3428 /* eg. \x24 indicates the hex constant 0x24 */
3433 bool valid = grok_bslash_x(&s, &uv, &error,
3434 TRUE, /* Output warning */
3435 FALSE, /* Not strict */
3436 TRUE, /* Output warnings for
3446 /* Insert oct or hex escaped character. There will always be
3447 * enough room in sv since such escapes will be longer than any
3448 * UTF-8 sequence they can end up as, except if they force us
3449 * to recode the rest of the string into utf8 */
3451 /* Here uv is the ordinal of the next character being added in
3452 * unicode (converted from native). */
3453 if (!UNI_IS_INVARIANT(uv)) {
3454 if (!has_utf8 && uv > 255) {
3455 /* Might need to recode whatever we have accumulated so
3456 * far if it contains any chars variant in utf8 or
3459 SvCUR_set(sv, d - SvPVX_const(sv));
3462 /* See Note on sizing above. */
3463 sv_utf8_upgrade_flags_grow(sv,
3464 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3465 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3466 d = SvPVX(sv) + SvCUR(sv);
3471 d = (char*)uvuni_to_utf8((U8*)d, uv);
3472 if (PL_lex_inwhat == OP_TRANS &&
3473 PL_sublex_info.sub_op) {
3474 PL_sublex_info.sub_op->op_private |=
3475 (PL_lex_repl ? OPpTRANS_FROM_UTF
3479 if (uv > 255 && !dorange)
3480 native_range = FALSE;
3493 /* In a non-pattern \N must be a named character, like \N{LATIN
3494 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3495 * mean to match a non-newline. For non-patterns, named
3496 * characters are converted to their string equivalents. In
3497 * patterns, named characters are not converted to their
3498 * ultimate forms for the same reasons that other escapes
3499 * aren't. Instead, they are converted to the \N{U+...} form
3500 * to get the value from the charnames that is in effect right
3501 * now, while preserving the fact that it was a named character
3502 * so that the regex compiler knows this */
3504 /* This section of code doesn't generally use the
3505 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3506 * a close examination of this macro and determined it is a
3507 * no-op except on utfebcdic variant characters. Every
3508 * character generated by this that would normally need to be
3509 * enclosed by this macro is invariant, so the macro is not
3510 * needed, and would complicate use of copy(). XXX There are
3511 * other parts of this file where the macro is used
3512 * inconsistently, but are saved by it being a no-op */
3514 /* The structure of this section of code (besides checking for
3515 * errors and upgrading to utf8) is:
3516 * Further disambiguate between the two meanings of \N, and if
3517 * not a charname, go process it elsewhere
3518 * If of form \N{U+...}, pass it through if a pattern;
3519 * otherwise convert to utf8
3520 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3521 * pattern; otherwise convert to utf8 */
3523 /* Here, s points to the 'N'; the test below is guaranteed to
3524 * succeed if we are being called on a pattern as we already
3525 * know from a test above that the next character is a '{'.
3526 * On a non-pattern \N must mean 'named sequence, which
3527 * requires braces */
3530 yyerror("Missing braces on \\N{}");
3535 /* If there is no matching '}', it is an error. */
3536 if (! (e = strchr(s, '}'))) {
3537 if (! PL_lex_inpat) {
3538 yyerror("Missing right brace on \\N{}");
3540 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3545 /* Here it looks like a named character */
3547 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3548 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3549 | PERL_SCAN_DISALLOW_PREFIX;
3552 /* For \N{U+...}, the '...' is a unicode value even on
3553 * EBCDIC machines */
3554 s += 2; /* Skip to next char after the 'U+' */
3556 uv = grok_hex(s, &len, &flags, NULL);
3557 if (len == 0 || len != (STRLEN)(e - s)) {
3558 yyerror("Invalid hexadecimal number in \\N{U+...}");
3565 /* On non-EBCDIC platforms, pass through to the regex
3566 * compiler unchanged. The reason we evaluated the
3567 * number above is to make sure there wasn't a syntax
3568 * error. But on EBCDIC we convert to native so
3569 * downstream code can continue to assume it's native
3571 s -= 5; /* Include the '\N{U+' */
3573 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3576 (unsigned int) UNI_TO_NATIVE(uv));
3578 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3582 else { /* Not a pattern: convert the hex to string */
3584 /* If destination is not in utf8, unconditionally
3585 * recode it to be so. This is because \N{} implies
3586 * Unicode semantics, and scalars have to be in utf8
3587 * to guarantee those semantics */
3589 SvCUR_set(sv, d - SvPVX_const(sv));
3592 /* See Note on sizing above. */
3593 sv_utf8_upgrade_flags_grow(
3595 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3596 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3597 d = SvPVX(sv) + SvCUR(sv);
3601 /* Add the string to the output */
3602 if (UNI_IS_INVARIANT(uv)) {
3605 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3608 else /* Here is \N{NAME} but not \N{U+...}. */
3609 if ((res = get_and_check_backslash_N_name(s, e)))
3612 const char *str = SvPV_const(res, len);
3615 if (! len) { /* The name resolved to an empty string */
3616 Copy("\\N{}", d, 4, char);
3620 /* In order to not lose information for the regex
3621 * compiler, pass the result in the specially made
3622 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3623 * the code points in hex of each character
3624 * returned by charnames */
3626 const char *str_end = str + len;
3627 const STRLEN off = d - SvPVX_const(sv);
3629 if (! SvUTF8(res)) {
3630 /* For the non-UTF-8 case, we can determine the
3631 * exact length needed without having to parse
3632 * through the string. Each character takes up
3633 * 2 hex digits plus either a trailing dot or
3635 d = off + SvGROW(sv, off
3637 + 6 /* For the "\N{U+", and
3639 + (STRLEN)(send - e));
3640 Copy("\\N{U+", d, 5, char);
3642 while (str < str_end) {
3644 my_snprintf(hex_string, sizeof(hex_string),
3645 "%02X.", (U8) *str);
3646 Copy(hex_string, d, 3, char);
3650 d--; /* We will overwrite below the final
3651 dot with a right brace */
3654 STRLEN char_length; /* cur char's byte length */
3656 /* and the number of bytes after this is
3657 * translated into hex digits */
3658 STRLEN output_length;
3660 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3661 * for max('U+', '.'); and 1 for NUL */
3662 char hex_string[2 * UTF8_MAXBYTES + 5];
3664 /* Get the first character of the result. */
3665 U32 uv = utf8n_to_uvuni((U8 *) str,
3669 /* Convert first code point to hex, including
3670 * the boiler plate before it. For all these,
3671 * we convert to native format so that
3672 * downstream code can continue to assume the
3673 * input is native */
3675 my_snprintf(hex_string, sizeof(hex_string),
3677 (unsigned int) UNI_TO_NATIVE(uv));
3679 /* Make sure there is enough space to hold it */
3680 d = off + SvGROW(sv, off
3682 + (STRLEN)(send - e)
3683 + 2); /* '}' + NUL */
3685 Copy(hex_string, d, output_length, char);
3688 /* For each subsequent character, append dot and
3689 * its ordinal in hex */
3690 while ((str += char_length) < str_end) {
3691 const STRLEN off = d - SvPVX_const(sv);
3692 U32 uv = utf8n_to_uvuni((U8 *) str,
3697 my_snprintf(hex_string,
3700 (unsigned int) UNI_TO_NATIVE(uv));
3702 d = off + SvGROW(sv, off
3704 + (STRLEN)(send - e)
3705 + 2); /* '}' + NUL */
3706 Copy(hex_string, d, output_length, char);
3711 *d++ = '}'; /* Done. Add the trailing brace */
3714 else { /* Here, not in a pattern. Convert the name to a
3717 /* If destination is not in utf8, unconditionally
3718 * recode it to be so. This is because \N{} implies
3719 * Unicode semantics, and scalars have to be in utf8
3720 * to guarantee those semantics */
3722 SvCUR_set(sv, d - SvPVX_const(sv));
3725 /* See Note on sizing above. */
3726 sv_utf8_upgrade_flags_grow(sv,
3727 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3728 len + (STRLEN)(send - s) + 1);
3729 d = SvPVX(sv) + SvCUR(sv);
3731 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3733 /* See Note on sizing above. (NOTE: SvCUR() is not
3734 * set correctly here). */
3735 const STRLEN off = d - SvPVX_const(sv);
3736 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3738 Copy(str, d, len, char);
3744 } /* End \N{NAME} */
3747 native_range = FALSE; /* \N{} is defined to be Unicode */
3749 s = e + 1; /* Point to just after the '}' */
3752 /* \c is a control character */
3756 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3759 yyerror("Missing control char name in \\c");
3763 /* printf-style backslashes, formfeeds, newlines, etc */
3765 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3768 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3771 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3774 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3777 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3780 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3783 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3789 } /* end if (backslash) */
3796 /* If we started with encoded form, or already know we want it,
3797 then encode the next character */
3798 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3802 /* One might think that it is wasted effort in the case of the
3803 * source being utf8 (this_utf8 == TRUE) to take the next character
3804 * in the source, convert it to an unsigned value, and then convert
3805 * it back again. But the source has not been validated here. The
3806 * routine that does the conversion checks for errors like
3809 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3810 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3812 SvCUR_set(sv, d - SvPVX_const(sv));
3815 /* See Note on sizing above. */
3816 sv_utf8_upgrade_flags_grow(sv,
3817 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3818 need + (STRLEN)(send - s) + 1);
3819 d = SvPVX(sv) + SvCUR(sv);
3821 } else if (need > len) {
3822 /* encoded value larger than old, may need extra space (NOTE:
3823 * SvCUR() is not set correctly here). See Note on sizing
3825 const STRLEN off = d - SvPVX_const(sv);
3826 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3830 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3832 if (uv > 255 && !dorange)
3833 native_range = FALSE;
3837 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3839 } /* while loop to process each character */
3841 /* terminate the string and set up the sv */
3843 SvCUR_set(sv, d - SvPVX_const(sv));
3844 if (SvCUR(sv) >= SvLEN(sv))
3845 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3846 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3849 if (PL_encoding && !has_utf8) {
3850 sv_recode_to_utf8(sv, PL_encoding);
3856 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3857 PL_sublex_info.sub_op->op_private |=
3858 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3862 /* shrink the sv if we allocated more than we used */
3863 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3864 SvPV_shrink_to_cur(sv);
3867 /* return the substring (via pl_yylval) only if we parsed anything */
3868 if (s > PL_bufptr) {
3869 SvREFCNT_inc_simple_void_NN(sv);
3870 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3871 && ! PL_parser->lex_re_reparsing)
3873 const char *const key = PL_lex_inpat ? "qr" : "q";
3874 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3878 if (PL_lex_inwhat == OP_TRANS) {
3881 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3884 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3892 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3895 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3897 LEAVE_with_name("scan_const");
3902 * Returns TRUE if there's more to the expression (e.g., a subscript),
3905 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3907 * ->[ and ->{ return TRUE
3908 * { and [ outside a pattern are always subscripts, so return TRUE
3909 * if we're outside a pattern and it's not { or [, then return FALSE
3910 * if we're in a pattern and the first char is a {
3911 * {4,5} (any digits around the comma) returns FALSE
3912 * if we're in a pattern and the first char is a [
3914 * [SOMETHING] has a funky algorithm to decide whether it's a
3915 * character class or not. It has to deal with things like
3916 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3917 * anything else returns TRUE
3920 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3923 S_intuit_more(pTHX_ char *s)
3927 PERL_ARGS_ASSERT_INTUIT_MORE;
3929 if (PL_lex_brackets)
3931 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3933 if (*s != '{' && *s != '[')
3938 /* In a pattern, so maybe we have {n,m}. */
3940 if (regcurly(s, FALSE)) {
3946 /* On the other hand, maybe we have a character class */
3949 if (*s == ']' || *s == '^')
3952 /* this is terrifying, and it works */
3955 const char * const send = strchr(s,']');
3956 unsigned char un_char, last_un_char;
3957 char tmpbuf[sizeof PL_tokenbuf * 4];
3959 if (!send) /* has to be an expression */
3961 weight = 2; /* let's weigh the evidence */
3965 else if (isDIGIT(*s)) {
3967 if (isDIGIT(s[1]) && s[2] == ']')
3973 Zero(seen,256,char);
3975 for (; s < send; s++) {
3976 last_un_char = un_char;
3977 un_char = (unsigned char)*s;
3982 weight -= seen[un_char] * 10;
3983 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3985 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3986 len = (int)strlen(tmpbuf);
3987 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3988 UTF ? SVf_UTF8 : 0, SVt_PV))
3993 else if (*s == '$' && s[1] &&
3994 strchr("[#!%*<>()-=",s[1])) {
3995 if (/*{*/ strchr("])} =",s[2]))
4004 if (strchr("wds]",s[1]))
4006 else if (seen[(U8)'\''] || seen[(U8)'"'])
4008 else if (strchr("rnftbxcav",s[1]))
4010 else if (isDIGIT(s[1])) {
4012 while (s[1] && isDIGIT(s[1]))
4022 if (strchr("aA01! ",last_un_char))
4024 if (strchr("zZ79~",s[1]))
4026 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4027 weight -= 5; /* cope with negative subscript */
4030 if (!isWORDCHAR(last_un_char)
4031 && !(last_un_char == '$' || last_un_char == '@'
4032 || last_un_char == '&')
4033 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4038 if (keyword(tmpbuf, d - tmpbuf, 0))
4041 if (un_char == last_un_char + 1)
4043 weight -= seen[un_char];
4048 if (weight >= 0) /* probably a character class */
4058 * Does all the checking to disambiguate
4060 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4061 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4063 * First argument is the stuff after the first token, e.g. "bar".
4065 * Not a method if foo is a filehandle.
4066 * Not a method if foo is a subroutine prototyped to take a filehandle.
4067 * Not a method if it's really "Foo $bar"
4068 * Method if it's "foo $bar"
4069 * Not a method if it's really "print foo $bar"
4070 * Method if it's really "foo package::" (interpreted as package->foo)
4071 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4072 * Not a method if bar is a filehandle or package, but is quoted with
4077 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
4080 char *s = start + (*start == '$');
4081 char tmpbuf[sizeof PL_tokenbuf];
4088 PERL_ARGS_ASSERT_INTUIT_METHOD;
4090 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4092 if (cv && SvPOK(cv)) {
4093 const char *proto = CvPROTO(cv);
4095 while (*proto && (isSPACE(*proto) || *proto == ';'))
4102 if (*start == '$') {
4103 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
4104 isUPPER(*PL_tokenbuf))
4107 len = start - SvPVX(PL_linestr);
4111 start = SvPVX(PL_linestr) + len;
4115 return *s == '(' ? FUNCMETH : METHOD;
4118 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4119 /* start is the beginning of the possible filehandle/object,
4120 * and s is the end of it
4121 * tmpbuf is a copy of it (but with single quotes as double colons)
4124 if (!keyword(tmpbuf, len, 0)) {
4125 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4129 soff = s - SvPVX(PL_linestr);
4133 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4134 if (indirgv && GvCVu(indirgv))
4136 /* filehandle or package name makes it a method */
4137 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4139 soff = s - SvPVX(PL_linestr);
4142 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4143 return 0; /* no assumptions -- "=>" quotes bareword */
4145 start_force(PL_curforce);
4146 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4147 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4148 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4150 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4151 ( UTF ? SVf_UTF8 : 0 )));
4156 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4158 return *s == '(' ? FUNCMETH : METHOD;
4164 /* Encoded script support. filter_add() effectively inserts a
4165 * 'pre-processing' function into the current source input stream.
4166 * Note that the filter function only applies to the current source file
4167 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4169 * The datasv parameter (which may be NULL) can be used to pass
4170 * private data to this instance of the filter. The filter function
4171 * can recover the SV using the FILTER_DATA macro and use it to
4172 * store private buffers and state information.
4174 * The supplied datasv parameter is upgraded to a PVIO type
4175 * and the IoDIRP/IoANY field is used to store the function pointer,
4176 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4177 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4178 * private use must be set using malloc'd pointers.
4182 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4191 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4192 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4194 if (!PL_rsfp_filters)
4195 PL_rsfp_filters = newAV();
4198 SvUPGRADE(datasv, SVt_PVIO);
4199 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4200 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4201 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4202 FPTR2DPTR(void *, IoANY(datasv)),
4203 SvPV_nolen(datasv)));
4204 av_unshift(PL_rsfp_filters, 1);
4205 av_store(PL_rsfp_filters, 0, datasv) ;
4207 !PL_parser->filtered
4208 && PL_parser->lex_flags & LEX_EVALBYTES
4209 && PL_bufptr < PL_bufend
4211 const char *s = PL_bufptr;
4212 while (s < PL_bufend) {
4214 SV *linestr = PL_parser->linestr;
4215 char *buf = SvPVX(linestr);
4216 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4217 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4218 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4219 STRLEN const linestart_pos = PL_parser->linestart - buf;
4220 STRLEN const last_uni_pos =
4221 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4222 STRLEN const last_lop_pos =
4223 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4224 av_push(PL_rsfp_filters, linestr);
4225 PL_parser->linestr =
4226 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4227 buf = SvPVX(PL_parser->linestr);
4228 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4229 PL_parser->bufptr = buf + bufptr_pos;
4230 PL_parser->oldbufptr = buf + oldbufptr_pos;
4231 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4232 PL_parser->linestart = buf + linestart_pos;
4233 if (PL_parser->last_uni)
4234 PL_parser->last_uni = buf + last_uni_pos;
4235 if (PL_parser->last_lop)
4236 PL_parser->last_lop = buf + last_lop_pos;
4237 SvLEN(linestr) = SvCUR(linestr);
4238 SvCUR(linestr) = s-SvPVX(linestr);
4239 PL_parser->filtered = 1;
4249 /* Delete most recently added instance of this filter function. */
4251 Perl_filter_del(pTHX_ filter_t funcp)
4256 PERL_ARGS_ASSERT_FILTER_DEL;
4259 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4260 FPTR2DPTR(void*, funcp)));
4262 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4264 /* if filter is on top of stack (usual case) just pop it off */
4265 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4266 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4267 sv_free(av_pop(PL_rsfp_filters));
4271 /* we need to search for the correct entry and clear it */
4272 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4276 /* Invoke the idxth filter function for the current rsfp. */
4277 /* maxlen 0 = read one text line */
4279 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4284 /* This API is bad. It should have been using unsigned int for maxlen.
4285 Not sure if we want to change the API, but if not we should sanity
4286 check the value here. */
4287 unsigned int correct_length
4296 PERL_ARGS_ASSERT_FILTER_READ;
4298 if (!PL_parser || !PL_rsfp_filters)
4300 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4301 /* Provide a default input filter to make life easy. */
4302 /* Note that we append to the line. This is handy. */
4303 DEBUG_P(PerlIO_printf(Perl_debug_log,
4304 "filter_read %d: from rsfp\n", idx));
4305 if (correct_length) {
4308 const int old_len = SvCUR(buf_sv);
4310 /* ensure buf_sv is large enough */
4311 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4312 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4313 correct_length)) <= 0) {
4314 if (PerlIO_error(PL_rsfp))
4315 return -1; /* error */
4317 return 0 ; /* end of file */
4319 SvCUR_set(buf_sv, old_len + len) ;
4320 SvPVX(buf_sv)[old_len + len] = '\0';
4323 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4324 if (PerlIO_error(PL_rsfp))
4325 return -1; /* error */
4327 return 0 ; /* end of file */
4330 return SvCUR(buf_sv);
4332 /* Skip this filter slot if filter has been deleted */
4333 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4334 DEBUG_P(PerlIO_printf(Perl_debug_log,
4335 "filter_read %d: skipped (filter deleted)\n",
4337 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4339 if (SvTYPE(datasv) != SVt_PVIO) {
4340 if (correct_length) {
4342 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4343 if (!remainder) return 0; /* eof */
4344 if (correct_length > remainder) correct_length = remainder;
4345 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4346 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4349 const char *s = SvEND(datasv);
4350 const char *send = SvPVX(datasv) + SvLEN(datasv);
4358 if (s == send) return 0; /* eof */
4359 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4360 SvCUR_set(datasv, s-SvPVX(datasv));
4362 return SvCUR(buf_sv);
4364 /* Get function pointer hidden within datasv */
4365 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4366 DEBUG_P(PerlIO_printf(Perl_debug_log,
4367 "filter_read %d: via function %p (%s)\n",
4368 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4369 /* Call function. The function is expected to */
4370 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4371 /* Return: <0:error, =0:eof, >0:not eof */
4372 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4376 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4380 PERL_ARGS_ASSERT_FILTER_GETS;
4382 #ifdef PERL_CR_FILTER
4383 if (!PL_rsfp_filters) {
4384 filter_add(S_cr_textfilter,NULL);
4387 if (PL_rsfp_filters) {
4389 SvCUR_set(sv, 0); /* start with empty line */
4390 if (FILTER_READ(0, sv, 0) > 0)
4391 return ( SvPVX(sv) ) ;
4396 return (sv_gets(sv, PL_rsfp, append));
4400 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4405 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4407 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4411 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4412 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4414 return GvHV(gv); /* Foo:: */
4417 /* use constant CLASS => 'MyClass' */
4418 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4419 if (gv && GvCV(gv)) {
4420 SV * const sv = cv_const_sv(GvCV(gv));
4422 pkgname = SvPV_const(sv, len);
4425 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4429 * S_readpipe_override
4430 * Check whether readpipe() is overridden, and generates the appropriate
4431 * optree, provided sublex_start() is called afterwards.
4434 S_readpipe_override(pTHX)
4437 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4438 pl_yylval.ival = OP_BACKTICK;
4440 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4442 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4443 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4444 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4446 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4447 op_append_elem(OP_LIST,
4448 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4449 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4456 * The intent of this yylex wrapper is to minimize the changes to the
4457 * tokener when we aren't interested in collecting madprops. It remains
4458 * to be seen how successful this strategy will be...
4465 char *s = PL_bufptr;
4467 /* make sure PL_thiswhite is initialized */
4471 /* previous token ate up our whitespace? */
4472 if (!PL_lasttoke && PL_nextwhite) {
4473 PL_thiswhite = PL_nextwhite;
4477 /* isolate the token, and figure out where it is without whitespace */
4478 PL_realtokenstart = -1;
4482 assert(PL_curforce < 0);
4484 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4485 if (!PL_thistoken) {
4486 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4487 PL_thistoken = newSVpvs("");
4489 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4490 PL_thistoken = newSVpvn(tstart, s - tstart);
4493 if (PL_thismad) /* install head */
4494 CURMAD('X', PL_thistoken);
4497 /* last whitespace of a sublex? */
4498 if (optype == ')' && PL_endwhite) {
4499 CURMAD('X', PL_endwhite);
4504 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4505 if (!PL_thiswhite && !PL_endwhite && !optype) {
4506 sv_free(PL_thistoken);
4511 /* put off final whitespace till peg */
4512 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4513 PL_nextwhite = PL_thiswhite;
4516 else if (PL_thisopen) {
4517 CURMAD('q', PL_thisopen);
4519 sv_free(PL_thistoken);
4523 /* Store actual token text as madprop X */
4524 CURMAD('X', PL_thistoken);
4528 /* add preceding whitespace as madprop _ */
4529 CURMAD('_', PL_thiswhite);
4533 /* add quoted material as madprop = */
4534 CURMAD('=', PL_thisstuff);
4538 /* add terminating quote as madprop Q */
4539 CURMAD('Q', PL_thisclose);
4543 /* special processing based on optype */
4547 /* opval doesn't need a TOKEN since it can already store mp */
4557 if (pl_yylval.opval)
4558 append_madprops(PL_thismad, pl_yylval.opval, 0);
4566 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4579 /* remember any fake bracket that lexer is about to discard */
4580 if (PL_lex_brackets == 1 &&
4581 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4584 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4587 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4588 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4591 break; /* don't bother looking for trailing comment */
4600 /* attach a trailing comment to its statement instead of next token */
4604 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4606 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4608 if (*s == '\n' || *s == '#') {
4609 while (s < PL_bufend && *s != '\n')
4613 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4614 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4627 /* Create new token struct. Note: opvals return early above. */
4628 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4635 S_tokenize_use(pTHX_ int is_use, char *s) {
4638 PERL_ARGS_ASSERT_TOKENIZE_USE;
4640 if (PL_expect != XSTATE)
4641 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4642 is_use ? "use" : "no"));
4645 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4646 s = force_version(s, TRUE);
4647 if (*s == ';' || *s == '}'
4648 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4649 start_force(PL_curforce);
4650 NEXTVAL_NEXTTOKE.opval = NULL;
4653 else if (*s == 'v') {
4654 s = force_word(s,WORD,FALSE,TRUE);
4655 s = force_version(s, FALSE);
4659 s = force_word(s,WORD,FALSE,TRUE);
4660 s = force_version(s, FALSE);
4662 pl_yylval.ival = is_use;
4666 static const char* const exp_name[] =
4667 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4668 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4672 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4674 S_word_takes_any_delimeter(char *p, STRLEN len)
4676 return (len == 1 && strchr("msyq", p[0])) ||
4678 (p[0] == 't' && p[1] == 'r') ||
4679 (p[0] == 'q' && strchr("qwxr", p[1]))));
4685 Works out what to call the token just pulled out of the input
4686 stream. The yacc parser takes care of taking the ops we return and
4687 stitching them into a tree.
4690 The type of the next token
4693 Switch based on the current state:
4694 - if we already built the token before, use it
4695 - if we have a case modifier in a string, deal with that
4696 - handle other cases of interpolation inside a string
4697 - scan the next line if we are inside a format
4698 In the normal state switch on the next character:
4700 if alphabetic, go to key lookup
4701 unrecoginized character - croak
4702 - 0/4/26: handle end-of-line or EOF
4703 - cases for whitespace
4704 - \n and #: handle comments and line numbers
4705 - various operators, brackets and sigils
4708 - 'v': vstrings (or go to key lookup)
4709 - 'x' repetition operator (or go to key lookup)
4710 - other ASCII alphanumerics (key lookup begins here):
4713 scan built-in keyword (but do nothing with it yet)
4714 check for statement label
4715 check for lexical subs
4716 goto just_a_word if there is one
4717 see whether built-in keyword is overridden
4718 switch on keyword number:
4719 - default: just_a_word:
4720 not a built-in keyword; handle bareword lookup
4721 disambiguate between method and sub call
4722 fall back to bareword
4723 - cases for built-in keywords
4728 #pragma segment Perl_yylex
4734 char *s = PL_bufptr;
4738 const bool saw_infix_sigil = PL_parser->saw_infix_sigil;
4742 /* orig_keyword, gvp, and gv are initialized here because
4743 * jump to the label just_a_word_zero can bypass their
4744 * initialization later. */
4745 I32 orig_keyword = 0;
4750 SV* tmp = newSVpvs("");
4751 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4752 (IV)CopLINE(PL_curcop),
4753 lex_state_names[PL_lex_state],
4754 exp_name[PL_expect],
4755 pv_display(tmp, s, strlen(s), 0, 60));
4759 switch (PL_lex_state) {
4761 case LEX_NORMAL: /* Some compilers will produce faster */
4762 case LEX_INTERPNORMAL: /* code if we comment these out. */
4766 /* when we've already built the next token, just pull it out of the queue */
4770 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4772 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4773 PL_nexttoke[PL_lasttoke].next_mad = 0;
4774 if (PL_thismad && PL_thismad->mad_key == '_') {
4775 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4776 PL_thismad->mad_val = 0;
4777 mad_free(PL_thismad);
4782 PL_lex_state = PL_lex_defer;
4783 PL_expect = PL_lex_expect;
4784 PL_lex_defer = LEX_NORMAL;
4785 if (!PL_nexttoke[PL_lasttoke].next_type)
4790 pl_yylval = PL_nextval[PL_nexttoke];
4792 PL_lex_state = PL_lex_defer;
4793 PL_expect = PL_lex_expect;
4794 PL_lex_defer = LEX_NORMAL;
4800 next_type = PL_nexttoke[PL_lasttoke].next_type;
4802 next_type = PL_nexttype[PL_nexttoke];
4804 if (next_type & (7<<24)) {
4805 if (next_type & (1<<24)) {
4806 if (PL_lex_brackets > 100)
4807 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4808 PL_lex_brackstack[PL_lex_brackets++] =
4809 (char) ((next_type >> 16) & 0xff);
4811 if (next_type & (2<<24))
4812 PL_lex_allbrackets++;
4813 if (next_type & (4<<24))
4814 PL_lex_allbrackets--;
4815 next_type &= 0xffff;
4817 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4820 /* interpolated case modifiers like \L \U, including \Q and \E.
4821 when we get here, PL_bufptr is at the \
4823 case LEX_INTERPCASEMOD:
4825 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4827 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4828 PL_bufptr, PL_bufend, *PL_bufptr);
4830 /* handle \E or end of string */
4831 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4833 if (PL_lex_casemods) {
4834 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4835 PL_lex_casestack[PL_lex_casemods] = '\0';
4837 if (PL_bufptr != PL_bufend
4838 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4839 || oldmod == 'F')) {
4841 PL_lex_state = LEX_INTERPCONCAT;
4844 PL_thistoken = newSVpvs("\\E");
4847 PL_lex_allbrackets--;
4850 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4851 /* Got an unpaired \E */
4852 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4853 "Useless use of \\E");
4856 while (PL_bufptr != PL_bufend &&
4857 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4860 PL_thiswhite = newSVpvs("");
4861 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4866 if (PL_bufptr != PL_bufend)
4869 PL_lex_state = LEX_INTERPCONCAT;
4873 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4874 "### Saw case modifier\n"); });
4876 if (s[1] == '\\' && s[2] == 'E') {
4880 PL_thiswhite = newSVpvs("");
4881 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4885 PL_lex_state = LEX_INTERPCONCAT;
4890 if (!PL_madskills) /* when just compiling don't need correct */
4891 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4892 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4893 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4894 (strchr(PL_lex_casestack, 'L')
4895 || strchr(PL_lex_casestack, 'U')
4896 || strchr(PL_lex_casestack, 'F'))) {
4897 PL_lex_casestack[--PL_lex_casemods] = '\0';
4898 PL_lex_allbrackets--;
4901 if (PL_lex_casemods > 10)
4902 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4903 PL_lex_casestack[PL_lex_casemods++] = *s;
4904 PL_lex_casestack[PL_lex_casemods] = '\0';
4905 PL_lex_state = LEX_INTERPCONCAT;
4906 start_force(PL_curforce);
4907 NEXTVAL_NEXTTOKE.ival = 0;
4908 force_next((2<<24)|'(');
4909 start_force(PL_curforce);
4911 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4913 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4915 NEXTVAL_NEXTTOKE.ival = OP_LC;
4917 NEXTVAL_NEXTTOKE.ival = OP_UC;
4919 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4921 NEXTVAL_NEXTTOKE.ival = OP_FC;
4923 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4925 SV* const tmpsv = newSVpvs("\\ ");
4926 /* replace the space with the character we want to escape
4928 SvPVX(tmpsv)[1] = *s;
4934 if (PL_lex_starts) {
4940 sv_free(PL_thistoken);
4941 PL_thistoken = newSVpvs("");
4944 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4945 if (PL_lex_casemods == 1 && PL_lex_inpat)
4954 case LEX_INTERPPUSH:
4955 return REPORT(sublex_push());
4957 case LEX_INTERPSTART:
4958 if (PL_bufptr == PL_bufend)
4959 return REPORT(sublex_done());
4960 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4961 "### Interpolated variable\n"); });
4963 /* for /@a/, we leave the joining for the regex engine to do
4964 * (unless we're within \Q etc) */
4965 PL_lex_dojoin = (*PL_bufptr == '@'
4966 && (!PL_lex_inpat || PL_lex_casemods));
4967 PL_lex_state = LEX_INTERPNORMAL;
4968 if (PL_lex_dojoin) {
4969 start_force(PL_curforce);
4970 NEXTVAL_NEXTTOKE.ival = 0;
4972 start_force(PL_curforce);
4973 force_ident("\"", '$');
4974 start_force(PL_curforce);
4975 NEXTVAL_NEXTTOKE.ival = 0;
4977 start_force(PL_curforce);
4978 NEXTVAL_NEXTTOKE.ival = 0;
4979 force_next((2<<24)|'(');
4980 start_force(PL_curforce);
4981 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4984 /* Convert (?{...}) and friends to 'do {...}' */
4985 if (PL_lex_inpat && *PL_bufptr == '(') {
4986 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4988 if (*PL_bufptr != '{')
4990 start_force(PL_curforce);
4991 /* XXX probably need a CURMAD(something) here */
4992 PL_expect = XTERMBLOCK;
4996 if (PL_lex_starts++) {
5001 sv_free(PL_thistoken);
5002 PL_thistoken = newSVpvs("");
5005 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5006 if (!PL_lex_casemods && PL_lex_inpat)
5013 case LEX_INTERPENDMAYBE:
5014 if (intuit_more(PL_bufptr)) {
5015 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
5021 if (PL_lex_dojoin) {
5022 PL_lex_dojoin = FALSE;
5023 PL_lex_state = LEX_INTERPCONCAT;
5027 sv_free(PL_thistoken);
5028 PL_thistoken = newSVpvs("");
5031 PL_lex_allbrackets--;
5034 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
5035 && SvEVALED(PL_lex_repl))
5037 if (PL_bufptr != PL_bufend)
5038 Perl_croak(aTHX_ "Bad evalled substitution pattern");
5041 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
5042 re_eval_str. If the here-doc body’s length equals the previous
5043 value of re_eval_start, re_eval_start will now be null. So
5044 check re_eval_str as well. */
5045 if (PL_parser->lex_shared->re_eval_start
5046 || PL_parser->lex_shared->re_eval_str) {
5048 if (*PL_bufptr != ')')
5049 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5051 /* having compiled a (?{..}) expression, return the original
5052 * text too, as a const */
5053 if (PL_parser->lex_shared->re_eval_str) {
5054 sv = PL_parser->lex_shared->re_eval_str;
5055 PL_parser->lex_shared->re_eval_str = NULL;
5057 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5058 SvPV_shrink_to_cur(sv);
5060 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5061 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5062 start_force(PL_curforce);
5063 /* XXX probably need a CURMAD(something) here */
5064 NEXTVAL_NEXTTOKE.opval =
5065 (OP*)newSVOP(OP_CONST, 0,
5068 PL_parser->lex_shared->re_eval_start = NULL;
5074 case LEX_INTERPCONCAT:
5076 if (PL_lex_brackets)
5077 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5078 (long) PL_lex_brackets);
5080 if (PL_bufptr == PL_bufend)
5081 return REPORT(sublex_done());
5083 /* m'foo' still needs to be parsed for possible (?{...}) */
5084 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5085 SV *sv = newSVsv(PL_linestr);
5087 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5091 s = scan_const(PL_bufptr);
5093 PL_lex_state = LEX_INTERPCASEMOD;
5095 PL_lex_state = LEX_INTERPSTART;
5098 if (s != PL_bufptr) {
5099 start_force(PL_curforce);
5101 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
5103 NEXTVAL_NEXTTOKE = pl_yylval;
5106 if (PL_lex_starts++) {
5110 sv_free(PL_thistoken);
5111 PL_thistoken = newSVpvs("");
5114 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5115 if (!PL_lex_casemods && PL_lex_inpat)
5128 s = scan_formline(PL_bufptr);
5129 if (!PL_lex_formbrack)
5139 PL_oldoldbufptr = PL_oldbufptr;
5141 PL_parser->saw_infix_sigil = 0;
5146 sv_free(PL_thistoken);
5149 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
5153 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
5156 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5157 const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
5159 SVs_TEMP | SVf_UTF8),
5160 10, UNI_DISPLAY_ISPRINT))
5161 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5162 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
5163 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5164 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
5172 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
5176 goto fake_eof; /* emulate EOF on ^D or ^Z */
5182 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
5185 if (PL_lex_brackets &&
5186 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
5187 yyerror((const char *)
5189 ? "Format not terminated"
5190 : "Missing right curly or square bracket"));
5192 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5193 "### Tokener got EOF\n");
5197 if (s++ < PL_bufend)
5198 goto retry; /* ignore stray nulls */
5201 if (!PL_in_eval && !PL_preambled) {
5202 PL_preambled = TRUE;
5208 /* Generate a string of Perl code to load the debugger.
5209 * If PERL5DB is set, it will return the contents of that,
5210 * otherwise a compile-time require of perl5db.pl. */
5212 const char * const pdb = PerlEnv_getenv("PERL5DB");
5215 sv_setpv(PL_linestr, pdb);
5216 sv_catpvs(PL_linestr,";");
5218 SETERRNO(0,SS_NORMAL);
5219 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5222 sv_setpvs(PL_linestr,"");
5223 if (PL_preambleav) {
5224 SV **svp = AvARRAY(PL_preambleav);
5225 SV **const end = svp + AvFILLp(PL_preambleav);
5227 sv_catsv(PL_linestr, *svp);
5229 sv_catpvs(PL_linestr, ";");
5231 sv_free(MUTABLE_SV(PL_preambleav));
5232 PL_preambleav = NULL;
5235 sv_catpvs(PL_linestr,
5236 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5237 if (PL_minus_n || PL_minus_p) {
5238 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5240 sv_catpvs(PL_linestr,"chomp;");
5243 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
5244 || *PL_splitstr == '"')
5245 && strchr(PL_splitstr + 1, *PL_splitstr))
5246 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5248 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5249 bytes can be used as quoting characters. :-) */
5250 const char *splits = PL_splitstr;
5251 sv_catpvs(PL_linestr, "our @F=split(q\0");
5254 if (*splits == '\\')
5255 sv_catpvn(PL_linestr, splits, 1);
5256 sv_catpvn(PL_linestr, splits, 1);
5257 } while (*splits++);
5258 /* This loop will embed the trailing NUL of
5259 PL_linestr as the last thing it does before
5261 sv_catpvs(PL_linestr, ");");
5265 sv_catpvs(PL_linestr,"our @F=split(' ');");
5268 sv_catpvs(PL_linestr, "\n");
5269 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5270 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5271 PL_last_lop = PL_last_uni = NULL;
5272 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
5273 update_debugger_info(PL_linestr, NULL, 0);
5278 bof = PL_rsfp ? TRUE : FALSE;
5281 fake_eof = LEX_FAKE_EOF;
5283 PL_bufptr = PL_bufend;
5284 COPLINE_INC_WITH_HERELINES;
5285 if (!lex_next_chunk(fake_eof)) {
5286 CopLINE_dec(PL_curcop);
5288 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5290 CopLINE_dec(PL_curcop);
5293 PL_realtokenstart = -1;
5296 /* If it looks like the start of a BOM or raw UTF-16,
5297 * check if it in fact is. */
5298 if (bof && PL_rsfp &&
5303 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5304 bof = (offset == (Off_t)SvCUR(PL_linestr));
5305 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5306 /* offset may include swallowed CR */
5308 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5311 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5312 s = swallow_bom((U8*)s);
5315 if (PL_parser->in_pod) {
5316 /* Incest with pod. */
5319 sv_catsv(PL_thiswhite, PL_linestr);
5321 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
5322 sv_setpvs(PL_linestr, "");
5323 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5324 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5325 PL_last_lop = PL_last_uni = NULL;
5326 PL_parser->in_pod = 0;
5329 if (PL_rsfp || PL_parser->filtered)
5331 } while (PL_parser->in_pod);
5332 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5333 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5334 PL_last_lop = PL_last_uni = NULL;
5335 if (CopLINE(PL_curcop) == 1) {
5336 while (s < PL_bufend && isSPACE(*s))
5338 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5342 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
5346 if (*s == '#' && *(s+1) == '!')
5348 #ifdef ALTERNATE_SHEBANG
5350 static char const as[] = ALTERNATE_SHEBANG;
5351 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5352 d = s + (sizeof(as) - 1);
5354 #endif /* ALTERNATE_SHEBANG */
5363 while (*d && !isSPACE(*d))
5367 #ifdef ARG_ZERO_IS_SCRIPT
5368 if (ipathend > ipath) {
5370 * HP-UX (at least) sets argv[0] to the script name,
5371 * which makes $^X incorrect. And Digital UNIX and Linux,
5372 * at least, set argv[0] to the basename of the Perl
5373 * interpreter. So, having found "#!", we'll set it right.
5375 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5377 assert(SvPOK(x) || SvGMAGICAL(x));
5378 if (sv_eq(x, CopFILESV(PL_curcop))) {
5379 sv_setpvn(x, ipath, ipathend - ipath);
5385 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
5386 const char * const lstart = SvPV_const(x,llen);
5388 bstart += blen - llen;
5389 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5390 sv_setpvn(x, ipath, ipathend - ipath);
5395 TAINT_NOT; /* $^X is always tainted, but that's OK */
5397 #endif /* ARG_ZERO_IS_SCRIPT */
5402 d = instr(s,"perl -");
5404 d = instr(s,"perl");
5406 /* avoid getting into infinite loops when shebang
5407 * line contains "Perl" rather than "perl" */
5409 for (d = ipathend-4; d >= ipath; --d) {
5410 if ((*d == 'p' || *d == 'P')
5411 && !ibcmp(d, "perl", 4))
5421 #ifdef ALTERNATE_SHEBANG
5423 * If the ALTERNATE_SHEBANG on this system starts with a
5424 * character that can be part of a Perl expression, then if
5425 * we see it but not "perl", we're probably looking at the
5426 * start of Perl code, not a request to hand off to some
5427 * other interpreter. Similarly, if "perl" is there, but
5428 * not in the first 'word' of the line, we assume the line
5429 * contains the start of the Perl program.
5431 if (d && *s != '#') {
5432 const char *c = ipath;
5433 while (*c && !strchr("; \t\r\n\f\v#", *c))
5436 d = NULL; /* "perl" not in first word; ignore */
5438 *s = '#'; /* Don't try to parse shebang line */
5440 #endif /* ALTERNATE_SHEBANG */
5445 !instr(s,"indir") &&
5446 instr(PL_origargv[0],"perl"))
5453 while (s < PL_bufend && isSPACE(*s))
5455 if (s < PL_bufend) {
5456 Newx(newargv,PL_origargc+3,char*);
5458 while (s < PL_bufend && !isSPACE(*s))
5461 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5464 newargv = PL_origargv;
5467 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5469 Perl_croak(aTHX_ "Can't exec %s", ipath);
5472 while (*d && !isSPACE(*d))
5474 while (SPACE_OR_TAB(*d))
5478 const bool switches_done = PL_doswitches;
5479 const U32 oldpdb = PL_perldb;
5480 const bool oldn = PL_minus_n;
5481 const bool oldp = PL_minus_p;
5485 bool baduni = FALSE;
5487 const char *d2 = d1 + 1;
5488 if (parse_unicode_opts((const char **)&d2)
5492 if (baduni || *d1 == 'M' || *d1 == 'm') {
5493 const char * const m = d1;
5494 while (*d1 && !isSPACE(*d1))
5496 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5499 d1 = moreswitches(d1);
5501 if (PL_doswitches && !switches_done) {
5502 int argc = PL_origargc;
5503 char **argv = PL_origargv;
5506 } while (argc && argv[0][0] == '-' && argv[0][1]);
5507 init_argv_symbols(argc,argv);
5509 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5510 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5511 /* if we have already added "LINE: while (<>) {",
5512 we must not do it again */
5514 sv_setpvs(PL_linestr, "");
5515 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5516 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5517 PL_last_lop = PL_last_uni = NULL;
5518 PL_preambled = FALSE;
5519 if (PERLDB_LINE || PERLDB_SAVESRC)
5520 (void)gv_fetchfile(PL_origfilename);
5527 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5528 PL_lex_state = LEX_FORMLINE;
5529 start_force(PL_curforce);
5530 NEXTVAL_NEXTTOKE.ival = 0;
5531 force_next(FORMRBRACK);
5536 #ifdef PERL_STRICT_CR
5537 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5539 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5541 case ' ': case '\t': case '\f': case 013:
5543 PL_realtokenstart = -1;
5546 PL_thiswhite = newSVpvs("");
5547 sv_catpvn(PL_thiswhite, s, 1);
5555 PL_realtokenstart = -1;
5559 if (PL_lex_state != LEX_NORMAL ||
5560 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
5561 if (*s == '#' && s == PL_linestart && PL_in_eval
5562 && !PL_rsfp && !PL_parser->filtered) {
5563 /* handle eval qq[#line 1 "foo"\n ...] */
5564 CopLINE_dec(PL_curcop);
5567 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5569 if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
5573 const bool in_comment = *s == '#';
5575 while (d < PL_bufend && *d != '\n')
5579 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5580 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5584 PL_thiswhite = newSVpvn(s, d - s);
5587 if (in_comment && d == PL_bufend
5588 && PL_lex_state == LEX_INTERPNORMAL
5589 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5590 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5593 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5594 PL_lex_state = LEX_FORMLINE;
5595 start_force(PL_curforce);
5596 NEXTVAL_NEXTTOKE.ival = 0;
5597 force_next(FORMRBRACK);
5603 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5604 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5607 TOKEN(PEG); /* make sure any #! line is accessible */
5612 /* if (PL_madskills && PL_lex_formbrack) { */
5614 while (d < PL_bufend && *d != '\n')
5618 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5619 Perl_croak(aTHX_ "panic: input overflow");
5620 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5622 PL_thiswhite = newSVpvs("");
5623 if (CopLINE(PL_curcop) == 1) {
5624 sv_setpvs(PL_thiswhite, "");
5627 sv_catpvn(PL_thiswhite, s, d - s);
5641 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5649 while (s < PL_bufend && SPACE_OR_TAB(*s))
5652 if (strnEQ(s,"=>",2)) {
5653 s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5654 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5655 OPERATOR('-'); /* unary minus */
5657 PL_last_uni = PL_oldbufptr;
5659 case 'r': ftst = OP_FTEREAD; break;
5660 case 'w': ftst = OP_FTEWRITE; break;
5661 case 'x': ftst = OP_FTEEXEC; break;
5662 case 'o': ftst = OP_FTEOWNED; break;
5663 case 'R': ftst = OP_FTRREAD; break;
5664 case 'W': ftst = OP_FTRWRITE; break;
5665 case 'X': ftst = OP_FTREXEC; break;
5666 case 'O': ftst = OP_FTROWNED; break;
5667 case 'e': ftst = OP_FTIS; break;
5668 case 'z': ftst = OP_FTZERO; break;
5669 case 's': ftst = OP_FTSIZE; break;
5670 case 'f': ftst = OP_FTFILE; break;
5671 case 'd': ftst = OP_FTDIR; break;
5672 case 'l': ftst = OP_FTLINK; break;
5673 case 'p': ftst = OP_FTPIPE; break;
5674 case 'S': ftst = OP_FTSOCK; break;
5675 case 'u': ftst = OP_FTSUID; break;
5676 case 'g': ftst = OP_FTSGID; break;
5677 case 'k': ftst = OP_FTSVTX; break;
5678 case 'b': ftst = OP_FTBLK; break;
5679 case 'c': ftst = OP_FTCHR; break;
5680 case 't': ftst = OP_FTTTY; break;
5681 case 'T': ftst = OP_FTTEXT; break;
5682 case 'B': ftst = OP_FTBINARY; break;
5683 case 'M': case 'A': case 'C':
5684 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5686 case 'M': ftst = OP_FTMTIME; break;
5687 case 'A': ftst = OP_FTATIME; break;
5688 case 'C': ftst = OP_FTCTIME; break;
5696 PL_last_lop_op = (OPCODE)ftst;
5697 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5698 "### Saw file test %c\n", (int)tmp);
5703 /* Assume it was a minus followed by a one-letter named
5704 * subroutine call (or a -bareword), then. */
5705 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5706 "### '-%c' looked like a file test but was not\n",
5713 const char tmp = *s++;
5716 if (PL_expect == XOPERATOR)
5721 else if (*s == '>') {
5724 if (isIDFIRST_lazy_if(s,UTF)) {
5725 s = force_word(s,METHOD,FALSE,TRUE);
5733 if (PL_expect == XOPERATOR) {
5734 if (*s == '=' && !PL_lex_allbrackets &&
5735 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5742 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5744 OPERATOR('-'); /* unary minus */
5750 const char tmp = *s++;
5753 if (PL_expect == XOPERATOR)
5758 if (PL_expect == XOPERATOR) {
5759 if (*s == '=' && !PL_lex_allbrackets &&
5760 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5767 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5774 if (PL_expect != XOPERATOR) {
5775 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5776 PL_expect = XOPERATOR;
5777 force_ident(PL_tokenbuf, '*');
5785 if (*s == '=' && !PL_lex_allbrackets &&
5786 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5792 if (*s == '=' && !PL_lex_allbrackets &&
5793 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5797 PL_parser->saw_infix_sigil = 1;
5801 if (PL_expect == XOPERATOR) {
5802 if (s[1] == '=' && !PL_lex_allbrackets &&
5803 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5806 PL_parser->saw_infix_sigil = 1;
5809 PL_tokenbuf[0] = '%';
5810 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5811 sizeof PL_tokenbuf - 1, FALSE);
5812 if (!PL_tokenbuf[1]) {
5815 PL_expect = XOPERATOR;
5816 force_ident_maybe_lex('%');
5820 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5821 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5826 if (PL_lex_brackets > 100)
5827 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5828 PL_lex_brackstack[PL_lex_brackets++] = 0;
5829 PL_lex_allbrackets++;
5831 const char tmp = *s++;
5836 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5838 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5841 Perl_ck_warner_d(aTHX_
5842 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5843 "Smartmatch is experimental");
5849 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5856 goto just_a_word_zero_gv;
5859 switch (PL_expect) {
5865 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5867 PL_bufptr = s; /* update in case we back off */
5870 "Use of := for an empty attribute list is not allowed");
5877 PL_expect = XTERMBLOCK;
5880 stuffstart = s - SvPVX(PL_linestr) - 1;
5884 while (isIDFIRST_lazy_if(s,UTF)) {
5887 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5888 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5889 if (tmp < 0) tmp = -tmp;
5904 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5906 d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
5908 /* MUST advance bufptr here to avoid bogus
5909 "at end of line" context messages from yyerror().
5911 PL_bufptr = s + len;
5912 yyerror("Unterminated attribute parameter in attribute list");
5916 return REPORT(0); /* EOF indicator */
5920 sv_catsv(sv, PL_lex_stuff);
5921 attrs = op_append_elem(OP_LIST, attrs,
5922 newSVOP(OP_CONST, 0, sv));
5923 SvREFCNT_dec(PL_lex_stuff);
5924 PL_lex_stuff = NULL;
5927 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5929 if (PL_in_my == KEY_our) {
5930 deprecate(":unique");
5933 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5936 /* NOTE: any CV attrs applied here need to be part of
5937 the CVf_BUILTIN_ATTRS define in cv.h! */
5938 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5940 CvLVALUE_on(PL_compcv);
5942 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5944 deprecate(":locked");
5946 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5948 CvMETHOD_on(PL_compcv);
5950 /* After we've set the flags, it could be argued that
5951 we don't need to do the attributes.pm-based setting
5952 process, and shouldn't bother appending recognized
5953 flags. To experiment with that, uncomment the
5954 following "else". (Note that's already been
5955 uncommented. That keeps the above-applied built-in
5956 attributes from being intercepted (and possibly
5957 rejected) by a package's attribute routines, but is
5958 justified by the performance win for the common case
5959 of applying only built-in attributes.) */
5961 attrs = op_append_elem(OP_LIST, attrs,
5962 newSVOP(OP_CONST, 0,
5966 if (*s == ':' && s[1] != ':')
5969 break; /* require real whitespace or :'s */
5970 /* XXX losing whitespace on sequential attributes here */
5974 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5975 if (*s != ';' && *s != '}' && *s != tmp
5976 && (tmp != '=' || *s != ')')) {
5977 const char q = ((*s == '\'') ? '"' : '\'');
5978 /* If here for an expression, and parsed no attrs, back
5980 if (tmp == '=' && !attrs) {
5984 /* MUST advance bufptr here to avoid bogus "at end of line"
5985 context messages from yyerror().
5988 yyerror( (const char *)
5990 ? Perl_form(aTHX_ "Invalid separator character "
5991 "%c%c%c in attribute list", q, *s, q)
5992 : "Unterminated attribute list" ) );
6000 start_force(PL_curforce);
6001 NEXTVAL_NEXTTOKE.opval = attrs;
6002 CURMAD('_', PL_nextwhite);
6007 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
6008 (s - SvPVX(PL_linestr)) - stuffstart);
6013 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6017 PL_lex_allbrackets--;
6021 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6022 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6026 PL_lex_allbrackets++;
6029 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6035 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6038 PL_lex_allbrackets--;
6044 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6047 if (PL_lex_brackets <= 0)
6048 yyerror("Unmatched right square bracket");
6051 PL_lex_allbrackets--;
6052 if (PL_lex_state == LEX_INTERPNORMAL) {
6053 if (PL_lex_brackets == 0) {
6054 if (*s == '-' && s[1] == '>')
6055 PL_lex_state = LEX_INTERPENDMAYBE;
6056 else if (*s != '[' && *s != '{')
6057 PL_lex_state = LEX_INTERPEND;
6064 if (PL_lex_brackets > 100) {
6065 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6067 switch (PL_expect) {
6069 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6070 PL_lex_allbrackets++;
6071 OPERATOR(HASHBRACK);
6073 while (s < PL_bufend && SPACE_OR_TAB(*s))
6076 PL_tokenbuf[0] = '\0';
6077 if (d < PL_bufend && *d == '-') {
6078 PL_tokenbuf[0] = '-';
6080 while (d < PL_bufend && SPACE_OR_TAB(*d))
6083 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
6084 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6086 while (d < PL_bufend && SPACE_OR_TAB(*d))
6089 const char minus = (PL_tokenbuf[0] == '-');
6090 s = force_word(s + minus, WORD, FALSE, TRUE);
6098 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6099 PL_lex_allbrackets++;
6104 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6105 PL_lex_allbrackets++;
6110 if (PL_oldoldbufptr == PL_last_lop)
6111 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6113 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6114 PL_lex_allbrackets++;
6117 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6119 /* This hack is to get the ${} in the message. */
6121 yyerror("syntax error");
6124 OPERATOR(HASHBRACK);
6126 /* This hack serves to disambiguate a pair of curlies
6127 * as being a block or an anon hash. Normally, expectation
6128 * determines that, but in cases where we're not in a
6129 * position to expect anything in particular (like inside
6130 * eval"") we have to resolve the ambiguity. This code
6131 * covers the case where the first term in the curlies is a
6132 * quoted string. Most other cases need to be explicitly
6133 * disambiguated by prepending a "+" before the opening
6134 * curly in order to force resolution as an anon hash.
6136 * XXX should probably propagate the outer expectation
6137 * into eval"" to rely less on this hack, but that could
6138 * potentially break current behavior of eval"".
6142 if (*s == '\'' || *s == '"' || *s == '`') {
6143 /* common case: get past first string, handling escapes */
6144 for (t++; t < PL_bufend && *t != *s;)
6145 if (*t++ == '\\' && (*t == '\\' || *t == *s))
6149 else if (*s == 'q') {
6152 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6153 && !isWORDCHAR(*t))))
6155 /* skip q//-like construct */
6157 char open, close, term;
6160 while (t < PL_bufend && isSPACE(*t))
6162 /* check for q => */
6163 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6164 OPERATOR(HASHBRACK);
6168 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6172 for (t++; t < PL_bufend; t++) {
6173 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6175 else if (*t == open)
6179 for (t++; t < PL_bufend; t++) {
6180 if (*t == '\\' && t+1 < PL_bufend)
6182 else if (*t == close && --brackets <= 0)
6184 else if (*t == open)
6191 /* skip plain q word */
6192 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6195 else if (isWORDCHAR_lazy_if(t,UTF)) {
6197 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6200 while (t < PL_bufend && isSPACE(*t))
6202 /* if comma follows first term, call it an anon hash */
6203 /* XXX it could be a comma expression with loop modifiers */
6204 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6205 || (*t == '=' && t[1] == '>')))
6206 OPERATOR(HASHBRACK);
6207 if (PL_expect == XREF)
6210 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6216 pl_yylval.ival = CopLINE(PL_curcop);
6217 if (isSPACE(*s) || *s == '#')
6218 PL_copline = NOLINE; /* invalidate current command line number */
6219 TOKEN(formbrack ? '=' : '{');
6221 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6225 if (PL_lex_brackets <= 0)
6226 yyerror("Unmatched right curly bracket");
6228 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6229 PL_lex_allbrackets--;
6230 if (PL_lex_state == LEX_INTERPNORMAL) {
6231 if (PL_lex_brackets == 0) {
6232 if (PL_expect & XFAKEBRACK) {
6233 PL_expect &= XENUMMASK;
6234 PL_lex_state = LEX_INTERPEND;
6239 PL_thiswhite = newSVpvs("");
6240 sv_catpvs(PL_thiswhite,"}");
6243 return yylex(); /* ignore fake brackets */
6245 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6246 && SvEVALED(PL_lex_repl))
6247 PL_lex_state = LEX_INTERPEND;
6248 else if (*s == '-' && s[1] == '>')
6249 PL_lex_state = LEX_INTERPENDMAYBE;
6250 else if (*s != '[' && *s != '{')
6251 PL_lex_state = LEX_INTERPEND;
6254 if (PL_expect & XFAKEBRACK) {
6255 PL_expect &= XENUMMASK;
6257 return yylex(); /* ignore fake brackets */
6259 start_force(PL_curforce);
6261 curmad('X', newSVpvn(s-1,1));
6262 CURMAD('_', PL_thiswhite);
6264 force_next(formbrack ? '.' : '}');
6265 if (formbrack) LEAVE;
6267 if (PL_madskills && !PL_thistoken)
6268 PL_thistoken = newSVpvs("");
6270 if (formbrack == 2) { /* means . where arguments were expected */
6271 start_force(PL_curforce);
6279 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6280 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6287 if (PL_expect == XOPERATOR) {
6288 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
6289 && isIDFIRST_lazy_if(s,UTF))
6291 CopLINE_dec(PL_curcop);
6292 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6293 CopLINE_inc(PL_curcop);
6295 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6296 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6300 PL_parser->saw_infix_sigil = 1;
6304 PL_tokenbuf[0] = '&';
6305 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
6306 sizeof PL_tokenbuf - 1, TRUE);
6307 if (PL_tokenbuf[1]) {
6308 PL_expect = XOPERATOR;
6309 force_ident_maybe_lex('&');
6313 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6319 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6320 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6327 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6328 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6336 const char tmp = *s++;
6338 if (!PL_lex_allbrackets &&
6339 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6346 if (!PL_lex_allbrackets &&
6347 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
6355 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6356 && strchr("+-*/%.^&|<",tmp))
6357 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6358 "Reversed %c= operator",(int)tmp);
6360 if (PL_expect == XSTATE && isALPHA(tmp) &&
6361 (s == PL_linestart+1 || s[-2] == '\n') )
6363 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6364 || PL_lex_state != LEX_NORMAL) {
6369 if (strnEQ(s,"=cut",4)) {
6385 PL_thiswhite = newSVpvs("");
6386 sv_catpvn(PL_thiswhite, PL_linestart,
6387 PL_bufend - PL_linestart);
6391 PL_parser->in_pod = 1;
6395 if (PL_expect == XBLOCK) {
6397 #ifdef PERL_STRICT_CR
6398 while (SPACE_OR_TAB(*t))
6400 while (SPACE_OR_TAB(*t) || *t == '\r')
6403 if (*t == '\n' || *t == '#') {
6406 SAVEI8(PL_parser->form_lex_state);
6407 SAVEI32(PL_lex_formbrack);
6408 PL_parser->form_lex_state = PL_lex_state;
6409 PL_lex_formbrack = PL_lex_brackets + 1;
6413 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6422 const char tmp = *s++;
6424 /* was this !=~ where !~ was meant?
6425 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6427 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6428 const char *t = s+1;
6430 while (t < PL_bufend && isSPACE(*t))
6433 if (*t == '/' || *t == '?' ||
6434 ((*t == 'm' || *t == 's' || *t == 'y')
6435 && !isWORDCHAR(t[1])) ||
6436 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6437 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6438 "!=~ should be !~");
6440 if (!PL_lex_allbrackets &&
6441 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6453 if (PL_expect != XOPERATOR) {
6454 if (s[1] != '<' && !strchr(s,'>'))
6457 s = scan_heredoc(s);
6459 s = scan_inputsymbol(s);
6460 PL_expect = XOPERATOR;
6461 TOKEN(sublex_start());
6467 if (*s == '=' && !PL_lex_allbrackets &&
6468 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6472 SHop(OP_LEFT_SHIFT);
6477 if (!PL_lex_allbrackets &&
6478 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6485 if (!PL_lex_allbrackets &&
6486 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6494 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6502 const char tmp = *s++;
6504 if (*s == '=' && !PL_lex_allbrackets &&
6505 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6509 SHop(OP_RIGHT_SHIFT);
6511 else if (tmp == '=') {
6512 if (!PL_lex_allbrackets &&
6513 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6521 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6530 if (PL_expect == XOPERATOR) {
6531 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6532 return deprecate_commaless_var_list();
6536 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6537 PL_tokenbuf[0] = '@';
6538 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6539 sizeof PL_tokenbuf - 1, FALSE);
6540 if (PL_expect == XOPERATOR)
6541 no_op("Array length", s);
6542 if (!PL_tokenbuf[1])
6544 PL_expect = XOPERATOR;
6545 force_ident_maybe_lex('#');
6549 PL_tokenbuf[0] = '$';
6550 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6551 sizeof PL_tokenbuf - 1, FALSE);
6552 if (PL_expect == XOPERATOR)
6554 if (!PL_tokenbuf[1]) {
6556 yyerror("Final $ should be \\$ or $name");
6562 const char tmp = *s;
6563 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6566 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6567 && intuit_more(s)) {
6569 PL_tokenbuf[0] = '@';
6570 if (ckWARN(WARN_SYNTAX)) {
6573 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6576 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6577 while (t < PL_bufend && *t != ']')
6579 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6580 "Multidimensional syntax %.*s not supported",
6581 (int)((t - PL_bufptr) + 1), PL_bufptr);
6585 else if (*s == '{') {
6587 PL_tokenbuf[0] = '%';
6588 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6589 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6591 char tmpbuf[sizeof PL_tokenbuf];
6594 } while (isSPACE(*t));
6595 if (isIDFIRST_lazy_if(t,UTF)) {
6597 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6602 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6603 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6604 "You need to quote \"%"UTF8f"\"",
6605 UTF8fARG(UTF, len, tmpbuf));
6611 PL_expect = XOPERATOR;
6612 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6613 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6614 if (!islop || PL_last_lop_op == OP_GREPSTART)
6615 PL_expect = XOPERATOR;
6616 else if (strchr("$@\"'`q", *s))
6617 PL_expect = XTERM; /* e.g. print $fh "foo" */
6618 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6619 PL_expect = XTERM; /* e.g. print $fh &sub */
6620 else if (isIDFIRST_lazy_if(s,UTF)) {
6621 char tmpbuf[sizeof PL_tokenbuf];
6623 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6624 if ((t2 = keyword(tmpbuf, len, 0))) {
6625 /* binary operators exclude handle interpretations */
6637 PL_expect = XTERM; /* e.g. print $fh length() */
6642 PL_expect = XTERM; /* e.g. print $fh subr() */
6645 else if (isDIGIT(*s))
6646 PL_expect = XTERM; /* e.g. print $fh 3 */
6647 else if (*s == '.' && isDIGIT(s[1]))
6648 PL_expect = XTERM; /* e.g. print $fh .3 */
6649 else if ((*s == '?' || *s == '-' || *s == '+')
6650 && !isSPACE(s[1]) && s[1] != '=')
6651 PL_expect = XTERM; /* e.g. print $fh -1 */
6652 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6654 PL_expect = XTERM; /* e.g. print $fh /.../
6655 XXX except DORDOR operator
6657 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6659 PL_expect = XTERM; /* print $fh <<"EOF" */
6662 force_ident_maybe_lex('$');
6666 if (PL_expect == XOPERATOR)
6668 PL_tokenbuf[0] = '@';
6669 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6670 if (!PL_tokenbuf[1]) {
6673 if (PL_lex_state == LEX_NORMAL)
6675 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6677 PL_tokenbuf[0] = '%';
6679 /* Warn about @ where they meant $. */
6680 if (*s == '[' || *s == '{') {
6681 if (ckWARN(WARN_SYNTAX)) {
6682 const char *t = s + 1;
6683 while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6684 t += UTF ? UTF8SKIP(t) : 1;
6685 if (*t == '}' || *t == ']') {
6687 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6688 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
6689 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6690 "Scalar value %"UTF8f" better written as $%"UTF8f,
6691 UTF8fARG(UTF, t-PL_bufptr, PL_bufptr),
6692 UTF8fARG(UTF, t-PL_bufptr-1, PL_bufptr+1));
6697 PL_expect = XOPERATOR;
6698 force_ident_maybe_lex('@');
6701 case '/': /* may be division, defined-or, or pattern */
6702 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6703 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6704 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6709 case '?': /* may either be conditional or pattern */
6710 if (PL_expect == XOPERATOR) {
6713 if (!PL_lex_allbrackets &&
6714 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6718 PL_lex_allbrackets++;
6724 /* A // operator. */
6725 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6726 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6727 LEX_FAKEEOF_LOGIC)) {
6735 if (*s == '=' && !PL_lex_allbrackets &&
6736 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6745 /* Disable warning on "study /blah/" */
6746 if (PL_oldoldbufptr == PL_last_uni
6747 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6748 || memNE(PL_last_uni, "study", 5)
6749 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6753 deprecate("?PATTERN? without explicit operator");
6754 s = scan_pat(s,OP_MATCH);
6755 TERM(sublex_start());
6759 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6760 #ifdef PERL_STRICT_CR
6763 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6765 && (s == PL_linestart || s[-1] == '\n') )
6768 formbrack = 2; /* dot seen where arguments expected */
6771 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6775 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6778 if (!PL_lex_allbrackets &&
6779 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6786 pl_yylval.ival = OPf_SPECIAL;
6792 if (*s == '=' && !PL_lex_allbrackets &&
6793 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6800 case '0': case '1': case '2': case '3': case '4':
6801 case '5': case '6': case '7': case '8': case '9':
6802 s = scan_num(s, &pl_yylval);
6803 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6804 if (PL_expect == XOPERATOR)
6809 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6810 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6811 if (PL_expect == XOPERATOR) {
6812 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6813 return deprecate_commaless_var_list();
6820 pl_yylval.ival = OP_CONST;
6821 TERM(sublex_start());
6824 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6825 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6826 if (PL_expect == XOPERATOR) {
6827 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6828 return deprecate_commaless_var_list();
6835 pl_yylval.ival = OP_CONST;
6836 /* FIXME. I think that this can be const if char *d is replaced by
6837 more localised variables. */
6838 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6839 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6840 pl_yylval.ival = OP_STRINGIFY;
6844 TERM(sublex_start());
6847 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6848 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6849 if (PL_expect == XOPERATOR)
6850 no_op("Backticks",s);
6853 readpipe_override();
6854 TERM(sublex_start());
6858 if (PL_lex_inwhat && isDIGIT(*s))
6859 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6861 if (PL_expect == XOPERATOR)
6862 no_op("Backslash",s);
6866 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6867 char *start = s + 2;
6868 while (isDIGIT(*start) || *start == '_')
6870 if (*start == '.' && isDIGIT(start[1])) {
6871 s = scan_num(s, &pl_yylval);
6874 else if ((*start == ':' && start[1] == ':')
6875 || (PL_expect == XSTATE && *start == ':'))
6877 else if (PL_expect == XSTATE) {
6879 while (d < PL_bufend && isSPACE(*d)) d++;
6880 if (*d == ':') goto keylookup;
6882 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6883 if (!isALPHA(*start) && (PL_expect == XTERM
6884 || PL_expect == XREF || PL_expect == XSTATE
6885 || PL_expect == XTERMORDORDOR)) {
6886 GV *const gv = gv_fetchpvn_flags(s, start - s,
6887 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6889 s = scan_num(s, &pl_yylval);
6896 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6949 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6951 /* Some keywords can be followed by any delimiter, including ':' */
6952 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6954 /* x::* is just a word, unless x is "CORE" */
6955 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6959 while (d < PL_bufend && isSPACE(*d))
6960 d++; /* no comments skipped here, or s### is misparsed */
6962 /* Is this a word before a => operator? */
6963 if (*d == '=' && d[1] == '>') {
6966 = (OP*)newSVOP(OP_CONST, 0,
6967 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6968 pl_yylval.opval->op_private = OPpCONST_BARE;
6972 /* Check for plugged-in keyword */
6976 char *saved_bufptr = PL_bufptr;
6978 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6980 if (result == KEYWORD_PLUGIN_DECLINE) {
6981 /* not a plugged-in keyword */
6982 PL_bufptr = saved_bufptr;
6983 } else if (result == KEYWORD_PLUGIN_STMT) {
6984 pl_yylval.opval = o;
6987 return REPORT(PLUGSTMT);
6988 } else if (result == KEYWORD_PLUGIN_EXPR) {
6989 pl_yylval.opval = o;
6991 PL_expect = XOPERATOR;
6992 return REPORT(PLUGEXPR);
6994 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6999 /* Check for built-in keyword */
7000 tmp = keyword(PL_tokenbuf, len, 0);
7002 /* Is this a label? */
7003 if (!anydelim && PL_expect == XSTATE
7004 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
7006 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
7007 pl_yylval.pval[len] = '\0';
7008 pl_yylval.pval[len+1] = UTF ? 1 : 0;
7013 /* Check for lexical sub */
7014 if (PL_expect != XOPERATOR) {
7015 char tmpbuf[sizeof PL_tokenbuf + 1];
7017 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7018 off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
7019 if (off != NOT_IN_PAD) {
7020 assert(off); /* we assume this is boolean-true below */
7021 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7022 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7023 HEK * const stashname = HvNAME_HEK(stash);
7024 sv = newSVhek(stashname);
7025 sv_catpvs(sv, "::");
7026 sv_catpvn_flags(sv, PL_tokenbuf, len,
7027 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7028 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7038 rv2cv_op = newOP(OP_PADANY, 0);
7039 rv2cv_op->op_targ = off;
7040 cv = find_lexical_cv(off);
7048 if (tmp < 0) { /* second-class keyword? */
7049 GV *ogv = NULL; /* override (winner) */
7050 GV *hgv = NULL; /* hidden (loser) */
7051 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7053 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7054 UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
7057 if (GvIMPORTED_CV(gv))
7059 else if (! CvMETHOD(cv))
7063 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7064 UTF ? -(I32)len : (I32)len, FALSE)) &&
7065 (gv = *gvp) && isGV_with_GP(gv) &&
7066 GvCVu(gv) && GvIMPORTED_CV(gv))
7073 tmp = 0; /* overridden by import or by GLOBAL */
7076 && -tmp==KEY_lock /* XXX generalizable kludge */
7079 tmp = 0; /* any sub overrides "weak" keyword */
7081 else { /* no override */
7083 if (tmp == KEY_dump) {
7084 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
7085 "dump() better written as CORE::dump()");
7089 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
7090 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7091 "Ambiguous call resolved as CORE::%s(), "
7092 "qualify as such or use &",
7100 default: /* not a keyword */
7101 /* Trade off - by using this evil construction we can pull the
7102 variable gv into the block labelled keylookup. If not, then
7103 we have to give it function scope so that the goto from the
7104 earlier ':' case doesn't bypass the initialisation. */
7106 just_a_word_zero_gv:
7118 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7119 const char penultchar =
7120 lastchar && PL_bufptr - 2 >= PL_linestart
7124 SV *nextPL_nextwhite = 0;
7128 /* Get the rest if it looks like a package qualifier */
7130 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7132 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7135 Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
7136 UTF8fARG(UTF, len, PL_tokenbuf),
7137 *s == '\'' ? "'" : "::");
7142 if (PL_expect == XOPERATOR) {
7143 if (PL_bufptr == PL_linestart) {
7144 CopLINE_dec(PL_curcop);
7145 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7146 CopLINE_inc(PL_curcop);
7149 no_op("Bareword",s);
7152 /* Look for a subroutine with this name in current package,
7153 unless this is a lexical sub, or name is "Foo::",
7154 in which case Foo is a bareword
7155 (and a package name). */
7157 if (len > 2 && !PL_madskills &&
7158 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
7160 if (ckWARN(WARN_BAREWORD)
7161 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7162 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7163 "Bareword \"%"UTF8f"\" refers to nonexistent package",
7164 UTF8fARG(UTF, len, PL_tokenbuf));
7166 PL_tokenbuf[len] = '\0';
7172 /* Mustn't actually add anything to a symbol table.
7173 But also don't want to "initialise" any placeholder
7174 constants that might already be there into full
7175 blown PVGVs with attached PVCV. */
7176 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7177 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
7183 /* if we saw a global override before, get the right name */
7186 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7187 len ? len : strlen(PL_tokenbuf));
7189 SV * const tmp_sv = sv;
7190 sv = newSVpvs("CORE::GLOBAL::");
7191 sv_catsv(sv, tmp_sv);
7192 SvREFCNT_dec(tmp_sv);
7196 if (PL_madskills && !PL_thistoken) {
7197 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
7198 PL_thistoken = newSVpvn(start,s - start);
7199 PL_realtokenstart = s - SvPVX(PL_linestr);
7203 /* Presume this is going to be a bareword of some sort. */
7205 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
7206 pl_yylval.opval->op_private = OPpCONST_BARE;
7208 /* And if "Foo::", then that's what it certainly is. */
7214 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7215 const_op->op_private = OPpCONST_BARE;
7216 rv2cv_op = newCVREF(0, const_op);
7217 cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
7220 /* See if it's the indirect object for a list operator. */
7222 if (PL_oldoldbufptr &&
7223 PL_oldoldbufptr < PL_bufptr &&
7224 (PL_oldoldbufptr == PL_last_lop
7225 || PL_oldoldbufptr == PL_last_uni) &&
7226 /* NO SKIPSPACE BEFORE HERE! */
7227 (PL_expect == XREF ||
7228 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
7230 bool immediate_paren = *s == '(';
7232 /* (Now we can afford to cross potential line boundary.) */
7233 s = SKIPSPACE2(s,nextPL_nextwhite);
7235 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
7238 /* Two barewords in a row may indicate method call. */
7240 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
7241 (tmp = intuit_method(s, gv, cv))) {
7243 if (tmp == METHOD && !PL_lex_allbrackets &&
7244 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7245 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7249 /* If not a declared subroutine, it's an indirect object. */
7250 /* (But it's an indir obj regardless for sort.) */
7251 /* Also, if "_" follows a filetest operator, it's a bareword */
7254 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
7256 (PL_last_lop_op != OP_MAPSTART &&
7257 PL_last_lop_op != OP_GREPSTART))))
7258 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7259 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
7262 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7267 PL_expect = XOPERATOR;
7270 s = SKIPSPACE2(s,nextPL_nextwhite);
7271 PL_nextwhite = nextPL_nextwhite;
7276 /* Is this a word before a => operator? */
7277 if (*s == '=' && s[1] == '>' && !pkgname) {
7280 /* This is our own scalar, created a few lines above,
7282 SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv);
7283 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
7284 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
7285 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
7286 SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv);
7290 /* If followed by a paren, it's certainly a subroutine. */
7295 while (SPACE_OR_TAB(*d))
7297 if (*d == ')' && (sv = cv_const_sv(cv))) {
7304 PL_nextwhite = PL_thiswhite;
7307 start_force(PL_curforce);
7309 NEXTVAL_NEXTTOKE.opval =
7310 off ? rv2cv_op : pl_yylval.opval;
7311 PL_expect = XOPERATOR;
7314 PL_nextwhite = nextPL_nextwhite;
7315 curmad('X', PL_thistoken);
7316 PL_thistoken = newSVpvs("");
7320 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7321 else op_free(rv2cv_op), force_next(WORD);
7326 /* If followed by var or block, call it a method (unless sub) */
7328 if ((*s == '$' || *s == '{') && !cv) {
7330 PL_last_lop = PL_oldbufptr;
7331 PL_last_lop_op = OP_METHOD;
7332 if (!PL_lex_allbrackets &&
7333 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7334 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7338 /* If followed by a bareword, see if it looks like indir obj. */
7341 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
7342 && (tmp = intuit_method(s, gv, cv))) {
7344 if (tmp == METHOD && !PL_lex_allbrackets &&
7345 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7346 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7350 /* Not a method, so call it a subroutine (if defined) */
7353 if (lastchar == '-' && penultchar != '-') {
7354 const STRLEN l = len ? len : strlen(PL_tokenbuf);
7355 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7356 "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()",
7357 UTF8fARG(UTF, l, PL_tokenbuf),
7358 UTF8fARG(UTF, l, PL_tokenbuf));
7360 /* Check for a constant sub */
7361 if ((sv = cv_const_sv(cv))) {
7364 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7365 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7366 pl_yylval.opval->op_private = OPpCONST_FOLDED;
7367 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7371 op_free(pl_yylval.opval);
7373 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7374 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7375 PL_last_lop = PL_oldbufptr;
7376 PL_last_lop_op = OP_ENTERSUB;
7377 /* Is there a prototype? */
7384 STRLEN protolen = CvPROTOLEN(cv);
7385 const char *proto = CvPROTO(cv);
7387 proto = S_strip_spaces(aTHX_ proto, &protolen);
7390 if ((optional = *proto == ';'))
7393 while (*proto == ';');
7397 *proto == '$' || *proto == '_'
7398 || *proto == '*' || *proto == '+'
7403 *proto == '\\' && proto[1] && proto[2] == '\0'
7406 UNIPROTO(UNIOPSUB,optional);
7407 if (*proto == '\\' && proto[1] == '[') {
7408 const char *p = proto + 2;
7409 while(*p && *p != ']')
7411 if(*p == ']' && !p[1])
7412 UNIPROTO(UNIOPSUB,optional);
7414 if (*proto == '&' && *s == '{') {
7416 sv_setpvs(PL_subname, "__ANON__");
7418 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7419 if (!PL_lex_allbrackets &&
7420 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7421 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7428 PL_nextwhite = PL_thiswhite;
7431 start_force(PL_curforce);
7432 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7435 PL_nextwhite = nextPL_nextwhite;
7436 curmad('X', PL_thistoken);
7437 PL_thistoken = newSVpvs("");
7439 force_next(off ? PRIVATEREF : WORD);
7440 if (!PL_lex_allbrackets &&
7441 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7442 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7447 /* Guess harder when madskills require "best effort". */
7448 if (PL_madskills && (!gv || !GvCVu(gv))) {
7449 int probable_sub = 0;
7450 if (strchr("\"'`$@%0123456789!*+{[<", *s))
7452 else if (isALPHA(*s)) {
7456 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
7457 if (!keyword(tmpbuf, tmplen, 0))
7460 while (d < PL_bufend && isSPACE(*d))
7462 if (*d == '=' && d[1] == '>')
7467 gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
7469 op_free(pl_yylval.opval);
7471 off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7472 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7473 PL_last_lop = PL_oldbufptr;
7474 PL_last_lop_op = OP_ENTERSUB;
7475 PL_nextwhite = PL_thiswhite;
7477 start_force(PL_curforce);
7478 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7480 PL_nextwhite = nextPL_nextwhite;
7481 curmad('X', PL_thistoken);
7482 PL_thistoken = newSVpvs("");
7483 force_next(off ? PRIVATEREF : WORD);
7484 if (!PL_lex_allbrackets &&
7485 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7486 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7490 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7492 force_next(off ? PRIVATEREF : WORD);
7493 if (!PL_lex_allbrackets &&
7494 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7495 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7500 /* Call it a bare word */
7502 if (PL_hints & HINT_STRICT_SUBS)
7503 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7506 /* after "print" and similar functions (corresponding to
7507 * "F? L" in opcode.pl), whatever wasn't already parsed as
7508 * a filehandle should be subject to "strict subs".
7509 * Likewise for the optional indirect-object argument to system
7510 * or exec, which can't be a bareword */
7511 if ((PL_last_lop_op == OP_PRINT
7512 || PL_last_lop_op == OP_PRTF
7513 || PL_last_lop_op == OP_SAY
7514 || PL_last_lop_op == OP_SYSTEM
7515 || PL_last_lop_op == OP_EXEC)
7516 && (PL_hints & HINT_STRICT_SUBS))
7517 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7518 if (lastchar != '-') {
7519 if (ckWARN(WARN_RESERVED)) {
7523 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7524 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7532 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7533 && saw_infix_sigil) {
7534 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7535 "Operator or semicolon missing before %c%"UTF8f,
7537 UTF8fARG(UTF, strlen(PL_tokenbuf),
7539 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7540 "Ambiguous use of %c resolved as operator %c",
7541 lastchar, lastchar);
7548 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7553 (OP*)newSVOP(OP_CONST, 0,
7554 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7557 case KEY___PACKAGE__:
7559 (OP*)newSVOP(OP_CONST, 0,
7561 ? newSVhek(HvNAME_HEK(PL_curstash))
7568 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7569 const char *pname = "main";
7572 if (PL_tokenbuf[2] == 'D')
7575 PL_curstash ? PL_curstash : PL_defstash;
7576 pname = HvNAME_get(stash);
7577 plen = HvNAMELEN (stash);
7578 if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
7580 gv = gv_fetchpvn_flags(
7581 Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
7582 plen+6, GV_ADD|putf8, SVt_PVIO
7586 GvIOp(gv) = newIO();
7587 IoIFP(GvIOp(gv)) = PL_rsfp;
7588 #if defined(HAS_FCNTL) && defined(F_SETFD)
7590 const int fd = PerlIO_fileno(PL_rsfp);
7591 fcntl(fd,F_SETFD,fd >= 3);
7594 /* Mark this internal pseudo-handle as clean */
7595 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7596 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7597 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7599 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7600 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7601 /* if the script was opened in binmode, we need to revert
7602 * it to text mode for compatibility; but only iff it has CRs
7603 * XXX this is a questionable hack at best. */
7604 if (PL_bufend-PL_bufptr > 2
7605 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7608 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7609 loc = PerlIO_tell(PL_rsfp);
7610 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7613 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7615 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7616 #endif /* NETWARE */
7618 PerlIO_seek(PL_rsfp, loc, 0);
7622 #ifdef PERLIO_LAYERS
7625 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7626 else if (PL_encoding) {
7633 XPUSHs(PL_encoding);
7635 call_method("name", G_SCALAR);
7639 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7640 Perl_form(aTHX_ ":encoding(%"SVf")",
7649 if (PL_realtokenstart >= 0) {
7650 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7652 PL_endwhite = newSVpvs("");
7653 sv_catsv(PL_endwhite, PL_thiswhite);
7655 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7656 PL_realtokenstart = -1;
7658 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7668 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
7677 if (PL_expect == XSTATE) {
7684 if (*s == ':' && s[1] == ':') {
7688 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7689 if ((*s == ':' && s[1] == ':')
7690 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7694 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7698 Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
7699 UTF8fARG(UTF, len, PL_tokenbuf));
7702 else if (tmp == KEY_require || tmp == KEY_do
7704 /* that's a way to remember we saw "CORE::" */
7717 LOP(OP_ACCEPT,XTERM);
7720 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7725 LOP(OP_ATAN2,XTERM);
7731 LOP(OP_BINMODE,XTERM);
7734 LOP(OP_BLESS,XTERM);
7743 /* We have to disambiguate the two senses of
7744 "continue". If the next token is a '{' then
7745 treat it as the start of a continue block;
7746 otherwise treat it as a control operator.
7756 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7766 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7775 if (!PL_cryptseen) {
7776 PL_cryptseen = TRUE;
7780 LOP(OP_CRYPT,XTERM);
7783 LOP(OP_CHMOD,XTERM);
7786 LOP(OP_CHOWN,XTERM);
7789 LOP(OP_CONNECT,XTERM);
7809 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7811 if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
7814 force_ident_maybe_lex('&');
7819 if (orig_keyword == KEY_do) {
7828 PL_hints |= HINT_BLOCK_SCOPE;
7838 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7839 STR_WITH_LEN("NDBM_File::"),
7840 STR_WITH_LEN("DB_File::"),
7841 STR_WITH_LEN("GDBM_File::"),
7842 STR_WITH_LEN("SDBM_File::"),
7843 STR_WITH_LEN("ODBM_File::"),
7845 LOP(OP_DBMOPEN,XTERM);
7851 PL_expect = XOPERATOR;
7852 s = force_word(s,WORD,TRUE,FALSE);
7859 pl_yylval.ival = CopLINE(PL_curcop);
7863 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7877 if (*s == '{') { /* block eval */
7878 PL_expect = XTERMBLOCK;
7879 UNIBRACK(OP_ENTERTRY);
7881 else { /* string eval */
7883 UNIBRACK(OP_ENTEREVAL);
7888 UNIBRACK(-OP_ENTEREVAL);
7902 case KEY_endhostent:
7908 case KEY_endservent:
7911 case KEY_endprotoent:
7922 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7924 pl_yylval.ival = CopLINE(PL_curcop);
7926 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7929 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7932 if ((PL_bufend - p) >= 3 &&
7933 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7935 else if ((PL_bufend - p) >= 4 &&
7936 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7939 if (isIDFIRST_lazy_if(p,UTF)) {
7940 p = scan_ident(p, PL_bufend,
7941 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7945 Perl_croak(aTHX_ "Missing $ on loop variable");
7947 s = SvPVX(PL_linestr) + soff;
7953 LOP(OP_FORMLINE,XTERM);
7962 LOP(OP_FCNTL,XTERM);
7968 LOP(OP_FLOCK,XTERM);
7971 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7976 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7981 LOP(OP_GREPSTART, XREF);
7984 PL_expect = XOPERATOR;
7985 s = force_word(s,WORD,TRUE,FALSE);
8000 case KEY_getpriority:
8001 LOP(OP_GETPRIORITY,XTERM);
8003 case KEY_getprotobyname:
8006 case KEY_getprotobynumber:
8007 LOP(OP_GPBYNUMBER,XTERM);
8009 case KEY_getprotoent:
8021 case KEY_getpeername:
8022 UNI(OP_GETPEERNAME);
8024 case KEY_gethostbyname:
8027 case KEY_gethostbyaddr:
8028 LOP(OP_GHBYADDR,XTERM);
8030 case KEY_gethostent:
8033 case KEY_getnetbyname:
8036 case KEY_getnetbyaddr:
8037 LOP(OP_GNBYADDR,XTERM);
8042 case KEY_getservbyname:
8043 LOP(OP_GSBYNAME,XTERM);
8045 case KEY_getservbyport:
8046 LOP(OP_GSBYPORT,XTERM);
8048 case KEY_getservent:
8051 case KEY_getsockname:
8052 UNI(OP_GETSOCKNAME);
8054 case KEY_getsockopt:
8055 LOP(OP_GSOCKOPT,XTERM);
8070 pl_yylval.ival = CopLINE(PL_curcop);
8071 Perl_ck_warner_d(aTHX_
8072 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8073 "given is experimental");
8078 orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
8086 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8088 pl_yylval.ival = CopLINE(PL_curcop);
8092 LOP(OP_INDEX,XTERM);
8098 LOP(OP_IOCTL,XTERM);
8110 PL_expect = XOPERATOR;
8111 s = force_word(s,WORD,TRUE,FALSE);
8128 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8133 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8147 LOP(OP_LISTEN,XTERM);
8156 s = scan_pat(s,OP_MATCH);
8157 TERM(sublex_start());
8160 LOP(OP_MAPSTART, XREF);
8163 LOP(OP_MKDIR,XTERM);
8166 LOP(OP_MSGCTL,XTERM);
8169 LOP(OP_MSGGET,XTERM);
8172 LOP(OP_MSGRCV,XTERM);
8175 LOP(OP_MSGSND,XTERM);
8180 PL_in_my = (U16)tmp;
8182 if (isIDFIRST_lazy_if(s,UTF)) {
8186 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8187 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
8189 if (!FEATURE_LEXSUBS_IS_ENABLED)
8191 "Experimental \"%s\" subs not enabled",
8192 tmp == KEY_my ? "my" :
8193 tmp == KEY_state ? "state" : "our");
8194 Perl_ck_warner_d(aTHX_
8195 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
8196 "The lexical_subs feature is experimental");
8199 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8200 if (!PL_in_my_stash) {
8203 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8204 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8207 if (PL_madskills) { /* just add type to declarator token */
8208 sv_catsv(PL_thistoken, PL_nextwhite);
8210 sv_catpvn(PL_thistoken, start, s - start);
8218 PL_expect = XOPERATOR;
8219 s = force_word(s,WORD,TRUE,FALSE);
8223 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8228 s = tokenize_use(0, s);
8232 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
8235 if (!PL_lex_allbrackets &&
8236 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8237 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8243 if (isIDFIRST_lazy_if(s,UTF)) {
8245 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8247 for (t=d; isSPACE(*t);)
8249 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8251 && !(t[0] == '=' && t[1] == '>')
8252 && !(t[0] == ':' && t[1] == ':')
8253 && !keyword(s, d-s, 0)
8255 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8256 "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
8257 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8263 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8265 pl_yylval.ival = OP_OR;
8275 LOP(OP_OPEN_DIR,XTERM);
8278 checkcomma(s,PL_tokenbuf,"filehandle");
8282 checkcomma(s,PL_tokenbuf,"filehandle");
8301 s = force_word(s,WORD,FALSE,TRUE);
8303 s = force_strict_version(s);
8304 PL_lex_expect = XBLOCK;
8308 LOP(OP_PIPE_OP,XTERM);
8311 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8314 pl_yylval.ival = OP_CONST;
8315 TERM(sublex_start());
8322 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8325 PL_expect = XOPERATOR;
8326 if (SvCUR(PL_lex_stuff)) {
8327 int warned_comma = !ckWARN(WARN_QW);
8328 int warned_comment = warned_comma;
8329 d = SvPV_force(PL_lex_stuff, len);
8331 for (; isSPACE(*d) && len; --len, ++d)
8336 if (!warned_comma || !warned_comment) {
8337 for (; !isSPACE(*d) && len; --len, ++d) {
8338 if (!warned_comma && *d == ',') {
8339 Perl_warner(aTHX_ packWARN(WARN_QW),
8340 "Possible attempt to separate words with commas");
8343 else if (!warned_comment && *d == '#') {
8344 Perl_warner(aTHX_ packWARN(WARN_QW),
8345 "Possible attempt to put comments in qw() list");
8351 for (; !isSPACE(*d) && len; --len, ++d)
8354 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8355 words = op_append_elem(OP_LIST, words,
8356 newSVOP(OP_CONST, 0, tokeq(sv)));
8361 words = newNULLLIST();
8363 SvREFCNT_dec(PL_lex_stuff);
8364 PL_lex_stuff = NULL;
8366 PL_expect = XOPERATOR;
8367 pl_yylval.opval = sawparens(words);
8372 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8375 pl_yylval.ival = OP_STRINGIFY;
8376 if (SvIVX(PL_lex_stuff) == '\'')
8377 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8378 TERM(sublex_start());
8381 s = scan_pat(s,OP_QR);
8382 TERM(sublex_start());
8385 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8388 readpipe_override();
8389 TERM(sublex_start());
8396 PL_expect = XOPERATOR;
8398 s = force_version(s, FALSE);
8400 else if (*s != 'v' || !isDIGIT(s[1])
8401 || (s = force_version(s, TRUE), *s == 'v'))
8403 *PL_tokenbuf = '\0';
8404 s = force_word(s,WORD,TRUE,TRUE);
8405 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
8406 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8407 GV_ADD | (UTF ? SVf_UTF8 : 0));
8409 yyerror("<> should be quotes");
8411 if (orig_keyword == KEY_require) {
8419 PL_last_uni = PL_oldbufptr;
8420 PL_last_lop_op = OP_REQUIRE;
8422 return REPORT( (int)REQUIRE );
8428 PL_expect = XOPERATOR;
8429 s = force_word(s,WORD,TRUE,FALSE);
8433 LOP(OP_RENAME,XTERM);
8442 LOP(OP_RINDEX,XTERM);
8451 UNIDOR(OP_READLINE);
8454 UNIDOR(OP_BACKTICK);
8463 LOP(OP_REVERSE,XTERM);
8466 UNIDOR(OP_READLINK);
8473 if (pl_yylval.opval)
8474 TERM(sublex_start());
8476 TOKEN(1); /* force error */
8479 checkcomma(s,PL_tokenbuf,"filehandle");
8489 LOP(OP_SELECT,XTERM);
8495 LOP(OP_SEMCTL,XTERM);
8498 LOP(OP_SEMGET,XTERM);
8501 LOP(OP_SEMOP,XTERM);
8507 LOP(OP_SETPGRP,XTERM);
8509 case KEY_setpriority:
8510 LOP(OP_SETPRIORITY,XTERM);
8512 case KEY_sethostent:
8518 case KEY_setservent:
8521 case KEY_setprotoent:
8531 LOP(OP_SEEKDIR,XTERM);
8533 case KEY_setsockopt:
8534 LOP(OP_SSOCKOPT,XTERM);
8540 LOP(OP_SHMCTL,XTERM);
8543 LOP(OP_SHMGET,XTERM);
8546 LOP(OP_SHMREAD,XTERM);
8549 LOP(OP_SHMWRITE,XTERM);
8552 LOP(OP_SHUTDOWN,XTERM);
8561 LOP(OP_SOCKET,XTERM);
8563 case KEY_socketpair:
8564 LOP(OP_SOCKPAIR,XTERM);
8567 checkcomma(s,PL_tokenbuf,"subroutine name");
8570 s = force_word(s,WORD,TRUE,TRUE);
8574 LOP(OP_SPLIT,XTERM);
8577 LOP(OP_SPRINTF,XTERM);
8580 LOP(OP_SPLICE,XTERM);
8595 LOP(OP_SUBSTR,XTERM);
8601 char * const tmpbuf = PL_tokenbuf + 1;
8602 expectation attrful;
8603 bool have_name, have_proto;
8604 const int key = tmp;
8606 SV *format_name = NULL;
8612 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
8613 SV *subtoken = PL_madskills
8614 ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr))
8619 s = SKIPSPACE2(s,tmpwhite);
8625 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
8626 (*s == ':' && s[1] == ':'))
8629 SV *nametoke = NULL;
8633 attrful = XATTRBLOCK;
8634 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8638 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
8640 if (key == KEY_format)
8641 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8644 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8646 PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
8648 sv_setpvn(PL_subname, tmpbuf, len);
8650 sv_setsv(PL_subname,PL_curstname);
8651 sv_catpvs(PL_subname,"::");
8652 sv_catpvn(PL_subname,tmpbuf,len);
8654 if (SvUTF8(PL_linestr))
8655 SvUTF8_on(PL_subname);
8661 CURMAD('X', nametoke);
8662 CURMAD('_', tmpwhite);
8663 force_ident_maybe_lex('&');
8665 s = SKIPSPACE2(d,tmpwhite);
8671 if (key == KEY_my || key == KEY_our || key==KEY_state)
8674 /* diag_listed_as: Missing name in "%s sub" */
8676 "Missing name in \"%s\"", PL_bufptr);
8678 PL_expect = XTERMBLOCK;
8679 attrful = XATTRTERM;
8680 sv_setpvs(PL_subname,"?");
8684 if (key == KEY_format) {
8686 PL_thistoken = subtoken;
8690 start_force(PL_curforce);
8691 NEXTVAL_NEXTTOKE.opval
8692 = (OP*)newSVOP(OP_CONST,0, format_name);
8693 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8700 /* Look for a prototype */
8702 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8704 Perl_croak(aTHX_ "Prototype not terminated");
8705 (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8710 CURMAD('q', PL_thisopen);
8711 CURMAD('_', tmpwhite);
8712 CURMAD('=', PL_thisstuff);
8713 CURMAD('Q', PL_thisclose);
8714 NEXTVAL_NEXTTOKE.opval =
8715 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8716 PL_lex_stuff = NULL;
8719 s = SKIPSPACE2(s,tmpwhite);
8727 if (*s == ':' && s[1] != ':')
8728 PL_expect = attrful;
8729 else if (*s != '{' && key == KEY_sub) {
8731 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8732 else if (*s != ';' && *s != '}')
8733 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8740 curmad('^', newSVpvs(""));
8741 CURMAD('_', tmpwhite);
8745 PL_thistoken = subtoken;
8746 PERL_UNUSED_VAR(have_proto);
8749 NEXTVAL_NEXTTOKE.opval =
8750 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8751 PL_lex_stuff = NULL;
8757 sv_setpvs(PL_subname, "__ANON__");
8759 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8763 force_ident_maybe_lex('&');
8769 LOP(OP_SYSTEM,XREF);
8772 LOP(OP_SYMLINK,XTERM);
8775 LOP(OP_SYSCALL,XTERM);
8778 LOP(OP_SYSOPEN,XTERM);
8781 LOP(OP_SYSSEEK,XTERM);
8784 LOP(OP_SYSREAD,XTERM);
8787 LOP(OP_SYSWRITE,XTERM);
8792 TERM(sublex_start());
8813 LOP(OP_TRUNCATE,XTERM);
8825 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8827 pl_yylval.ival = CopLINE(PL_curcop);
8831 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8833 pl_yylval.ival = CopLINE(PL_curcop);
8837 LOP(OP_UNLINK,XTERM);
8843 LOP(OP_UNPACK,XTERM);
8846 LOP(OP_UTIME,XTERM);
8852 LOP(OP_UNSHIFT,XTERM);
8855 s = tokenize_use(1, s);
8865 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8867 pl_yylval.ival = CopLINE(PL_curcop);
8868 Perl_ck_warner_d(aTHX_
8869 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8870 "when is experimental");
8874 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8876 pl_yylval.ival = CopLINE(PL_curcop);
8880 PL_hints |= HINT_BLOCK_SCOPE;
8887 LOP(OP_WAITPID,XTERM);
8896 ctl_l[0] = toCTRL('L');
8898 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8901 /* Make sure $^L is defined */
8902 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8907 if (PL_expect == XOPERATOR) {
8908 if (*s == '=' && !PL_lex_allbrackets &&
8909 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8917 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8919 pl_yylval.ival = OP_XOR;
8925 #pragma segment Main
8931 Looks up an identifier in the pad or in a package
8934 PRIVATEREF if this is a lexical name.
8935 WORD if this belongs to a package.
8938 if we're in a my declaration
8939 croak if they tried to say my($foo::bar)
8940 build the ops for a my() declaration
8941 if it's an access to a my() variable
8942 build ops for access to a my() variable
8943 if in a dq string, and they've said @foo and we can't find @foo
8945 build ops for a bareword
8949 S_pending_ident(pTHX)
8953 const char pit = (char)pl_yylval.ival;
8954 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8955 /* All routes through this function want to know if there is a colon. */
8956 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8958 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8959 "### Pending identifier '%s'\n", PL_tokenbuf); });
8961 /* if we're in a my(), we can't allow dynamics here.
8962 $foo'bar has already been turned into $foo::bar, so
8963 just check for colons.
8965 if it's a legal name, the OP is a PADANY.
8968 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8970 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8971 "variable %s in \"our\"",
8972 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8973 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8977 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8978 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8979 UTF ? SVf_UTF8 : 0);
8981 pl_yylval.opval = newOP(OP_PADANY, 0);
8982 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8983 UTF ? SVf_UTF8 : 0);
8989 build the ops for accesses to a my() variable.
8994 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8995 UTF ? SVf_UTF8 : 0);
8996 if (tmp != NOT_IN_PAD) {
8997 /* might be an "our" variable" */
8998 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8999 /* build ops for a bareword */
9000 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9001 HEK * const stashname = HvNAME_HEK(stash);
9002 SV * const sym = newSVhek(stashname);
9003 sv_catpvs(sym, "::");
9004 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9005 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
9006 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9010 ? (GV_ADDMULTI | GV_ADDINEVAL)
9013 ((PL_tokenbuf[0] == '$') ? SVt_PV
9014 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9019 pl_yylval.opval = newOP(OP_PADANY, 0);
9020 pl_yylval.opval->op_targ = tmp;
9026 Whine if they've said @foo in a doublequoted string,
9027 and @foo isn't a variable we can find in the symbol
9030 if (ckWARN(WARN_AMBIGUOUS) &&
9031 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
9032 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
9033 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
9034 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9035 /* DO NOT warn for @- and @+ */
9036 && !( PL_tokenbuf[2] == '\0' &&
9037 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
9040 /* Downgraded from fatal to warning 20000522 mjd */
9041 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9042 "Possible unintended interpolation of %"UTF8f
9044 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9048 /* build ops for a bareword */
9049 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
9050 newSVpvn_flags(PL_tokenbuf + 1,
9052 UTF ? SVf_UTF8 : 0 ));
9053 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9055 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
9056 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
9057 | ( UTF ? SVf_UTF8 : 0 ),
9058 ((PL_tokenbuf[0] == '$') ? SVt_PV
9059 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9065 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9069 PERL_ARGS_ASSERT_CHECKCOMMA;
9071 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9072 if (ckWARN(WARN_SYNTAX)) {
9075 for (w = s+2; *w && level; w++) {
9083 /* the list of chars below is for end of statements or
9084 * block / parens, boolean operators (&&, ||, //) and branch
9085 * constructs (or, and, if, until, unless, while, err, for).
9086 * Not a very solid hack... */
9087 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9088 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9089 "%s (...) interpreted as function",name);
9092 while (s < PL_bufend && isSPACE(*s))
9096 while (s < PL_bufend && isSPACE(*s))
9098 if (isIDFIRST_lazy_if(s,UTF)) {
9099 const char * const w = s;
9100 s += UTF ? UTF8SKIP(s) : 1;
9101 while (isWORDCHAR_lazy_if(s,UTF))
9102 s += UTF ? UTF8SKIP(s) : 1;
9103 while (s < PL_bufend && isSPACE(*s))
9107 if (keyword(w, s - w, 0))
9110 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9111 if (gv && GvCVu(gv))
9113 Perl_croak(aTHX_ "No comma allowed after %s", what);
9118 /* S_new_constant(): do any overload::constant lookup.
9120 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9121 Best used as sv=new_constant(..., sv, ...).
9122 If s, pv are NULL, calls subroutine with one argument,
9123 and <type> is used with error messages only.
9124 <type> is assumed to be well formed UTF-8 */
9127 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9128 SV *sv, SV *pv, const char *type, STRLEN typelen)
9131 HV * table = GvHV(PL_hintgv); /* ^H */
9136 const char *why1 = "", *why2 = "", *why3 = "";
9138 PERL_ARGS_ASSERT_NEW_CONSTANT;
9139 /* We assume that this is true: */
9140 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9143 /* charnames doesn't work well if there have been errors found */
9144 if (PL_error_count > 0 && *key == 'c')
9146 SvREFCNT_dec_NN(sv);
9147 return &PL_sv_undef;
9150 sv_2mortal(sv); /* Parent created it permanently */
9152 || ! (PL_hints & HINT_LOCALIZE_HH)
9153 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9158 /* Here haven't found what we're looking for. If it is charnames,
9159 * perhaps it needs to be loaded. Try doing that before giving up */
9161 Perl_load_module(aTHX_
9163 newSVpvs("_charnames"),
9164 /* version parameter; no need to specify it, as if
9165 * we get too early a version, will fail anyway,
9166 * not being able to find '_charnames' */
9172 table = GvHV(PL_hintgv);
9174 && (PL_hints & HINT_LOCALIZE_HH)
9175 && (cvp = hv_fetch(table, key, keylen, FALSE))
9181 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9182 msg = Perl_form(aTHX_
9183 "Constant(%.*s) unknown",
9184 (int)(type ? typelen : len),
9190 why3 = "} is not defined";
9193 msg = Perl_form(aTHX_
9194 /* The +3 is for '\N{'; -4 for that, plus '}' */
9195 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9199 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9200 (int)(type ? typelen : len),
9201 (type ? type: s), why1, why2, why3);
9204 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9205 return SvREFCNT_inc_simple_NN(sv);
9210 pv = newSVpvn_flags(s, len, SVs_TEMP);
9212 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9214 typesv = &PL_sv_undef;
9216 PUSHSTACKi(PERLSI_OVERLOAD);
9228 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9232 /* Check the eval first */
9233 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9235 const char * errstr;
9236 sv_catpvs(errsv, "Propagated");
9237 errstr = SvPV_const(errsv, errlen);
9238 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9240 res = SvREFCNT_inc_simple_NN(sv);
9244 SvREFCNT_inc_simple_void_NN(res);
9253 why1 = "Call to &{$^H{";
9255 why3 = "}} did not return a defined value";
9257 (void)sv_2mortal(sv);
9264 PERL_STATIC_INLINE void
9265 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
9267 PERL_ARGS_ASSERT_PARSE_IDENT;
9271 Perl_croak(aTHX_ "%s", ident_too_long);
9272 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
9273 /* The UTF-8 case must come first, otherwise things
9274 * like c\N{COMBINING TILDE} would start failing, as the
9275 * isWORDCHAR_A case below would gobble the 'c' up.
9278 char *t = *s + UTF8SKIP(*s);
9279 while (isIDCONT_utf8((U8*)t))
9281 if (*d + (t - *s) > e)
9282 Perl_croak(aTHX_ "%s", ident_too_long);
9283 Copy(*s, *d, t - *s, char);
9287 else if ( isWORDCHAR_A(**s) ) {
9290 } while isWORDCHAR_A(**s);
9292 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
9297 else if (allow_package && **s == ':' && (*s)[1] == ':'
9298 /* Disallow things like Foo::$bar. For the curious, this is
9299 * the code path that triggers the "Bad name after" warning
9300 * when looking for barewords.
9302 && (*s)[2] != '$') {
9312 /* Returns a NUL terminated string, with the length of the string written to
9316 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9320 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9321 bool is_utf8 = cBOOL(UTF);
9323 PERL_ARGS_ASSERT_SCAN_WORD;
9325 parse_ident(&s, &d, e, allow_package, is_utf8);
9332 S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9335 char *bracket = NULL;
9338 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9339 bool is_utf8 = cBOOL(UTF);
9341 PERL_ARGS_ASSERT_SCAN_IDENT;
9346 while (isDIGIT(*s)) {
9348 Perl_croak(aTHX_ "%s", ident_too_long);
9353 parse_ident(&s, &d, e, 1, is_utf8);
9358 /* Either a digit variable, or parse_ident() found an identifier
9359 (anything valid as a bareword), so job done and return. */
9360 if (PL_lex_state != LEX_NORMAL)
9361 PL_lex_state = LEX_INTERPENDMAYBE;
9364 if (*s == '$' && s[1] &&
9365 (isIDFIRST_lazy_if(s+1,is_utf8)
9366 || isDIGIT_A((U8)s[1])
9369 || strnEQ(s+1,"::",2)) )
9371 /* Dereferencing a value in a scalar variable.
9372 The alternatives are different syntaxes for a scalar variable.
9373 Using ' as a leading package separator isn't allowed. :: is. */
9376 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9380 while (s < send && SPACE_OR_TAB(*s))
9384 #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
9385 || isCNTRL_A((U8)(d)) \
9386 || isDIGIT_A((U8)(d)) \
9387 || (!(u) && !UTF8_IS_INVARIANT((U8)(d))))
9389 && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
9392 const STRLEN skip = UTF8SKIP(s);
9395 for ( i = 0; i < skip; i++ )
9403 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9404 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9408 /* Warn about ambiguous code after unary operators if {...} notation isn't
9409 used. There's no difference in ambiguity; it's merely a heuristic
9410 about when not to warn. */
9411 else if (ck_uni && !bracket)
9414 /* If we were processing {...} notation then... */
9415 if (isIDFIRST_lazy_if(d,is_utf8)) {
9416 /* if it starts as a valid identifier, assume that it is one.
9417 (the later check for } being at the expected point will trap
9418 cases where this doesn't pan out.) */
9419 d += is_utf8 ? UTF8SKIP(d) : 1;
9420 parse_ident(&s, &d, e, 1, is_utf8);
9422 while (s < send && SPACE_OR_TAB(*s))
9424 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9425 /* ${foo[0]} and ${foo{bar}} notation. */
9426 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9427 const char * const brack =
9429 ((*s == '[') ? "[...]" : "{...}");
9430 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9431 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9432 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9433 funny, dest, brack, funny, dest, brack);
9436 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9437 PL_lex_allbrackets++;
9441 /* Handle extended ${^Foo} variables
9442 * 1999-02-27 mjd-perl-patch@plover.com */
9443 else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9447 while (isWORDCHAR(*s) && d < e) {
9451 Perl_croak(aTHX_ "%s", ident_too_long);
9455 while (s < send && SPACE_OR_TAB(*s))
9458 /* Expect to find a closing } after consuming any trailing whitespace.
9462 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9463 PL_lex_state = LEX_INTERPEND;
9466 if (PL_lex_state == LEX_NORMAL) {
9467 if (ckWARN(WARN_AMBIGUOUS) &&
9468 (keyword(dest, d - dest, 0)
9469 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
9471 SV *tmp = newSVpvn_flags( dest, d - dest,
9472 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9475 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9476 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9477 funny, tmp, funny, tmp);
9482 /* Didn't find the closing } at the point we expected, so restore
9483 state such that the next thing to process is the opening { and */
9484 s = bracket; /* let the parser handle it */
9488 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9489 PL_lex_state = LEX_INTERPEND;
9494 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
9496 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
9497 * the parse starting at 's', based on the subset that are valid in this
9498 * context input to this routine in 'valid_flags'. Advances s. Returns
9499 * TRUE if the input should be treated as a valid flag, so the next char
9500 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
9501 * first call on the current regex. This routine will set it to any
9502 * charset modifier found. The caller shouldn't change it. This way,
9503 * another charset modifier encountered in the parse can be detected as an
9504 * error, as we have decided to allow only one */
9507 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9509 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9510 if (isWORDCHAR_lazy_if(*s, UTF)) {
9511 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9512 UTF ? SVf_UTF8 : 0);
9514 /* Pretend that it worked, so will continue processing before
9523 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
9524 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9525 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9526 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9527 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9528 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9529 case LOCALE_PAT_MOD:
9531 goto multiple_charsets;
9533 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9536 case UNICODE_PAT_MOD:
9538 goto multiple_charsets;
9540 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9543 case ASCII_RESTRICT_PAT_MOD:
9545 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9549 /* Error if previous modifier wasn't an 'a', but if it was, see
9550 * if, and accept, a second occurrence (only) */
9552 || get_regex_charset(*pmfl)
9553 != REGEX_ASCII_RESTRICTED_CHARSET)
9555 goto multiple_charsets;
9557 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9561 case DEPENDS_PAT_MOD:
9563 goto multiple_charsets;
9565 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9574 if (*charset != c) {
9575 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9577 else if (c == 'a') {
9578 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9581 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9584 /* Pretend that it worked, so will continue processing before dieing */
9590 S_scan_pat(pTHX_ char *start, I32 type)
9595 const char * const valid_flags =
9596 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9597 char charset = '\0'; /* character set modifier */
9602 PERL_ARGS_ASSERT_SCAN_PAT;
9604 s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
9605 TRUE /* look for escaped bracketed metas */ );
9608 const char * const delimiter = skipspace(start);
9612 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9613 : "Search pattern not terminated" ));
9616 pm = (PMOP*)newPMOP(type, 0);
9617 if (PL_multi_open == '?') {
9618 /* This is the only point in the code that sets PMf_ONCE: */
9619 pm->op_pmflags |= PMf_ONCE;
9621 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9622 allows us to restrict the list needed by reset to just the ??
9624 assert(type != OP_TRANS);
9626 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9629 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9632 elements = mg->mg_len / sizeof(PMOP**);
9633 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9634 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9635 mg->mg_len = elements * sizeof(PMOP**);
9636 PmopSTASH_set(pm,PL_curstash);
9643 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9644 * anon CV. False positives like qr/[(?{]/ are harmless */
9646 if (type == OP_QR) {
9648 char *e, *p = SvPV(PL_lex_stuff, len);
9650 for (; p < e; p++) {
9651 if (p[0] == '(' && p[1] == '?'
9652 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9654 pm->op_pmflags |= PMf_HAS_CV;
9658 pm->op_pmflags |= PMf_IS_QR;
9661 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9663 if (PL_madskills && modstart != s) {
9664 SV* tmptoken = newSVpvn(modstart, s - modstart);
9665 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9668 /* issue a warning if /c is specified,but /g is not */
9669 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9671 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9672 "Use of /c modifier is meaningless without /g" );
9675 PL_lex_op = (OP*)pm;
9676 pl_yylval.ival = OP_MATCH;
9681 S_scan_subst(pTHX_ char *start)
9688 char charset = '\0'; /* character set modifier */
9693 PERL_ARGS_ASSERT_SCAN_SUBST;
9695 pl_yylval.ival = OP_NULL;
9697 s = scan_str(start,!!PL_madskills,FALSE,FALSE,
9698 TRUE /* look for escaped bracketed metas */ );
9701 Perl_croak(aTHX_ "Substitution pattern not terminated");
9703 if (s[-1] == PL_multi_open)
9707 CURMAD('q', PL_thisopen);
9708 CURMAD('_', PL_thiswhite);
9709 CURMAD('E', PL_thisstuff);
9710 CURMAD('Q', PL_thisclose);
9711 PL_realtokenstart = s - SvPVX(PL_linestr);
9715 first_start = PL_multi_start;
9716 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9719 SvREFCNT_dec(PL_lex_stuff);
9720 PL_lex_stuff = NULL;
9722 Perl_croak(aTHX_ "Substitution replacement not terminated");
9724 PL_multi_start = first_start; /* so whole substitution is taken together */
9726 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9730 CURMAD('z', PL_thisopen);
9731 CURMAD('R', PL_thisstuff);
9732 CURMAD('Z', PL_thisclose);
9738 if (*s == EXEC_PAT_MOD) {
9742 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9751 curmad('m', newSVpvn(modstart, s - modstart));
9752 append_madprops(PL_thismad, (OP*)pm, 0);
9756 if ((pm->op_pmflags & PMf_CONTINUE)) {
9757 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9761 SV * const repl = newSVpvs("");
9764 pm->op_pmflags |= PMf_EVAL;
9767 sv_catpvs(repl, "eval ");
9769 sv_catpvs(repl, "do ");
9771 sv_catpvs(repl, "{");
9772 sv_catsv(repl, PL_sublex_info.repl);
9773 sv_catpvs(repl, "}");
9775 SvREFCNT_dec(PL_sublex_info.repl);
9776 PL_sublex_info.repl = repl;
9779 PL_lex_op = (OP*)pm;
9780 pl_yylval.ival = OP_SUBST;
9785 S_scan_trans(pTHX_ char *start)
9793 bool nondestruct = 0;
9798 PERL_ARGS_ASSERT_SCAN_TRANS;
9800 pl_yylval.ival = OP_NULL;
9802 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
9804 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9806 if (s[-1] == PL_multi_open)
9810 CURMAD('q', PL_thisopen);
9811 CURMAD('_', PL_thiswhite);
9812 CURMAD('E', PL_thisstuff);
9813 CURMAD('Q', PL_thisclose);
9814 PL_realtokenstart = s - SvPVX(PL_linestr);
9818 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9821 SvREFCNT_dec(PL_lex_stuff);
9822 PL_lex_stuff = NULL;
9824 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9827 CURMAD('z', PL_thisopen);
9828 CURMAD('R', PL_thisstuff);
9829 CURMAD('Z', PL_thisclose);
9832 complement = del = squash = 0;
9839 complement = OPpTRANS_COMPLEMENT;
9842 del = OPpTRANS_DELETE;
9845 squash = OPpTRANS_SQUASH;
9857 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9858 o->op_private &= ~OPpTRANS_ALL;
9859 o->op_private |= del|squash|complement|
9860 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9861 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9864 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9869 curmad('m', newSVpvn(modstart, s - modstart));
9870 append_madprops(PL_thismad, o, 0);
9879 Takes a pointer to the first < in <<FOO.
9880 Returns a pointer to the byte following <<FOO.
9882 This function scans a heredoc, which involves different methods
9883 depending on whether we are in a string eval, quoted construct, etc.
9884 This is because PL_linestr could containing a single line of input, or
9885 a whole string being evalled, or the contents of the current quote-
9888 The two basic methods are:
9889 - Steal lines from the input stream
9890 - Scan the heredoc in PL_linestr and remove it therefrom
9892 In a file scope or filtered eval, the first method is used; in a
9893 string eval, the second.
9895 In a quote-like operator, we have to choose between the two,
9896 depending on where we can find a newline. We peek into outer lex-
9897 ing scopes until we find one with a newline in it. If we reach the
9898 outermost lexing scope and it is a file, we use the stream method.
9899 Otherwise it is treated as an eval.
9903 S_scan_heredoc(pTHX_ char *s)
9906 I32 op_type = OP_SCALAR;
9913 const bool infile = PL_rsfp || PL_parser->filtered;
9914 LEXSHARED *shared = PL_parser->lex_shared;
9916 I32 stuffstart = s - SvPVX(PL_linestr);
9919 PL_realtokenstart = -1;
9922 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9925 d = PL_tokenbuf + 1;
9926 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9927 *PL_tokenbuf = '\n';
9929 while (SPACE_OR_TAB(*peek))
9931 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9934 s = delimcpy(d, e, s, PL_bufend, term, &len);
9936 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9942 /* <<\FOO is equivalent to <<'FOO' */
9946 if (!isWORDCHAR_lazy_if(s,UTF))
9947 deprecate("bare << to mean <<\"\"");
9948 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9953 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9954 Perl_croak(aTHX_ "Delimiter for here document is too long");
9957 len = d - PL_tokenbuf;
9961 tstart = PL_tokenbuf + 1;
9962 PL_thisclose = newSVpvn(tstart, len - 1);
9963 tstart = SvPVX(PL_linestr) + stuffstart;
9964 PL_thisopen = newSVpvn(tstart, s - tstart);
9965 stuffstart = s - SvPVX(PL_linestr);
9968 #ifndef PERL_STRICT_CR
9969 d = strchr(s, '\r');
9971 char * const olds = s;
9973 while (s < PL_bufend) {
9979 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9988 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9994 tstart = SvPVX(PL_linestr) + stuffstart;
9996 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9998 PL_thisstuff = newSVpvn(tstart, s - tstart);
10001 stuffstart = s - SvPVX(PL_linestr);
10004 tmpstr = newSV_type(SVt_PVIV);
10005 SvGROW(tmpstr, 80);
10006 if (term == '\'') {
10007 op_type = OP_CONST;
10008 SvIV_set(tmpstr, -1);
10010 else if (term == '`') {
10011 op_type = OP_BACKTICK;
10012 SvIV_set(tmpstr, '\\');
10015 PL_multi_start = CopLINE(PL_curcop) + 1;
10016 PL_multi_open = PL_multi_close = '<';
10017 /* inside a string eval or quote-like operator */
10018 if (!infile || PL_lex_inwhat) {
10021 char * const olds = s;
10022 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
10023 /* These two fields are not set until an inner lexing scope is
10024 entered. But we need them set here. */
10025 shared->ls_bufptr = s;
10026 shared->ls_linestr = PL_linestr;
10028 /* Look for a newline. If the current buffer does not have one,
10029 peek into the line buffer of the parent lexing scope, going
10030 up as many levels as necessary to find one with a newline
10033 while (!(s = (char *)memchr(
10034 (void *)shared->ls_bufptr, '\n',
10035 SvEND(shared->ls_linestr)-shared->ls_bufptr
10037 shared = shared->ls_prev;
10038 /* shared is only null if we have gone beyond the outermost
10039 lexing scope. In a file, we will have broken out of the
10040 loop in the previous iteration. In an eval, the string buf-
10041 fer ends with "\n;", so the while condition below will have
10042 evaluated to false. So shared can never be null. */
10044 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10045 most lexing scope. In a file, shared->ls_linestr at that
10046 level is just one line, so there is no body to steal. */
10047 if (infile && !shared->ls_prev) {
10053 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10056 linestr = shared->ls_linestr;
10057 bufend = SvEND(linestr);
10059 while (s < bufend - len + 1 &&
10060 memNE(s,PL_tokenbuf,len) ) {
10062 ++shared->herelines;
10064 if (s >= bufend - len + 1) {
10067 sv_setpvn(tmpstr,d+1,s-d);
10069 if (PL_madskills) {
10071 sv_catpvn(PL_thisstuff, d + 1, s - d);
10073 PL_thisstuff = newSVpvn(d + 1, s - d);
10074 stuffstart = s - SvPVX(PL_linestr);
10078 /* the preceding stmt passes a newline */
10079 shared->herelines++;
10081 /* s now points to the newline after the heredoc terminator.
10082 d points to the newline before the body of the heredoc.
10085 /* We are going to modify linestr in place here, so set
10086 aside copies of the string if necessary for re-evals or
10088 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10089 check shared->re_eval_str. */
10090 if (shared->re_eval_start || shared->re_eval_str) {
10091 /* Set aside the rest of the regexp */
10092 if (!shared->re_eval_str)
10093 shared->re_eval_str =
10094 newSVpvn(shared->re_eval_start,
10095 bufend - shared->re_eval_start);
10096 shared->re_eval_start -= s-d;
10098 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
10099 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
10100 cx->blk_eval.cur_text == linestr)
10102 cx->blk_eval.cur_text = newSVsv(linestr);
10103 SvSCREAM_on(cx->blk_eval.cur_text);
10105 /* Copy everything from s onwards back to d. */
10106 Move(s,d,bufend-s + 1,char);
10107 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10108 /* Setting PL_bufend only applies when we have not dug deeper
10109 into other scopes, because sublex_done sets PL_bufend to
10110 SvEND(PL_linestr). */
10111 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10118 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
10119 term = PL_tokenbuf[1];
10121 linestr_save = PL_linestr; /* must restore this afterwards */
10122 d = s; /* and this */
10123 PL_linestr = newSVpvs("");
10124 PL_bufend = SvPVX(PL_linestr);
10127 if (PL_madskills) {
10128 tstart = SvPVX(PL_linestr) + stuffstart;
10130 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10132 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10135 PL_bufptr = PL_bufend;
10136 CopLINE_set(PL_curcop,
10137 PL_multi_start + shared->herelines);
10138 if (!lex_next_chunk(LEX_NO_TERM)
10139 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10140 SvREFCNT_dec(linestr_save);
10143 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10144 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10145 lex_grow_linestr(SvCUR(PL_linestr) + 2);
10146 sv_catpvs(PL_linestr, "\n\0");
10150 stuffstart = s - SvPVX(PL_linestr);
10152 shared->herelines++;
10153 PL_last_lop = PL_last_uni = NULL;
10154 #ifndef PERL_STRICT_CR
10155 if (PL_bufend - PL_linestart >= 2) {
10156 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
10157 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10159 PL_bufend[-2] = '\n';
10161 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10163 else if (PL_bufend[-1] == '\r')
10164 PL_bufend[-1] = '\n';
10166 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10167 PL_bufend[-1] = '\n';
10169 if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
10170 SvREFCNT_dec(PL_linestr);
10171 PL_linestr = linestr_save;
10172 PL_linestart = SvPVX(linestr_save);
10173 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10178 sv_catsv(tmpstr,PL_linestr);
10182 PL_multi_end = CopLINE(PL_curcop);
10183 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10184 SvPV_shrink_to_cur(tmpstr);
10187 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10189 else if (PL_encoding)
10190 sv_recode_to_utf8(tmpstr, PL_encoding);
10192 PL_lex_stuff = tmpstr;
10193 pl_yylval.ival = op_type;
10197 SvREFCNT_dec(tmpstr);
10198 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10199 missingterm(PL_tokenbuf + 1);
10202 /* scan_inputsymbol
10203 takes: current position in input buffer
10204 returns: new position in input buffer
10205 side-effects: pl_yylval and lex_op are set.
10210 <FH> read from filehandle
10211 <pkg::FH> read from package qualified filehandle
10212 <pkg'FH> read from package qualified filehandle
10213 <$fh> read from filehandle in $fh
10214 <*.h> filename glob
10219 S_scan_inputsymbol(pTHX_ char *start)
10222 char *s = start; /* current position in buffer */
10225 char *d = PL_tokenbuf; /* start of temp holding space */
10226 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10228 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10230 end = strchr(s, '\n');
10233 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10235 /* die if we didn't have space for the contents of the <>,
10236 or if it didn't end, or if we see a newline
10239 if (len >= (I32)sizeof PL_tokenbuf)
10240 Perl_croak(aTHX_ "Excessively long <> operator");
10242 Perl_croak(aTHX_ "Unterminated <> operator");
10247 Remember, only scalar variables are interpreted as filehandles by
10248 this code. Anything more complex (e.g., <$fh{$num}>) will be
10249 treated as a glob() call.
10250 This code makes use of the fact that except for the $ at the front,
10251 a scalar variable and a filehandle look the same.
10253 if (*d == '$' && d[1]) d++;
10255 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10256 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
10257 d += UTF ? UTF8SKIP(d) : 1;
10259 /* If we've tried to read what we allow filehandles to look like, and
10260 there's still text left, then it must be a glob() and not a getline.
10261 Use scan_str to pull out the stuff between the <> and treat it
10262 as nothing more than a string.
10265 if (d - PL_tokenbuf != len) {
10266 pl_yylval.ival = OP_GLOB;
10267 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
10269 Perl_croak(aTHX_ "Glob not terminated");
10273 bool readline_overriden = FALSE;
10276 /* we're in a filehandle read situation */
10279 /* turn <> into <ARGV> */
10281 Copy("ARGV",d,5,char);
10283 /* Check whether readline() is overriden */
10284 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
10286 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
10288 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
10289 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
10290 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
10291 readline_overriden = TRUE;
10293 /* if <$fh>, create the ops to turn the variable into a
10297 /* try to find it in the pad for this block, otherwise find
10298 add symbol table ops
10300 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
10301 if (tmp != NOT_IN_PAD) {
10302 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10303 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10304 HEK * const stashname = HvNAME_HEK(stash);
10305 SV * const sym = sv_2mortal(newSVhek(stashname));
10306 sv_catpvs(sym, "::");
10307 sv_catpv(sym, d+1);
10312 OP * const o = newOP(OP_PADSV, 0);
10314 PL_lex_op = readline_overriden
10315 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10316 op_append_elem(OP_LIST, o,
10317 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10318 : (OP*)newUNOP(OP_READLINE, 0, o);
10327 ? (GV_ADDMULTI | GV_ADDINEVAL)
10328 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
10330 PL_lex_op = readline_overriden
10331 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10332 op_append_elem(OP_LIST,
10333 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10334 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10335 : (OP*)newUNOP(OP_READLINE, 0,
10336 newUNOP(OP_RV2SV, 0,
10337 newGVOP(OP_GV, 0, gv)));
10339 if (!readline_overriden)
10340 PL_lex_op->op_flags |= OPf_SPECIAL;
10341 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10342 pl_yylval.ival = OP_NULL;
10345 /* If it's none of the above, it must be a literal filehandle
10346 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10348 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10349 PL_lex_op = readline_overriden
10350 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10351 op_append_elem(OP_LIST,
10352 newGVOP(OP_GV, 0, gv),
10353 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10354 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10355 pl_yylval.ival = OP_NULL;
10364 takes: start position in buffer
10365 keep_quoted preserve \ on the embedded delimiter(s)
10366 keep_delims preserve the delimiters around the string
10367 re_reparse compiling a run-time /(?{})/:
10368 collapse // to /, and skip encoding src
10369 returns: position to continue reading from buffer
10370 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10371 updates the read buffer.
10373 This subroutine pulls a string out of the input. It is called for:
10374 q single quotes q(literal text)
10375 ' single quotes 'literal text'
10376 qq double quotes qq(interpolate $here please)
10377 " double quotes "interpolate $here please"
10378 qx backticks qx(/bin/ls -l)
10379 ` backticks `/bin/ls -l`
10380 qw quote words @EXPORT_OK = qw( func() $spam )
10381 m// regexp match m/this/
10382 s/// regexp substitute s/this/that/
10383 tr/// string transliterate tr/this/that/
10384 y/// string transliterate y/this/that/
10385 ($*@) sub prototypes sub foo ($)
10386 (stuff) sub attr parameters sub foo : attr(stuff)
10387 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10389 In most of these cases (all but <>, patterns and transliterate)
10390 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10391 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10392 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10395 It skips whitespace before the string starts, and treats the first
10396 character as the delimiter. If the delimiter is one of ([{< then
10397 the corresponding "close" character )]}> is used as the closing
10398 delimiter. It allows quoting of delimiters, and if the string has
10399 balanced delimiters ([{<>}]) it allows nesting.
10401 On success, the SV with the resulting string is put into lex_stuff or,
10402 if that is already non-NULL, into lex_repl. The second case occurs only
10403 when parsing the RHS of the special constructs s/// and tr/// (y///).
10404 For convenience, the terminating delimiter character is stuffed into
10409 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
10410 bool deprecate_escaped_meta /* Should we issue a deprecation warning
10411 for certain paired metacharacters that
10412 appear escaped within it */
10416 SV *sv; /* scalar value: string */
10417 const char *tmps; /* temp string, used for delimiter matching */
10418 char *s = start; /* current position in the buffer */
10419 char term; /* terminating character */
10420 char *to; /* current position in the sv's data */
10421 I32 brackets = 1; /* bracket nesting level */
10422 bool has_utf8 = FALSE; /* is there any utf8 content? */
10423 I32 termcode; /* terminating char. code */
10424 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10425 STRLEN termlen; /* length of terminating string */
10426 int last_off = 0; /* last position for nesting bracket */
10427 char *escaped_open = NULL;
10433 PERL_ARGS_ASSERT_SCAN_STR;
10435 /* skip space before the delimiter */
10441 if (PL_realtokenstart >= 0) {
10442 stuffstart = PL_realtokenstart;
10443 PL_realtokenstart = -1;
10446 stuffstart = start - SvPVX(PL_linestr);
10448 /* mark where we are, in case we need to report errors */
10451 /* after skipping whitespace, the next character is the terminator */
10454 termcode = termstr[0] = term;
10458 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10459 Copy(s, termstr, termlen, U8);
10460 if (!UTF8_IS_INVARIANT(term))
10464 /* mark where we are */
10465 PL_multi_start = CopLINE(PL_curcop);
10466 PL_multi_open = term;
10468 /* find corresponding closing delimiter */
10469 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10470 termcode = termstr[0] = term = tmps[5];
10472 PL_multi_close = term;
10474 /* A warning is raised if the input parameter requires it for escaped (by a
10475 * backslash) paired metacharacters {} [] and () when the delimiters are
10476 * those same characters, and the backslash is ineffective. This doesn't
10477 * happen for <>, as they aren't metas. */
10478 if (deprecate_escaped_meta
10479 && (PL_multi_open == PL_multi_close
10480 || ! ckWARN_d(WARN_DEPRECATED)
10481 || PL_multi_open == '<'))
10483 deprecate_escaped_meta = FALSE;
10486 /* create a new SV to hold the contents. 79 is the SV's initial length.
10487 What a random number. */
10488 sv = newSV_type(SVt_PVIV);
10490 SvIV_set(sv, termcode);
10491 (void)SvPOK_only(sv); /* validate pointer */
10493 /* move past delimiter and try to read a complete string */
10495 sv_catpvn(sv, s, termlen);
10498 tstart = SvPVX(PL_linestr) + stuffstart;
10499 if (PL_madskills && !PL_thisopen && !keep_delims) {
10500 PL_thisopen = newSVpvn(tstart, s - tstart);
10501 stuffstart = s - SvPVX(PL_linestr);
10505 if (PL_encoding && !UTF && !re_reparse) {
10509 int offset = s - SvPVX_const(PL_linestr);
10510 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10511 &offset, (char*)termstr, termlen);
10512 const char * const ns = SvPVX_const(PL_linestr) + offset;
10513 char * const svlast = SvEND(sv) - 1;
10515 for (; s < ns; s++) {
10516 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10517 COPLINE_INC_WITH_HERELINES;
10520 goto read_more_line;
10522 /* handle quoted delimiters */
10523 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10525 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10527 if ((svlast-1 - t) % 2) {
10528 if (!keep_quoted) {
10529 *(svlast-1) = term;
10531 SvCUR_set(sv, SvCUR(sv) - 1);
10536 if (PL_multi_open == PL_multi_close) {
10542 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10543 /* At here, all closes are "was quoted" one,
10544 so we don't check PL_multi_close. */
10546 if (!keep_quoted && *(t+1) == PL_multi_open)
10551 else if (*t == PL_multi_open)
10559 SvCUR_set(sv, w - SvPVX_const(sv));
10561 last_off = w - SvPVX(sv);
10562 if (--brackets <= 0)
10567 if (!keep_delims) {
10568 SvCUR_set(sv, SvCUR(sv) - 1);
10574 /* extend sv if need be */
10575 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10576 /* set 'to' to the next character in the sv's string */
10577 to = SvPVX(sv)+SvCUR(sv);
10579 /* if open delimiter is the close delimiter read unbridle */
10580 if (PL_multi_open == PL_multi_close) {
10581 for (; s < PL_bufend; s++,to++) {
10582 /* embedded newlines increment the current line number */
10583 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10584 COPLINE_INC_WITH_HERELINES;
10585 /* handle quoted delimiters */
10586 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10589 || (re_reparse && s[1] == '\\'))
10592 /* any other quotes are simply copied straight through */
10596 /* terminate when run out of buffer (the for() condition), or
10597 have found the terminator */
10598 else if (*s == term) {
10601 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10604 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10610 /* if the terminator isn't the same as the start character (e.g.,
10611 matched brackets), we have to allow more in the quoting, and
10612 be prepared for nested brackets.
10615 /* read until we run out of string, or we find the terminator */
10616 for (; s < PL_bufend; s++,to++) {
10617 /* embedded newlines increment the line count */
10618 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10619 COPLINE_INC_WITH_HERELINES;
10620 /* backslashes can escape the open or closing characters */
10621 if (*s == '\\' && s+1 < PL_bufend) {
10622 if (!keep_quoted &&
10623 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10627 /* Here, 'deprecate_escaped_meta' is true iff the
10628 * delimiters are paired metacharacters, and 's' points
10629 * to an occurrence of one of them within the string,
10630 * which was preceded by a backslash. If this is a
10631 * context where the delimiter is also a metacharacter,
10632 * the backslash is useless, and deprecated. () and []
10633 * are meta in any context. {} are meta only when
10634 * appearing in a quantifier or in things like '\p{'.
10635 * They also aren't meta unless there is a matching
10636 * closed, escaped char later on within the string.
10637 * If 's' points to an open, set a flag; if to a close,
10638 * test that flag, and raise a warning if it was set */
10640 if (deprecate_escaped_meta) {
10641 if (*s == PL_multi_open) {
10645 else if (regcurly(s,
10646 TRUE /* Look for a closing
10648 || (s - start > 2 /* Look for e.g.
10650 && _generic_isCC(*(s-2), _CC_BACKSLASH_FOO_LBRACE_IS_META)))
10655 else if (escaped_open) {
10656 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10657 "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open);
10658 escaped_open = NULL;
10665 /* allow nested opens and closes */
10666 else if (*s == PL_multi_close && --brackets <= 0)
10668 else if (*s == PL_multi_open)
10670 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10675 /* terminate the copied string and update the sv's end-of-string */
10677 SvCUR_set(sv, to - SvPVX_const(sv));
10680 * this next chunk reads more into the buffer if we're not done yet
10684 break; /* handle case where we are done yet :-) */
10686 #ifndef PERL_STRICT_CR
10687 if (to - SvPVX_const(sv) >= 2) {
10688 if ((to[-2] == '\r' && to[-1] == '\n') ||
10689 (to[-2] == '\n' && to[-1] == '\r'))
10693 SvCUR_set(sv, to - SvPVX_const(sv));
10695 else if (to[-1] == '\r')
10698 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10703 /* if we're out of file, or a read fails, bail and reset the current
10704 line marker so we can report where the unterminated string began
10707 if (PL_madskills) {
10708 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10710 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10712 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10715 COPLINE_INC_WITH_HERELINES;
10716 PL_bufptr = PL_bufend;
10717 if (!lex_next_chunk(0)) {
10719 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10728 /* at this point, we have successfully read the delimited string */
10730 if (!PL_encoding || UTF || re_reparse) {
10732 if (PL_madskills) {
10733 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10734 const int len = s - tstart;
10736 sv_catpvn(PL_thisstuff, tstart, len);
10738 PL_thisstuff = newSVpvn(tstart, len);
10739 if (!PL_thisclose && !keep_delims)
10740 PL_thisclose = newSVpvn(s,termlen);
10745 sv_catpvn(sv, s, termlen);
10750 if (PL_madskills) {
10751 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10752 const int len = s - tstart - termlen;
10754 sv_catpvn(PL_thisstuff, tstart, len);
10756 PL_thisstuff = newSVpvn(tstart, len);
10757 if (!PL_thisclose && !keep_delims)
10758 PL_thisclose = newSVpvn(s - termlen,termlen);
10762 if (has_utf8 || (PL_encoding && !re_reparse))
10765 PL_multi_end = CopLINE(PL_curcop);
10767 /* if we allocated too much space, give some back */
10768 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10769 SvLEN_set(sv, SvCUR(sv) + 1);
10770 SvPV_renew(sv, SvLEN(sv));
10773 /* decide whether this is the first or second quoted string we've read
10778 PL_sublex_info.repl = sv;
10786 takes: pointer to position in buffer
10787 returns: pointer to new position in buffer
10788 side-effects: builds ops for the constant in pl_yylval.op
10790 Read a number in any of the formats that Perl accepts:
10792 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10793 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10796 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10798 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10801 If it reads a number without a decimal point or an exponent, it will
10802 try converting the number to an integer and see if it can do so
10803 without loss of precision.
10807 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10810 const char *s = start; /* current position in buffer */
10811 char *d; /* destination in temp buffer */
10812 char *e; /* end of temp buffer */
10813 NV nv; /* number read, as a double */
10814 SV *sv = NULL; /* place to put the converted number */
10815 bool floatit; /* boolean: int or float? */
10816 const char *lastub = NULL; /* position of last underbar */
10817 static const char* const number_too_long = "Number too long";
10819 PERL_ARGS_ASSERT_SCAN_NUM;
10821 /* We use the first character to decide what type of number this is */
10825 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10827 /* if it starts with a 0, it could be an octal number, a decimal in
10828 0.13 disguise, or a hexadecimal number, or a binary number. */
10832 u holds the "number so far"
10833 shift the power of 2 of the base
10834 (hex == 4, octal == 3, binary == 1)
10835 overflowed was the number more than we can hold?
10837 Shift is used when we add a digit. It also serves as an "are
10838 we in octal/hex/binary?" indicator to disallow hex characters
10839 when in octal mode.
10844 bool overflowed = FALSE;
10845 bool just_zero = TRUE; /* just plain 0 or binary number? */
10846 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10847 static const char* const bases[5] =
10848 { "", "binary", "", "octal", "hexadecimal" };
10849 static const char* const Bases[5] =
10850 { "", "Binary", "", "Octal", "Hexadecimal" };
10851 static const char* const maxima[5] =
10853 "0b11111111111111111111111111111111",
10857 const char *base, *Base, *max;
10859 /* check for hex */
10860 if (s[1] == 'x' || s[1] == 'X') {
10864 } else if (s[1] == 'b' || s[1] == 'B') {
10869 /* check for a decimal in disguise */
10870 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10872 /* so it must be octal */
10879 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10880 "Misplaced _ in number");
10884 base = bases[shift];
10885 Base = Bases[shift];
10886 max = maxima[shift];
10888 /* read the rest of the number */
10890 /* x is used in the overflow test,
10891 b is the digit we're adding on. */
10896 /* if we don't mention it, we're done */
10900 /* _ are ignored -- but warned about if consecutive */
10902 if (lastub && s == lastub + 1)
10903 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10904 "Misplaced _ in number");
10908 /* 8 and 9 are not octal */
10909 case '8': case '9':
10911 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10915 case '2': case '3': case '4':
10916 case '5': case '6': case '7':
10918 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10921 case '0': case '1':
10922 b = *s++ & 15; /* ASCII digit -> value of digit */
10926 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10927 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10928 /* make sure they said 0x */
10931 b = (*s++ & 7) + 9;
10933 /* Prepare to put the digit we have onto the end
10934 of the number so far. We check for overflows.
10940 x = u << shift; /* make room for the digit */
10942 if ((x >> shift) != u
10943 && !(PL_hints & HINT_NEW_BINARY)) {
10946 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10947 "Integer overflow in %s number",
10950 u = x | b; /* add the digit to the end */
10953 n *= nvshift[shift];
10954 /* If an NV has not enough bits in its
10955 * mantissa to represent an UV this summing of
10956 * small low-order numbers is a waste of time
10957 * (because the NV cannot preserve the
10958 * low-order bits anyway): we could just
10959 * remember when did we overflow and in the
10960 * end just multiply n by the right
10968 /* if we get here, we had success: make a scalar value from
10973 /* final misplaced underbar check */
10974 if (s[-1] == '_') {
10975 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10979 if (n > 4294967295.0)
10980 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10981 "%s number > %s non-portable",
10987 if (u > 0xffffffff)
10988 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10989 "%s number > %s non-portable",
10994 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10995 sv = new_constant(start, s - start, "integer",
10996 sv, NULL, NULL, 0);
10997 else if (PL_hints & HINT_NEW_BINARY)
10998 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11003 handle decimal numbers.
11004 we're also sent here when we read a 0 as the first digit
11006 case '1': case '2': case '3': case '4': case '5':
11007 case '6': case '7': case '8': case '9': case '.':
11010 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11013 /* read next group of digits and _ and copy into d */
11014 while (isDIGIT(*s) || *s == '_') {
11015 /* skip underscores, checking for misplaced ones
11019 if (lastub && s == lastub + 1)
11020 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11021 "Misplaced _ in number");
11025 /* check for end of fixed-length buffer */
11027 Perl_croak(aTHX_ "%s", number_too_long);
11028 /* if we're ok, copy the character */
11033 /* final misplaced underbar check */
11034 if (lastub && s == lastub + 1) {
11035 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11038 /* read a decimal portion if there is one. avoid
11039 3..5 being interpreted as the number 3. followed
11042 if (*s == '.' && s[1] != '.') {
11047 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11048 "Misplaced _ in number");
11052 /* copy, ignoring underbars, until we run out of digits.
11054 for (; isDIGIT(*s) || *s == '_'; s++) {
11055 /* fixed length buffer check */
11057 Perl_croak(aTHX_ "%s", number_too_long);
11059 if (lastub && s == lastub + 1)
11060 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11061 "Misplaced _ in number");
11067 /* fractional part ending in underbar? */
11068 if (s[-1] == '_') {
11069 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11070 "Misplaced _ in number");
11072 if (*s == '.' && isDIGIT(s[1])) {
11073 /* oops, it's really a v-string, but without the "v" */
11079 /* read exponent part, if present */
11080 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
11084 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
11085 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
11087 /* stray preinitial _ */
11089 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11090 "Misplaced _ in number");
11094 /* allow positive or negative exponent */
11095 if (*s == '+' || *s == '-')
11098 /* stray initial _ */
11100 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11101 "Misplaced _ in number");
11105 /* read digits of exponent */
11106 while (isDIGIT(*s) || *s == '_') {
11109 Perl_croak(aTHX_ "%s", number_too_long);
11113 if (((lastub && s == lastub + 1) ||
11114 (!isDIGIT(s[1]) && s[1] != '_')))
11115 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11116 "Misplaced _ in number");
11124 We try to do an integer conversion first if no characters
11125 indicating "float" have been found.
11130 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11132 if (flags == IS_NUMBER_IN_UV) {
11134 sv = newSViv(uv); /* Prefer IVs over UVs. */
11137 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11138 if (uv <= (UV) IV_MIN)
11139 sv = newSViv(-(IV)uv);
11146 /* terminate the string */
11148 nv = Atof(PL_tokenbuf);
11153 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11154 const char *const key = floatit ? "float" : "integer";
11155 const STRLEN keylen = floatit ? 5 : 7;
11156 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11157 key, keylen, sv, NULL, NULL, 0);
11161 /* if it starts with a v, it could be a v-string */
11164 sv = newSV(5); /* preallocate storage space */
11165 ENTER_with_name("scan_vstring");
11167 s = scan_vstring(s, PL_bufend, sv);
11168 SvREFCNT_inc_simple_void_NN(sv);
11169 LEAVE_with_name("scan_vstring");
11173 /* make the op for the constant and return */
11176 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11178 lvalp->opval = NULL;
11184 S_scan_formline(pTHX_ char *s)
11189 SV * const stuff = newSVpvs("");
11190 bool needargs = FALSE;
11191 bool eofmt = FALSE;
11193 char *tokenstart = s;
11194 SV* savewhite = NULL;
11196 if (PL_madskills) {
11197 savewhite = PL_thiswhite;
11202 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11204 while (!needargs) {
11207 #ifdef PERL_STRICT_CR
11208 while (SPACE_OR_TAB(*t))
11211 while (SPACE_OR_TAB(*t) || *t == '\r')
11214 if (*t == '\n' || t == PL_bufend) {
11219 eol = (char *) memchr(s,'\n',PL_bufend-s);
11223 for (t = s; t < eol; t++) {
11224 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11226 goto enough; /* ~~ must be first line in formline */
11228 if (*t == '@' || *t == '^')
11232 sv_catpvn(stuff, s, eol-s);
11233 #ifndef PERL_STRICT_CR
11234 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11235 char *end = SvPVX(stuff) + SvCUR(stuff);
11238 SvCUR_set(stuff, SvCUR(stuff) - 1);
11246 if ((PL_rsfp || PL_parser->filtered)
11247 && PL_parser->form_lex_state == LEX_NORMAL) {
11250 if (PL_madskills) {
11252 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
11254 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
11257 PL_bufptr = PL_bufend;
11258 COPLINE_INC_WITH_HERELINES;
11259 got_some = lex_next_chunk(0);
11260 CopLINE_dec(PL_curcop);
11263 tokenstart = PL_bufptr;
11271 if (!SvCUR(stuff) || needargs)
11272 PL_lex_state = PL_parser->form_lex_state;
11273 if (SvCUR(stuff)) {
11274 PL_expect = XSTATE;
11276 start_force(PL_curforce);
11277 NEXTVAL_NEXTTOKE.ival = 0;
11278 force_next(FORMLBRACK);
11281 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11283 else if (PL_encoding)
11284 sv_recode_to_utf8(stuff, PL_encoding);
11286 start_force(PL_curforce);
11287 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
11291 SvREFCNT_dec(stuff);
11293 PL_lex_formbrack = 0;
11296 if (PL_madskills) {
11298 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
11300 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
11301 PL_thiswhite = savewhite;
11308 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11311 const I32 oldsavestack_ix = PL_savestack_ix;
11312 CV* const outsidecv = PL_compcv;
11314 SAVEI32(PL_subline);
11315 save_item(PL_subname);
11316 SAVESPTR(PL_compcv);
11318 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11319 CvFLAGS(PL_compcv) |= flags;
11321 PL_subline = CopLINE(PL_curcop);
11322 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11323 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11324 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11325 if (outsidecv && CvPADLIST(outsidecv))
11326 CvPADLIST(PL_compcv)->xpadl_outid =
11327 PadlistNAMES(CvPADLIST(outsidecv));
11329 return oldsavestack_ix;
11333 #pragma segment Perl_yylex
11336 S_yywarn(pTHX_ const char *const s, U32 flags)
11340 PERL_ARGS_ASSERT_YYWARN;
11342 PL_in_eval |= EVAL_WARNONLY;
11343 yyerror_pv(s, flags);
11344 PL_in_eval &= ~EVAL_WARNONLY;
11349 Perl_yyerror(pTHX_ const char *const s)
11351 PERL_ARGS_ASSERT_YYERROR;
11352 return yyerror_pvn(s, strlen(s), 0);
11356 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11358 PERL_ARGS_ASSERT_YYERROR_PV;
11359 return yyerror_pvn(s, strlen(s), flags);
11363 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11366 const char *context = NULL;
11369 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11370 int yychar = PL_parser->yychar;
11372 PERL_ARGS_ASSERT_YYERROR_PVN;
11374 if (!yychar || (yychar == ';' && !PL_rsfp))
11375 sv_catpvs(where_sv, "at EOF");
11376 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
11377 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
11378 PL_oldbufptr != PL_bufptr) {
11381 The code below is removed for NetWare because it abends/crashes on NetWare
11382 when the script has error such as not having the closing quotes like:
11383 if ($var eq "value)
11384 Checking of white spaces is anyway done in NetWare code.
11387 while (isSPACE(*PL_oldoldbufptr))
11390 context = PL_oldoldbufptr;
11391 contlen = PL_bufptr - PL_oldoldbufptr;
11393 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
11394 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
11397 The code below is removed for NetWare because it abends/crashes on NetWare
11398 when the script has error such as not having the closing quotes like:
11399 if ($var eq "value)
11400 Checking of white spaces is anyway done in NetWare code.
11403 while (isSPACE(*PL_oldbufptr))
11406 context = PL_oldbufptr;
11407 contlen = PL_bufptr - PL_oldbufptr;
11409 else if (yychar > 255)
11410 sv_catpvs(where_sv, "next token ???");
11411 else if (yychar == -2) { /* YYEMPTY */
11412 if (PL_lex_state == LEX_NORMAL ||
11413 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11414 sv_catpvs(where_sv, "at end of line");
11415 else if (PL_lex_inpat)
11416 sv_catpvs(where_sv, "within pattern");
11418 sv_catpvs(where_sv, "within string");
11421 sv_catpvs(where_sv, "next char ");
11423 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11424 else if (isPRINT_LC(yychar)) {
11425 const char string = yychar;
11426 sv_catpvn(where_sv, &string, 1);
11429 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11431 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11432 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11433 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11435 Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
11436 UTF8fARG(UTF, contlen, context));
11438 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
11439 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
11440 Perl_sv_catpvf(aTHX_ msg,
11441 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11442 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11445 if (PL_in_eval & EVAL_WARNONLY) {
11446 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
11450 if (PL_error_count >= 10) {
11452 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
11453 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11454 SVfARG(errsv), OutCopFILE(PL_curcop));
11456 Perl_croak(aTHX_ "%s has too many errors.\n",
11457 OutCopFILE(PL_curcop));
11460 PL_in_my_stash = NULL;
11464 #pragma segment Main
11468 S_swallow_bom(pTHX_ U8 *s)
11471 const STRLEN slen = SvCUR(PL_linestr);
11473 PERL_ARGS_ASSERT_SWALLOW_BOM;
11477 if (s[1] == 0xFE) {
11478 /* UTF-16 little-endian? (or UTF-32LE?) */
11479 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11480 /* diag_listed_as: Unsupported script encoding %s */
11481 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11482 #ifndef PERL_NO_UTF16_FILTER
11483 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11485 if (PL_bufend > (char*)s) {
11486 s = add_utf16_textfilter(s, TRUE);
11489 /* diag_listed_as: Unsupported script encoding %s */
11490 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11495 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11496 #ifndef PERL_NO_UTF16_FILTER
11497 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11499 if (PL_bufend > (char *)s) {
11500 s = add_utf16_textfilter(s, FALSE);
11503 /* diag_listed_as: Unsupported script encoding %s */
11504 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11509 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11510 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11511 s += 3; /* UTF-8 */
11517 if (s[2] == 0xFE && s[3] == 0xFF) {
11518 /* UTF-32 big-endian */
11519 /* diag_listed_as: Unsupported script encoding %s */
11520 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11523 else if (s[2] == 0 && s[3] != 0) {
11526 * are a good indicator of UTF-16BE. */
11527 #ifndef PERL_NO_UTF16_FILTER
11528 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11529 s = add_utf16_textfilter(s, FALSE);
11531 /* diag_listed_as: Unsupported script encoding %s */
11532 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11538 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
11539 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11540 s += 4; /* UTF-8 */
11546 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11549 * are a good indicator of UTF-16LE. */
11550 #ifndef PERL_NO_UTF16_FILTER
11551 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11552 s = add_utf16_textfilter(s, TRUE);
11554 /* diag_listed_as: Unsupported script encoding %s */
11555 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11563 #ifndef PERL_NO_UTF16_FILTER
11565 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11568 SV *const filter = FILTER_DATA(idx);
11569 /* We re-use this each time round, throwing the contents away before we
11571 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11572 SV *const utf8_buffer = filter;
11573 IV status = IoPAGE(filter);
11574 const bool reverse = cBOOL(IoLINES(filter));
11577 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11579 /* As we're automatically added, at the lowest level, and hence only called
11580 from this file, we can be sure that we're not called in block mode. Hence
11581 don't bother writing code to deal with block mode. */
11583 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11586 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11588 DEBUG_P(PerlIO_printf(Perl_debug_log,
11589 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11590 FPTR2DPTR(void *, S_utf16_textfilter),
11591 reverse ? 'l' : 'b', idx, maxlen, status,
11592 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11599 /* First, look in our buffer of existing UTF-8 data: */
11600 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11604 } else if (status == 0) {
11606 IoPAGE(filter) = 0;
11607 nl = SvEND(utf8_buffer);
11610 STRLEN got = nl - SvPVX(utf8_buffer);
11611 /* Did we have anything to append? */
11613 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11614 /* Everything else in this code works just fine if SVp_POK isn't
11615 set. This, however, needs it, and we need it to work, else
11616 we loop infinitely because the buffer is never consumed. */
11617 sv_chop(utf8_buffer, nl);
11621 /* OK, not a complete line there, so need to read some more UTF-16.
11622 Read an extra octect if the buffer currently has an odd number. */
11626 if (SvCUR(utf16_buffer) >= 2) {
11627 /* Location of the high octet of the last complete code point.
11628 Gosh, UTF-16 is a pain. All the benefits of variable length,
11629 *coupled* with all the benefits of partial reads and
11631 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11632 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11634 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11638 /* We have the first half of a surrogate. Read more. */
11639 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11642 status = FILTER_READ(idx + 1, utf16_buffer,
11643 160 + (SvCUR(utf16_buffer) & 1));
11644 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11645 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11648 IoPAGE(filter) = status;
11653 chars = SvCUR(utf16_buffer) >> 1;
11654 have = SvCUR(utf8_buffer);
11655 SvGROW(utf8_buffer, have + chars * 3 + 1);
11658 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11659 (U8*)SvPVX_const(utf8_buffer) + have,
11660 chars * 2, &newlen);
11662 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11663 (U8*)SvPVX_const(utf8_buffer) + have,
11664 chars * 2, &newlen);
11666 SvCUR_set(utf8_buffer, have + newlen);
11669 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11670 it's private to us, and utf16_to_utf8{,reversed} take a
11671 (pointer,length) pair, rather than a NUL-terminated string. */
11672 if(SvCUR(utf16_buffer) & 1) {
11673 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11674 SvCUR_set(utf16_buffer, 1);
11676 SvCUR_set(utf16_buffer, 0);
11679 DEBUG_P(PerlIO_printf(Perl_debug_log,
11680 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11682 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11683 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11688 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11690 SV *filter = filter_add(S_utf16_textfilter, NULL);
11692 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11694 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11695 sv_setpvs(filter, "");
11696 IoLINES(filter) = reversed;
11697 IoPAGE(filter) = 1; /* Not EOF */
11699 /* Sadly, we have to return a valid pointer, come what may, so we have to
11700 ignore any error return from this. */
11701 SvCUR_set(PL_linestr, 0);
11702 if (FILTER_READ(0, PL_linestr, 0)) {
11703 SvUTF8_on(PL_linestr);
11705 SvUTF8_on(PL_linestr);
11707 PL_bufend = SvEND(PL_linestr);
11708 return (U8*)SvPVX(PL_linestr);
11713 Returns a pointer to the next character after the parsed
11714 vstring, as well as updating the passed in sv.
11716 Function must be called like
11718 sv = sv_2mortal(newSV(5));
11719 s = scan_vstring(s,e,sv);
11721 where s and e are the start and end of the string.
11722 The sv should already be large enough to store the vstring
11723 passed in, for performance reasons.
11725 This function may croak if fatal warnings are enabled in the
11726 calling scope, hence the sv_2mortal in the example (to prevent
11727 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11733 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11736 const char *pos = s;
11737 const char *start = s;
11739 PERL_ARGS_ASSERT_SCAN_VSTRING;
11741 if (*pos == 'v') pos++; /* get past 'v' */
11742 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11744 if ( *pos != '.') {
11745 /* this may not be a v-string if followed by => */
11746 const char *next = pos;
11747 while (next < e && isSPACE(*next))
11749 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11750 /* return string not v-string */
11751 sv_setpvn(sv,(char *)s,pos-s);
11752 return (char *)pos;
11756 if (!isALPHA(*pos)) {
11757 U8 tmpbuf[UTF8_MAXBYTES+1];
11760 s++; /* get past 'v' */
11765 /* this is atoi() that tolerates underscores */
11768 const char *end = pos;
11770 while (--end >= s) {
11772 const UV orev = rev;
11773 rev += (*end - '0') * mult;
11776 /* diag_listed_as: Integer overflow in %s number */
11777 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11778 "Integer overflow in decimal number");
11782 if (rev > 0x7FFFFFFF)
11783 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11785 /* Append native character for the rev point */
11786 tmpend = uvchr_to_utf8(tmpbuf, rev);
11787 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11788 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11790 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11796 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11800 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11807 Perl_keyword_plugin_standard(pTHX_
11808 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11810 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11811 PERL_UNUSED_CONTEXT;
11812 PERL_UNUSED_ARG(keyword_ptr);
11813 PERL_UNUSED_ARG(keyword_len);
11814 PERL_UNUSED_ARG(op_ptr);
11815 return KEYWORD_PLUGIN_DECLINE;
11818 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11820 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11822 SAVEI32(PL_lex_brackets);
11823 if (PL_lex_brackets > 100)
11824 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11825 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11826 SAVEI32(PL_lex_allbrackets);
11827 PL_lex_allbrackets = 0;
11828 SAVEI8(PL_lex_fakeeof);
11829 PL_lex_fakeeof = (U8)fakeeof;
11830 if(yyparse(gramtype) && !PL_parser->error_count)
11831 qerror(Perl_mess(aTHX_ "Parse error"));
11834 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11836 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11840 SAVEVPTR(PL_eval_root);
11841 PL_eval_root = NULL;
11842 parse_recdescent(gramtype, fakeeof);
11848 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11850 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11853 if (flags & ~PARSE_OPTIONAL)
11854 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11855 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11856 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11857 if (!PL_parser->error_count)
11858 qerror(Perl_mess(aTHX_ "Parse error"));
11859 exprop = newOP(OP_NULL, 0);
11865 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11867 Parse a Perl arithmetic expression. This may contain operators of precedence
11868 down to the bit shift operators. The expression must be followed (and thus
11869 terminated) either by a comparison or lower-precedence operator or by
11870 something that would normally terminate an expression such as semicolon.
11871 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11872 otherwise it is mandatory. It is up to the caller to ensure that the
11873 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11874 the source of the code to be parsed and the lexical context for the
11877 The op tree representing the expression is returned. If an optional
11878 expression is absent, a null pointer is returned, otherwise the pointer
11881 If an error occurs in parsing or compilation, in most cases a valid op
11882 tree is returned anyway. The error is reflected in the parser state,
11883 normally resulting in a single exception at the top level of parsing
11884 which covers all the compilation errors that occurred. Some compilation
11885 errors, however, will throw an exception immediately.
11891 Perl_parse_arithexpr(pTHX_ U32 flags)
11893 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11897 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11899 Parse a Perl term expression. This may contain operators of precedence
11900 down to the assignment operators. The expression must be followed (and thus
11901 terminated) either by a comma or lower-precedence operator or by
11902 something that would normally terminate an expression such as semicolon.
11903 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11904 otherwise it is mandatory. It is up to the caller to ensure that the
11905 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11906 the source of the code to be parsed and the lexical context for the
11909 The op tree representing the expression is returned. If an optional
11910 expression is absent, a null pointer is returned, otherwise the pointer
11913 If an error occurs in parsing or compilation, in most cases a valid op
11914 tree is returned anyway. The error is reflected in the parser state,
11915 normally resulting in a single exception at the top level of parsing
11916 which covers all the compilation errors that occurred. Some compilation
11917 errors, however, will throw an exception immediately.
11923 Perl_parse_termexpr(pTHX_ U32 flags)
11925 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11929 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11931 Parse a Perl list expression. This may contain operators of precedence
11932 down to the comma operator. The expression must be followed (and thus
11933 terminated) either by a low-precedence logic operator such as C<or> or by
11934 something that would normally terminate an expression such as semicolon.
11935 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11936 otherwise it is mandatory. It is up to the caller to ensure that the
11937 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11938 the source of the code to be parsed and the lexical context for the
11941 The op tree representing the expression is returned. If an optional
11942 expression is absent, a null pointer is returned, otherwise the pointer
11945 If an error occurs in parsing or compilation, in most cases a valid op
11946 tree is returned anyway. The error is reflected in the parser state,
11947 normally resulting in a single exception at the top level of parsing
11948 which covers all the compilation errors that occurred. Some compilation
11949 errors, however, will throw an exception immediately.
11955 Perl_parse_listexpr(pTHX_ U32 flags)
11957 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11961 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11963 Parse a single complete Perl expression. This allows the full
11964 expression grammar, including the lowest-precedence operators such
11965 as C<or>. The expression must be followed (and thus terminated) by a
11966 token that an expression would normally be terminated by: end-of-file,
11967 closing bracketing punctuation, semicolon, or one of the keywords that
11968 signals a postfix expression-statement modifier. If I<flags> includes
11969 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11970 mandatory. It is up to the caller to ensure that the dynamic parser
11971 state (L</PL_parser> et al) is correctly set to reflect the source of
11972 the code to be parsed and the lexical context for the expression.
11974 The op tree representing the expression is returned. If an optional
11975 expression is absent, a null pointer is returned, otherwise the pointer
11978 If an error occurs in parsing or compilation, in most cases a valid op
11979 tree is returned anyway. The error is reflected in the parser state,
11980 normally resulting in a single exception at the top level of parsing
11981 which covers all the compilation errors that occurred. Some compilation
11982 errors, however, will throw an exception immediately.
11988 Perl_parse_fullexpr(pTHX_ U32 flags)
11990 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11994 =for apidoc Amx|OP *|parse_block|U32 flags
11996 Parse a single complete Perl code block. This consists of an opening
11997 brace, a sequence of statements, and a closing brace. The block
11998 constitutes a lexical scope, so C<my> variables and various compile-time
11999 effects can be contained within it. It is up to the caller to ensure
12000 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12001 reflect the source of the code to be parsed and the lexical context for
12004 The op tree representing the code block is returned. This is always a
12005 real op, never a null pointer. It will normally be a C<lineseq> list,
12006 including C<nextstate> or equivalent ops. No ops to construct any kind
12007 of runtime scope are included by virtue of it being a block.
12009 If an error occurs in parsing or compilation, in most cases a valid op
12010 tree (most likely null) is returned anyway. The error is reflected in
12011 the parser state, normally resulting in a single exception at the top
12012 level of parsing which covers all the compilation errors that occurred.
12013 Some compilation errors, however, will throw an exception immediately.
12015 The I<flags> parameter is reserved for future use, and must always
12022 Perl_parse_block(pTHX_ U32 flags)
12025 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12026 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12030 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12032 Parse a single unadorned Perl statement. This may be a normal imperative
12033 statement or a declaration that has compile-time effect. It does not
12034 include any label or other affixture. It is up to the caller to ensure
12035 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12036 reflect the source of the code to be parsed and the lexical context for
12039 The op tree representing the statement is returned. This may be a
12040 null pointer if the statement is null, for example if it was actually
12041 a subroutine definition (which has compile-time side effects). If not
12042 null, it will be ops directly implementing the statement, suitable to
12043 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12044 equivalent op (except for those embedded in a scope contained entirely
12045 within the statement).
12047 If an error occurs in parsing or compilation, in most cases a valid op
12048 tree (most likely null) is returned anyway. The error is reflected in
12049 the parser state, normally resulting in a single exception at the top
12050 level of parsing which covers all the compilation errors that occurred.
12051 Some compilation errors, however, will throw an exception immediately.
12053 The I<flags> parameter is reserved for future use, and must always
12060 Perl_parse_barestmt(pTHX_ U32 flags)
12063 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12064 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12068 =for apidoc Amx|SV *|parse_label|U32 flags
12070 Parse a single label, possibly optional, of the type that may prefix a
12071 Perl statement. It is up to the caller to ensure that the dynamic parser
12072 state (L</PL_parser> et al) is correctly set to reflect the source of
12073 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
12074 label is optional, otherwise it is mandatory.
12076 The name of the label is returned in the form of a fresh scalar. If an
12077 optional label is absent, a null pointer is returned.
12079 If an error occurs in parsing, which can only occur if the label is
12080 mandatory, a valid label is returned anyway. The error is reflected in
12081 the parser state, normally resulting in a single exception at the top
12082 level of parsing which covers all the compilation errors that occurred.
12088 Perl_parse_label(pTHX_ U32 flags)
12090 if (flags & ~PARSE_OPTIONAL)
12091 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12092 if (PL_lex_state == LEX_KNOWNEXT) {
12093 PL_parser->yychar = yylex();
12094 if (PL_parser->yychar == LABEL) {
12095 char * const lpv = pl_yylval.pval;
12096 STRLEN llen = strlen(lpv);
12097 PL_parser->yychar = YYEMPTY;
12098 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12105 STRLEN wlen, bufptr_pos;
12108 if (!isIDFIRST_lazy_if(s, UTF))
12110 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12111 if (word_takes_any_delimeter(s, wlen))
12113 bufptr_pos = s - SvPVX(PL_linestr);
12115 lex_read_space(LEX_KEEP_PREVIOUS);
12117 s = SvPVX(PL_linestr) + bufptr_pos;
12118 if (t[0] == ':' && t[1] != ':') {
12119 PL_oldoldbufptr = PL_oldbufptr;
12122 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12126 if (flags & PARSE_OPTIONAL) {
12129 qerror(Perl_mess(aTHX_ "Parse error"));
12130 return newSVpvs("x");
12137 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12139 Parse a single complete Perl statement. This may be a normal imperative
12140 statement or a declaration that has compile-time effect, and may include
12141 optional labels. It is up to the caller to ensure that the dynamic
12142 parser state (L</PL_parser> et al) is correctly set to reflect the source
12143 of the code to be parsed and the lexical context for the statement.
12145 The op tree representing the statement is returned. This may be a
12146 null pointer if the statement is null, for example if it was actually
12147 a subroutine definition (which has compile-time side effects). If not
12148 null, it will be the result of a L</newSTATEOP> call, normally including
12149 a C<nextstate> or equivalent op.
12151 If an error occurs in parsing or compilation, in most cases a valid op
12152 tree (most likely null) is returned anyway. The error is reflected in
12153 the parser state, normally resulting in a single exception at the top
12154 level of parsing which covers all the compilation errors that occurred.
12155 Some compilation errors, however, will throw an exception immediately.
12157 The I<flags> parameter is reserved for future use, and must always
12164 Perl_parse_fullstmt(pTHX_ U32 flags)
12167 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12168 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12172 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12174 Parse a sequence of zero or more Perl statements. These may be normal
12175 imperative statements, including optional labels, or declarations
12176 that have compile-time effect, or any mixture thereof. The statement
12177 sequence ends when a closing brace or end-of-file is encountered in a
12178 place where a new statement could have validly started. It is up to
12179 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12180 is correctly set to reflect the source of the code to be parsed and the
12181 lexical context for the statements.
12183 The op tree representing the statement sequence is returned. This may
12184 be a null pointer if the statements were all null, for example if there
12185 were no statements or if there were only subroutine definitions (which
12186 have compile-time side effects). If not null, it will be a C<lineseq>
12187 list, normally including C<nextstate> or equivalent ops.
12189 If an error occurs in parsing or compilation, in most cases a valid op
12190 tree is returned anyway. The error is reflected in the parser state,
12191 normally resulting in a single exception at the top level of parsing
12192 which covers all the compilation errors that occurred. Some compilation
12193 errors, however, will throw an exception immediately.
12195 The I<flags> parameter is reserved for future use, and must always
12202 Perl_parse_stmtseq(pTHX_ U32 flags)
12207 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12208 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12209 c = lex_peek_unichar(0);
12210 if (c != -1 && c != /*{*/'}')
12211 qerror(Perl_mess(aTHX_ "Parse error"));
12217 * c-indentation-style: bsd
12218 * c-basic-offset: 4
12219 * indent-tabs-mode: nil
12222 * ex: set ts=8 sts=4 sw=4 et: