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) ((c)==' '||(c)=='\t')
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 <= '~')
430 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
432 sv_catpvs(report, "EOF");
434 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
439 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
441 case TOKENTYPE_OPNUM:
442 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
443 PL_op_name[lvalp->ival]);
446 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
448 case TOKENTYPE_OPVAL:
450 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
451 PL_op_name[lvalp->opval->op_type]);
452 if (lvalp->opval->op_type == OP_CONST) {
453 Perl_sv_catpvf(aTHX_ report, " %s",
454 SvPEEK(cSVOPx_sv(lvalp->opval)));
459 sv_catpvs(report, "(opval=null)");
462 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
468 /* print the buffer with suitable escapes */
471 S_printbuf(pTHX_ const char *const fmt, const char *const s)
473 SV* const tmp = newSVpvs("");
475 PERL_ARGS_ASSERT_PRINTBUF;
477 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
484 S_deprecate_commaless_var_list(pTHX) {
486 deprecate("comma-less variable list");
487 return REPORT(','); /* grandfather non-comma-format format */
493 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
494 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
498 S_ao(pTHX_ int toketype)
501 if (*PL_bufptr == '=') {
503 if (toketype == ANDAND)
504 pl_yylval.ival = OP_ANDASSIGN;
505 else if (toketype == OROR)
506 pl_yylval.ival = OP_ORASSIGN;
507 else if (toketype == DORDOR)
508 pl_yylval.ival = OP_DORASSIGN;
516 * When Perl expects an operator and finds something else, no_op
517 * prints the warning. It always prints "<something> found where
518 * operator expected. It prints "Missing semicolon on previous line?"
519 * if the surprise occurs at the start of the line. "do you need to
520 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
521 * where the compiler doesn't know if foo is a method call or a function.
522 * It prints "Missing operator before end of line" if there's nothing
523 * after the missing operator, or "... before <...>" if there is something
524 * after the missing operator.
528 S_no_op(pTHX_ const char *const what, char *s)
531 char * const oldbp = PL_bufptr;
532 const bool is_first = (PL_oldbufptr == PL_linestart);
534 PERL_ARGS_ASSERT_NO_OP;
540 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
541 if (ckWARN_d(WARN_SYNTAX)) {
543 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
544 "\t(Missing semicolon on previous line?)\n");
545 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
547 for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
548 t += UTF ? UTF8SKIP(t) : 1)
550 if (t < PL_bufptr && isSPACE(*t))
551 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
552 "\t(Do you need to predeclare %"SVf"?)\n",
553 SVfARG(newSVpvn_flags(PL_oldoldbufptr, (STRLEN)(t - PL_oldoldbufptr),
554 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
558 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
559 "\t(Missing operator before %"SVf"?)\n",
560 SVfARG(newSVpvn_flags(oldbp, (STRLEN)(s - oldbp),
561 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
569 * Complain about missing quote/regexp/heredoc terminator.
570 * If it's called with NULL then it cauterizes the line buffer.
571 * If we're in a delimited string and the delimiter is a control
572 * character, it's reformatted into a two-char sequence like ^C.
577 S_missingterm(pTHX_ char *s)
583 char * const nl = strrchr(s,'\n');
587 else if (isCNTRL(PL_multi_close)) {
589 tmpbuf[1] = (char)toCTRL(PL_multi_close);
594 *tmpbuf = (char)PL_multi_close;
598 q = strchr(s,'"') ? '\'' : '"';
599 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
605 * Check whether the named feature is enabled.
608 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
611 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
613 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
615 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
617 if (namelen > MAX_FEATURE_LEN)
619 memcpy(&he_name[8], name, namelen);
621 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
622 REFCOUNTED_HE_EXISTS));
626 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
627 * utf16-to-utf8-reversed.
630 #ifdef PERL_CR_FILTER
634 const char *s = SvPVX_const(sv);
635 const char * const e = s + SvCUR(sv);
637 PERL_ARGS_ASSERT_STRIP_RETURN;
639 /* outer loop optimized to do nothing if there are no CR-LFs */
641 if (*s++ == '\r' && *s == '\n') {
642 /* hit a CR-LF, need to copy the rest */
646 if (*s == '\r' && s[1] == '\n')
657 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
659 const I32 count = FILTER_READ(idx+1, sv, maxlen);
660 if (count > 0 && !maxlen)
667 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
669 Creates and initialises a new lexer/parser state object, supplying
670 a context in which to lex and parse from a new source of Perl code.
671 A pointer to the new state object is placed in L</PL_parser>. An entry
672 is made on the save stack so that upon unwinding the new state object
673 will be destroyed and the former value of L</PL_parser> will be restored.
674 Nothing else need be done to clean up the parsing context.
676 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
677 non-null, provides a string (in SV form) containing code to be parsed.
678 A copy of the string is made, so subsequent modification of I<line>
679 does not affect parsing. I<rsfp>, if non-null, provides an input stream
680 from which code will be read to be parsed. If both are non-null, the
681 code in I<line> comes first and must consist of complete lines of input,
682 and I<rsfp> supplies the remainder of the source.
684 The I<flags> parameter is reserved for future use. Currently it is only
685 used by perl internally, so extensions should always pass zero.
690 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
691 can share filters with the current parser.
692 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
693 caller, hence isn't owned by the parser, so shouldn't be closed on parser
694 destruction. This is used to handle the case of defaulting to reading the
695 script from the standard input because no filename was given on the command
696 line (without getting confused by situation where STDIN has been closed, so
697 the script handle is opened on fd 0) */
700 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
703 const char *s = NULL;
704 yy_parser *parser, *oparser;
705 if (flags && flags & ~LEX_START_FLAGS)
706 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
708 /* create and initialise a parser */
710 Newxz(parser, 1, yy_parser);
711 parser->old_parser = oparser = PL_parser;
714 parser->stack = NULL;
716 parser->stack_size = 0;
718 /* on scope exit, free this parser and restore any outer one */
720 parser->saved_curcop = PL_curcop;
722 /* initialise lexer state */
725 parser->curforce = -1;
727 parser->nexttoke = 0;
729 parser->error_count = oparser ? oparser->error_count : 0;
730 parser->copline = NOLINE;
731 parser->lex_state = LEX_NORMAL;
732 parser->expect = XSTATE;
734 parser->rsfp_filters =
735 !(flags & LEX_START_SAME_FILTER) || !oparser
737 : MUTABLE_AV(SvREFCNT_inc(
738 oparser->rsfp_filters
739 ? oparser->rsfp_filters
740 : (oparser->rsfp_filters = newAV())
743 Newx(parser->lex_brackstack, 120, char);
744 Newx(parser->lex_casestack, 12, char);
745 *parser->lex_casestack = '\0';
746 Newxz(parser->lex_shared, 1, LEXSHARED);
750 s = SvPV_const(line, len);
751 parser->linestr = flags & LEX_START_COPIED
752 ? SvREFCNT_inc_simple_NN(line)
753 : newSVpvn_flags(s, len, SvUTF8(line));
754 sv_catpvs(parser->linestr, "\n;");
756 parser->linestr = newSVpvs("\n;");
758 parser->oldoldbufptr =
761 parser->linestart = SvPVX(parser->linestr);
762 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
763 parser->last_lop = parser->last_uni = NULL;
764 parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
765 |LEX_DONT_CLOSE_RSFP);
767 parser->in_pod = parser->filtered = 0;
771 /* delete a parser object */
774 Perl_parser_free(pTHX_ const yy_parser *parser)
776 PERL_ARGS_ASSERT_PARSER_FREE;
778 PL_curcop = parser->saved_curcop;
779 SvREFCNT_dec(parser->linestr);
781 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
782 PerlIO_clearerr(parser->rsfp);
783 else if (parser->rsfp && (!parser->old_parser ||
784 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
785 PerlIO_close(parser->rsfp);
786 SvREFCNT_dec(parser->rsfp_filters);
787 SvREFCNT_dec(parser->lex_stuff);
788 SvREFCNT_dec(parser->sublex_info.repl);
790 Safefree(parser->lex_brackstack);
791 Safefree(parser->lex_casestack);
792 Safefree(parser->lex_shared);
793 PL_parser = parser->old_parser;
798 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
801 I32 nexttoke = parser->lasttoke;
803 I32 nexttoke = parser->nexttoke;
805 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
808 if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
810 && parser->nexttoke[nexttoke].next_val.opval
811 && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
812 && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
813 op_free(parser->nexttoke[nexttoke].next_val.opval);
814 parser->nexttoke[nexttoke].next_val.opval = NULL;
817 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
818 && parser->nextval[nexttoke].opval
819 && parser->nextval[nexttoke].opval->op_slabbed
820 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
821 op_free(parser->nextval[nexttoke].opval);
822 parser->nextval[nexttoke].opval = NULL;
830 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
832 Buffer scalar containing the chunk currently under consideration of the
833 text currently being lexed. This is always a plain string scalar (for
834 which C<SvPOK> is true). It is not intended to be used as a scalar by
835 normal scalar means; instead refer to the buffer directly by the pointer
836 variables described below.
838 The lexer maintains various C<char*> pointers to things in the
839 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
840 reallocated, all of these pointers must be updated. Don't attempt to
841 do this manually, but rather use L</lex_grow_linestr> if you need to
842 reallocate the buffer.
844 The content of the text chunk in the buffer is commonly exactly one
845 complete line of input, up to and including a newline terminator,
846 but there are situations where it is otherwise. The octets of the
847 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
848 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
849 flag on this scalar, which may disagree with it.
851 For direct examination of the buffer, the variable
852 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
853 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
854 of these pointers is usually preferable to examination of the scalar
855 through normal scalar means.
857 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
859 Direct pointer to the end of the chunk of text currently being lexed, the
860 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
861 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
862 always located at the end of the buffer, and does not count as part of
863 the buffer's contents.
865 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
867 Points to the current position of lexing inside the lexer buffer.
868 Characters around this point may be freely examined, within
869 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
870 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
871 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
873 Lexing code (whether in the Perl core or not) moves this pointer past
874 the characters that it consumes. It is also expected to perform some
875 bookkeeping whenever a newline character is consumed. This movement
876 can be more conveniently performed by the function L</lex_read_to>,
877 which handles newlines appropriately.
879 Interpretation of the buffer's octets can be abstracted out by
880 using the slightly higher-level functions L</lex_peek_unichar> and
881 L</lex_read_unichar>.
883 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
885 Points to the start of the current line inside the lexer buffer.
886 This is useful for indicating at which column an error occurred, and
887 not much else. This must be updated by any lexing code that consumes
888 a newline; the function L</lex_read_to> handles this detail.
894 =for apidoc Amx|bool|lex_bufutf8
896 Indicates whether the octets in the lexer buffer
897 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
898 of Unicode characters. If not, they should be interpreted as Latin-1
899 characters. This is analogous to the C<SvUTF8> flag for scalars.
901 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
902 contains valid UTF-8. Lexing code must be robust in the face of invalid
905 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
906 is significant, but not the whole story regarding the input character
907 encoding. Normally, when a file is being read, the scalar contains octets
908 and its C<SvUTF8> flag is off, but the octets should be interpreted as
909 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
910 however, the scalar may have the C<SvUTF8> flag on, and in this case its
911 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
912 is in effect. This logic may change in the future; use this function
913 instead of implementing the logic yourself.
919 Perl_lex_bufutf8(pTHX)
925 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
927 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
928 at least I<len> octets (including terminating NUL). Returns a
929 pointer to the reallocated buffer. This is necessary before making
930 any direct modification of the buffer that would increase its length.
931 L</lex_stuff_pvn> provides a more convenient way to insert text into
934 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
935 this function updates all of the lexer's variables that point directly
942 Perl_lex_grow_linestr(pTHX_ STRLEN len)
946 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
947 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
948 linestr = PL_parser->linestr;
949 buf = SvPVX(linestr);
950 if (len <= SvLEN(linestr))
952 bufend_pos = PL_parser->bufend - buf;
953 bufptr_pos = PL_parser->bufptr - buf;
954 oldbufptr_pos = PL_parser->oldbufptr - buf;
955 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
956 linestart_pos = PL_parser->linestart - buf;
957 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
958 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
959 re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
960 PL_parser->lex_shared->re_eval_start - buf : 0;
962 buf = sv_grow(linestr, len);
964 PL_parser->bufend = buf + bufend_pos;
965 PL_parser->bufptr = buf + bufptr_pos;
966 PL_parser->oldbufptr = buf + oldbufptr_pos;
967 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
968 PL_parser->linestart = buf + linestart_pos;
969 if (PL_parser->last_uni)
970 PL_parser->last_uni = buf + last_uni_pos;
971 if (PL_parser->last_lop)
972 PL_parser->last_lop = buf + last_lop_pos;
973 if (PL_parser->lex_shared->re_eval_start)
974 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
979 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
981 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
982 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
983 reallocating the buffer if necessary. This means that lexing code that
984 runs later will see the characters as if they had appeared in the input.
985 It is not recommended to do this as part of normal parsing, and most
986 uses of this facility run the risk of the inserted characters being
987 interpreted in an unintended manner.
989 The string to be inserted is represented by I<len> octets starting
990 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
991 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
992 The characters are recoded for the lexer buffer, according to how the
993 buffer is currently being interpreted (L</lex_bufutf8>). If a string
994 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
995 function is more convenient.
1001 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1005 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1006 if (flags & ~(LEX_STUFF_UTF8))
1007 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1009 if (flags & LEX_STUFF_UTF8) {
1012 STRLEN highhalf = 0; /* Count of variants */
1013 const char *p, *e = pv+len;
1014 for (p = pv; p != e; p++) {
1015 if (! UTF8_IS_INVARIANT(*p)) {
1021 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1022 bufptr = PL_parser->bufptr;
1023 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1024 SvCUR_set(PL_parser->linestr,
1025 SvCUR(PL_parser->linestr) + len+highhalf);
1026 PL_parser->bufend += len+highhalf;
1027 for (p = pv; p != e; p++) {
1029 if (! UTF8_IS_INVARIANT(c)) {
1030 *bufptr++ = UTF8_TWO_BYTE_HI(c);
1031 *bufptr++ = UTF8_TWO_BYTE_LO(c);
1033 *bufptr++ = (char)c;
1038 if (flags & LEX_STUFF_UTF8) {
1039 STRLEN highhalf = 0;
1040 const char *p, *e = pv+len;
1041 for (p = pv; p != e; p++) {
1043 if (UTF8_IS_ABOVE_LATIN1(c)) {
1044 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1045 "non-Latin-1 character into Latin-1 input");
1046 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1049 } else if (! UTF8_IS_INVARIANT(c)) {
1050 /* malformed UTF-8 */
1052 SAVESPTR(PL_warnhook);
1053 PL_warnhook = PERL_WARNHOOK_FATAL;
1054 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
1060 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1061 bufptr = PL_parser->bufptr;
1062 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1063 SvCUR_set(PL_parser->linestr,
1064 SvCUR(PL_parser->linestr) + len-highhalf);
1065 PL_parser->bufend += len-highhalf;
1068 if (UTF8_IS_INVARIANT(*p)) {
1074 *bufptr++ = TWO_BYTE_UTF8_TO_UNI(*p, *(p+1));
1080 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1081 bufptr = PL_parser->bufptr;
1082 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1083 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1084 PL_parser->bufend += len;
1085 Copy(pv, bufptr, len, char);
1091 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1093 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1094 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1095 reallocating the buffer if necessary. This means that lexing code that
1096 runs later will see the characters as if they had appeared in the input.
1097 It is not recommended to do this as part of normal parsing, and most
1098 uses of this facility run the risk of the inserted characters being
1099 interpreted in an unintended manner.
1101 The string to be inserted is represented by octets starting at I<pv>
1102 and continuing to the first nul. These octets are interpreted as either
1103 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1104 in I<flags>. The characters are recoded for the lexer buffer, according
1105 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1106 If it is not convenient to nul-terminate a string to be inserted, the
1107 L</lex_stuff_pvn> function is more appropriate.
1113 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1115 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1116 lex_stuff_pvn(pv, strlen(pv), flags);
1120 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1122 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1123 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1124 reallocating the buffer if necessary. This means that lexing code that
1125 runs later will see the characters as if they had appeared in the input.
1126 It is not recommended to do this as part of normal parsing, and most
1127 uses of this facility run the risk of the inserted characters being
1128 interpreted in an unintended manner.
1130 The string to be inserted is the string value of I<sv>. The characters
1131 are recoded for the lexer buffer, according to how the buffer is currently
1132 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1133 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1134 need to construct a scalar.
1140 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1144 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1146 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1148 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1152 =for apidoc Amx|void|lex_unstuff|char *ptr
1154 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1155 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1156 This hides the discarded text from any lexing code that runs later,
1157 as if the text had never appeared.
1159 This is not the normal way to consume lexed text. For that, use
1166 Perl_lex_unstuff(pTHX_ char *ptr)
1170 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1171 buf = PL_parser->bufptr;
1173 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1176 bufend = PL_parser->bufend;
1178 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1179 unstuff_len = ptr - buf;
1180 Move(ptr, buf, bufend+1-ptr, char);
1181 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1182 PL_parser->bufend = bufend - unstuff_len;
1186 =for apidoc Amx|void|lex_read_to|char *ptr
1188 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1189 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1190 performing the correct bookkeeping whenever a newline character is passed.
1191 This is the normal way to consume lexed text.
1193 Interpretation of the buffer's octets can be abstracted out by
1194 using the slightly higher-level functions L</lex_peek_unichar> and
1195 L</lex_read_unichar>.
1201 Perl_lex_read_to(pTHX_ char *ptr)
1204 PERL_ARGS_ASSERT_LEX_READ_TO;
1205 s = PL_parser->bufptr;
1206 if (ptr < s || ptr > PL_parser->bufend)
1207 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1208 for (; s != ptr; s++)
1210 COPLINE_INC_WITH_HERELINES;
1211 PL_parser->linestart = s+1;
1213 PL_parser->bufptr = ptr;
1217 =for apidoc Amx|void|lex_discard_to|char *ptr
1219 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1220 up to I<ptr>. The remaining content of the buffer will be moved, and
1221 all pointers into the buffer updated appropriately. I<ptr> must not
1222 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1223 it is not permitted to discard text that has yet to be lexed.
1225 Normally it is not necessarily to do this directly, because it suffices to
1226 use the implicit discarding behaviour of L</lex_next_chunk> and things
1227 based on it. However, if a token stretches across multiple lines,
1228 and the lexing code has kept multiple lines of text in the buffer for
1229 that purpose, then after completion of the token it would be wise to
1230 explicitly discard the now-unneeded earlier lines, to avoid future
1231 multi-line tokens growing the buffer without bound.
1237 Perl_lex_discard_to(pTHX_ char *ptr)
1241 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1242 buf = SvPVX(PL_parser->linestr);
1244 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1247 if (ptr > PL_parser->bufptr)
1248 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1249 discard_len = ptr - buf;
1250 if (PL_parser->oldbufptr < ptr)
1251 PL_parser->oldbufptr = ptr;
1252 if (PL_parser->oldoldbufptr < ptr)
1253 PL_parser->oldoldbufptr = ptr;
1254 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1255 PL_parser->last_uni = NULL;
1256 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1257 PL_parser->last_lop = NULL;
1258 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1259 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1260 PL_parser->bufend -= discard_len;
1261 PL_parser->bufptr -= discard_len;
1262 PL_parser->oldbufptr -= discard_len;
1263 PL_parser->oldoldbufptr -= discard_len;
1264 if (PL_parser->last_uni)
1265 PL_parser->last_uni -= discard_len;
1266 if (PL_parser->last_lop)
1267 PL_parser->last_lop -= discard_len;
1271 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1273 Reads in the next chunk of text to be lexed, appending it to
1274 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1275 looked to the end of the current chunk and wants to know more. It is
1276 usual, but not necessary, for lexing to have consumed the entirety of
1277 the current chunk at this time.
1279 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1280 chunk (i.e., the current chunk has been entirely consumed), normally the
1281 current chunk will be discarded at the same time that the new chunk is
1282 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1283 will not be discarded. If the current chunk has not been entirely
1284 consumed, then it will not be discarded regardless of the flag.
1286 Returns true if some new text was added to the buffer, or false if the
1287 buffer has reached the end of the input text.
1292 #define LEX_FAKE_EOF 0x80000000
1293 #define LEX_NO_TERM 0x40000000
1296 Perl_lex_next_chunk(pTHX_ U32 flags)
1300 STRLEN old_bufend_pos, new_bufend_pos;
1301 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1302 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1303 bool got_some_for_debugger = 0;
1305 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1306 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1307 linestr = PL_parser->linestr;
1308 buf = SvPVX(linestr);
1309 if (!(flags & LEX_KEEP_PREVIOUS) &&
1310 PL_parser->bufptr == PL_parser->bufend) {
1311 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1313 if (PL_parser->last_uni != PL_parser->bufend)
1314 PL_parser->last_uni = NULL;
1315 if (PL_parser->last_lop != PL_parser->bufend)
1316 PL_parser->last_lop = NULL;
1317 last_uni_pos = last_lop_pos = 0;
1321 old_bufend_pos = PL_parser->bufend - buf;
1322 bufptr_pos = PL_parser->bufptr - buf;
1323 oldbufptr_pos = PL_parser->oldbufptr - buf;
1324 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1325 linestart_pos = PL_parser->linestart - buf;
1326 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1327 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1329 if (flags & LEX_FAKE_EOF) {
1331 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1333 } else if (filter_gets(linestr, old_bufend_pos)) {
1335 got_some_for_debugger = 1;
1336 } else if (flags & LEX_NO_TERM) {
1339 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1340 sv_setpvs(linestr, "");
1342 /* End of real input. Close filehandle (unless it was STDIN),
1343 * then add implicit termination.
1345 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1346 PerlIO_clearerr(PL_parser->rsfp);
1347 else if (PL_parser->rsfp)
1348 (void)PerlIO_close(PL_parser->rsfp);
1349 PL_parser->rsfp = NULL;
1350 PL_parser->in_pod = PL_parser->filtered = 0;
1352 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1355 if (!PL_in_eval && PL_minus_p) {
1357 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1358 PL_minus_n = PL_minus_p = 0;
1359 } else if (!PL_in_eval && PL_minus_n) {
1360 sv_catpvs(linestr, /*{*/";}");
1363 sv_catpvs(linestr, ";");
1366 buf = SvPVX(linestr);
1367 new_bufend_pos = SvCUR(linestr);
1368 PL_parser->bufend = buf + new_bufend_pos;
1369 PL_parser->bufptr = buf + bufptr_pos;
1370 PL_parser->oldbufptr = buf + oldbufptr_pos;
1371 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1372 PL_parser->linestart = buf + linestart_pos;
1373 if (PL_parser->last_uni)
1374 PL_parser->last_uni = buf + last_uni_pos;
1375 if (PL_parser->last_lop)
1376 PL_parser->last_lop = buf + last_lop_pos;
1377 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1378 PL_curstash != PL_debstash) {
1379 /* debugger active and we're not compiling the debugger code,
1380 * so store the line into the debugger's array of lines
1382 update_debugger_info(NULL, buf+old_bufend_pos,
1383 new_bufend_pos-old_bufend_pos);
1389 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1391 Looks ahead one (Unicode) character in the text currently being lexed.
1392 Returns the codepoint (unsigned integer value) of the next character,
1393 or -1 if lexing has reached the end of the input text. To consume the
1394 peeked character, use L</lex_read_unichar>.
1396 If the next character is in (or extends into) the next chunk of input
1397 text, the next chunk will be read in. Normally the current chunk will be
1398 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1399 then the current chunk will not be discarded.
1401 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1402 is encountered, an exception is generated.
1408 Perl_lex_peek_unichar(pTHX_ U32 flags)
1412 if (flags & ~(LEX_KEEP_PREVIOUS))
1413 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1414 s = PL_parser->bufptr;
1415 bufend = PL_parser->bufend;
1421 if (!lex_next_chunk(flags))
1423 s = PL_parser->bufptr;
1424 bufend = PL_parser->bufend;
1427 if (UTF8_IS_INVARIANT(head))
1429 if (UTF8_IS_START(head)) {
1430 len = UTF8SKIP(&head);
1431 while ((STRLEN)(bufend-s) < len) {
1432 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1434 s = PL_parser->bufptr;
1435 bufend = PL_parser->bufend;
1438 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1439 if (retlen == (STRLEN)-1) {
1440 /* malformed UTF-8 */
1442 SAVESPTR(PL_warnhook);
1443 PL_warnhook = PERL_WARNHOOK_FATAL;
1444 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1450 if (!lex_next_chunk(flags))
1452 s = PL_parser->bufptr;
1459 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1461 Reads the next (Unicode) character in the text currently being lexed.
1462 Returns the codepoint (unsigned integer value) of the character read,
1463 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1464 if lexing has reached the end of the input text. To non-destructively
1465 examine the next character, use L</lex_peek_unichar> instead.
1467 If the next character is in (or extends into) the next chunk of input
1468 text, the next chunk will be read in. Normally the current chunk will be
1469 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1470 then the current chunk will not be discarded.
1472 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1473 is encountered, an exception is generated.
1479 Perl_lex_read_unichar(pTHX_ U32 flags)
1482 if (flags & ~(LEX_KEEP_PREVIOUS))
1483 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1484 c = lex_peek_unichar(flags);
1487 COPLINE_INC_WITH_HERELINES;
1489 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1491 ++(PL_parser->bufptr);
1497 =for apidoc Amx|void|lex_read_space|U32 flags
1499 Reads optional spaces, in Perl style, in the text currently being
1500 lexed. The spaces may include ordinary whitespace characters and
1501 Perl-style comments. C<#line> directives are processed if encountered.
1502 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1503 at a non-space character (or the end of the input text).
1505 If spaces extend into the next chunk of input text, the next chunk will
1506 be read in. Normally the current chunk will be discarded at the same
1507 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1508 chunk will not be discarded.
1513 #define LEX_NO_NEXT_CHUNK 0x80000000
1516 Perl_lex_read_space(pTHX_ U32 flags)
1519 bool need_incline = 0;
1520 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
1521 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1524 sv_free(PL_skipwhite);
1525 PL_skipwhite = NULL;
1528 PL_skipwhite = newSVpvs("");
1529 #endif /* PERL_MAD */
1530 s = PL_parser->bufptr;
1531 bufend = PL_parser->bufend;
1537 } while (!(c == '\n' || (c == 0 && s == bufend)));
1538 } else if (c == '\n') {
1540 PL_parser->linestart = s;
1545 } else if (isSPACE(c)) {
1547 } else if (c == 0 && s == bufend) {
1551 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1552 #endif /* PERL_MAD */
1553 if (flags & LEX_NO_NEXT_CHUNK)
1555 PL_parser->bufptr = s;
1556 COPLINE_INC_WITH_HERELINES;
1557 got_more = lex_next_chunk(flags);
1558 CopLINE_dec(PL_curcop);
1559 s = PL_parser->bufptr;
1560 bufend = PL_parser->bufend;
1563 if (need_incline && PL_parser->rsfp) {
1573 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1574 #endif /* PERL_MAD */
1575 PL_parser->bufptr = s;
1580 * This subroutine has nothing to do with tilting, whether at windmills
1581 * or pinball tables. Its name is short for "increment line". It
1582 * increments the current line number in CopLINE(PL_curcop) and checks
1583 * to see whether the line starts with a comment of the form
1584 * # line 500 "foo.pm"
1585 * If so, it sets the current line number and file to the values in the comment.
1589 S_incline(pTHX_ const char *s)
1597 PERL_ARGS_ASSERT_INCLINE;
1599 COPLINE_INC_WITH_HERELINES;
1600 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1601 && s+1 == PL_bufend && *s == ';') {
1602 /* fake newline in string eval */
1603 CopLINE_dec(PL_curcop);
1608 while (SPACE_OR_TAB(*s))
1610 if (strnEQ(s, "line", 4))
1614 if (SPACE_OR_TAB(*s))
1618 while (SPACE_OR_TAB(*s))
1626 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1628 while (SPACE_OR_TAB(*s))
1630 if (*s == '"' && (t = strchr(s+1, '"'))) {
1636 while (!isSPACE(*t))
1640 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1642 if (*e != '\n' && *e != '\0')
1643 return; /* false alarm */
1645 line_num = atoi(n)-1;
1648 const STRLEN len = t - s;
1649 SV *const temp_sv = CopFILESV(PL_curcop);
1654 cf = SvPVX(temp_sv);
1655 tmplen = SvCUR(temp_sv);
1661 if (!PL_rsfp && !PL_parser->filtered) {
1662 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1663 * to *{"::_<newfilename"} */
1664 /* However, the long form of evals is only turned on by the
1665 debugger - usually they're "(eval %lu)" */
1669 STRLEN tmplen2 = len;
1670 if (tmplen + 2 <= sizeof smallbuf)
1673 Newx(tmpbuf, tmplen + 2, char);
1676 memcpy(tmpbuf + 2, cf, tmplen);
1678 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1683 if (tmplen2 + 2 <= sizeof smallbuf)
1686 Newx(tmpbuf2, tmplen2 + 2, char);
1688 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1689 /* Either they malloc'd it, or we malloc'd it,
1690 so no prefix is present in ours. */
1695 memcpy(tmpbuf2 + 2, s, tmplen2);
1698 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1700 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1701 /* adjust ${"::_<newfilename"} to store the new file name */
1702 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1703 /* The line number may differ. If that is the case,
1704 alias the saved lines that are in the array.
1705 Otherwise alias the whole array. */
1706 if (CopLINE(PL_curcop) == line_num) {
1707 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1708 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1710 else if (GvAV(*gvp)) {
1711 AV * const av = GvAV(*gvp);
1712 const I32 start = CopLINE(PL_curcop)+1;
1713 I32 items = AvFILLp(av) - start;
1715 AV * const av2 = GvAVn(gv2);
1716 SV **svp = AvARRAY(av) + start;
1717 I32 l = (I32)line_num+1;
1719 av_store(av2, l++, SvREFCNT_inc(*svp++));
1724 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1726 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1728 CopFILE_free(PL_curcop);
1729 CopFILE_setn(PL_curcop, s, len);
1731 CopLINE_set(PL_curcop, line_num);
1735 /* skip space before PL_thistoken */
1738 S_skipspace0(pTHX_ char *s)
1740 PERL_ARGS_ASSERT_SKIPSPACE0;
1747 PL_thiswhite = newSVpvs("");
1748 sv_catsv(PL_thiswhite, PL_skipwhite);
1749 sv_free(PL_skipwhite);
1752 PL_realtokenstart = s - SvPVX(PL_linestr);
1756 /* skip space after PL_thistoken */
1759 S_skipspace1(pTHX_ char *s)
1761 const char *start = s;
1762 I32 startoff = start - SvPVX(PL_linestr);
1764 PERL_ARGS_ASSERT_SKIPSPACE1;
1769 start = SvPVX(PL_linestr) + startoff;
1770 if (!PL_thistoken && PL_realtokenstart >= 0) {
1771 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1772 PL_thistoken = newSVpvn(tstart, start - tstart);
1774 PL_realtokenstart = -1;
1777 PL_nextwhite = newSVpvs("");
1778 sv_catsv(PL_nextwhite, PL_skipwhite);
1779 sv_free(PL_skipwhite);
1786 S_skipspace2(pTHX_ char *s, SV **svp)
1789 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1790 const I32 startoff = s - SvPVX(PL_linestr);
1792 PERL_ARGS_ASSERT_SKIPSPACE2;
1795 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1796 if (!PL_madskills || !svp)
1798 start = SvPVX(PL_linestr) + startoff;
1799 if (!PL_thistoken && PL_realtokenstart >= 0) {
1800 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1801 PL_thistoken = newSVpvn(tstart, start - tstart);
1802 PL_realtokenstart = -1;
1806 *svp = newSVpvs("");
1807 sv_setsv(*svp, PL_skipwhite);
1808 sv_free(PL_skipwhite);
1817 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1819 AV *av = CopFILEAVx(PL_curcop);
1821 SV * const sv = newSV_type(SVt_PVMG);
1823 sv_setsv(sv, orig_sv);
1825 sv_setpvn(sv, buf, len);
1828 av_store(av, (I32)CopLINE(PL_curcop), sv);
1834 * Called to gobble the appropriate amount and type of whitespace.
1835 * Skips comments as well.
1839 S_skipspace(pTHX_ char *s)
1843 #endif /* PERL_MAD */
1844 PERL_ARGS_ASSERT_SKIPSPACE;
1847 sv_free(PL_skipwhite);
1848 PL_skipwhite = NULL;
1850 #endif /* PERL_MAD */
1851 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1852 while (s < PL_bufend && SPACE_OR_TAB(*s))
1855 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1857 lex_read_space(LEX_KEEP_PREVIOUS |
1858 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1859 LEX_NO_NEXT_CHUNK : 0));
1861 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1862 if (PL_linestart > PL_bufptr)
1863 PL_bufptr = PL_linestart;
1868 PL_skipwhite = newSVpvn(start, s-start);
1869 #endif /* PERL_MAD */
1875 * Check the unary operators to ensure there's no ambiguity in how they're
1876 * used. An ambiguous piece of code would be:
1878 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1879 * the +5 is its argument.
1889 if (PL_oldoldbufptr != PL_last_uni)
1891 while (isSPACE(*PL_last_uni))
1894 while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1896 if ((t = strchr(s, '(')) && t < PL_bufptr)
1899 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1900 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1901 (int)(s - PL_last_uni), PL_last_uni);
1905 * LOP : macro to build a list operator. Its behaviour has been replaced
1906 * with a subroutine, S_lop() for which LOP is just another name.
1909 #define LOP(f,x) return lop(f,x,s)
1913 * Build a list operator (or something that might be one). The rules:
1914 * - if we have a next token, then it's a list operator [why?]
1915 * - if the next thing is an opening paren, then it's a function
1916 * - else it's a list operator
1920 S_lop(pTHX_ I32 f, int x, char *s)
1924 PERL_ARGS_ASSERT_LOP;
1930 PL_last_lop = PL_oldbufptr;
1931 PL_last_lop_op = (OPCODE)f;
1940 return REPORT(FUNC);
1943 return REPORT(FUNC);
1946 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1947 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1948 return REPORT(LSTOP);
1955 * Sets up for an eventual force_next(). start_force(0) basically does
1956 * an unshift, while start_force(-1) does a push. yylex removes items
1961 S_start_force(pTHX_ int where)
1965 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1966 where = PL_lasttoke;
1967 assert(PL_curforce < 0 || PL_curforce == where);
1968 if (PL_curforce != where) {
1969 for (i = PL_lasttoke; i > where; --i) {
1970 PL_nexttoke[i] = PL_nexttoke[i-1];
1974 if (PL_curforce < 0) /* in case of duplicate start_force() */
1975 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1976 PL_curforce = where;
1979 curmad('^', newSVpvs(""));
1980 CURMAD('_', PL_nextwhite);
1985 S_curmad(pTHX_ char slot, SV *sv)
1991 if (PL_curforce < 0)
1992 where = &PL_thismad;
1994 where = &PL_nexttoke[PL_curforce].next_mad;
2000 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2002 else if (PL_encoding) {
2003 sv_recode_to_utf8(sv, PL_encoding);
2008 /* keep a slot open for the head of the list? */
2009 if (slot != '_' && *where && (*where)->mad_key == '^') {
2010 (*where)->mad_key = slot;
2011 sv_free(MUTABLE_SV(((*where)->mad_val)));
2012 (*where)->mad_val = (void*)sv;
2015 addmad(newMADsv(slot, sv), where, 0);
2018 # define start_force(where) NOOP
2019 # define curmad(slot, sv) NOOP
2024 * When the lexer realizes it knows the next token (for instance,
2025 * it is reordering tokens for the parser) then it can call S_force_next
2026 * to know what token to return the next time the lexer is called. Caller
2027 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2028 * and possibly PL_expect to ensure the lexer handles the token correctly.
2032 S_force_next(pTHX_ I32 type)
2037 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2038 tokereport(type, &NEXTVAL_NEXTTOKE);
2042 if (PL_curforce < 0)
2043 start_force(PL_lasttoke);
2044 PL_nexttoke[PL_curforce].next_type = type;
2045 if (PL_lex_state != LEX_KNOWNEXT)
2046 PL_lex_defer = PL_lex_state;
2047 PL_lex_state = LEX_KNOWNEXT;
2048 PL_lex_expect = PL_expect;
2051 PL_nexttype[PL_nexttoke] = type;
2053 if (PL_lex_state != LEX_KNOWNEXT) {
2054 PL_lex_defer = PL_lex_state;
2055 PL_lex_expect = PL_expect;
2056 PL_lex_state = LEX_KNOWNEXT;
2064 int yyc = PL_parser->yychar;
2065 if (yyc != YYEMPTY) {
2068 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2069 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2070 PL_lex_allbrackets--;
2072 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2073 } else if (yyc == '('/*)*/) {
2074 PL_lex_allbrackets--;
2079 PL_parser->yychar = YYEMPTY;
2084 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2087 SV * const sv = newSVpvn_utf8(start, len,
2090 && !is_ascii_string((const U8*)start, len)
2091 && is_utf8_string((const U8*)start, len));
2097 * When the lexer knows the next thing is a word (for instance, it has
2098 * just seen -> and it knows that the next char is a word char, then
2099 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2103 * char *start : buffer position (must be within PL_linestr)
2104 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2105 * int check_keyword : if true, Perl checks to make sure the word isn't
2106 * a keyword (do this if the word is a label, e.g. goto FOO)
2107 * int allow_pack : if true, : characters will also be allowed (require,
2108 * use, etc. do this)
2109 * int allow_initial_tick : used by the "sub" lexer only.
2113 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
2119 PERL_ARGS_ASSERT_FORCE_WORD;
2121 start = SKIPSPACE1(start);
2123 if (isIDFIRST_lazy_if(s,UTF) ||
2124 (allow_pack && *s == ':') ||
2125 (allow_initial_tick && *s == '\'') )
2127 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2128 if (check_keyword && keyword(PL_tokenbuf, len, 0))
2130 start_force(PL_curforce);
2132 curmad('X', newSVpvn(start,s-start));
2133 if (token == METHOD) {
2138 PL_expect = XOPERATOR;
2142 curmad('g', newSVpvs( "forced" ));
2143 NEXTVAL_NEXTTOKE.opval
2144 = (OP*)newSVOP(OP_CONST,0,
2145 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2146 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2154 * Called when the lexer wants $foo *foo &foo etc, but the program
2155 * text only contains the "foo" portion. The first argument is a pointer
2156 * to the "foo", and the second argument is the type symbol to prefix.
2157 * Forces the next token to be a "WORD".
2158 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2162 S_force_ident(pTHX_ const char *s, int kind)
2166 PERL_ARGS_ASSERT_FORCE_IDENT;
2169 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2170 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2171 UTF ? SVf_UTF8 : 0));
2172 start_force(PL_curforce);
2173 NEXTVAL_NEXTTOKE.opval = o;
2176 o->op_private = OPpCONST_ENTERED;
2177 /* XXX see note in pp_entereval() for why we forgo typo
2178 warnings if the symbol must be introduced in an eval.
2180 gv_fetchpvn_flags(s, len,
2181 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2182 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2183 kind == '$' ? SVt_PV :
2184 kind == '@' ? SVt_PVAV :
2185 kind == '%' ? SVt_PVHV :
2193 S_force_ident_maybe_lex(pTHX_ char pit)
2195 start_force(PL_curforce);
2196 NEXTVAL_NEXTTOKE.ival = pit;
2201 Perl_str_to_version(pTHX_ SV *sv)
2206 const char *start = SvPV_const(sv,len);
2207 const char * const end = start + len;
2208 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2210 PERL_ARGS_ASSERT_STR_TO_VERSION;
2212 while (start < end) {
2216 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2221 retval += ((NV)n)/nshift;
2230 * Forces the next token to be a version number.
2231 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2232 * and if "guessing" is TRUE, then no new token is created (and the caller
2233 * must use an alternative parsing method).
2237 S_force_version(pTHX_ char *s, int guessing)
2243 I32 startoff = s - SvPVX(PL_linestr);
2246 PERL_ARGS_ASSERT_FORCE_VERSION;
2254 while (isDIGIT(*d) || *d == '_' || *d == '.')
2258 start_force(PL_curforce);
2259 curmad('X', newSVpvn(s,d-s));
2262 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2264 #ifdef USE_LOCALE_NUMERIC
2265 char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2266 setlocale(LC_NUMERIC, "C");
2268 s = scan_num(s, &pl_yylval);
2269 #ifdef USE_LOCALE_NUMERIC
2270 setlocale(LC_NUMERIC, loc);
2273 version = pl_yylval.opval;
2274 ver = cSVOPx(version)->op_sv;
2275 if (SvPOK(ver) && !SvNIOK(ver)) {
2276 SvUPGRADE(ver, SVt_PVNV);
2277 SvNV_set(ver, str_to_version(ver));
2278 SvNOK_on(ver); /* hint that it is a version */
2281 else if (guessing) {
2284 sv_free(PL_nextwhite); /* let next token collect whitespace */
2286 s = SvPVX(PL_linestr) + startoff;
2294 if (PL_madskills && !version) {
2295 sv_free(PL_nextwhite); /* let next token collect whitespace */
2297 s = SvPVX(PL_linestr) + startoff;
2300 /* NOTE: The parser sees the package name and the VERSION swapped */
2301 start_force(PL_curforce);
2302 NEXTVAL_NEXTTOKE.opval = version;
2309 * S_force_strict_version
2310 * Forces the next token to be a version number using strict syntax rules.
2314 S_force_strict_version(pTHX_ char *s)
2319 I32 startoff = s - SvPVX(PL_linestr);
2321 const char *errstr = NULL;
2323 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2325 while (isSPACE(*s)) /* leading whitespace */
2328 if (is_STRICT_VERSION(s,&errstr)) {
2330 s = (char *)scan_version(s, ver, 0);
2331 version = newSVOP(OP_CONST, 0, ver);
2333 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2334 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2338 yyerror(errstr); /* version required */
2343 if (PL_madskills && !version) {
2344 sv_free(PL_nextwhite); /* let next token collect whitespace */
2346 s = SvPVX(PL_linestr) + startoff;
2349 /* NOTE: The parser sees the package name and the VERSION swapped */
2350 start_force(PL_curforce);
2351 NEXTVAL_NEXTTOKE.opval = version;
2359 * Tokenize a quoted string passed in as an SV. It finds the next
2360 * chunk, up to end of string or a backslash. It may make a new
2361 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2366 S_tokeq(pTHX_ SV *sv)
2375 PERL_ARGS_ASSERT_TOKEQ;
2380 s = SvPV_force(sv, len);
2381 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2384 /* This is relying on the SV being "well formed" with a trailing '\0' */
2385 while (s < send && !(*s == '\\' && s[1] == '\\'))
2390 if ( PL_hints & HINT_NEW_STRING ) {
2391 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2395 if (s + 1 < send && (s[1] == '\\'))
2396 s++; /* all that, just for this */
2401 SvCUR_set(sv, d - SvPVX_const(sv));
2403 if ( PL_hints & HINT_NEW_STRING )
2404 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2409 * Now come three functions related to double-quote context,
2410 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2411 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2412 * interact with PL_lex_state, and create fake ( ... ) argument lists
2413 * to handle functions and concatenation.
2417 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2422 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2424 * Pattern matching will set PL_lex_op to the pattern-matching op to
2425 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2427 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2429 * Everything else becomes a FUNC.
2431 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2432 * had an OP_CONST or OP_READLINE). This just sets us up for a
2433 * call to S_sublex_push().
2437 S_sublex_start(pTHX)
2440 const I32 op_type = pl_yylval.ival;
2442 if (op_type == OP_NULL) {
2443 pl_yylval.opval = PL_lex_op;
2447 if (op_type == OP_CONST || op_type == OP_READLINE) {
2448 SV *sv = tokeq(PL_lex_stuff);
2450 if (SvTYPE(sv) == SVt_PVIV) {
2451 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2453 const char * const p = SvPV_const(sv, len);
2454 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2458 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2459 PL_lex_stuff = NULL;
2460 /* Allow <FH> // "foo" */
2461 if (op_type == OP_READLINE)
2462 PL_expect = XTERMORDORDOR;
2465 else if (op_type == OP_BACKTICK && PL_lex_op) {
2466 /* readpipe() vas overriden */
2467 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2468 pl_yylval.opval = PL_lex_op;
2470 PL_lex_stuff = NULL;
2474 PL_sublex_info.super_state = PL_lex_state;
2475 PL_sublex_info.sub_inwhat = (U16)op_type;
2476 PL_sublex_info.sub_op = PL_lex_op;
2477 PL_lex_state = LEX_INTERPPUSH;
2481 pl_yylval.opval = PL_lex_op;
2491 * Create a new scope to save the lexing state. The scope will be
2492 * ended in S_sublex_done. Returns a '(', starting the function arguments
2493 * to the uc, lc, etc. found before.
2494 * Sets PL_lex_state to LEX_INTERPCONCAT.
2504 PL_lex_state = PL_sublex_info.super_state;
2505 SAVEBOOL(PL_lex_dojoin);
2506 SAVEI32(PL_lex_brackets);
2507 SAVEI32(PL_lex_allbrackets);
2508 SAVEI32(PL_lex_formbrack);
2509 SAVEI8(PL_lex_fakeeof);
2510 SAVEI32(PL_lex_casemods);
2511 SAVEI32(PL_lex_starts);
2512 SAVEI8(PL_lex_state);
2513 SAVESPTR(PL_lex_repl);
2514 SAVEVPTR(PL_lex_inpat);
2515 SAVEI16(PL_lex_inwhat);
2516 SAVECOPLINE(PL_curcop);
2517 SAVEPPTR(PL_bufptr);
2518 SAVEPPTR(PL_bufend);
2519 SAVEPPTR(PL_oldbufptr);
2520 SAVEPPTR(PL_oldoldbufptr);
2521 SAVEPPTR(PL_last_lop);
2522 SAVEPPTR(PL_last_uni);
2523 SAVEPPTR(PL_linestart);
2524 SAVESPTR(PL_linestr);
2525 SAVEGENERICPV(PL_lex_brackstack);
2526 SAVEGENERICPV(PL_lex_casestack);
2527 SAVEGENERICPV(PL_parser->lex_shared);
2528 SAVEBOOL(PL_parser->lex_re_reparsing);
2530 /* The here-doc parser needs to be able to peek into outer lexing
2531 scopes to find the body of the here-doc. So we put PL_linestr and
2532 PL_bufptr into lex_shared, to ‘share’ those values.
2534 PL_parser->lex_shared->ls_linestr = PL_linestr;
2535 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2537 PL_linestr = PL_lex_stuff;
2538 PL_lex_repl = PL_sublex_info.repl;
2539 PL_lex_stuff = NULL;
2540 PL_sublex_info.repl = NULL;
2542 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2543 = SvPVX(PL_linestr);
2544 PL_bufend += SvCUR(PL_linestr);
2545 PL_last_lop = PL_last_uni = NULL;
2546 SAVEFREESV(PL_linestr);
2547 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2549 PL_lex_dojoin = FALSE;
2550 PL_lex_brackets = PL_lex_formbrack = 0;
2551 PL_lex_allbrackets = 0;
2552 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2553 Newx(PL_lex_brackstack, 120, char);
2554 Newx(PL_lex_casestack, 12, char);
2555 PL_lex_casemods = 0;
2556 *PL_lex_casestack = '\0';
2558 PL_lex_state = LEX_INTERPCONCAT;
2559 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2561 Newxz(shared, 1, LEXSHARED);
2562 shared->ls_prev = PL_parser->lex_shared;
2563 PL_parser->lex_shared = shared;
2565 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2566 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2567 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2568 PL_lex_inpat = PL_sublex_info.sub_op;
2570 PL_lex_inpat = NULL;
2572 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2573 PL_in_eval &= ~EVAL_RE_REPARSING;
2580 * Restores lexer state after a S_sublex_push.
2587 if (!PL_lex_starts++) {
2588 SV * const sv = newSVpvs("");
2589 if (SvUTF8(PL_linestr))
2591 PL_expect = XOPERATOR;
2592 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2596 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2597 PL_lex_state = LEX_INTERPCASEMOD;
2601 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2602 assert(PL_lex_inwhat != OP_TRANSR);
2603 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2604 PL_linestr = PL_lex_repl;
2606 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2607 PL_bufend += SvCUR(PL_linestr);
2608 PL_last_lop = PL_last_uni = NULL;
2609 PL_lex_dojoin = FALSE;
2610 PL_lex_brackets = 0;
2611 PL_lex_allbrackets = 0;
2612 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2613 PL_lex_casemods = 0;
2614 *PL_lex_casestack = '\0';
2616 if (SvEVALED(PL_lex_repl)) {
2617 PL_lex_state = LEX_INTERPNORMAL;
2619 /* we don't clear PL_lex_repl here, so that we can check later
2620 whether this is an evalled subst; that means we rely on the
2621 logic to ensure sublex_done() is called again only via the
2622 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2625 PL_lex_state = LEX_INTERPCONCAT;
2635 PL_endwhite = newSVpvs("");
2636 sv_catsv(PL_endwhite, PL_thiswhite);
2640 sv_setpvs(PL_thistoken,"");
2642 PL_realtokenstart = -1;
2646 PL_bufend = SvPVX(PL_linestr);
2647 PL_bufend += SvCUR(PL_linestr);
2648 PL_expect = XOPERATOR;
2649 PL_sublex_info.sub_inwhat = 0;
2654 PERL_STATIC_INLINE SV*
2655 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2657 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2658 * interior, hence to the "}". Finds what the name resolves to, returning
2659 * an SV* containing it; NULL if no valid one found */
2661 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2668 const U8* first_bad_char_loc;
2669 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2671 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2673 if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2675 &first_bad_char_loc))
2677 /* If warnings are on, this will print a more detailed analysis of what
2678 * is wrong than the error message below */
2679 utf8n_to_uvuni(first_bad_char_loc,
2680 e - ((char *) first_bad_char_loc),
2683 /* We deliberately don't try to print the malformed character, which
2684 * might not print very well; it also may be just the first of many
2685 * malformations, so don't print what comes after it */
2686 yyerror(Perl_form(aTHX_
2687 "Malformed UTF-8 character immediately after '%.*s'",
2688 (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2692 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2693 /* include the <}> */
2694 e - backslash_ptr + 1);
2696 SvREFCNT_dec_NN(res);
2700 /* See if the charnames handler is the Perl core's, and if so, we can skip
2701 * the validation needed for a user-supplied one, as Perl's does its own
2703 table = GvHV(PL_hintgv); /* ^H */
2704 cvp = hv_fetchs(table, "charnames", FALSE);
2705 if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
2706 && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
2708 const char * const name = HvNAME(stash);
2709 if strEQ(name, "_charnames") {
2714 /* Here, it isn't Perl's charname handler. We can't rely on a
2715 * user-supplied handler to validate the input name. For non-ut8 input,
2716 * look to see that the first character is legal. Then loop through the
2717 * rest checking that each is a continuation */
2719 /* This code needs to be sync'ed with a regex in _charnames.pm which does
2723 if (! isALPHAU(*s)) {
2728 if (! isCHARNAME_CONT(*s)) {
2731 if (*s == ' ' && *(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
2732 Perl_warn(aTHX_ "A sequence of multiple spaces in a charnames alias definition is deprecated");
2736 if (*(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
2737 Perl_warn(aTHX_ "Trailing white-space in a charnames alias definition is deprecated");
2741 /* Similarly for utf8. For invariants can check directly; for other
2742 * Latin1, can calculate their code point and check; otherwise use a
2744 if (UTF8_IS_INVARIANT(*s)) {
2745 if (! isALPHAU(*s)) {
2749 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2750 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s, *(s+1))))) {
2756 if (! PL_utf8_charname_begin) {
2757 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2758 PL_utf8_charname_begin = _core_swash_init("utf8",
2759 "_Perl_Charname_Begin",
2761 1, 0, NULL, &flags);
2763 if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2770 if (UTF8_IS_INVARIANT(*s)) {
2771 if (! isCHARNAME_CONT(*s)) {
2774 if (*s == ' ' && *(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
2775 Perl_warn(aTHX_ "A sequence of multiple spaces in a charnames alias definition is deprecated");
2779 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2780 if (! isCHARNAME_CONT(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*s,
2788 if (! PL_utf8_charname_continue) {
2789 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2790 PL_utf8_charname_continue = _core_swash_init("utf8",
2791 "_Perl_Charname_Continue",
2793 1, 0, NULL, &flags);
2795 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2801 if (*(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
2802 Perl_warn(aTHX_ "Trailing white-space in a charnames alias definition is deprecated");
2806 if (SvUTF8(res)) { /* Don't accept malformed input */
2807 const U8* first_bad_char_loc;
2809 const char* const str = SvPV_const(res, len);
2810 if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2811 /* If warnings are on, this will print a more detailed analysis of
2812 * what is wrong than the error message below */
2813 utf8n_to_uvuni(first_bad_char_loc,
2814 (char *) first_bad_char_loc - str,
2817 /* We deliberately don't try to print the malformed character,
2818 * which might not print very well; it also may be just the first
2819 * of many malformations, so don't print what comes after it */
2822 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2823 (int) (e - backslash_ptr + 1), backslash_ptr,
2824 (int) ((char *) first_bad_char_loc - str), str
2834 int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
2836 /* The final %.*s makes sure that should the trailing NUL be missing
2837 * that this print won't run off the end of the string */
2840 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2841 (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2842 (int)(e - s + bad_char_size), s + bad_char_size
2844 UTF ? SVf_UTF8 : 0);
2852 Extracts the next constant part of a pattern, double-quoted string,
2853 or transliteration. This is terrifying code.
2855 For example, in parsing the double-quoted string "ab\x63$d", it would
2856 stop at the '$' and return an OP_CONST containing 'abc'.
2858 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2859 processing a pattern (PL_lex_inpat is true), a transliteration
2860 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2862 Returns a pointer to the character scanned up to. If this is
2863 advanced from the start pointer supplied (i.e. if anything was
2864 successfully parsed), will leave an OP_CONST for the substring scanned
2865 in pl_yylval. Caller must intuit reason for not parsing further
2866 by looking at the next characters herself.
2870 \N{FOO} => \N{U+hex_for_character_FOO}
2871 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2874 all other \-char, including \N and \N{ apart from \N{ABC}
2877 @ and $ where it appears to be a var, but not for $ as tail anchor
2882 In transliterations:
2883 characters are VERY literal, except for - not at the start or end
2884 of the string, which indicates a range. If the range is in bytes,
2885 scan_const expands the range to the full set of intermediate
2886 characters. If the range is in utf8, the hyphen is replaced with
2887 a certain range mark which will be handled by pmtrans() in op.c.
2889 In double-quoted strings:
2891 double-quoted style: \r and \n
2892 constants: \x31, etc.
2893 deprecated backrefs: \1 (in substitution replacements)
2894 case and quoting: \U \Q \E
2897 scan_const does *not* construct ops to handle interpolated strings.
2898 It stops processing as soon as it finds an embedded $ or @ variable
2899 and leaves it to the caller to work out what's going on.
2901 embedded arrays (whether in pattern or not) could be:
2902 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2904 $ in double-quoted strings must be the symbol of an embedded scalar.
2906 $ in pattern could be $foo or could be tail anchor. Assumption:
2907 it's a tail anchor if $ is the last thing in the string, or if it's
2908 followed by one of "()| \r\n\t"
2910 \1 (backreferences) are turned into $1 in substitutions
2912 The structure of the code is
2913 while (there's a character to process) {
2914 handle transliteration ranges
2915 skip regexp comments /(?#comment)/ and codes /(?{code})/
2916 skip #-initiated comments in //x patterns
2917 check for embedded arrays
2918 check for embedded scalars
2920 deprecate \1 in substitution replacements
2921 handle string-changing backslashes \l \U \Q \E, etc.
2922 switch (what was escaped) {
2923 handle \- in a transliteration (becomes a literal -)
2924 if a pattern and not \N{, go treat as regular character
2925 handle \132 (octal characters)
2926 handle \x15 and \x{1234} (hex characters)
2927 handle \N{name} (named characters, also \N{3,5} in a pattern)
2928 handle \cV (control characters)
2929 handle printf-style backslashes (\f, \r, \n, etc)
2932 } (end if backslash)
2933 handle regular character
2934 } (end while character to read)
2939 S_scan_const(pTHX_ char *start)
2942 char *send = PL_bufend; /* end of the constant */
2943 SV *sv = newSV(send - start); /* sv for the constant. See
2944 note below on sizing. */
2945 char *s = start; /* start of the constant */
2946 char *d = SvPVX(sv); /* destination for copies */
2947 bool dorange = FALSE; /* are we in a translit range? */
2948 bool didrange = FALSE; /* did we just finish a range? */
2949 bool in_charclass = FALSE; /* within /[...]/ */
2950 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2951 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2952 to be UTF8? But, this can
2953 show as true when the source
2954 isn't utf8, as for example
2955 when it is entirely composed
2957 SV *res; /* result from charnames */
2959 /* Note on sizing: The scanned constant is placed into sv, which is
2960 * initialized by newSV() assuming one byte of output for every byte of
2961 * input. This routine expects newSV() to allocate an extra byte for a
2962 * trailing NUL, which this routine will append if it gets to the end of
2963 * the input. There may be more bytes of input than output (eg., \N{LATIN
2964 * CAPITAL LETTER A}), or more output than input if the constant ends up
2965 * recoded to utf8, but each time a construct is found that might increase
2966 * the needed size, SvGROW() is called. Its size parameter each time is
2967 * based on the best guess estimate at the time, namely the length used so
2968 * far, plus the length the current construct will occupy, plus room for
2969 * the trailing NUL, plus one byte for every input byte still unscanned */
2971 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2974 UV literal_endpoint = 0;
2975 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2978 PERL_ARGS_ASSERT_SCAN_CONST;
2980 assert(PL_lex_inwhat != OP_TRANSR);
2981 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2982 /* If we are doing a trans and we know we want UTF8 set expectation */
2983 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2984 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2987 /* Protect sv from errors and fatal warnings. */
2988 ENTER_with_name("scan_const");
2991 while (s < send || dorange) {
2993 /* get transliterations out of the way (they're most literal) */
2994 if (PL_lex_inwhat == OP_TRANS) {
2995 /* expand a range A-Z to the full set of characters. AIE! */
2997 I32 i; /* current expanded character */
2998 I32 min; /* first character in range */
2999 I32 max; /* last character in range */
3010 char * const c = (char*)utf8_hop((U8*)d, -1);
3014 *c = (char)UTF_TO_NATIVE(0xff);
3015 /* mark the range as done, and continue */
3021 i = d - SvPVX_const(sv); /* remember current offset */
3024 SvLEN(sv) + (has_utf8 ?
3025 (512 - UTF_CONTINUATION_MARK +
3028 /* How many two-byte within 0..255: 128 in UTF-8,
3029 * 96 in UTF-8-mod. */
3031 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
3033 d = SvPVX(sv) + i; /* refresh d after realloc */
3037 for (j = 0; j <= 1; j++) {
3038 char * const c = (char*)utf8_hop((U8*)d, -1);
3039 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3045 max = (U8)0xff; /* only to \xff */
3046 uvmax = uv; /* \x{100} to uvmax */
3048 d = c; /* eat endpoint chars */
3053 d -= 2; /* eat the first char and the - */
3054 min = (U8)*d; /* first char in range */
3055 max = (U8)d[1]; /* last char in range */
3062 "Invalid range \"%c-%c\" in transliteration operator",
3063 (char)min, (char)max);
3067 if (literal_endpoint == 2 &&
3068 ((isLOWER(min) && isLOWER(max)) ||
3069 (isUPPER(min) && isUPPER(max)))) {
3071 for (i = min; i <= max; i++)
3073 *d++ = NATIVE_TO_NEED(has_utf8,i);
3075 for (i = min; i <= max; i++)
3077 *d++ = NATIVE_TO_NEED(has_utf8,i);
3082 for (i = min; i <= max; i++)
3085 const U8 ch = (U8)NATIVE_TO_UTF(i);
3086 if (UNI_IS_INVARIANT(ch))
3089 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
3090 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
3099 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3101 *d++ = (char)UTF_TO_NATIVE(0xff);
3103 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3107 /* mark the range as done, and continue */
3111 literal_endpoint = 0;
3116 /* range begins (ignore - as first or last char) */
3117 else if (*s == '-' && s+1 < send && s != start) {
3119 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3126 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
3136 literal_endpoint = 0;
3137 native_range = TRUE;
3142 /* if we get here, we're not doing a transliteration */
3144 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3147 while (s1 >= start && *s1-- == '\\')
3150 in_charclass = TRUE;
3153 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3156 while (s1 >= start && *s1-- == '\\')
3159 in_charclass = FALSE;
3162 /* skip for regexp comments /(?#comment)/, except for the last
3163 * char, which will be done separately.
3164 * Stop on (?{..}) and friends */
3166 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
3168 while (s+1 < send && *s != ')')
3169 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3171 else if (!PL_lex_casemods && !in_charclass &&
3172 ( s[2] == '{' /* This should match regcomp.c */
3173 || (s[2] == '?' && s[3] == '{')))
3179 /* likewise skip #-initiated comments in //x patterns */
3180 else if (*s == '#' && PL_lex_inpat &&
3181 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3182 while (s+1 < send && *s != '\n')
3183 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3186 /* no further processing of single-quoted regex */
3187 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3188 goto default_action;
3190 /* check for embedded arrays
3191 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3193 else if (*s == '@' && s[1]) {
3194 if (isWORDCHAR_lazy_if(s+1,UTF))
3196 if (strchr(":'{$", s[1]))
3198 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3199 break; /* in regexp, neither @+ nor @- are interpolated */
3202 /* check for embedded scalars. only stop if we're sure it's a
3205 else if (*s == '$') {
3206 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3208 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3210 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3211 "Possible unintended interpolation of $\\ in regex");
3213 break; /* in regexp, $ might be tail anchor */
3217 /* End of else if chain - OP_TRANS rejoin rest */
3220 if (*s == '\\' && s+1 < send) {
3221 char* e; /* Can be used for ending '}', etc. */
3225 /* warn on \1 - \9 in substitution replacements, but note that \11
3226 * is an octal; and \19 is \1 followed by '9' */
3227 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3228 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3230 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3235 /* string-change backslash escapes */
3236 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3240 /* In a pattern, process \N, but skip any other backslash escapes.
3241 * This is because we don't want to translate an escape sequence
3242 * into a meta symbol and have the regex compiler use the meta
3243 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3244 * in spite of this, we do have to process \N here while the proper
3245 * charnames handler is in scope. See bugs #56444 and #62056.
3246 * There is a complication because \N in a pattern may also stand
3247 * for 'match a non-nl', and not mean a charname, in which case its
3248 * processing should be deferred to the regex compiler. To be a
3249 * charname it must be followed immediately by a '{', and not look
3250 * like \N followed by a curly quantifier, i.e., not something like
3251 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3253 else if (PL_lex_inpat
3256 || regcurly(s + 1, FALSE)))
3258 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
3259 goto default_action;
3264 /* quoted - in transliterations */
3266 if (PL_lex_inwhat == OP_TRANS) {
3273 if ((isALPHANUMERIC(*s)))
3274 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3275 "Unrecognized escape \\%c passed through",
3277 /* default action is to copy the quoted character */
3278 goto default_action;
3281 /* eg. \132 indicates the octal constant 0132 */
3282 case '0': case '1': case '2': case '3':
3283 case '4': case '5': case '6': case '7':
3285 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3287 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
3289 if (len < 3 && s < send && isDIGIT(*s)
3290 && ckWARN(WARN_MISC))
3292 Perl_warner(aTHX_ packWARN(WARN_MISC),
3293 "%s", form_short_octal_warning(s, len));
3296 goto NUM_ESCAPE_INSERT;
3298 /* eg. \o{24} indicates the octal constant \024 */
3303 bool valid = grok_bslash_o(&s, &uv, &error,
3304 TRUE, /* Output warning */
3305 FALSE, /* Not strict */
3306 TRUE, /* Output warnings for
3313 goto NUM_ESCAPE_INSERT;
3316 /* eg. \x24 indicates the hex constant 0x24 */
3321 bool valid = grok_bslash_x(&s, &uv, &error,
3322 TRUE, /* Output warning */
3323 FALSE, /* Not strict */
3324 TRUE, /* Output warnings for
3334 /* Insert oct or hex escaped character. There will always be
3335 * enough room in sv since such escapes will be longer than any
3336 * UTF-8 sequence they can end up as, except if they force us
3337 * to recode the rest of the string into utf8 */
3339 /* Here uv is the ordinal of the next character being added in
3340 * unicode (converted from native). */
3341 if (!UNI_IS_INVARIANT(uv)) {
3342 if (!has_utf8 && uv > 255) {
3343 /* Might need to recode whatever we have accumulated so
3344 * far if it contains any chars variant in utf8 or
3347 SvCUR_set(sv, d - SvPVX_const(sv));
3350 /* See Note on sizing above. */
3351 sv_utf8_upgrade_flags_grow(sv,
3352 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3353 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3354 d = SvPVX(sv) + SvCUR(sv);
3359 d = (char*)uvuni_to_utf8((U8*)d, uv);
3360 if (PL_lex_inwhat == OP_TRANS &&
3361 PL_sublex_info.sub_op) {
3362 PL_sublex_info.sub_op->op_private |=
3363 (PL_lex_repl ? OPpTRANS_FROM_UTF
3367 if (uv > 255 && !dorange)
3368 native_range = FALSE;
3381 /* In a non-pattern \N must be a named character, like \N{LATIN
3382 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3383 * mean to match a non-newline. For non-patterns, named
3384 * characters are converted to their string equivalents. In
3385 * patterns, named characters are not converted to their
3386 * ultimate forms for the same reasons that other escapes
3387 * aren't. Instead, they are converted to the \N{U+...} form
3388 * to get the value from the charnames that is in effect right
3389 * now, while preserving the fact that it was a named character
3390 * so that the regex compiler knows this */
3392 /* This section of code doesn't generally use the
3393 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3394 * a close examination of this macro and determined it is a
3395 * no-op except on utfebcdic variant characters. Every
3396 * character generated by this that would normally need to be
3397 * enclosed by this macro is invariant, so the macro is not
3398 * needed, and would complicate use of copy(). XXX There are
3399 * other parts of this file where the macro is used
3400 * inconsistently, but are saved by it being a no-op */
3402 /* The structure of this section of code (besides checking for
3403 * errors and upgrading to utf8) is:
3404 * Further disambiguate between the two meanings of \N, and if
3405 * not a charname, go process it elsewhere
3406 * If of form \N{U+...}, pass it through if a pattern;
3407 * otherwise convert to utf8
3408 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3409 * pattern; otherwise convert to utf8 */
3411 /* Here, s points to the 'N'; the test below is guaranteed to
3412 * succeed if we are being called on a pattern as we already
3413 * know from a test above that the next character is a '{'.
3414 * On a non-pattern \N must mean 'named sequence, which
3415 * requires braces */
3418 yyerror("Missing braces on \\N{}");
3423 /* If there is no matching '}', it is an error. */
3424 if (! (e = strchr(s, '}'))) {
3425 if (! PL_lex_inpat) {
3426 yyerror("Missing right brace on \\N{}");
3428 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3433 /* Here it looks like a named character */
3435 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3436 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3437 | PERL_SCAN_DISALLOW_PREFIX;
3440 /* For \N{U+...}, the '...' is a unicode value even on
3441 * EBCDIC machines */
3442 s += 2; /* Skip to next char after the 'U+' */
3444 uv = grok_hex(s, &len, &flags, NULL);
3445 if (len == 0 || len != (STRLEN)(e - s)) {
3446 yyerror("Invalid hexadecimal number in \\N{U+...}");
3453 /* On non-EBCDIC platforms, pass through to the regex
3454 * compiler unchanged. The reason we evaluated the
3455 * number above is to make sure there wasn't a syntax
3456 * error. But on EBCDIC we convert to native so
3457 * downstream code can continue to assume it's native
3459 s -= 5; /* Include the '\N{U+' */
3461 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3464 (unsigned int) UNI_TO_NATIVE(uv));
3466 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3470 else { /* Not a pattern: convert the hex to string */
3472 /* If destination is not in utf8, unconditionally
3473 * recode it to be so. This is because \N{} implies
3474 * Unicode semantics, and scalars have to be in utf8
3475 * to guarantee those semantics */
3477 SvCUR_set(sv, d - SvPVX_const(sv));
3480 /* See Note on sizing above. */
3481 sv_utf8_upgrade_flags_grow(
3483 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3484 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3485 d = SvPVX(sv) + SvCUR(sv);
3489 /* Add the string to the output */
3490 if (UNI_IS_INVARIANT(uv)) {
3493 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3496 else /* Here is \N{NAME} but not \N{U+...}. */
3497 if ((res = get_and_check_backslash_N_name(s, e)))
3500 const char *str = SvPV_const(res, len);
3503 if (! len) { /* The name resolved to an empty string */
3504 Copy("\\N{}", d, 4, char);
3508 /* In order to not lose information for the regex
3509 * compiler, pass the result in the specially made
3510 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3511 * the code points in hex of each character
3512 * returned by charnames */
3514 const char *str_end = str + len;
3515 const STRLEN off = d - SvPVX_const(sv);
3517 if (! SvUTF8(res)) {
3518 /* For the non-UTF-8 case, we can determine the
3519 * exact length needed without having to parse
3520 * through the string. Each character takes up
3521 * 2 hex digits plus either a trailing dot or
3523 d = off + SvGROW(sv, off
3525 + 6 /* For the "\N{U+", and
3527 + (STRLEN)(send - e));
3528 Copy("\\N{U+", d, 5, char);
3530 while (str < str_end) {
3532 my_snprintf(hex_string, sizeof(hex_string),
3533 "%02X.", (U8) *str);
3534 Copy(hex_string, d, 3, char);
3538 d--; /* We will overwrite below the final
3539 dot with a right brace */
3542 STRLEN char_length; /* cur char's byte length */
3544 /* and the number of bytes after this is
3545 * translated into hex digits */
3546 STRLEN output_length;
3548 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3549 * for max('U+', '.'); and 1 for NUL */
3550 char hex_string[2 * UTF8_MAXBYTES + 5];
3552 /* Get the first character of the result. */
3553 U32 uv = utf8n_to_uvuni((U8 *) str,
3557 /* Convert first code point to hex, including
3558 * the boiler plate before it. For all these,
3559 * we convert to native format so that
3560 * downstream code can continue to assume the
3561 * input is native */
3563 my_snprintf(hex_string, sizeof(hex_string),
3565 (unsigned int) UNI_TO_NATIVE(uv));
3567 /* Make sure there is enough space to hold it */
3568 d = off + SvGROW(sv, off
3570 + (STRLEN)(send - e)
3571 + 2); /* '}' + NUL */
3573 Copy(hex_string, d, output_length, char);
3576 /* For each subsequent character, append dot and
3577 * its ordinal in hex */
3578 while ((str += char_length) < str_end) {
3579 const STRLEN off = d - SvPVX_const(sv);
3580 U32 uv = utf8n_to_uvuni((U8 *) str,
3585 my_snprintf(hex_string,
3588 (unsigned int) UNI_TO_NATIVE(uv));
3590 d = off + SvGROW(sv, off
3592 + (STRLEN)(send - e)
3593 + 2); /* '}' + NUL */
3594 Copy(hex_string, d, output_length, char);
3599 *d++ = '}'; /* Done. Add the trailing brace */
3602 else { /* Here, not in a pattern. Convert the name to a
3605 /* If destination is not in utf8, unconditionally
3606 * recode it to be so. This is because \N{} implies
3607 * Unicode semantics, and scalars have to be in utf8
3608 * to guarantee those semantics */
3610 SvCUR_set(sv, d - SvPVX_const(sv));
3613 /* See Note on sizing above. */
3614 sv_utf8_upgrade_flags_grow(sv,
3615 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3616 len + (STRLEN)(send - s) + 1);
3617 d = SvPVX(sv) + SvCUR(sv);
3619 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3621 /* See Note on sizing above. (NOTE: SvCUR() is not
3622 * set correctly here). */
3623 const STRLEN off = d - SvPVX_const(sv);
3624 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3626 Copy(str, d, len, char);
3632 } /* End \N{NAME} */
3635 native_range = FALSE; /* \N{} is defined to be Unicode */
3637 s = e + 1; /* Point to just after the '}' */
3640 /* \c is a control character */
3644 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3647 yyerror("Missing control char name in \\c");
3651 /* printf-style backslashes, formfeeds, newlines, etc */
3653 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3656 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3659 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3662 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3665 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3668 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3671 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3677 } /* end if (backslash) */
3684 /* If we started with encoded form, or already know we want it,
3685 then encode the next character */
3686 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3690 /* One might think that it is wasted effort in the case of the
3691 * source being utf8 (this_utf8 == TRUE) to take the next character
3692 * in the source, convert it to an unsigned value, and then convert
3693 * it back again. But the source has not been validated here. The
3694 * routine that does the conversion checks for errors like
3697 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3698 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3700 SvCUR_set(sv, d - SvPVX_const(sv));
3703 /* See Note on sizing above. */
3704 sv_utf8_upgrade_flags_grow(sv,
3705 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3706 need + (STRLEN)(send - s) + 1);
3707 d = SvPVX(sv) + SvCUR(sv);
3709 } else if (need > len) {
3710 /* encoded value larger than old, may need extra space (NOTE:
3711 * SvCUR() is not set correctly here). See Note on sizing
3713 const STRLEN off = d - SvPVX_const(sv);
3714 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3718 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3720 if (uv > 255 && !dorange)
3721 native_range = FALSE;
3725 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3727 } /* while loop to process each character */
3729 /* terminate the string and set up the sv */
3731 SvCUR_set(sv, d - SvPVX_const(sv));
3732 if (SvCUR(sv) >= SvLEN(sv))
3733 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3734 " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3737 if (PL_encoding && !has_utf8) {
3738 sv_recode_to_utf8(sv, PL_encoding);
3744 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3745 PL_sublex_info.sub_op->op_private |=
3746 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3750 /* shrink the sv if we allocated more than we used */
3751 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3752 SvPV_shrink_to_cur(sv);
3755 /* return the substring (via pl_yylval) only if we parsed anything */
3756 if (s > PL_bufptr) {
3757 SvREFCNT_inc_simple_void_NN(sv);
3758 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3759 && ! PL_parser->lex_re_reparsing)
3761 const char *const key = PL_lex_inpat ? "qr" : "q";
3762 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3766 if (PL_lex_inwhat == OP_TRANS) {
3769 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3772 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3780 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3783 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3785 LEAVE_with_name("scan_const");
3790 * Returns TRUE if there's more to the expression (e.g., a subscript),
3793 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3795 * ->[ and ->{ return TRUE
3796 * { and [ outside a pattern are always subscripts, so return TRUE
3797 * if we're outside a pattern and it's not { or [, then return FALSE
3798 * if we're in a pattern and the first char is a {
3799 * {4,5} (any digits around the comma) returns FALSE
3800 * if we're in a pattern and the first char is a [
3802 * [SOMETHING] has a funky algorithm to decide whether it's a
3803 * character class or not. It has to deal with things like
3804 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3805 * anything else returns TRUE
3808 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3811 S_intuit_more(pTHX_ char *s)
3815 PERL_ARGS_ASSERT_INTUIT_MORE;
3817 if (PL_lex_brackets)
3819 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3821 if (*s != '{' && *s != '[')
3826 /* In a pattern, so maybe we have {n,m}. */
3828 if (regcurly(s, FALSE)) {
3834 /* On the other hand, maybe we have a character class */
3837 if (*s == ']' || *s == '^')
3840 /* this is terrifying, and it works */
3843 const char * const send = strchr(s,']');
3844 unsigned char un_char, last_un_char;
3845 char tmpbuf[sizeof PL_tokenbuf * 4];
3847 if (!send) /* has to be an expression */
3849 weight = 2; /* let's weigh the evidence */
3853 else if (isDIGIT(*s)) {
3855 if (isDIGIT(s[1]) && s[2] == ']')
3861 Zero(seen,256,char);
3863 for (; s < send; s++) {
3864 last_un_char = un_char;
3865 un_char = (unsigned char)*s;
3870 weight -= seen[un_char] * 10;
3871 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3873 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3874 len = (int)strlen(tmpbuf);
3875 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3876 UTF ? SVf_UTF8 : 0, SVt_PV))
3881 else if (*s == '$' && s[1] &&
3882 strchr("[#!%*<>()-=",s[1])) {
3883 if (/*{*/ strchr("])} =",s[2]))
3892 if (strchr("wds]",s[1]))
3894 else if (seen[(U8)'\''] || seen[(U8)'"'])
3896 else if (strchr("rnftbxcav",s[1]))
3898 else if (isDIGIT(s[1])) {
3900 while (s[1] && isDIGIT(s[1]))
3910 if (strchr("aA01! ",last_un_char))
3912 if (strchr("zZ79~",s[1]))
3914 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3915 weight -= 5; /* cope with negative subscript */
3918 if (!isWORDCHAR(last_un_char)
3919 && !(last_un_char == '$' || last_un_char == '@'
3920 || last_un_char == '&')
3921 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3926 if (keyword(tmpbuf, d - tmpbuf, 0))
3929 if (un_char == last_un_char + 1)
3931 weight -= seen[un_char];
3936 if (weight >= 0) /* probably a character class */
3946 * Does all the checking to disambiguate
3948 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3949 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3951 * First argument is the stuff after the first token, e.g. "bar".
3953 * Not a method if foo is a filehandle.
3954 * Not a method if foo is a subroutine prototyped to take a filehandle.
3955 * Not a method if it's really "Foo $bar"
3956 * Method if it's "foo $bar"
3957 * Not a method if it's really "print foo $bar"
3958 * Method if it's really "foo package::" (interpreted as package->foo)
3959 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3960 * Not a method if bar is a filehandle or package, but is quoted with
3965 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3968 char *s = start + (*start == '$');
3969 char tmpbuf[sizeof PL_tokenbuf];
3976 PERL_ARGS_ASSERT_INTUIT_METHOD;
3978 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3980 if (cv && SvPOK(cv)) {
3981 const char *proto = CvPROTO(cv);
3989 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3990 /* start is the beginning of the possible filehandle/object,
3991 * and s is the end of it
3992 * tmpbuf is a copy of it
3995 if (*start == '$') {
3996 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3997 isUPPER(*PL_tokenbuf))
4000 len = start - SvPVX(PL_linestr);
4004 start = SvPVX(PL_linestr) + len;
4008 return *s == '(' ? FUNCMETH : METHOD;
4010 if (!keyword(tmpbuf, len, 0)) {
4011 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4015 soff = s - SvPVX(PL_linestr);
4019 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4020 if (indirgv && GvCVu(indirgv))
4022 /* filehandle or package name makes it a method */
4023 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4025 soff = s - SvPVX(PL_linestr);
4028 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4029 return 0; /* no assumptions -- "=>" quotes bareword */
4031 start_force(PL_curforce);
4032 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4033 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4034 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4036 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4037 ( UTF ? SVf_UTF8 : 0 )));
4042 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4044 return *s == '(' ? FUNCMETH : METHOD;
4050 /* Encoded script support. filter_add() effectively inserts a
4051 * 'pre-processing' function into the current source input stream.
4052 * Note that the filter function only applies to the current source file
4053 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4055 * The datasv parameter (which may be NULL) can be used to pass
4056 * private data to this instance of the filter. The filter function
4057 * can recover the SV using the FILTER_DATA macro and use it to
4058 * store private buffers and state information.
4060 * The supplied datasv parameter is upgraded to a PVIO type
4061 * and the IoDIRP/IoANY field is used to store the function pointer,
4062 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4063 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4064 * private use must be set using malloc'd pointers.
4068 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4077 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4078 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4080 if (!PL_rsfp_filters)
4081 PL_rsfp_filters = newAV();
4084 SvUPGRADE(datasv, SVt_PVIO);
4085 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4086 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4087 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4088 FPTR2DPTR(void *, IoANY(datasv)),
4089 SvPV_nolen(datasv)));
4090 av_unshift(PL_rsfp_filters, 1);
4091 av_store(PL_rsfp_filters, 0, datasv) ;
4093 !PL_parser->filtered
4094 && PL_parser->lex_flags & LEX_EVALBYTES
4095 && PL_bufptr < PL_bufend
4097 const char *s = PL_bufptr;
4098 while (s < PL_bufend) {
4100 SV *linestr = PL_parser->linestr;
4101 char *buf = SvPVX(linestr);
4102 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4103 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4104 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4105 STRLEN const linestart_pos = PL_parser->linestart - buf;
4106 STRLEN const last_uni_pos =
4107 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4108 STRLEN const last_lop_pos =
4109 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4110 av_push(PL_rsfp_filters, linestr);
4111 PL_parser->linestr =
4112 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4113 buf = SvPVX(PL_parser->linestr);
4114 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4115 PL_parser->bufptr = buf + bufptr_pos;
4116 PL_parser->oldbufptr = buf + oldbufptr_pos;
4117 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4118 PL_parser->linestart = buf + linestart_pos;
4119 if (PL_parser->last_uni)
4120 PL_parser->last_uni = buf + last_uni_pos;
4121 if (PL_parser->last_lop)
4122 PL_parser->last_lop = buf + last_lop_pos;
4123 SvLEN(linestr) = SvCUR(linestr);
4124 SvCUR(linestr) = s-SvPVX(linestr);
4125 PL_parser->filtered = 1;
4135 /* Delete most recently added instance of this filter function. */
4137 Perl_filter_del(pTHX_ filter_t funcp)
4142 PERL_ARGS_ASSERT_FILTER_DEL;
4145 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4146 FPTR2DPTR(void*, funcp)));
4148 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4150 /* if filter is on top of stack (usual case) just pop it off */
4151 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4152 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4153 sv_free(av_pop(PL_rsfp_filters));
4157 /* we need to search for the correct entry and clear it */
4158 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4162 /* Invoke the idxth filter function for the current rsfp. */
4163 /* maxlen 0 = read one text line */
4165 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4170 /* This API is bad. It should have been using unsigned int for maxlen.
4171 Not sure if we want to change the API, but if not we should sanity
4172 check the value here. */
4173 unsigned int correct_length
4182 PERL_ARGS_ASSERT_FILTER_READ;
4184 if (!PL_parser || !PL_rsfp_filters)
4186 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4187 /* Provide a default input filter to make life easy. */
4188 /* Note that we append to the line. This is handy. */
4189 DEBUG_P(PerlIO_printf(Perl_debug_log,
4190 "filter_read %d: from rsfp\n", idx));
4191 if (correct_length) {
4194 const int old_len = SvCUR(buf_sv);
4196 /* ensure buf_sv is large enough */
4197 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4198 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4199 correct_length)) <= 0) {
4200 if (PerlIO_error(PL_rsfp))
4201 return -1; /* error */
4203 return 0 ; /* end of file */
4205 SvCUR_set(buf_sv, old_len + len) ;
4206 SvPVX(buf_sv)[old_len + len] = '\0';
4209 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4210 if (PerlIO_error(PL_rsfp))
4211 return -1; /* error */
4213 return 0 ; /* end of file */
4216 return SvCUR(buf_sv);
4218 /* Skip this filter slot if filter has been deleted */
4219 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4220 DEBUG_P(PerlIO_printf(Perl_debug_log,
4221 "filter_read %d: skipped (filter deleted)\n",
4223 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4225 if (SvTYPE(datasv) != SVt_PVIO) {
4226 if (correct_length) {
4228 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4229 if (!remainder) return 0; /* eof */
4230 if (correct_length > remainder) correct_length = remainder;
4231 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4232 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4235 const char *s = SvEND(datasv);
4236 const char *send = SvPVX(datasv) + SvLEN(datasv);
4244 if (s == send) return 0; /* eof */
4245 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4246 SvCUR_set(datasv, s-SvPVX(datasv));
4248 return SvCUR(buf_sv);
4250 /* Get function pointer hidden within datasv */
4251 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4252 DEBUG_P(PerlIO_printf(Perl_debug_log,
4253 "filter_read %d: via function %p (%s)\n",
4254 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4255 /* Call function. The function is expected to */
4256 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4257 /* Return: <0:error, =0:eof, >0:not eof */
4258 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4262 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4266 PERL_ARGS_ASSERT_FILTER_GETS;
4268 #ifdef PERL_CR_FILTER
4269 if (!PL_rsfp_filters) {
4270 filter_add(S_cr_textfilter,NULL);
4273 if (PL_rsfp_filters) {
4275 SvCUR_set(sv, 0); /* start with empty line */
4276 if (FILTER_READ(0, sv, 0) > 0)
4277 return ( SvPVX(sv) ) ;
4282 return (sv_gets(sv, PL_rsfp, append));
4286 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4291 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4293 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4297 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4298 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4300 return GvHV(gv); /* Foo:: */
4303 /* use constant CLASS => 'MyClass' */
4304 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4305 if (gv && GvCV(gv)) {
4306 SV * const sv = cv_const_sv(GvCV(gv));
4308 pkgname = SvPV_const(sv, len);
4311 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4315 * S_readpipe_override
4316 * Check whether readpipe() is overridden, and generates the appropriate
4317 * optree, provided sublex_start() is called afterwards.
4320 S_readpipe_override(pTHX)
4323 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4324 pl_yylval.ival = OP_BACKTICK;
4326 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4328 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4329 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4330 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4332 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4333 op_append_elem(OP_LIST,
4334 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4335 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4342 * The intent of this yylex wrapper is to minimize the changes to the
4343 * tokener when we aren't interested in collecting madprops. It remains
4344 * to be seen how successful this strategy will be...
4351 char *s = PL_bufptr;
4353 /* make sure PL_thiswhite is initialized */
4357 /* previous token ate up our whitespace? */
4358 if (!PL_lasttoke && PL_nextwhite) {
4359 PL_thiswhite = PL_nextwhite;
4363 /* isolate the token, and figure out where it is without whitespace */
4364 PL_realtokenstart = -1;
4368 assert(PL_curforce < 0);
4370 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4371 if (!PL_thistoken) {
4372 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4373 PL_thistoken = newSVpvs("");
4375 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4376 PL_thistoken = newSVpvn(tstart, s - tstart);
4379 if (PL_thismad) /* install head */
4380 CURMAD('X', PL_thistoken);
4383 /* last whitespace of a sublex? */
4384 if (optype == ')' && PL_endwhite) {
4385 CURMAD('X', PL_endwhite);
4390 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4391 if (!PL_thiswhite && !PL_endwhite && !optype) {
4392 sv_free(PL_thistoken);
4397 /* put off final whitespace till peg */
4398 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4399 PL_nextwhite = PL_thiswhite;
4402 else if (PL_thisopen) {
4403 CURMAD('q', PL_thisopen);
4405 sv_free(PL_thistoken);
4409 /* Store actual token text as madprop X */
4410 CURMAD('X', PL_thistoken);
4414 /* add preceding whitespace as madprop _ */
4415 CURMAD('_', PL_thiswhite);
4419 /* add quoted material as madprop = */
4420 CURMAD('=', PL_thisstuff);
4424 /* add terminating quote as madprop Q */
4425 CURMAD('Q', PL_thisclose);
4429 /* special processing based on optype */
4433 /* opval doesn't need a TOKEN since it can already store mp */
4443 if (pl_yylval.opval)
4444 append_madprops(PL_thismad, pl_yylval.opval, 0);
4452 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4465 /* remember any fake bracket that lexer is about to discard */
4466 if (PL_lex_brackets == 1 &&
4467 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4470 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4473 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4474 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4477 break; /* don't bother looking for trailing comment */
4486 /* attach a trailing comment to its statement instead of next token */
4490 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4492 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4494 if (*s == '\n' || *s == '#') {
4495 while (s < PL_bufend && *s != '\n')
4499 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4500 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4513 /* Create new token struct. Note: opvals return early above. */
4514 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4521 S_tokenize_use(pTHX_ int is_use, char *s) {
4524 PERL_ARGS_ASSERT_TOKENIZE_USE;
4526 if (PL_expect != XSTATE)
4527 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4528 is_use ? "use" : "no"));
4531 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4532 s = force_version(s, TRUE);
4533 if (*s == ';' || *s == '}'
4534 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4535 start_force(PL_curforce);
4536 NEXTVAL_NEXTTOKE.opval = NULL;
4539 else if (*s == 'v') {
4540 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4541 s = force_version(s, FALSE);
4545 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4546 s = force_version(s, FALSE);
4548 pl_yylval.ival = is_use;
4552 static const char* const exp_name[] =
4553 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4554 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4558 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4560 S_word_takes_any_delimeter(char *p, STRLEN len)
4562 return (len == 1 && strchr("msyq", p[0])) ||
4564 (p[0] == 't' && p[1] == 'r') ||
4565 (p[0] == 'q' && strchr("qwxr", p[1]))));
4571 Works out what to call the token just pulled out of the input
4572 stream. The yacc parser takes care of taking the ops we return and
4573 stitching them into a tree.
4576 The type of the next token
4579 Switch based on the current state:
4580 - if we already built the token before, use it
4581 - if we have a case modifier in a string, deal with that
4582 - handle other cases of interpolation inside a string
4583 - scan the next line if we are inside a format
4584 In the normal state switch on the next character:
4586 if alphabetic, go to key lookup
4587 unrecoginized character - croak
4588 - 0/4/26: handle end-of-line or EOF
4589 - cases for whitespace
4590 - \n and #: handle comments and line numbers
4591 - various operators, brackets and sigils
4594 - 'v': vstrings (or go to key lookup)
4595 - 'x' repetition operator (or go to key lookup)
4596 - other ASCII alphanumerics (key lookup begins here):
4599 scan built-in keyword (but do nothing with it yet)
4600 check for statement label
4601 check for lexical subs
4602 goto just_a_word if there is one
4603 see whether built-in keyword is overridden
4604 switch on keyword number:
4605 - default: just_a_word:
4606 not a built-in keyword; handle bareword lookup
4607 disambiguate between method and sub call
4608 fall back to bareword
4609 - cases for built-in keywords
4614 #pragma segment Perl_yylex
4620 char *s = PL_bufptr;
4627 /* orig_keyword, gvp, and gv are initialized here because
4628 * jump to the label just_a_word_zero can bypass their
4629 * initialization later. */
4630 I32 orig_keyword = 0;
4635 SV* tmp = newSVpvs("");
4636 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4637 (IV)CopLINE(PL_curcop),
4638 lex_state_names[PL_lex_state],
4639 exp_name[PL_expect],
4640 pv_display(tmp, s, strlen(s), 0, 60));
4644 switch (PL_lex_state) {
4646 case LEX_NORMAL: /* Some compilers will produce faster */
4647 case LEX_INTERPNORMAL: /* code if we comment these out. */
4651 /* when we've already built the next token, just pull it out of the queue */
4655 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4657 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4658 PL_nexttoke[PL_lasttoke].next_mad = 0;
4659 if (PL_thismad && PL_thismad->mad_key == '_') {
4660 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4661 PL_thismad->mad_val = 0;
4662 mad_free(PL_thismad);
4667 PL_lex_state = PL_lex_defer;
4668 PL_expect = PL_lex_expect;
4669 PL_lex_defer = LEX_NORMAL;
4670 if (!PL_nexttoke[PL_lasttoke].next_type)
4675 pl_yylval = PL_nextval[PL_nexttoke];
4677 PL_lex_state = PL_lex_defer;
4678 PL_expect = PL_lex_expect;
4679 PL_lex_defer = LEX_NORMAL;
4685 next_type = PL_nexttoke[PL_lasttoke].next_type;
4687 next_type = PL_nexttype[PL_nexttoke];
4689 if (next_type & (7<<24)) {
4690 if (next_type & (1<<24)) {
4691 if (PL_lex_brackets > 100)
4692 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4693 PL_lex_brackstack[PL_lex_brackets++] =
4694 (char) ((next_type >> 16) & 0xff);
4696 if (next_type & (2<<24))
4697 PL_lex_allbrackets++;
4698 if (next_type & (4<<24))
4699 PL_lex_allbrackets--;
4700 next_type &= 0xffff;
4702 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4705 /* interpolated case modifiers like \L \U, including \Q and \E.
4706 when we get here, PL_bufptr is at the \
4708 case LEX_INTERPCASEMOD:
4710 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4712 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4713 PL_bufptr, PL_bufend, *PL_bufptr);
4715 /* handle \E or end of string */
4716 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4718 if (PL_lex_casemods) {
4719 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4720 PL_lex_casestack[PL_lex_casemods] = '\0';
4722 if (PL_bufptr != PL_bufend
4723 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4724 || oldmod == 'F')) {
4726 PL_lex_state = LEX_INTERPCONCAT;
4729 PL_thistoken = newSVpvs("\\E");
4732 PL_lex_allbrackets--;
4735 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4736 /* Got an unpaired \E */
4737 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4738 "Useless use of \\E");
4741 while (PL_bufptr != PL_bufend &&
4742 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4745 PL_thiswhite = newSVpvs("");
4746 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4751 if (PL_bufptr != PL_bufend)
4754 PL_lex_state = LEX_INTERPCONCAT;
4758 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4759 "### Saw case modifier\n"); });
4761 if (s[1] == '\\' && s[2] == 'E') {
4765 PL_thiswhite = newSVpvs("");
4766 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4770 PL_lex_state = LEX_INTERPCONCAT;
4775 if (!PL_madskills) /* when just compiling don't need correct */
4776 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4777 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4778 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4779 (strchr(PL_lex_casestack, 'L')
4780 || strchr(PL_lex_casestack, 'U')
4781 || strchr(PL_lex_casestack, 'F'))) {
4782 PL_lex_casestack[--PL_lex_casemods] = '\0';
4783 PL_lex_allbrackets--;
4786 if (PL_lex_casemods > 10)
4787 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4788 PL_lex_casestack[PL_lex_casemods++] = *s;
4789 PL_lex_casestack[PL_lex_casemods] = '\0';
4790 PL_lex_state = LEX_INTERPCONCAT;
4791 start_force(PL_curforce);
4792 NEXTVAL_NEXTTOKE.ival = 0;
4793 force_next((2<<24)|'(');
4794 start_force(PL_curforce);
4796 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4798 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4800 NEXTVAL_NEXTTOKE.ival = OP_LC;
4802 NEXTVAL_NEXTTOKE.ival = OP_UC;
4804 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4806 NEXTVAL_NEXTTOKE.ival = OP_FC;
4808 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4810 SV* const tmpsv = newSVpvs("\\ ");
4811 /* replace the space with the character we want to escape
4813 SvPVX(tmpsv)[1] = *s;
4819 if (PL_lex_starts) {
4825 sv_free(PL_thistoken);
4826 PL_thistoken = newSVpvs("");
4829 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4830 if (PL_lex_casemods == 1 && PL_lex_inpat)
4839 case LEX_INTERPPUSH:
4840 return REPORT(sublex_push());
4842 case LEX_INTERPSTART:
4843 if (PL_bufptr == PL_bufend)
4844 return REPORT(sublex_done());
4845 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4846 "### Interpolated variable\n"); });
4848 /* for /@a/, we leave the joining for the regex engine to do
4849 * (unless we're within \Q etc) */
4850 PL_lex_dojoin = (*PL_bufptr == '@'
4851 && (!PL_lex_inpat || PL_lex_casemods));
4852 PL_lex_state = LEX_INTERPNORMAL;
4853 if (PL_lex_dojoin) {
4854 start_force(PL_curforce);
4855 NEXTVAL_NEXTTOKE.ival = 0;
4857 start_force(PL_curforce);
4858 force_ident("\"", '$');
4859 start_force(PL_curforce);
4860 NEXTVAL_NEXTTOKE.ival = 0;
4862 start_force(PL_curforce);
4863 NEXTVAL_NEXTTOKE.ival = 0;
4864 force_next((2<<24)|'(');
4865 start_force(PL_curforce);
4866 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4869 /* Convert (?{...}) and friends to 'do {...}' */
4870 if (PL_lex_inpat && *PL_bufptr == '(') {
4871 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4873 if (*PL_bufptr != '{')
4875 start_force(PL_curforce);
4876 /* XXX probably need a CURMAD(something) here */
4877 PL_expect = XTERMBLOCK;
4881 if (PL_lex_starts++) {
4886 sv_free(PL_thistoken);
4887 PL_thistoken = newSVpvs("");
4890 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4891 if (!PL_lex_casemods && PL_lex_inpat)
4898 case LEX_INTERPENDMAYBE:
4899 if (intuit_more(PL_bufptr)) {
4900 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4906 if (PL_lex_dojoin) {
4907 PL_lex_dojoin = FALSE;
4908 PL_lex_state = LEX_INTERPCONCAT;
4912 sv_free(PL_thistoken);
4913 PL_thistoken = newSVpvs("");
4916 PL_lex_allbrackets--;
4919 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4920 && SvEVALED(PL_lex_repl))
4922 if (PL_bufptr != PL_bufend)
4923 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4926 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
4927 re_eval_str. If the here-doc body’s length equals the previous
4928 value of re_eval_start, re_eval_start will now be null. So
4929 check re_eval_str as well. */
4930 if (PL_parser->lex_shared->re_eval_start
4931 || PL_parser->lex_shared->re_eval_str) {
4933 if (*PL_bufptr != ')')
4934 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
4936 /* having compiled a (?{..}) expression, return the original
4937 * text too, as a const */
4938 if (PL_parser->lex_shared->re_eval_str) {
4939 sv = PL_parser->lex_shared->re_eval_str;
4940 PL_parser->lex_shared->re_eval_str = NULL;
4942 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4943 SvPV_shrink_to_cur(sv);
4945 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
4946 PL_bufptr - PL_parser->lex_shared->re_eval_start);
4947 start_force(PL_curforce);
4948 /* XXX probably need a CURMAD(something) here */
4949 NEXTVAL_NEXTTOKE.opval =
4950 (OP*)newSVOP(OP_CONST, 0,
4953 PL_parser->lex_shared->re_eval_start = NULL;
4959 case LEX_INTERPCONCAT:
4961 if (PL_lex_brackets)
4962 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
4963 (long) PL_lex_brackets);
4965 if (PL_bufptr == PL_bufend)
4966 return REPORT(sublex_done());
4968 /* m'foo' still needs to be parsed for possible (?{...}) */
4969 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
4970 SV *sv = newSVsv(PL_linestr);
4972 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4976 s = scan_const(PL_bufptr);
4978 PL_lex_state = LEX_INTERPCASEMOD;
4980 PL_lex_state = LEX_INTERPSTART;
4983 if (s != PL_bufptr) {
4984 start_force(PL_curforce);
4986 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
4988 NEXTVAL_NEXTTOKE = pl_yylval;
4991 if (PL_lex_starts++) {
4995 sv_free(PL_thistoken);
4996 PL_thistoken = newSVpvs("");
4999 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5000 if (!PL_lex_casemods && PL_lex_inpat)
5013 s = scan_formline(PL_bufptr);
5014 if (!PL_lex_formbrack)
5024 PL_oldoldbufptr = PL_oldbufptr;
5030 sv_free(PL_thistoken);
5033 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
5037 if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
5040 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5041 const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
5043 SVs_TEMP | SVf_UTF8),
5044 10, UNI_DISPLAY_ISPRINT))
5045 : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5046 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
5047 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5048 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
5056 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
5060 goto fake_eof; /* emulate EOF on ^D or ^Z */
5066 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
5069 if (PL_lex_brackets &&
5070 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
5071 yyerror((const char *)
5073 ? "Format not terminated"
5074 : "Missing right curly or square bracket"));
5076 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5077 "### Tokener got EOF\n");
5081 if (s++ < PL_bufend)
5082 goto retry; /* ignore stray nulls */
5085 if (!PL_in_eval && !PL_preambled) {
5086 PL_preambled = TRUE;
5092 /* Generate a string of Perl code to load the debugger.
5093 * If PERL5DB is set, it will return the contents of that,
5094 * otherwise a compile-time require of perl5db.pl. */
5096 const char * const pdb = PerlEnv_getenv("PERL5DB");
5099 sv_setpv(PL_linestr, pdb);
5100 sv_catpvs(PL_linestr,";");
5102 SETERRNO(0,SS_NORMAL);
5103 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5106 sv_setpvs(PL_linestr,"");
5107 if (PL_preambleav) {
5108 SV **svp = AvARRAY(PL_preambleav);
5109 SV **const end = svp + AvFILLp(PL_preambleav);
5111 sv_catsv(PL_linestr, *svp);
5113 sv_catpvs(PL_linestr, ";");
5115 sv_free(MUTABLE_SV(PL_preambleav));
5116 PL_preambleav = NULL;
5119 sv_catpvs(PL_linestr,
5120 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5121 if (PL_minus_n || PL_minus_p) {
5122 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5124 sv_catpvs(PL_linestr,"chomp;");
5127 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
5128 || *PL_splitstr == '"')
5129 && strchr(PL_splitstr + 1, *PL_splitstr))
5130 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5132 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5133 bytes can be used as quoting characters. :-) */
5134 const char *splits = PL_splitstr;
5135 sv_catpvs(PL_linestr, "our @F=split(q\0");
5138 if (*splits == '\\')
5139 sv_catpvn(PL_linestr, splits, 1);
5140 sv_catpvn(PL_linestr, splits, 1);
5141 } while (*splits++);
5142 /* This loop will embed the trailing NUL of
5143 PL_linestr as the last thing it does before
5145 sv_catpvs(PL_linestr, ");");
5149 sv_catpvs(PL_linestr,"our @F=split(' ');");
5152 sv_catpvs(PL_linestr, "\n");
5153 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5154 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5155 PL_last_lop = PL_last_uni = NULL;
5156 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
5157 update_debugger_info(PL_linestr, NULL, 0);
5162 bof = PL_rsfp ? TRUE : FALSE;
5165 fake_eof = LEX_FAKE_EOF;
5167 PL_bufptr = PL_bufend;
5168 COPLINE_INC_WITH_HERELINES;
5169 if (!lex_next_chunk(fake_eof)) {
5170 CopLINE_dec(PL_curcop);
5172 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5174 CopLINE_dec(PL_curcop);
5177 PL_realtokenstart = -1;
5180 /* If it looks like the start of a BOM or raw UTF-16,
5181 * check if it in fact is. */
5182 if (bof && PL_rsfp &&
5187 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5188 bof = (offset == (Off_t)SvCUR(PL_linestr));
5189 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5190 /* offset may include swallowed CR */
5192 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5195 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5196 s = swallow_bom((U8*)s);
5199 if (PL_parser->in_pod) {
5200 /* Incest with pod. */
5203 sv_catsv(PL_thiswhite, PL_linestr);
5205 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
5206 sv_setpvs(PL_linestr, "");
5207 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5208 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5209 PL_last_lop = PL_last_uni = NULL;
5210 PL_parser->in_pod = 0;
5213 if (PL_rsfp || PL_parser->filtered)
5215 } while (PL_parser->in_pod);
5216 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5217 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5218 PL_last_lop = PL_last_uni = NULL;
5219 if (CopLINE(PL_curcop) == 1) {
5220 while (s < PL_bufend && isSPACE(*s))
5222 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5226 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
5230 if (*s == '#' && *(s+1) == '!')
5232 #ifdef ALTERNATE_SHEBANG
5234 static char const as[] = ALTERNATE_SHEBANG;
5235 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5236 d = s + (sizeof(as) - 1);
5238 #endif /* ALTERNATE_SHEBANG */
5247 while (*d && !isSPACE(*d))
5251 #ifdef ARG_ZERO_IS_SCRIPT
5252 if (ipathend > ipath) {
5254 * HP-UX (at least) sets argv[0] to the script name,
5255 * which makes $^X incorrect. And Digital UNIX and Linux,
5256 * at least, set argv[0] to the basename of the Perl
5257 * interpreter. So, having found "#!", we'll set it right.
5259 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5261 assert(SvPOK(x) || SvGMAGICAL(x));
5262 if (sv_eq(x, CopFILESV(PL_curcop))) {
5263 sv_setpvn(x, ipath, ipathend - ipath);
5269 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
5270 const char * const lstart = SvPV_const(x,llen);
5272 bstart += blen - llen;
5273 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5274 sv_setpvn(x, ipath, ipathend - ipath);
5279 TAINT_NOT; /* $^X is always tainted, but that's OK */
5281 #endif /* ARG_ZERO_IS_SCRIPT */
5286 d = instr(s,"perl -");
5288 d = instr(s,"perl");
5290 /* avoid getting into infinite loops when shebang
5291 * line contains "Perl" rather than "perl" */
5293 for (d = ipathend-4; d >= ipath; --d) {
5294 if ((*d == 'p' || *d == 'P')
5295 && !ibcmp(d, "perl", 4))
5305 #ifdef ALTERNATE_SHEBANG
5307 * If the ALTERNATE_SHEBANG on this system starts with a
5308 * character that can be part of a Perl expression, then if
5309 * we see it but not "perl", we're probably looking at the
5310 * start of Perl code, not a request to hand off to some
5311 * other interpreter. Similarly, if "perl" is there, but
5312 * not in the first 'word' of the line, we assume the line
5313 * contains the start of the Perl program.
5315 if (d && *s != '#') {
5316 const char *c = ipath;
5317 while (*c && !strchr("; \t\r\n\f\v#", *c))
5320 d = NULL; /* "perl" not in first word; ignore */
5322 *s = '#'; /* Don't try to parse shebang line */
5324 #endif /* ALTERNATE_SHEBANG */
5329 !instr(s,"indir") &&
5330 instr(PL_origargv[0],"perl"))
5337 while (s < PL_bufend && isSPACE(*s))
5339 if (s < PL_bufend) {
5340 Newx(newargv,PL_origargc+3,char*);
5342 while (s < PL_bufend && !isSPACE(*s))
5345 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5348 newargv = PL_origargv;
5351 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5353 Perl_croak(aTHX_ "Can't exec %s", ipath);
5356 while (*d && !isSPACE(*d))
5358 while (SPACE_OR_TAB(*d))
5362 const bool switches_done = PL_doswitches;
5363 const U32 oldpdb = PL_perldb;
5364 const bool oldn = PL_minus_n;
5365 const bool oldp = PL_minus_p;
5369 bool baduni = FALSE;
5371 const char *d2 = d1 + 1;
5372 if (parse_unicode_opts((const char **)&d2)
5376 if (baduni || *d1 == 'M' || *d1 == 'm') {
5377 const char * const m = d1;
5378 while (*d1 && !isSPACE(*d1))
5380 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5383 d1 = moreswitches(d1);
5385 if (PL_doswitches && !switches_done) {
5386 int argc = PL_origargc;
5387 char **argv = PL_origargv;
5390 } while (argc && argv[0][0] == '-' && argv[0][1]);
5391 init_argv_symbols(argc,argv);
5393 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5394 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5395 /* if we have already added "LINE: while (<>) {",
5396 we must not do it again */
5398 sv_setpvs(PL_linestr, "");
5399 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5400 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5401 PL_last_lop = PL_last_uni = NULL;
5402 PL_preambled = FALSE;
5403 if (PERLDB_LINE || PERLDB_SAVESRC)
5404 (void)gv_fetchfile(PL_origfilename);
5411 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5412 PL_lex_state = LEX_FORMLINE;
5413 start_force(PL_curforce);
5414 NEXTVAL_NEXTTOKE.ival = 0;
5415 force_next(FORMRBRACK);
5420 #ifdef PERL_STRICT_CR
5421 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5423 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5425 case ' ': case '\t': case '\f': case 013:
5427 PL_realtokenstart = -1;
5430 PL_thiswhite = newSVpvs("");
5431 sv_catpvn(PL_thiswhite, s, 1);
5439 PL_realtokenstart = -1;
5443 if (PL_lex_state != LEX_NORMAL ||
5444 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
5445 if (*s == '#' && s == PL_linestart && PL_in_eval
5446 && !PL_rsfp && !PL_parser->filtered) {
5447 /* handle eval qq[#line 1 "foo"\n ...] */
5448 CopLINE_dec(PL_curcop);
5451 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5453 if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
5457 const bool in_comment = *s == '#';
5459 while (d < PL_bufend && *d != '\n')
5463 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5464 Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5468 PL_thiswhite = newSVpvn(s, d - s);
5471 if (in_comment && d == PL_bufend
5472 && PL_lex_state == LEX_INTERPNORMAL
5473 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5474 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5477 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5478 PL_lex_state = LEX_FORMLINE;
5479 start_force(PL_curforce);
5480 NEXTVAL_NEXTTOKE.ival = 0;
5481 force_next(FORMRBRACK);
5487 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5488 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5491 TOKEN(PEG); /* make sure any #! line is accessible */
5496 /* if (PL_madskills && PL_lex_formbrack) { */
5498 while (d < PL_bufend && *d != '\n')
5502 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5503 Perl_croak(aTHX_ "panic: input overflow");
5504 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5506 PL_thiswhite = newSVpvs("");
5507 if (CopLINE(PL_curcop) == 1) {
5508 sv_setpvs(PL_thiswhite, "");
5511 sv_catpvn(PL_thiswhite, s, d - s);
5525 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5533 while (s < PL_bufend && SPACE_OR_TAB(*s))
5536 if (strnEQ(s,"=>",2)) {
5537 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
5538 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5539 OPERATOR('-'); /* unary minus */
5541 PL_last_uni = PL_oldbufptr;
5543 case 'r': ftst = OP_FTEREAD; break;
5544 case 'w': ftst = OP_FTEWRITE; break;
5545 case 'x': ftst = OP_FTEEXEC; break;
5546 case 'o': ftst = OP_FTEOWNED; break;
5547 case 'R': ftst = OP_FTRREAD; break;
5548 case 'W': ftst = OP_FTRWRITE; break;
5549 case 'X': ftst = OP_FTREXEC; break;
5550 case 'O': ftst = OP_FTROWNED; break;
5551 case 'e': ftst = OP_FTIS; break;
5552 case 'z': ftst = OP_FTZERO; break;
5553 case 's': ftst = OP_FTSIZE; break;
5554 case 'f': ftst = OP_FTFILE; break;
5555 case 'd': ftst = OP_FTDIR; break;
5556 case 'l': ftst = OP_FTLINK; break;
5557 case 'p': ftst = OP_FTPIPE; break;
5558 case 'S': ftst = OP_FTSOCK; break;
5559 case 'u': ftst = OP_FTSUID; break;
5560 case 'g': ftst = OP_FTSGID; break;
5561 case 'k': ftst = OP_FTSVTX; break;
5562 case 'b': ftst = OP_FTBLK; break;
5563 case 'c': ftst = OP_FTCHR; break;
5564 case 't': ftst = OP_FTTTY; break;
5565 case 'T': ftst = OP_FTTEXT; break;
5566 case 'B': ftst = OP_FTBINARY; break;
5567 case 'M': case 'A': case 'C':
5568 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5570 case 'M': ftst = OP_FTMTIME; break;
5571 case 'A': ftst = OP_FTATIME; break;
5572 case 'C': ftst = OP_FTCTIME; break;
5580 PL_last_lop_op = (OPCODE)ftst;
5581 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5582 "### Saw file test %c\n", (int)tmp);
5587 /* Assume it was a minus followed by a one-letter named
5588 * subroutine call (or a -bareword), then. */
5589 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5590 "### '-%c' looked like a file test but was not\n",
5597 const char tmp = *s++;
5600 if (PL_expect == XOPERATOR)
5605 else if (*s == '>') {
5608 if (isIDFIRST_lazy_if(s,UTF)) {
5609 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
5617 if (PL_expect == XOPERATOR) {
5618 if (*s == '=' && !PL_lex_allbrackets &&
5619 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5626 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5628 OPERATOR('-'); /* unary minus */
5634 const char tmp = *s++;
5637 if (PL_expect == XOPERATOR)
5642 if (PL_expect == XOPERATOR) {
5643 if (*s == '=' && !PL_lex_allbrackets &&
5644 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5651 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5658 if (PL_expect != XOPERATOR) {
5659 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5660 PL_expect = XOPERATOR;
5661 force_ident(PL_tokenbuf, '*');
5669 if (*s == '=' && !PL_lex_allbrackets &&
5670 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5676 if (*s == '=' && !PL_lex_allbrackets &&
5677 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5684 if (PL_expect == XOPERATOR) {
5685 if (s[1] == '=' && !PL_lex_allbrackets &&
5686 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5691 PL_tokenbuf[0] = '%';
5692 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5693 sizeof PL_tokenbuf - 1, FALSE);
5694 if (!PL_tokenbuf[1]) {
5697 PL_expect = XOPERATOR;
5698 force_ident_maybe_lex('%');
5702 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5703 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5708 if (PL_lex_brackets > 100)
5709 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5710 PL_lex_brackstack[PL_lex_brackets++] = 0;
5711 PL_lex_allbrackets++;
5713 const char tmp = *s++;
5718 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5720 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5723 Perl_ck_warner_d(aTHX_
5724 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5725 "Smartmatch is experimental");
5731 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5738 goto just_a_word_zero_gv;
5741 switch (PL_expect) {
5747 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5749 PL_bufptr = s; /* update in case we back off */
5752 "Use of := for an empty attribute list is not allowed");
5759 PL_expect = XTERMBLOCK;
5762 stuffstart = s - SvPVX(PL_linestr) - 1;
5766 while (isIDFIRST_lazy_if(s,UTF)) {
5769 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5770 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5771 if (tmp < 0) tmp = -tmp;
5786 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5788 d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
5790 /* MUST advance bufptr here to avoid bogus
5791 "at end of line" context messages from yyerror().
5793 PL_bufptr = s + len;
5794 yyerror("Unterminated attribute parameter in attribute list");
5798 return REPORT(0); /* EOF indicator */
5802 sv_catsv(sv, PL_lex_stuff);
5803 attrs = op_append_elem(OP_LIST, attrs,
5804 newSVOP(OP_CONST, 0, sv));
5805 SvREFCNT_dec(PL_lex_stuff);
5806 PL_lex_stuff = NULL;
5809 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5811 if (PL_in_my == KEY_our) {
5812 deprecate(":unique");
5815 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5818 /* NOTE: any CV attrs applied here need to be part of
5819 the CVf_BUILTIN_ATTRS define in cv.h! */
5820 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5822 CvLVALUE_on(PL_compcv);
5824 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5826 deprecate(":locked");
5828 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5830 CvMETHOD_on(PL_compcv);
5832 /* After we've set the flags, it could be argued that
5833 we don't need to do the attributes.pm-based setting
5834 process, and shouldn't bother appending recognized
5835 flags. To experiment with that, uncomment the
5836 following "else". (Note that's already been
5837 uncommented. That keeps the above-applied built-in
5838 attributes from being intercepted (and possibly
5839 rejected) by a package's attribute routines, but is
5840 justified by the performance win for the common case
5841 of applying only built-in attributes.) */
5843 attrs = op_append_elem(OP_LIST, attrs,
5844 newSVOP(OP_CONST, 0,
5848 if (*s == ':' && s[1] != ':')
5851 break; /* require real whitespace or :'s */
5852 /* XXX losing whitespace on sequential attributes here */
5856 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5857 if (*s != ';' && *s != '}' && *s != tmp
5858 && (tmp != '=' || *s != ')')) {
5859 const char q = ((*s == '\'') ? '"' : '\'');
5860 /* If here for an expression, and parsed no attrs, back
5862 if (tmp == '=' && !attrs) {
5866 /* MUST advance bufptr here to avoid bogus "at end of line"
5867 context messages from yyerror().
5870 yyerror( (const char *)
5872 ? Perl_form(aTHX_ "Invalid separator character "
5873 "%c%c%c in attribute list", q, *s, q)
5874 : "Unterminated attribute list" ) );
5882 start_force(PL_curforce);
5883 NEXTVAL_NEXTTOKE.opval = attrs;
5884 CURMAD('_', PL_nextwhite);
5889 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
5890 (s - SvPVX(PL_linestr)) - stuffstart);
5895 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5899 PL_lex_allbrackets--;
5903 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5904 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5908 PL_lex_allbrackets++;
5911 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5917 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5920 PL_lex_allbrackets--;
5926 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5929 if (PL_lex_brackets <= 0)
5930 yyerror("Unmatched right square bracket");
5933 PL_lex_allbrackets--;
5934 if (PL_lex_state == LEX_INTERPNORMAL) {
5935 if (PL_lex_brackets == 0) {
5936 if (*s == '-' && s[1] == '>')
5937 PL_lex_state = LEX_INTERPENDMAYBE;
5938 else if (*s != '[' && *s != '{')
5939 PL_lex_state = LEX_INTERPEND;
5946 if (PL_lex_brackets > 100) {
5947 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5949 switch (PL_expect) {
5951 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5952 PL_lex_allbrackets++;
5953 OPERATOR(HASHBRACK);
5955 while (s < PL_bufend && SPACE_OR_TAB(*s))
5958 PL_tokenbuf[0] = '\0';
5959 if (d < PL_bufend && *d == '-') {
5960 PL_tokenbuf[0] = '-';
5962 while (d < PL_bufend && SPACE_OR_TAB(*d))
5965 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5966 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5968 while (d < PL_bufend && SPACE_OR_TAB(*d))
5971 const char minus = (PL_tokenbuf[0] == '-');
5972 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
5980 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5981 PL_lex_allbrackets++;
5986 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5987 PL_lex_allbrackets++;
5992 if (PL_oldoldbufptr == PL_last_lop)
5993 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5995 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5996 PL_lex_allbrackets++;
5999 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6001 /* This hack is to get the ${} in the message. */
6003 yyerror("syntax error");
6006 OPERATOR(HASHBRACK);
6008 /* This hack serves to disambiguate a pair of curlies
6009 * as being a block or an anon hash. Normally, expectation
6010 * determines that, but in cases where we're not in a
6011 * position to expect anything in particular (like inside
6012 * eval"") we have to resolve the ambiguity. This code
6013 * covers the case where the first term in the curlies is a
6014 * quoted string. Most other cases need to be explicitly
6015 * disambiguated by prepending a "+" before the opening
6016 * curly in order to force resolution as an anon hash.
6018 * XXX should probably propagate the outer expectation
6019 * into eval"" to rely less on this hack, but that could
6020 * potentially break current behavior of eval"".
6024 if (*s == '\'' || *s == '"' || *s == '`') {
6025 /* common case: get past first string, handling escapes */
6026 for (t++; t < PL_bufend && *t != *s;)
6027 if (*t++ == '\\' && (*t == '\\' || *t == *s))
6031 else if (*s == 'q') {
6034 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6035 && !isWORDCHAR(*t))))
6037 /* skip q//-like construct */
6039 char open, close, term;
6042 while (t < PL_bufend && isSPACE(*t))
6044 /* check for q => */
6045 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6046 OPERATOR(HASHBRACK);
6050 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6054 for (t++; t < PL_bufend; t++) {
6055 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6057 else if (*t == open)
6061 for (t++; t < PL_bufend; t++) {
6062 if (*t == '\\' && t+1 < PL_bufend)
6064 else if (*t == close && --brackets <= 0)
6066 else if (*t == open)
6073 /* skip plain q word */
6074 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6077 else if (isWORDCHAR_lazy_if(t,UTF)) {
6079 while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
6082 while (t < PL_bufend && isSPACE(*t))
6084 /* if comma follows first term, call it an anon hash */
6085 /* XXX it could be a comma expression with loop modifiers */
6086 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6087 || (*t == '=' && t[1] == '>')))
6088 OPERATOR(HASHBRACK);
6089 if (PL_expect == XREF)
6092 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6098 pl_yylval.ival = CopLINE(PL_curcop);
6099 if (isSPACE(*s) || *s == '#')
6100 PL_copline = NOLINE; /* invalidate current command line number */
6101 TOKEN(formbrack ? '=' : '{');
6103 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6107 if (PL_lex_brackets <= 0)
6108 yyerror("Unmatched right curly bracket");
6110 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6111 PL_lex_allbrackets--;
6112 if (PL_lex_state == LEX_INTERPNORMAL) {
6113 if (PL_lex_brackets == 0) {
6114 if (PL_expect & XFAKEBRACK) {
6115 PL_expect &= XENUMMASK;
6116 PL_lex_state = LEX_INTERPEND;
6121 PL_thiswhite = newSVpvs("");
6122 sv_catpvs(PL_thiswhite,"}");
6125 return yylex(); /* ignore fake brackets */
6127 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6128 && SvEVALED(PL_lex_repl))
6129 PL_lex_state = LEX_INTERPEND;
6130 else if (*s == '-' && s[1] == '>')
6131 PL_lex_state = LEX_INTERPENDMAYBE;
6132 else if (*s != '[' && *s != '{')
6133 PL_lex_state = LEX_INTERPEND;
6136 if (PL_expect & XFAKEBRACK) {
6137 PL_expect &= XENUMMASK;
6139 return yylex(); /* ignore fake brackets */
6141 start_force(PL_curforce);
6143 curmad('X', newSVpvn(s-1,1));
6144 CURMAD('_', PL_thiswhite);
6146 force_next(formbrack ? '.' : '}');
6147 if (formbrack) LEAVE;
6149 if (PL_madskills && !PL_thistoken)
6150 PL_thistoken = newSVpvs("");
6152 if (formbrack == 2) { /* means . where arguments were expected */
6153 start_force(PL_curforce);
6161 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6162 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6169 if (PL_expect == XOPERATOR) {
6170 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
6171 && isIDFIRST_lazy_if(s,UTF))
6173 CopLINE_dec(PL_curcop);
6174 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6175 CopLINE_inc(PL_curcop);
6177 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6178 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6185 PL_tokenbuf[0] = '&';
6186 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
6187 sizeof PL_tokenbuf - 1, TRUE);
6188 if (PL_tokenbuf[1]) {
6189 PL_expect = XOPERATOR;
6190 force_ident_maybe_lex('&');
6194 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6200 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6201 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6208 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6209 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6217 const char tmp = *s++;
6219 if (!PL_lex_allbrackets &&
6220 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6227 if (!PL_lex_allbrackets &&
6228 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
6236 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6237 && strchr("+-*/%.^&|<",tmp))
6238 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6239 "Reversed %c= operator",(int)tmp);
6241 if (PL_expect == XSTATE && isALPHA(tmp) &&
6242 (s == PL_linestart+1 || s[-2] == '\n') )
6244 if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6245 || PL_lex_state != LEX_NORMAL) {
6250 if (strnEQ(s,"=cut",4)) {
6266 PL_thiswhite = newSVpvs("");
6267 sv_catpvn(PL_thiswhite, PL_linestart,
6268 PL_bufend - PL_linestart);
6272 PL_parser->in_pod = 1;
6276 if (PL_expect == XBLOCK) {
6278 #ifdef PERL_STRICT_CR
6279 while (SPACE_OR_TAB(*t))
6281 while (SPACE_OR_TAB(*t) || *t == '\r')
6284 if (*t == '\n' || *t == '#') {
6287 SAVEI8(PL_parser->form_lex_state);
6288 SAVEI32(PL_lex_formbrack);
6289 PL_parser->form_lex_state = PL_lex_state;
6290 PL_lex_formbrack = PL_lex_brackets + 1;
6294 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6303 const char tmp = *s++;
6305 /* was this !=~ where !~ was meant?
6306 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6308 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6309 const char *t = s+1;
6311 while (t < PL_bufend && isSPACE(*t))
6314 if (*t == '/' || *t == '?' ||
6315 ((*t == 'm' || *t == 's' || *t == 'y')
6316 && !isWORDCHAR(t[1])) ||
6317 (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6318 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6319 "!=~ should be !~");
6321 if (!PL_lex_allbrackets &&
6322 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6334 if (PL_expect != XOPERATOR) {
6335 if (s[1] != '<' && !strchr(s,'>'))
6338 s = scan_heredoc(s);
6340 s = scan_inputsymbol(s);
6341 PL_expect = XOPERATOR;
6342 TOKEN(sublex_start());
6348 if (*s == '=' && !PL_lex_allbrackets &&
6349 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6353 SHop(OP_LEFT_SHIFT);
6358 if (!PL_lex_allbrackets &&
6359 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6366 if (!PL_lex_allbrackets &&
6367 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6375 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6383 const char tmp = *s++;
6385 if (*s == '=' && !PL_lex_allbrackets &&
6386 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6390 SHop(OP_RIGHT_SHIFT);
6392 else if (tmp == '=') {
6393 if (!PL_lex_allbrackets &&
6394 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6402 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6411 if (PL_expect == XOPERATOR) {
6412 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6413 return deprecate_commaless_var_list();
6417 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6418 PL_tokenbuf[0] = '@';
6419 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6420 sizeof PL_tokenbuf - 1, FALSE);
6421 if (PL_expect == XOPERATOR)
6422 no_op("Array length", s);
6423 if (!PL_tokenbuf[1])
6425 PL_expect = XOPERATOR;
6426 force_ident_maybe_lex('#');
6430 PL_tokenbuf[0] = '$';
6431 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6432 sizeof PL_tokenbuf - 1, FALSE);
6433 if (PL_expect == XOPERATOR)
6435 if (!PL_tokenbuf[1]) {
6437 yyerror("Final $ should be \\$ or $name");
6443 const char tmp = *s;
6444 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6447 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6448 && intuit_more(s)) {
6450 PL_tokenbuf[0] = '@';
6451 if (ckWARN(WARN_SYNTAX)) {
6454 while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
6457 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6458 while (t < PL_bufend && *t != ']')
6460 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6461 "Multidimensional syntax %.*s not supported",
6462 (int)((t - PL_bufptr) + 1), PL_bufptr);
6466 else if (*s == '{') {
6468 PL_tokenbuf[0] = '%';
6469 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6470 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6472 char tmpbuf[sizeof PL_tokenbuf];
6475 } while (isSPACE(*t));
6476 if (isIDFIRST_lazy_if(t,UTF)) {
6478 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6483 && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
6484 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6485 "You need to quote \"%"SVf"\"",
6486 SVfARG(newSVpvn_flags(tmpbuf, len,
6487 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
6493 PL_expect = XOPERATOR;
6494 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6495 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6496 if (!islop || PL_last_lop_op == OP_GREPSTART)
6497 PL_expect = XOPERATOR;
6498 else if (strchr("$@\"'`q", *s))
6499 PL_expect = XTERM; /* e.g. print $fh "foo" */
6500 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6501 PL_expect = XTERM; /* e.g. print $fh &sub */
6502 else if (isIDFIRST_lazy_if(s,UTF)) {
6503 char tmpbuf[sizeof PL_tokenbuf];
6505 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6506 if ((t2 = keyword(tmpbuf, len, 0))) {
6507 /* binary operators exclude handle interpretations */
6519 PL_expect = XTERM; /* e.g. print $fh length() */
6524 PL_expect = XTERM; /* e.g. print $fh subr() */
6527 else if (isDIGIT(*s))
6528 PL_expect = XTERM; /* e.g. print $fh 3 */
6529 else if (*s == '.' && isDIGIT(s[1]))
6530 PL_expect = XTERM; /* e.g. print $fh .3 */
6531 else if ((*s == '?' || *s == '-' || *s == '+')
6532 && !isSPACE(s[1]) && s[1] != '=')
6533 PL_expect = XTERM; /* e.g. print $fh -1 */
6534 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6536 PL_expect = XTERM; /* e.g. print $fh /.../
6537 XXX except DORDOR operator
6539 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6541 PL_expect = XTERM; /* print $fh <<"EOF" */
6544 force_ident_maybe_lex('$');
6548 if (PL_expect == XOPERATOR)
6550 PL_tokenbuf[0] = '@';
6551 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6552 if (!PL_tokenbuf[1]) {
6555 if (PL_lex_state == LEX_NORMAL)
6557 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6559 PL_tokenbuf[0] = '%';
6561 /* Warn about @ where they meant $. */
6562 if (*s == '[' || *s == '{') {
6563 if (ckWARN(WARN_SYNTAX)) {
6564 const char *t = s + 1;
6565 while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6566 t += UTF ? UTF8SKIP(t) : 1;
6567 if (*t == '}' || *t == ']') {
6569 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6570 /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
6571 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6572 "Scalar value %"SVf" better written as $%"SVf,
6573 SVfARG(newSVpvn_flags(PL_bufptr, (STRLEN)(t-PL_bufptr),
6574 SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))),
6575 SVfARG(newSVpvn_flags(PL_bufptr+1, (STRLEN)(t-PL_bufptr-1),
6576 SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))));
6581 PL_expect = XOPERATOR;
6582 force_ident_maybe_lex('@');
6585 case '/': /* may be division, defined-or, or pattern */
6586 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6587 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6588 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6593 case '?': /* may either be conditional or pattern */
6594 if (PL_expect == XOPERATOR) {
6597 if (!PL_lex_allbrackets &&
6598 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6602 PL_lex_allbrackets++;
6608 /* A // operator. */
6609 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6610 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6611 LEX_FAKEEOF_LOGIC)) {
6619 if (*s == '=' && !PL_lex_allbrackets &&
6620 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6629 /* Disable warning on "study /blah/" */
6630 if (PL_oldoldbufptr == PL_last_uni
6631 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6632 || memNE(PL_last_uni, "study", 5)
6633 || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
6637 deprecate("?PATTERN? without explicit operator");
6638 s = scan_pat(s,OP_MATCH);
6639 TERM(sublex_start());
6643 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6644 #ifdef PERL_STRICT_CR
6647 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6649 && (s == PL_linestart || s[-1] == '\n') )
6652 formbrack = 2; /* dot seen where arguments expected */
6655 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6659 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6662 if (!PL_lex_allbrackets &&
6663 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6670 pl_yylval.ival = OPf_SPECIAL;
6676 if (*s == '=' && !PL_lex_allbrackets &&
6677 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6684 case '0': case '1': case '2': case '3': case '4':
6685 case '5': case '6': case '7': case '8': case '9':
6686 s = scan_num(s, &pl_yylval);
6687 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6688 if (PL_expect == XOPERATOR)
6693 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6694 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6695 if (PL_expect == XOPERATOR) {
6696 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6697 return deprecate_commaless_var_list();
6704 pl_yylval.ival = OP_CONST;
6705 TERM(sublex_start());
6708 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6709 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6710 if (PL_expect == XOPERATOR) {
6711 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6712 return deprecate_commaless_var_list();
6719 pl_yylval.ival = OP_CONST;
6720 /* FIXME. I think that this can be const if char *d is replaced by
6721 more localised variables. */
6722 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6723 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6724 pl_yylval.ival = OP_STRINGIFY;
6728 TERM(sublex_start());
6731 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6732 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6733 if (PL_expect == XOPERATOR)
6734 no_op("Backticks",s);
6737 readpipe_override();
6738 TERM(sublex_start());
6742 if (PL_lex_inwhat && isDIGIT(*s))
6743 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6745 if (PL_expect == XOPERATOR)
6746 no_op("Backslash",s);
6750 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6751 char *start = s + 2;
6752 while (isDIGIT(*start) || *start == '_')
6754 if (*start == '.' && isDIGIT(start[1])) {
6755 s = scan_num(s, &pl_yylval);
6758 else if ((*start == ':' && start[1] == ':')
6759 || (PL_expect == XSTATE && *start == ':'))
6761 else if (PL_expect == XSTATE) {
6763 while (d < PL_bufend && isSPACE(*d)) d++;
6764 if (*d == ':') goto keylookup;
6766 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6767 if (!isALPHA(*start) && (PL_expect == XTERM
6768 || PL_expect == XREF || PL_expect == XSTATE
6769 || PL_expect == XTERMORDORDOR)) {
6770 GV *const gv = gv_fetchpvn_flags(s, start - s,
6771 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6773 s = scan_num(s, &pl_yylval);
6780 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6833 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6835 /* Some keywords can be followed by any delimiter, including ':' */
6836 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6838 /* x::* is just a word, unless x is "CORE" */
6839 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6843 while (d < PL_bufend && isSPACE(*d))
6844 d++; /* no comments skipped here, or s### is misparsed */
6846 /* Is this a word before a => operator? */
6847 if (*d == '=' && d[1] == '>') {
6850 = (OP*)newSVOP(OP_CONST, 0,
6851 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6852 pl_yylval.opval->op_private = OPpCONST_BARE;
6856 /* Check for plugged-in keyword */
6860 char *saved_bufptr = PL_bufptr;
6862 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6864 if (result == KEYWORD_PLUGIN_DECLINE) {
6865 /* not a plugged-in keyword */
6866 PL_bufptr = saved_bufptr;
6867 } else if (result == KEYWORD_PLUGIN_STMT) {
6868 pl_yylval.opval = o;
6871 return REPORT(PLUGSTMT);
6872 } else if (result == KEYWORD_PLUGIN_EXPR) {
6873 pl_yylval.opval = o;
6875 PL_expect = XOPERATOR;
6876 return REPORT(PLUGEXPR);
6878 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6883 /* Check for built-in keyword */
6884 tmp = keyword(PL_tokenbuf, len, 0);
6886 /* Is this a label? */
6887 if (!anydelim && PL_expect == XSTATE
6888 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6890 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
6891 pl_yylval.pval[len] = '\0';
6892 pl_yylval.pval[len+1] = UTF ? 1 : 0;
6897 /* Check for lexical sub */
6898 if (PL_expect != XOPERATOR) {
6899 char tmpbuf[sizeof PL_tokenbuf + 1];
6901 Copy(PL_tokenbuf, tmpbuf+1, len, char);
6902 off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
6903 if (off != NOT_IN_PAD) {
6904 assert(off); /* we assume this is boolean-true below */
6905 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
6906 HV * const stash = PAD_COMPNAME_OURSTASH(off);
6907 HEK * const stashname = HvNAME_HEK(stash);
6908 sv = newSVhek(stashname);
6909 sv_catpvs(sv, "::");
6910 sv_catpvn_flags(sv, PL_tokenbuf, len,
6911 (UTF ? SV_CATUTF8 : SV_CATBYTES));
6912 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
6922 rv2cv_op = newOP(OP_PADANY, 0);
6923 rv2cv_op->op_targ = off;
6924 rv2cv_op = (OP*)newCVREF(0, rv2cv_op);
6925 cv = (CV *)PAD_SV(off);
6933 if (tmp < 0) { /* second-class keyword? */
6934 GV *ogv = NULL; /* override (winner) */
6935 GV *hgv = NULL; /* hidden (loser) */
6936 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6938 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6939 UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
6942 if (GvIMPORTED_CV(gv))
6944 else if (! CvMETHOD(cv))
6948 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6949 UTF ? -(I32)len : (I32)len, FALSE)) &&
6950 (gv = *gvp) && isGV_with_GP(gv) &&
6951 GvCVu(gv) && GvIMPORTED_CV(gv))
6958 tmp = 0; /* overridden by import or by GLOBAL */
6961 && -tmp==KEY_lock /* XXX generalizable kludge */
6964 tmp = 0; /* any sub overrides "weak" keyword */
6966 else { /* no override */
6968 if (tmp == KEY_dump) {
6969 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6970 "dump() better written as CORE::dump()");
6974 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
6975 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6976 "Ambiguous call resolved as CORE::%s(), "
6977 "qualify as such or use &",
6985 default: /* not a keyword */
6986 /* Trade off - by using this evil construction we can pull the
6987 variable gv into the block labelled keylookup. If not, then
6988 we have to give it function scope so that the goto from the
6989 earlier ':' case doesn't bypass the initialisation. */
6991 just_a_word_zero_gv:
7003 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7004 const char penultchar =
7005 lastchar && PL_bufptr - 2 >= PL_linestart
7009 SV *nextPL_nextwhite = 0;
7013 /* Get the rest if it looks like a package qualifier */
7015 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7017 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7020 Perl_croak(aTHX_ "Bad name after %"SVf"%s",
7021 SVfARG(newSVpvn_flags(PL_tokenbuf, len,
7022 (UTF ? SVf_UTF8 : 0) | SVs_TEMP )),
7023 *s == '\'' ? "'" : "::");
7028 if (PL_expect == XOPERATOR) {
7029 if (PL_bufptr == PL_linestart) {
7030 CopLINE_dec(PL_curcop);
7031 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7032 CopLINE_inc(PL_curcop);
7035 no_op("Bareword",s);
7038 /* Look for a subroutine with this name in current package,
7039 unless this is a lexical sub, or name is "Foo::",
7040 in which case Foo is a bareword
7041 (and a package name). */
7043 if (len > 2 && !PL_madskills &&
7044 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
7046 if (ckWARN(WARN_BAREWORD)
7047 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7048 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7049 "Bareword \"%"SVf"\" refers to nonexistent package",
7050 SVfARG(newSVpvn_flags(PL_tokenbuf, len,
7051 (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
7053 PL_tokenbuf[len] = '\0';
7059 /* Mustn't actually add anything to a symbol table.
7060 But also don't want to "initialise" any placeholder
7061 constants that might already be there into full
7062 blown PVGVs with attached PVCV. */
7063 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7064 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
7070 /* if we saw a global override before, get the right name */
7073 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7074 len ? len : strlen(PL_tokenbuf));
7076 SV * const tmp_sv = sv;
7077 sv = newSVpvs("CORE::GLOBAL::");
7078 sv_catsv(sv, tmp_sv);
7079 SvREFCNT_dec(tmp_sv);
7083 if (PL_madskills && !PL_thistoken) {
7084 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
7085 PL_thistoken = newSVpvn(start,s - start);
7086 PL_realtokenstart = s - SvPVX(PL_linestr);
7090 /* Presume this is going to be a bareword of some sort. */
7092 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
7093 pl_yylval.opval->op_private = OPpCONST_BARE;
7095 /* And if "Foo::", then that's what it certainly is. */
7101 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7102 const_op->op_private = OPpCONST_BARE;
7103 rv2cv_op = newCVREF(0, const_op);
7104 cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
7107 /* See if it's the indirect object for a list operator. */
7109 if (PL_oldoldbufptr &&
7110 PL_oldoldbufptr < PL_bufptr &&
7111 (PL_oldoldbufptr == PL_last_lop
7112 || PL_oldoldbufptr == PL_last_uni) &&
7113 /* NO SKIPSPACE BEFORE HERE! */
7114 (PL_expect == XREF ||
7115 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
7117 bool immediate_paren = *s == '(';
7119 /* (Now we can afford to cross potential line boundary.) */
7120 s = SKIPSPACE2(s,nextPL_nextwhite);
7122 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
7125 /* Two barewords in a row may indicate method call. */
7127 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
7128 (tmp = intuit_method(s, gv, cv))) {
7130 if (tmp == METHOD && !PL_lex_allbrackets &&
7131 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7132 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7136 /* If not a declared subroutine, it's an indirect object. */
7137 /* (But it's an indir obj regardless for sort.) */
7138 /* Also, if "_" follows a filetest operator, it's a bareword */
7141 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
7143 (PL_last_lop_op != OP_MAPSTART &&
7144 PL_last_lop_op != OP_GREPSTART))))
7145 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7146 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
7149 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7154 PL_expect = XOPERATOR;
7157 s = SKIPSPACE2(s,nextPL_nextwhite);
7158 PL_nextwhite = nextPL_nextwhite;
7163 /* Is this a word before a => operator? */
7164 if (*s == '=' && s[1] == '>' && !pkgname) {
7167 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
7168 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
7169 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
7173 /* If followed by a paren, it's certainly a subroutine. */
7178 while (SPACE_OR_TAB(*d))
7180 if (*d == ')' && (sv = cv_const_sv(cv))) {
7187 PL_nextwhite = PL_thiswhite;
7190 start_force(PL_curforce);
7192 NEXTVAL_NEXTTOKE.opval =
7193 off ? rv2cv_op : pl_yylval.opval;
7194 PL_expect = XOPERATOR;
7197 PL_nextwhite = nextPL_nextwhite;
7198 curmad('X', PL_thistoken);
7199 PL_thistoken = newSVpvs("");
7203 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7204 else op_free(rv2cv_op), force_next(WORD);
7209 /* If followed by var or block, call it a method (unless sub) */
7211 if ((*s == '$' || *s == '{') && !cv) {
7213 PL_last_lop = PL_oldbufptr;
7214 PL_last_lop_op = OP_METHOD;
7215 if (!PL_lex_allbrackets &&
7216 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7217 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7221 /* If followed by a bareword, see if it looks like indir obj. */
7224 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
7225 && (tmp = intuit_method(s, gv, cv))) {
7227 if (tmp == METHOD && !PL_lex_allbrackets &&
7228 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7229 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7233 /* Not a method, so call it a subroutine (if defined) */
7236 if (lastchar == '-' && penultchar != '-') {
7237 const SV *tmpsv = newSVpvn_flags( PL_tokenbuf, len ? len : strlen(PL_tokenbuf), (UTF ? SVf_UTF8 : 0) | SVs_TEMP );
7238 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7239 "Ambiguous use of -%"SVf" resolved as -&%"SVf"()",
7240 SVfARG(tmpsv), SVfARG(tmpsv));
7242 /* Check for a constant sub */
7243 if ((sv = cv_const_sv(cv))) {
7246 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7247 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7248 pl_yylval.opval->op_private = OPpCONST_FOLDED;
7249 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7253 op_free(pl_yylval.opval);
7254 pl_yylval.opval = rv2cv_op;
7255 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7256 PL_last_lop = PL_oldbufptr;
7257 PL_last_lop_op = OP_ENTERSUB;
7258 /* Is there a prototype? */
7265 STRLEN protolen = CvPROTOLEN(cv);
7266 const char *proto = CvPROTO(cv);
7270 if ((optional = *proto == ';'))
7273 while (*proto == ';');
7277 *proto == '$' || *proto == '_'
7278 || *proto == '*' || *proto == '+'
7283 *proto == '\\' && proto[1] && proto[2] == '\0'
7286 UNIPROTO(UNIOPSUB,optional);
7287 if (*proto == '\\' && proto[1] == '[') {
7288 const char *p = proto + 2;
7289 while(*p && *p != ']')
7291 if(*p == ']' && !p[1])
7292 UNIPROTO(UNIOPSUB,optional);
7294 if (*proto == '&' && *s == '{') {
7296 sv_setpvs(PL_subname, "__ANON__");
7298 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7299 if (!PL_lex_allbrackets &&
7300 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7301 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7308 PL_nextwhite = PL_thiswhite;
7311 start_force(PL_curforce);
7312 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7315 PL_nextwhite = nextPL_nextwhite;
7316 curmad('X', PL_thistoken);
7317 PL_thistoken = newSVpvs("");
7319 force_next(off ? PRIVATEREF : WORD);
7320 if (!PL_lex_allbrackets &&
7321 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7322 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7327 /* Guess harder when madskills require "best effort". */
7328 if (PL_madskills && (!gv || !GvCVu(gv))) {
7329 int probable_sub = 0;
7330 if (strchr("\"'`$@%0123456789!*+{[<", *s))
7332 else if (isALPHA(*s)) {
7336 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
7337 if (!keyword(tmpbuf, tmplen, 0))
7340 while (d < PL_bufend && isSPACE(*d))
7342 if (*d == '=' && d[1] == '>')
7347 gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
7349 op_free(pl_yylval.opval);
7350 pl_yylval.opval = rv2cv_op;
7351 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7352 PL_last_lop = PL_oldbufptr;
7353 PL_last_lop_op = OP_ENTERSUB;
7354 PL_nextwhite = PL_thiswhite;
7356 start_force(PL_curforce);
7357 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7359 PL_nextwhite = nextPL_nextwhite;
7360 curmad('X', PL_thistoken);
7361 PL_thistoken = newSVpvs("");
7362 force_next(off ? PRIVATEREF : WORD);
7363 if (!PL_lex_allbrackets &&
7364 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7365 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7369 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7371 force_next(off ? PRIVATEREF : WORD);
7372 if (!PL_lex_allbrackets &&
7373 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7374 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7379 /* Call it a bare word */
7381 if (PL_hints & HINT_STRICT_SUBS)
7382 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7385 /* after "print" and similar functions (corresponding to
7386 * "F? L" in opcode.pl), whatever wasn't already parsed as
7387 * a filehandle should be subject to "strict subs".
7388 * Likewise for the optional indirect-object argument to system
7389 * or exec, which can't be a bareword */
7390 if ((PL_last_lop_op == OP_PRINT
7391 || PL_last_lop_op == OP_PRTF
7392 || PL_last_lop_op == OP_SAY
7393 || PL_last_lop_op == OP_SYSTEM
7394 || PL_last_lop_op == OP_EXEC)
7395 && (PL_hints & HINT_STRICT_SUBS))
7396 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7397 if (lastchar != '-') {
7398 if (ckWARN(WARN_RESERVED)) {
7402 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7403 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7411 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
7412 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7413 "Operator or semicolon missing before %c%"SVf,
7414 lastchar, SVfARG(newSVpvn_flags(PL_tokenbuf,
7415 strlen(PL_tokenbuf),
7416 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
7417 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7418 "Ambiguous use of %c resolved as operator %c",
7419 lastchar, lastchar);
7426 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7431 (OP*)newSVOP(OP_CONST, 0,
7432 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7435 case KEY___PACKAGE__:
7437 (OP*)newSVOP(OP_CONST, 0,
7439 ? newSVhek(HvNAME_HEK(PL_curstash))
7446 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7447 const char *pname = "main";
7450 if (PL_tokenbuf[2] == 'D')
7453 PL_curstash ? PL_curstash : PL_defstash;
7454 pname = HvNAME_get(stash);
7455 plen = HvNAMELEN (stash);
7456 if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
7458 gv = gv_fetchpvn_flags(
7459 Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
7460 plen+6, GV_ADD|putf8, SVt_PVIO
7464 GvIOp(gv) = newIO();
7465 IoIFP(GvIOp(gv)) = PL_rsfp;
7466 #if defined(HAS_FCNTL) && defined(F_SETFD)
7468 const int fd = PerlIO_fileno(PL_rsfp);
7469 fcntl(fd,F_SETFD,fd >= 3);
7472 /* Mark this internal pseudo-handle as clean */
7473 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7474 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7475 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7477 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7478 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7479 /* if the script was opened in binmode, we need to revert
7480 * it to text mode for compatibility; but only iff it has CRs
7481 * XXX this is a questionable hack at best. */
7482 if (PL_bufend-PL_bufptr > 2
7483 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7486 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7487 loc = PerlIO_tell(PL_rsfp);
7488 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7491 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7493 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7494 #endif /* NETWARE */
7496 PerlIO_seek(PL_rsfp, loc, 0);
7500 #ifdef PERLIO_LAYERS
7503 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7504 else if (PL_encoding) {
7511 XPUSHs(PL_encoding);
7513 call_method("name", G_SCALAR);
7517 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7518 Perl_form(aTHX_ ":encoding(%"SVf")",
7527 if (PL_realtokenstart >= 0) {
7528 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7530 PL_endwhite = newSVpvs("");
7531 sv_catsv(PL_endwhite, PL_thiswhite);
7533 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7534 PL_realtokenstart = -1;
7536 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7546 FUN0OP(newPVOP(OP_RUNCV,0,NULL));
7555 if (PL_expect == XSTATE) {
7562 if (*s == ':' && s[1] == ':') {
7566 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7567 if ((*s == ':' && s[1] == ':')
7568 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7572 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7576 Perl_croak(aTHX_ "CORE::%"SVf" is not a keyword",
7577 SVfARG(newSVpvn_flags(PL_tokenbuf, len,
7578 (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
7581 else if (tmp == KEY_require || tmp == KEY_do
7583 /* that's a way to remember we saw "CORE::" */
7596 LOP(OP_ACCEPT,XTERM);
7599 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7604 LOP(OP_ATAN2,XTERM);
7610 LOP(OP_BINMODE,XTERM);
7613 LOP(OP_BLESS,XTERM);
7622 /* We have to disambiguate the two senses of
7623 "continue". If the next token is a '{' then
7624 treat it as the start of a continue block;
7625 otherwise treat it as a control operator.
7635 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7645 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7654 if (!PL_cryptseen) {
7655 PL_cryptseen = TRUE;
7659 LOP(OP_CRYPT,XTERM);
7662 LOP(OP_CHMOD,XTERM);
7665 LOP(OP_CHOWN,XTERM);
7668 LOP(OP_CONNECT,XTERM);
7688 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7690 if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
7693 force_ident_maybe_lex('&');
7698 if (orig_keyword == KEY_do) {
7707 PL_hints |= HINT_BLOCK_SCOPE;
7717 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7718 STR_WITH_LEN("NDBM_File::"),
7719 STR_WITH_LEN("DB_File::"),
7720 STR_WITH_LEN("GDBM_File::"),
7721 STR_WITH_LEN("SDBM_File::"),
7722 STR_WITH_LEN("ODBM_File::"),
7724 LOP(OP_DBMOPEN,XTERM);
7730 PL_expect = XOPERATOR;
7731 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7738 pl_yylval.ival = CopLINE(PL_curcop);
7742 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7756 if (*s == '{') { /* block eval */
7757 PL_expect = XTERMBLOCK;
7758 UNIBRACK(OP_ENTERTRY);
7760 else { /* string eval */
7762 UNIBRACK(OP_ENTEREVAL);
7767 UNIBRACK(-OP_ENTEREVAL);
7781 case KEY_endhostent:
7787 case KEY_endservent:
7790 case KEY_endprotoent:
7801 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7803 pl_yylval.ival = CopLINE(PL_curcop);
7805 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7808 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7811 if ((PL_bufend - p) >= 3 &&
7812 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7814 else if ((PL_bufend - p) >= 4 &&
7815 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7818 if (isIDFIRST_lazy_if(p,UTF)) {
7819 p = scan_ident(p, PL_bufend,
7820 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7824 Perl_croak(aTHX_ "Missing $ on loop variable");
7826 s = SvPVX(PL_linestr) + soff;
7832 LOP(OP_FORMLINE,XTERM);
7841 LOP(OP_FCNTL,XTERM);
7847 LOP(OP_FLOCK,XTERM);
7850 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7855 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7860 LOP(OP_GREPSTART, XREF);
7863 PL_expect = XOPERATOR;
7864 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7879 case KEY_getpriority:
7880 LOP(OP_GETPRIORITY,XTERM);
7882 case KEY_getprotobyname:
7885 case KEY_getprotobynumber:
7886 LOP(OP_GPBYNUMBER,XTERM);
7888 case KEY_getprotoent:
7900 case KEY_getpeername:
7901 UNI(OP_GETPEERNAME);
7903 case KEY_gethostbyname:
7906 case KEY_gethostbyaddr:
7907 LOP(OP_GHBYADDR,XTERM);
7909 case KEY_gethostent:
7912 case KEY_getnetbyname:
7915 case KEY_getnetbyaddr:
7916 LOP(OP_GNBYADDR,XTERM);
7921 case KEY_getservbyname:
7922 LOP(OP_GSBYNAME,XTERM);
7924 case KEY_getservbyport:
7925 LOP(OP_GSBYPORT,XTERM);
7927 case KEY_getservent:
7930 case KEY_getsockname:
7931 UNI(OP_GETSOCKNAME);
7933 case KEY_getsockopt:
7934 LOP(OP_GSOCKOPT,XTERM);
7949 pl_yylval.ival = CopLINE(PL_curcop);
7950 Perl_ck_warner_d(aTHX_
7951 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
7952 "given is experimental");
7957 orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
7965 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7967 pl_yylval.ival = CopLINE(PL_curcop);
7971 LOP(OP_INDEX,XTERM);
7977 LOP(OP_IOCTL,XTERM);
7989 PL_expect = XOPERATOR;
7990 s = force_word(s,WORD,TRUE,FALSE,FALSE);
8007 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8012 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8026 LOP(OP_LISTEN,XTERM);
8035 s = scan_pat(s,OP_MATCH);
8036 TERM(sublex_start());
8039 LOP(OP_MAPSTART, XREF);
8042 LOP(OP_MKDIR,XTERM);
8045 LOP(OP_MSGCTL,XTERM);
8048 LOP(OP_MSGGET,XTERM);
8051 LOP(OP_MSGRCV,XTERM);
8054 LOP(OP_MSGSND,XTERM);
8059 PL_in_my = (U16)tmp;
8061 if (isIDFIRST_lazy_if(s,UTF)) {
8065 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8066 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
8068 if (!FEATURE_LEXSUBS_IS_ENABLED)
8070 "Experimental \"%s\" subs not enabled",
8071 tmp == KEY_my ? "my" :
8072 tmp == KEY_state ? "state" : "our");
8073 Perl_ck_warner_d(aTHX_
8074 packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
8075 "The lexical_subs feature is experimental");
8078 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8079 if (!PL_in_my_stash) {
8082 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8083 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8086 if (PL_madskills) { /* just add type to declarator token */
8087 sv_catsv(PL_thistoken, PL_nextwhite);
8089 sv_catpvn(PL_thistoken, start, s - start);
8097 PL_expect = XOPERATOR;
8098 s = force_word(s,WORD,TRUE,FALSE,FALSE);
8102 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8107 s = tokenize_use(0, s);
8111 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
8114 if (!PL_lex_allbrackets &&
8115 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8116 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8122 if (isIDFIRST_lazy_if(s,UTF)) {
8124 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8126 for (t=d; isSPACE(*t);)
8128 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8130 && !(t[0] == '=' && t[1] == '>')
8131 && !(t[0] == ':' && t[1] == ':')
8132 && !keyword(s, d-s, 0)
8134 SV *tmpsv = newSVpvn_flags(s, (STRLEN)(d-s),
8135 SVs_TEMP | (UTF ? SVf_UTF8 : 0));
8136 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8137 "Precedence problem: open %"SVf" should be open(%"SVf")",
8138 SVfARG(tmpsv), SVfARG(tmpsv));
8144 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8146 pl_yylval.ival = OP_OR;
8156 LOP(OP_OPEN_DIR,XTERM);
8159 checkcomma(s,PL_tokenbuf,"filehandle");
8163 checkcomma(s,PL_tokenbuf,"filehandle");
8182 s = force_word(s,WORD,FALSE,TRUE,FALSE);
8184 s = force_strict_version(s);
8185 PL_lex_expect = XBLOCK;
8189 LOP(OP_PIPE_OP,XTERM);
8192 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8195 pl_yylval.ival = OP_CONST;
8196 TERM(sublex_start());
8203 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8206 PL_expect = XOPERATOR;
8207 if (SvCUR(PL_lex_stuff)) {
8208 int warned_comma = !ckWARN(WARN_QW);
8209 int warned_comment = warned_comma;
8210 d = SvPV_force(PL_lex_stuff, len);
8212 for (; isSPACE(*d) && len; --len, ++d)
8217 if (!warned_comma || !warned_comment) {
8218 for (; !isSPACE(*d) && len; --len, ++d) {
8219 if (!warned_comma && *d == ',') {
8220 Perl_warner(aTHX_ packWARN(WARN_QW),
8221 "Possible attempt to separate words with commas");
8224 else if (!warned_comment && *d == '#') {
8225 Perl_warner(aTHX_ packWARN(WARN_QW),
8226 "Possible attempt to put comments in qw() list");
8232 for (; !isSPACE(*d) && len; --len, ++d)
8235 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8236 words = op_append_elem(OP_LIST, words,
8237 newSVOP(OP_CONST, 0, tokeq(sv)));
8242 words = newNULLLIST();
8244 SvREFCNT_dec(PL_lex_stuff);
8245 PL_lex_stuff = NULL;
8247 PL_expect = XOPERATOR;
8248 pl_yylval.opval = sawparens(words);
8253 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8256 pl_yylval.ival = OP_STRINGIFY;
8257 if (SvIVX(PL_lex_stuff) == '\'')
8258 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8259 TERM(sublex_start());
8262 s = scan_pat(s,OP_QR);
8263 TERM(sublex_start());
8266 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8269 readpipe_override();
8270 TERM(sublex_start());
8277 PL_expect = XOPERATOR;
8279 s = force_version(s, FALSE);
8281 else if (*s != 'v' || !isDIGIT(s[1])
8282 || (s = force_version(s, TRUE), *s == 'v'))
8284 *PL_tokenbuf = '\0';
8285 s = force_word(s,WORD,TRUE,TRUE,FALSE);
8286 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
8287 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8288 GV_ADD | (UTF ? SVf_UTF8 : 0));
8290 yyerror("<> should be quotes");
8292 if (orig_keyword == KEY_require) {
8300 PL_last_uni = PL_oldbufptr;
8301 PL_last_lop_op = OP_REQUIRE;
8303 return REPORT( (int)REQUIRE );
8309 PL_expect = XOPERATOR;
8310 s = force_word(s,WORD,TRUE,FALSE,FALSE);
8314 LOP(OP_RENAME,XTERM);
8323 LOP(OP_RINDEX,XTERM);
8332 UNIDOR(OP_READLINE);
8335 UNIDOR(OP_BACKTICK);
8344 LOP(OP_REVERSE,XTERM);
8347 UNIDOR(OP_READLINK);
8354 if (pl_yylval.opval)
8355 TERM(sublex_start());
8357 TOKEN(1); /* force error */
8360 checkcomma(s,PL_tokenbuf,"filehandle");
8370 LOP(OP_SELECT,XTERM);
8376 LOP(OP_SEMCTL,XTERM);
8379 LOP(OP_SEMGET,XTERM);
8382 LOP(OP_SEMOP,XTERM);
8388 LOP(OP_SETPGRP,XTERM);
8390 case KEY_setpriority:
8391 LOP(OP_SETPRIORITY,XTERM);
8393 case KEY_sethostent:
8399 case KEY_setservent:
8402 case KEY_setprotoent:
8412 LOP(OP_SEEKDIR,XTERM);
8414 case KEY_setsockopt:
8415 LOP(OP_SSOCKOPT,XTERM);
8421 LOP(OP_SHMCTL,XTERM);
8424 LOP(OP_SHMGET,XTERM);
8427 LOP(OP_SHMREAD,XTERM);
8430 LOP(OP_SHMWRITE,XTERM);
8433 LOP(OP_SHUTDOWN,XTERM);
8442 LOP(OP_SOCKET,XTERM);
8444 case KEY_socketpair:
8445 LOP(OP_SOCKPAIR,XTERM);
8448 checkcomma(s,PL_tokenbuf,"subroutine name");
8451 s = force_word(s,WORD,TRUE,TRUE,FALSE);
8455 LOP(OP_SPLIT,XTERM);
8458 LOP(OP_SPRINTF,XTERM);
8461 LOP(OP_SPLICE,XTERM);
8476 LOP(OP_SUBSTR,XTERM);
8482 char * const tmpbuf = PL_tokenbuf + 1;
8483 SSize_t tboffset = 0;
8484 expectation attrful;
8485 bool have_name, have_proto;
8486 const int key = tmp;
8491 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
8492 SV *subtoken = PL_madskills
8493 ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr))
8498 s = SKIPSPACE2(s,tmpwhite);
8504 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
8505 (*s == ':' && s[1] == ':'))
8508 SV *nametoke = NULL;
8512 attrful = XATTRBLOCK;
8513 /* remember buffer pos'n for later force_word */
8514 tboffset = s - PL_oldbufptr;
8515 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8519 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
8522 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8524 PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
8526 sv_setpvn(PL_subname, tmpbuf, len);
8528 sv_setsv(PL_subname,PL_curstname);
8529 sv_catpvs(PL_subname,"::");
8530 sv_catpvn(PL_subname,tmpbuf,len);
8532 if (SvUTF8(PL_linestr))
8533 SvUTF8_on(PL_subname);
8539 CURMAD('X', nametoke);
8540 CURMAD('_', tmpwhite);
8541 force_ident_maybe_lex('&');
8543 s = SKIPSPACE2(d,tmpwhite);
8549 if (key == KEY_my || key == KEY_our || key==KEY_state)
8552 /* diag_listed_as: Missing name in "%s sub" */
8554 "Missing name in \"%s\"", PL_bufptr);
8556 PL_expect = XTERMBLOCK;
8557 attrful = XATTRTERM;
8558 sv_setpvs(PL_subname,"?");
8562 if (key == KEY_format) {
8564 PL_thistoken = subtoken;
8566 PERL_UNUSED_VAR(tboffset);
8569 (void) force_word(PL_oldbufptr + tboffset, WORD,
8575 /* Look for a prototype */
8578 bool bad_proto = FALSE;
8579 bool in_brackets = FALSE;
8580 char greedy_proto = ' ';
8581 bool proto_after_greedy_proto = FALSE;
8582 bool must_be_last = FALSE;
8583 bool underscore = FALSE;
8584 bool seen_underscore = FALSE;
8585 const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
8588 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8590 Perl_croak(aTHX_ "Prototype not terminated");
8591 /* strip spaces and check for bad characters */
8592 d = SvPV(PL_lex_stuff, tmplen);
8594 for (p = d; tmplen; tmplen--, ++p) {
8598 if (warnillegalproto) {
8600 proto_after_greedy_proto = TRUE;
8601 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
8606 if ( !strchr(";@%", *p) )
8613 else if ( *p == ']' ) {
8614 in_brackets = FALSE;
8616 else if ( (*p == '@' || *p == '%') &&
8617 ( tmp < 2 || d[tmp-2] != '\\' ) &&
8619 must_be_last = TRUE;
8622 else if ( *p == '_' ) {
8623 underscore = seen_underscore = TRUE;
8630 if (proto_after_greedy_proto)
8631 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8632 "Prototype after '%c' for %"SVf" : %s",
8633 greedy_proto, SVfARG(PL_subname), d);
8635 SV *dsv = newSVpvs_flags("", SVs_TEMP);
8636 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8637 "Illegal character %sin prototype for %"SVf" : %s",
8638 seen_underscore ? "after '_' " : "",
8640 SvUTF8(PL_lex_stuff)
8641 ? sv_uni_display(dsv,
8642 newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8),
8644 UNI_DISPLAY_ISPRINT)
8645 : pv_pretty(dsv, d, tmp, 60, NULL, NULL,
8646 PERL_PV_ESCAPE_NONASCII));
8648 SvCUR_set(PL_lex_stuff, tmp);
8653 CURMAD('q', PL_thisopen);
8654 CURMAD('_', tmpwhite);
8655 CURMAD('=', PL_thisstuff);
8656 CURMAD('Q', PL_thisclose);
8657 NEXTVAL_NEXTTOKE.opval =
8658 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8659 PL_lex_stuff = NULL;
8662 s = SKIPSPACE2(s,tmpwhite);
8670 if (*s == ':' && s[1] != ':')
8671 PL_expect = attrful;
8672 else if (*s != '{' && key == KEY_sub) {
8674 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8675 else if (*s != ';' && *s != '}')
8676 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8683 curmad('^', newSVpvs(""));
8684 CURMAD('_', tmpwhite);
8688 PL_thistoken = subtoken;
8689 PERL_UNUSED_VAR(have_proto);
8692 NEXTVAL_NEXTTOKE.opval =
8693 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8694 PL_lex_stuff = NULL;
8700 sv_setpvs(PL_subname, "__ANON__");
8702 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8706 force_ident_maybe_lex('&');
8712 LOP(OP_SYSTEM,XREF);
8715 LOP(OP_SYMLINK,XTERM);
8718 LOP(OP_SYSCALL,XTERM);
8721 LOP(OP_SYSOPEN,XTERM);
8724 LOP(OP_SYSSEEK,XTERM);
8727 LOP(OP_SYSREAD,XTERM);
8730 LOP(OP_SYSWRITE,XTERM);
8735 TERM(sublex_start());
8756 LOP(OP_TRUNCATE,XTERM);
8768 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8770 pl_yylval.ival = CopLINE(PL_curcop);
8774 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8776 pl_yylval.ival = CopLINE(PL_curcop);
8780 LOP(OP_UNLINK,XTERM);
8786 LOP(OP_UNPACK,XTERM);
8789 LOP(OP_UTIME,XTERM);
8795 LOP(OP_UNSHIFT,XTERM);
8798 s = tokenize_use(1, s);
8808 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8810 pl_yylval.ival = CopLINE(PL_curcop);
8811 Perl_ck_warner_d(aTHX_
8812 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8813 "when is experimental");
8817 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8819 pl_yylval.ival = CopLINE(PL_curcop);
8823 PL_hints |= HINT_BLOCK_SCOPE;
8830 LOP(OP_WAITPID,XTERM);
8839 ctl_l[0] = toCTRL('L');
8841 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8844 /* Make sure $^L is defined */
8845 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8850 if (PL_expect == XOPERATOR) {
8851 if (*s == '=' && !PL_lex_allbrackets &&
8852 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8860 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8862 pl_yylval.ival = OP_XOR;
8868 #pragma segment Main
8874 Looks up an identifier in the pad or in a package
8877 PRIVATEREF if this is a lexical name.
8878 WORD if this belongs to a package.
8881 if we're in a my declaration
8882 croak if they tried to say my($foo::bar)
8883 build the ops for a my() declaration
8884 if it's an access to a my() variable
8885 build ops for access to a my() variable
8886 if in a dq string, and they've said @foo and we can't find @foo
8888 build ops for a bareword
8892 S_pending_ident(pTHX)
8896 const char pit = (char)pl_yylval.ival;
8897 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8898 /* All routes through this function want to know if there is a colon. */
8899 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8901 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8902 "### Pending identifier '%s'\n", PL_tokenbuf); });
8904 /* if we're in a my(), we can't allow dynamics here.
8905 $foo'bar has already been turned into $foo::bar, so
8906 just check for colons.
8908 if it's a legal name, the OP is a PADANY.
8911 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8913 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8914 "variable %s in \"our\"",
8915 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8916 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8920 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
8921 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8922 UTF ? SVf_UTF8 : 0);
8924 pl_yylval.opval = newOP(OP_PADANY, 0);
8925 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8926 UTF ? SVf_UTF8 : 0);
8932 build the ops for accesses to a my() variable.
8937 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8938 UTF ? SVf_UTF8 : 0);
8939 if (tmp != NOT_IN_PAD) {
8940 /* might be an "our" variable" */
8941 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8942 /* build ops for a bareword */
8943 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8944 HEK * const stashname = HvNAME_HEK(stash);
8945 SV * const sym = newSVhek(stashname);
8946 sv_catpvs(sym, "::");
8947 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8948 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8949 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8953 ? (GV_ADDMULTI | GV_ADDINEVAL)
8956 ((PL_tokenbuf[0] == '$') ? SVt_PV
8957 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8962 pl_yylval.opval = newOP(OP_PADANY, 0);
8963 pl_yylval.opval->op_targ = tmp;
8969 Whine if they've said @foo in a doublequoted string,
8970 and @foo isn't a variable we can find in the symbol
8973 if (ckWARN(WARN_AMBIGUOUS) &&
8974 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8975 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8976 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8977 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8978 /* DO NOT warn for @- and @+ */
8979 && !( PL_tokenbuf[2] == '\0' &&
8980 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8983 /* Downgraded from fatal to warning 20000522 mjd */
8984 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8985 "Possible unintended interpolation of %"SVf" in string",
8986 SVfARG(newSVpvn_flags(PL_tokenbuf, tokenbuf_len,
8987 SVs_TEMP | ( UTF ? SVf_UTF8 : 0 ))));
8991 /* build ops for a bareword */
8992 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
8993 newSVpvn_flags(PL_tokenbuf + 1,
8995 UTF ? SVf_UTF8 : 0 ));
8996 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8998 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8999 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
9000 | ( UTF ? SVf_UTF8 : 0 ),
9001 ((PL_tokenbuf[0] == '$') ? SVt_PV
9002 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9008 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9012 PERL_ARGS_ASSERT_CHECKCOMMA;
9014 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9015 if (ckWARN(WARN_SYNTAX)) {
9018 for (w = s+2; *w && level; w++) {
9026 /* the list of chars below is for end of statements or
9027 * block / parens, boolean operators (&&, ||, //) and branch
9028 * constructs (or, and, if, until, unless, while, err, for).
9029 * Not a very solid hack... */
9030 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9031 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9032 "%s (...) interpreted as function",name);
9035 while (s < PL_bufend && isSPACE(*s))
9039 while (s < PL_bufend && isSPACE(*s))
9041 if (isIDFIRST_lazy_if(s,UTF)) {
9042 const char * const w = s;
9043 s += UTF ? UTF8SKIP(s) : 1;
9044 while (isWORDCHAR_lazy_if(s,UTF))
9045 s += UTF ? UTF8SKIP(s) : 1;
9046 while (s < PL_bufend && isSPACE(*s))
9050 if (keyword(w, s - w, 0))
9053 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9054 if (gv && GvCVu(gv))
9056 Perl_croak(aTHX_ "No comma allowed after %s", what);
9061 /* S_new_constant(): do any overload::constant lookup.
9063 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9064 Best used as sv=new_constant(..., sv, ...).
9065 If s, pv are NULL, calls subroutine with one argument,
9066 and <type> is used with error messages only.
9067 <type> is assumed to be well formed UTF-8 */
9070 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9071 SV *sv, SV *pv, const char *type, STRLEN typelen)
9074 HV * table = GvHV(PL_hintgv); /* ^H */
9079 const char *why1 = "", *why2 = "", *why3 = "";
9081 PERL_ARGS_ASSERT_NEW_CONSTANT;
9082 /* We assume that this is true: */
9083 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9086 /* charnames doesn't work well if there have been errors found */
9087 if (PL_error_count > 0 && *key == 'c')
9089 SvREFCNT_dec_NN(sv);
9090 return &PL_sv_undef;
9093 sv_2mortal(sv); /* Parent created it permanently */
9095 || ! (PL_hints & HINT_LOCALIZE_HH)
9096 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9101 /* Here haven't found what we're looking for. If it is charnames,
9102 * perhaps it needs to be loaded. Try doing that before giving up */
9104 Perl_load_module(aTHX_
9106 newSVpvs("_charnames"),
9107 /* version parameter; no need to specify it, as if
9108 * we get too early a version, will fail anyway,
9109 * not being able to find '_charnames' */
9115 table = GvHV(PL_hintgv);
9117 && (PL_hints & HINT_LOCALIZE_HH)
9118 && (cvp = hv_fetch(table, key, keylen, FALSE))
9124 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9125 msg = Perl_form(aTHX_
9126 "Constant(%.*s) unknown",
9127 (int)(type ? typelen : len),
9133 why3 = "} is not defined";
9136 msg = Perl_form(aTHX_
9137 /* The +3 is for '\N{'; -4 for that, plus '}' */
9138 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9142 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9143 (int)(type ? typelen : len),
9144 (type ? type: s), why1, why2, why3);
9147 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9148 return SvREFCNT_inc_simple_NN(sv);
9153 pv = newSVpvn_flags(s, len, SVs_TEMP);
9155 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9157 typesv = &PL_sv_undef;
9159 PUSHSTACKi(PERLSI_OVERLOAD);
9171 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9175 /* Check the eval first */
9176 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9178 const char * errstr;
9179 sv_catpvs(errsv, "Propagated");
9180 errstr = SvPV_const(errsv, errlen);
9181 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9183 res = SvREFCNT_inc_simple_NN(sv);
9187 SvREFCNT_inc_simple_void_NN(res);
9196 why1 = "Call to &{$^H{";
9198 why3 = "}} did not return a defined value";
9200 (void)sv_2mortal(sv);
9207 PERL_STATIC_INLINE void
9208 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
9210 PERL_ARGS_ASSERT_PARSE_IDENT;
9214 Perl_croak(aTHX_ "%s", ident_too_long);
9215 if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
9216 /* The UTF-8 case must come first, otherwise things
9217 * like c\N{COMBINING TILDE} would start failing, as the
9218 * isWORDCHAR_A case below would gobble the 'c' up.
9221 char *t = *s + UTF8SKIP(*s);
9222 while (isIDCONT_utf8((U8*)t))
9224 if (*d + (t - *s) > e)
9225 Perl_croak(aTHX_ "%s", ident_too_long);
9226 Copy(*s, *d, t - *s, char);
9230 else if ( isWORDCHAR_A(**s) ) {
9233 } while isWORDCHAR_A(**s);
9235 else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
9240 else if (allow_package && **s == ':' && (*s)[1] == ':'
9241 /* Disallow things like Foo::$bar. For the curious, this is
9242 * the code path that triggers the "Bad name after" warning
9243 * when looking for barewords.
9245 && (*s)[2] != '$') {
9255 /* Returns a NUL terminated string, with the length of the string written to
9259 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9263 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9264 bool is_utf8 = cBOOL(UTF);
9266 PERL_ARGS_ASSERT_SCAN_WORD;
9268 parse_ident(&s, &d, e, allow_package, is_utf8);
9275 S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9278 char *bracket = NULL;
9281 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9282 bool is_utf8 = cBOOL(UTF);
9284 PERL_ARGS_ASSERT_SCAN_IDENT;
9289 while (isDIGIT(*s)) {
9291 Perl_croak(aTHX_ "%s", ident_too_long);
9296 parse_ident(&s, &d, e, 1, is_utf8);
9301 if (PL_lex_state != LEX_NORMAL)
9302 PL_lex_state = LEX_INTERPENDMAYBE;
9305 if (*s == '$' && s[1] &&
9306 (isIDFIRST_lazy_if(s+1,is_utf8)
9307 || isDIGIT_A((U8)s[1])
9310 || strnEQ(s+1,"::",2)) )
9317 while (s < send && SPACE_OR_TAB(*s))
9321 #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)*(d)) \
9322 || isCNTRL_A((U8)*(d)) \
9323 || isDIGIT_A((U8)*(d)) \
9324 || (!(u) && !UTF8_IS_INVARIANT((U8)*(d))))
9326 && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(s, is_utf8)))
9329 const STRLEN skip = UTF8SKIP(s);
9332 for ( i = 0; i < skip; i++ )
9340 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9344 else if (ck_uni && !bracket)
9347 if (isIDFIRST_lazy_if(d,is_utf8)) {
9348 d += is_utf8 ? UTF8SKIP(d) : 1;
9349 parse_ident(&s, &d, e, 1, is_utf8);
9351 while (s < send && SPACE_OR_TAB(*s))
9353 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9354 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9355 const char * const brack =
9357 ((*s == '[') ? "[...]" : "{...}");
9358 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9359 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9360 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9361 funny, dest, brack, funny, dest, brack);
9364 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9365 PL_lex_allbrackets++;
9369 /* Handle extended ${^Foo} variables
9370 * 1999-02-27 mjd-perl-patch@plover.com */
9371 else if (!isWORDCHAR(*d) && !isPRINT(*d) /* isCTRL(d) */
9375 while (isWORDCHAR(*s) && d < e) {
9379 Perl_croak(aTHX_ "%s", ident_too_long);
9383 while (s < send && SPACE_OR_TAB(*s))
9388 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9389 PL_lex_state = LEX_INTERPEND;
9392 if (PL_lex_state == LEX_NORMAL) {
9393 if (ckWARN(WARN_AMBIGUOUS) &&
9394 (keyword(dest, d - dest, 0)
9395 || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
9397 SV *tmp = newSVpvn_flags( dest, d - dest,
9398 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9401 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9402 "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9403 funny, tmp, funny, tmp);
9408 s = bracket; /* let the parser handle it */
9412 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9413 PL_lex_state = LEX_INTERPEND;
9418 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
9420 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
9421 * the parse starting at 's', based on the subset that are valid in this
9422 * context input to this routine in 'valid_flags'. Advances s. Returns
9423 * TRUE if the input should be treated as a valid flag, so the next char
9424 * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
9425 * first call on the current regex. This routine will set it to any
9426 * charset modifier found. The caller shouldn't change it. This way,
9427 * another charset modifier encountered in the parse can be detected as an
9428 * error, as we have decided to allow only one */
9431 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9433 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9434 if (isWORDCHAR_lazy_if(*s, UTF)) {
9435 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9436 UTF ? SVf_UTF8 : 0);
9438 /* Pretend that it worked, so will continue processing before
9447 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
9448 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9449 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9450 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9451 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9452 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9453 case LOCALE_PAT_MOD:
9455 goto multiple_charsets;
9457 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9460 case UNICODE_PAT_MOD:
9462 goto multiple_charsets;
9464 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9467 case ASCII_RESTRICT_PAT_MOD:
9469 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9473 /* Error if previous modifier wasn't an 'a', but if it was, see
9474 * if, and accept, a second occurrence (only) */
9476 || get_regex_charset(*pmfl)
9477 != REGEX_ASCII_RESTRICTED_CHARSET)
9479 goto multiple_charsets;
9481 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9485 case DEPENDS_PAT_MOD:
9487 goto multiple_charsets;
9489 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9498 if (*charset != c) {
9499 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9501 else if (c == 'a') {
9502 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9505 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9508 /* Pretend that it worked, so will continue processing before dieing */
9514 S_scan_pat(pTHX_ char *start, I32 type)
9519 const char * const valid_flags =
9520 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9521 char charset = '\0'; /* character set modifier */
9526 PERL_ARGS_ASSERT_SCAN_PAT;
9528 s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
9529 TRUE /* look for escaped bracketed metas */ );
9532 const char * const delimiter = skipspace(start);
9536 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9537 : "Search pattern not terminated" ));
9540 pm = (PMOP*)newPMOP(type, 0);
9541 if (PL_multi_open == '?') {
9542 /* This is the only point in the code that sets PMf_ONCE: */
9543 pm->op_pmflags |= PMf_ONCE;
9545 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9546 allows us to restrict the list needed by reset to just the ??
9548 assert(type != OP_TRANS);
9550 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9553 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9556 elements = mg->mg_len / sizeof(PMOP**);
9557 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9558 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9559 mg->mg_len = elements * sizeof(PMOP**);
9560 PmopSTASH_set(pm,PL_curstash);
9567 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9568 * anon CV. False positives like qr/[(?{]/ are harmless */
9570 if (type == OP_QR) {
9572 char *e, *p = SvPV(PL_lex_stuff, len);
9574 for (; p < e; p++) {
9575 if (p[0] == '(' && p[1] == '?'
9576 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9578 pm->op_pmflags |= PMf_HAS_CV;
9582 pm->op_pmflags |= PMf_IS_QR;
9585 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9587 if (PL_madskills && modstart != s) {
9588 SV* tmptoken = newSVpvn(modstart, s - modstart);
9589 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9592 /* issue a warning if /c is specified,but /g is not */
9593 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9595 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9596 "Use of /c modifier is meaningless without /g" );
9599 PL_lex_op = (OP*)pm;
9600 pl_yylval.ival = OP_MATCH;
9605 S_scan_subst(pTHX_ char *start)
9612 char charset = '\0'; /* character set modifier */
9617 PERL_ARGS_ASSERT_SCAN_SUBST;
9619 pl_yylval.ival = OP_NULL;
9621 s = scan_str(start,!!PL_madskills,FALSE,FALSE,
9622 TRUE /* look for escaped bracketed metas */ );
9625 Perl_croak(aTHX_ "Substitution pattern not terminated");
9627 if (s[-1] == PL_multi_open)
9631 CURMAD('q', PL_thisopen);
9632 CURMAD('_', PL_thiswhite);
9633 CURMAD('E', PL_thisstuff);
9634 CURMAD('Q', PL_thisclose);
9635 PL_realtokenstart = s - SvPVX(PL_linestr);
9639 first_start = PL_multi_start;
9640 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9643 SvREFCNT_dec(PL_lex_stuff);
9644 PL_lex_stuff = NULL;
9646 Perl_croak(aTHX_ "Substitution replacement not terminated");
9648 PL_multi_start = first_start; /* so whole substitution is taken together */
9650 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9654 CURMAD('z', PL_thisopen);
9655 CURMAD('R', PL_thisstuff);
9656 CURMAD('Z', PL_thisclose);
9662 if (*s == EXEC_PAT_MOD) {
9666 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9675 curmad('m', newSVpvn(modstart, s - modstart));
9676 append_madprops(PL_thismad, (OP*)pm, 0);
9680 if ((pm->op_pmflags & PMf_CONTINUE)) {
9681 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9685 SV * const repl = newSVpvs("");
9688 pm->op_pmflags |= PMf_EVAL;
9691 sv_catpvs(repl, "eval ");
9693 sv_catpvs(repl, "do ");
9695 sv_catpvs(repl, "{");
9696 sv_catsv(repl, PL_sublex_info.repl);
9697 sv_catpvs(repl, "}");
9699 SvREFCNT_dec(PL_sublex_info.repl);
9700 PL_sublex_info.repl = repl;
9703 PL_lex_op = (OP*)pm;
9704 pl_yylval.ival = OP_SUBST;
9709 S_scan_trans(pTHX_ char *start)
9717 bool nondestruct = 0;
9722 PERL_ARGS_ASSERT_SCAN_TRANS;
9724 pl_yylval.ival = OP_NULL;
9726 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
9728 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9730 if (s[-1] == PL_multi_open)
9734 CURMAD('q', PL_thisopen);
9735 CURMAD('_', PL_thiswhite);
9736 CURMAD('E', PL_thisstuff);
9737 CURMAD('Q', PL_thisclose);
9738 PL_realtokenstart = s - SvPVX(PL_linestr);
9742 s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9745 SvREFCNT_dec(PL_lex_stuff);
9746 PL_lex_stuff = NULL;
9748 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9751 CURMAD('z', PL_thisopen);
9752 CURMAD('R', PL_thisstuff);
9753 CURMAD('Z', PL_thisclose);
9756 complement = del = squash = 0;
9763 complement = OPpTRANS_COMPLEMENT;
9766 del = OPpTRANS_DELETE;
9769 squash = OPpTRANS_SQUASH;
9781 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9782 o->op_private &= ~OPpTRANS_ALL;
9783 o->op_private |= del|squash|complement|
9784 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9785 (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9788 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9793 curmad('m', newSVpvn(modstart, s - modstart));
9794 append_madprops(PL_thismad, o, 0);
9803 Takes a pointer to the first < in <<FOO.
9804 Returns a pointer to the byte following <<FOO.
9806 This function scans a heredoc, which involves different methods
9807 depending on whether we are in a string eval, quoted construct, etc.
9808 This is because PL_linestr could containing a single line of input, or
9809 a whole string being evalled, or the contents of the current quote-
9812 The two basic methods are:
9813 - Steal lines from the input stream
9814 - Scan the heredoc in PL_linestr and remove it therefrom
9816 In a file scope or filtered eval, the first method is used; in a
9817 string eval, the second.
9819 In a quote-like operator, we have to choose between the two,
9820 depending on where we can find a newline. We peek into outer lex-
9821 ing scopes until we find one with a newline in it. If we reach the
9822 outermost lexing scope and it is a file, we use the stream method.
9823 Otherwise it is treated as an eval.
9827 S_scan_heredoc(pTHX_ char *s)
9830 I32 op_type = OP_SCALAR;
9837 const bool infile = PL_rsfp || PL_parser->filtered;
9838 LEXSHARED *shared = PL_parser->lex_shared;
9840 I32 stuffstart = s - SvPVX(PL_linestr);
9843 PL_realtokenstart = -1;
9846 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9849 d = PL_tokenbuf + 1;
9850 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9851 *PL_tokenbuf = '\n';
9853 while (SPACE_OR_TAB(*peek))
9855 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9858 s = delimcpy(d, e, s, PL_bufend, term, &len);
9860 Perl_croak(aTHX_ "Unterminated delimiter for here document");
9866 /* <<\FOO is equivalent to <<'FOO' */
9870 if (!isWORDCHAR_lazy_if(s,UTF))
9871 deprecate("bare << to mean <<\"\"");
9872 for (; isWORDCHAR_lazy_if(s,UTF); s++) {
9877 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9878 Perl_croak(aTHX_ "Delimiter for here document is too long");
9881 len = d - PL_tokenbuf;
9885 tstart = PL_tokenbuf + 1;
9886 PL_thisclose = newSVpvn(tstart, len - 1);
9887 tstart = SvPVX(PL_linestr) + stuffstart;
9888 PL_thisopen = newSVpvn(tstart, s - tstart);
9889 stuffstart = s - SvPVX(PL_linestr);
9892 #ifndef PERL_STRICT_CR
9893 d = strchr(s, '\r');
9895 char * const olds = s;
9897 while (s < PL_bufend) {
9903 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9912 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9918 tstart = SvPVX(PL_linestr) + stuffstart;
9920 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9922 PL_thisstuff = newSVpvn(tstart, s - tstart);
9925 stuffstart = s - SvPVX(PL_linestr);
9928 tmpstr = newSV_type(SVt_PVIV);
9932 SvIV_set(tmpstr, -1);
9934 else if (term == '`') {
9935 op_type = OP_BACKTICK;
9936 SvIV_set(tmpstr, '\\');
9939 PL_multi_start = CopLINE(PL_curcop) + 1;
9940 PL_multi_open = PL_multi_close = '<';
9941 /* inside a string eval or quote-like operator */
9942 if (!infile || PL_lex_inwhat) {
9945 char * const olds = s;
9946 PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
9947 /* These two fields are not set until an inner lexing scope is
9948 entered. But we need them set here. */
9949 shared->ls_bufptr = s;
9950 shared->ls_linestr = PL_linestr;
9952 /* Look for a newline. If the current buffer does not have one,
9953 peek into the line buffer of the parent lexing scope, going
9954 up as many levels as necessary to find one with a newline
9957 while (!(s = (char *)memchr(
9958 (void *)shared->ls_bufptr, '\n',
9959 SvEND(shared->ls_linestr)-shared->ls_bufptr
9961 shared = shared->ls_prev;
9962 /* shared is only null if we have gone beyond the outermost
9963 lexing scope. In a file, we will have broken out of the
9964 loop in the previous iteration. In an eval, the string buf-
9965 fer ends with "\n;", so the while condition below will have
9966 evaluated to false. So shared can never be null. */
9968 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
9969 most lexing scope. In a file, shared->ls_linestr at that
9970 level is just one line, so there is no body to steal. */
9971 if (infile && !shared->ls_prev) {
9977 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
9980 linestr = shared->ls_linestr;
9981 bufend = SvEND(linestr);
9983 while (s < bufend - len + 1 &&
9984 memNE(s,PL_tokenbuf,len) ) {
9986 ++shared->herelines;
9988 if (s >= bufend - len + 1) {
9991 sv_setpvn(tmpstr,d+1,s-d);
9995 sv_catpvn(PL_thisstuff, d + 1, s - d);
9997 PL_thisstuff = newSVpvn(d + 1, s - d);
9998 stuffstart = s - SvPVX(PL_linestr);
10002 /* the preceding stmt passes a newline */
10003 shared->herelines++;
10005 /* s now points to the newline after the heredoc terminator.
10006 d points to the newline before the body of the heredoc.
10009 /* We are going to modify linestr in place here, so set
10010 aside copies of the string if necessary for re-evals or
10012 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10013 check shared->re_eval_str. */
10014 if (shared->re_eval_start || shared->re_eval_str) {
10015 /* Set aside the rest of the regexp */
10016 if (!shared->re_eval_str)
10017 shared->re_eval_str =
10018 newSVpvn(shared->re_eval_start,
10019 bufend - shared->re_eval_start);
10020 shared->re_eval_start -= s-d;
10022 if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
10023 CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
10024 cx->blk_eval.cur_text == linestr)
10026 cx->blk_eval.cur_text = newSVsv(linestr);
10027 SvSCREAM_on(cx->blk_eval.cur_text);
10029 /* Copy everything from s onwards back to d. */
10030 Move(s,d,bufend-s + 1,char);
10031 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10032 /* Setting PL_bufend only applies when we have not dug deeper
10033 into other scopes, because sublex_done sets PL_bufend to
10034 SvEND(PL_linestr). */
10035 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10042 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
10043 term = PL_tokenbuf[1];
10045 linestr_save = PL_linestr; /* must restore this afterwards */
10046 d = s; /* and this */
10047 PL_linestr = newSVpvs("");
10048 PL_bufend = SvPVX(PL_linestr);
10051 if (PL_madskills) {
10052 tstart = SvPVX(PL_linestr) + stuffstart;
10054 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10056 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10059 PL_bufptr = PL_bufend;
10060 CopLINE_set(PL_curcop,
10061 PL_multi_start + shared->herelines);
10062 if (!lex_next_chunk(LEX_NO_TERM)
10063 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10064 SvREFCNT_dec(linestr_save);
10067 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10068 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10069 lex_grow_linestr(SvCUR(PL_linestr) + 2);
10070 sv_catpvs(PL_linestr, "\n\0");
10074 stuffstart = s - SvPVX(PL_linestr);
10076 shared->herelines++;
10077 PL_last_lop = PL_last_uni = NULL;
10078 #ifndef PERL_STRICT_CR
10079 if (PL_bufend - PL_linestart >= 2) {
10080 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
10081 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10083 PL_bufend[-2] = '\n';
10085 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10087 else if (PL_bufend[-1] == '\r')
10088 PL_bufend[-1] = '\n';
10090 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10091 PL_bufend[-1] = '\n';
10093 if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
10094 SvREFCNT_dec(PL_linestr);
10095 PL_linestr = linestr_save;
10096 PL_linestart = SvPVX(linestr_save);
10097 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10102 sv_catsv(tmpstr,PL_linestr);
10106 PL_multi_end = CopLINE(PL_curcop);
10107 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10108 SvPV_shrink_to_cur(tmpstr);
10111 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10113 else if (PL_encoding)
10114 sv_recode_to_utf8(tmpstr, PL_encoding);
10116 PL_lex_stuff = tmpstr;
10117 pl_yylval.ival = op_type;
10121 SvREFCNT_dec(tmpstr);
10122 CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10123 missingterm(PL_tokenbuf + 1);
10126 /* scan_inputsymbol
10127 takes: current position in input buffer
10128 returns: new position in input buffer
10129 side-effects: pl_yylval and lex_op are set.
10134 <FH> read from filehandle
10135 <pkg::FH> read from package qualified filehandle
10136 <pkg'FH> read from package qualified filehandle
10137 <$fh> read from filehandle in $fh
10138 <*.h> filename glob
10143 S_scan_inputsymbol(pTHX_ char *start)
10146 char *s = start; /* current position in buffer */
10149 char *d = PL_tokenbuf; /* start of temp holding space */
10150 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10152 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10154 end = strchr(s, '\n');
10157 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10159 /* die if we didn't have space for the contents of the <>,
10160 or if it didn't end, or if we see a newline
10163 if (len >= (I32)sizeof PL_tokenbuf)
10164 Perl_croak(aTHX_ "Excessively long <> operator");
10166 Perl_croak(aTHX_ "Unterminated <> operator");
10171 Remember, only scalar variables are interpreted as filehandles by
10172 this code. Anything more complex (e.g., <$fh{$num}>) will be
10173 treated as a glob() call.
10174 This code makes use of the fact that except for the $ at the front,
10175 a scalar variable and a filehandle look the same.
10177 if (*d == '$' && d[1]) d++;
10179 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10180 while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
10181 d += UTF ? UTF8SKIP(d) : 1;
10183 /* If we've tried to read what we allow filehandles to look like, and
10184 there's still text left, then it must be a glob() and not a getline.
10185 Use scan_str to pull out the stuff between the <> and treat it
10186 as nothing more than a string.
10189 if (d - PL_tokenbuf != len) {
10190 pl_yylval.ival = OP_GLOB;
10191 s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
10193 Perl_croak(aTHX_ "Glob not terminated");
10197 bool readline_overriden = FALSE;
10200 /* we're in a filehandle read situation */
10203 /* turn <> into <ARGV> */
10205 Copy("ARGV",d,5,char);
10207 /* Check whether readline() is overriden */
10208 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
10210 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
10212 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
10213 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
10214 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
10215 readline_overriden = TRUE;
10217 /* if <$fh>, create the ops to turn the variable into a
10221 /* try to find it in the pad for this block, otherwise find
10222 add symbol table ops
10224 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
10225 if (tmp != NOT_IN_PAD) {
10226 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10227 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10228 HEK * const stashname = HvNAME_HEK(stash);
10229 SV * const sym = sv_2mortal(newSVhek(stashname));
10230 sv_catpvs(sym, "::");
10231 sv_catpv(sym, d+1);
10236 OP * const o = newOP(OP_PADSV, 0);
10238 PL_lex_op = readline_overriden
10239 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10240 op_append_elem(OP_LIST, o,
10241 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10242 : (OP*)newUNOP(OP_READLINE, 0, o);
10251 ? (GV_ADDMULTI | GV_ADDINEVAL)
10252 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
10254 PL_lex_op = readline_overriden
10255 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10256 op_append_elem(OP_LIST,
10257 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10258 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10259 : (OP*)newUNOP(OP_READLINE, 0,
10260 newUNOP(OP_RV2SV, 0,
10261 newGVOP(OP_GV, 0, gv)));
10263 if (!readline_overriden)
10264 PL_lex_op->op_flags |= OPf_SPECIAL;
10265 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10266 pl_yylval.ival = OP_NULL;
10269 /* If it's none of the above, it must be a literal filehandle
10270 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10272 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10273 PL_lex_op = readline_overriden
10274 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10275 op_append_elem(OP_LIST,
10276 newGVOP(OP_GV, 0, gv),
10277 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10278 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10279 pl_yylval.ival = OP_NULL;
10288 takes: start position in buffer
10289 keep_quoted preserve \ on the embedded delimiter(s)
10290 keep_delims preserve the delimiters around the string
10291 re_reparse compiling a run-time /(?{})/:
10292 collapse // to /, and skip encoding src
10293 returns: position to continue reading from buffer
10294 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10295 updates the read buffer.
10297 This subroutine pulls a string out of the input. It is called for:
10298 q single quotes q(literal text)
10299 ' single quotes 'literal text'
10300 qq double quotes qq(interpolate $here please)
10301 " double quotes "interpolate $here please"
10302 qx backticks qx(/bin/ls -l)
10303 ` backticks `/bin/ls -l`
10304 qw quote words @EXPORT_OK = qw( func() $spam )
10305 m// regexp match m/this/
10306 s/// regexp substitute s/this/that/
10307 tr/// string transliterate tr/this/that/
10308 y/// string transliterate y/this/that/
10309 ($*@) sub prototypes sub foo ($)
10310 (stuff) sub attr parameters sub foo : attr(stuff)
10311 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10313 In most of these cases (all but <>, patterns and transliterate)
10314 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10315 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10316 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10319 It skips whitespace before the string starts, and treats the first
10320 character as the delimiter. If the delimiter is one of ([{< then
10321 the corresponding "close" character )]}> is used as the closing
10322 delimiter. It allows quoting of delimiters, and if the string has
10323 balanced delimiters ([{<>}]) it allows nesting.
10325 On success, the SV with the resulting string is put into lex_stuff or,
10326 if that is already non-NULL, into lex_repl. The second case occurs only
10327 when parsing the RHS of the special constructs s/// and tr/// (y///).
10328 For convenience, the terminating delimiter character is stuffed into
10333 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
10334 bool deprecate_escaped_meta /* Should we issue a deprecation warning
10335 for certain paired metacharacters that
10336 appear escaped within it */
10340 SV *sv; /* scalar value: string */
10341 const char *tmps; /* temp string, used for delimiter matching */
10342 char *s = start; /* current position in the buffer */
10343 char term; /* terminating character */
10344 char *to; /* current position in the sv's data */
10345 I32 brackets = 1; /* bracket nesting level */
10346 bool has_utf8 = FALSE; /* is there any utf8 content? */
10347 I32 termcode; /* terminating char. code */
10348 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10349 STRLEN termlen; /* length of terminating string */
10350 int last_off = 0; /* last position for nesting bracket */
10351 char *escaped_open = NULL;
10357 PERL_ARGS_ASSERT_SCAN_STR;
10359 /* skip space before the delimiter */
10365 if (PL_realtokenstart >= 0) {
10366 stuffstart = PL_realtokenstart;
10367 PL_realtokenstart = -1;
10370 stuffstart = start - SvPVX(PL_linestr);
10372 /* mark where we are, in case we need to report errors */
10375 /* after skipping whitespace, the next character is the terminator */
10378 termcode = termstr[0] = term;
10382 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10383 Copy(s, termstr, termlen, U8);
10384 if (!UTF8_IS_INVARIANT(term))
10388 /* mark where we are */
10389 PL_multi_start = CopLINE(PL_curcop);
10390 PL_multi_open = term;
10392 /* find corresponding closing delimiter */
10393 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
10394 termcode = termstr[0] = term = tmps[5];
10396 PL_multi_close = term;
10398 /* A warning is raised if the input parameter requires it for escaped (by a
10399 * backslash) paired metacharacters {} [] and () when the delimiters are
10400 * those same characters, and the backslash is ineffective. This doesn't
10401 * happen for <>, as they aren't metas. */
10402 if (deprecate_escaped_meta
10403 && (PL_multi_open == PL_multi_close
10404 || ! ckWARN_d(WARN_DEPRECATED)
10405 || PL_multi_open == '<'))
10407 deprecate_escaped_meta = FALSE;
10410 /* create a new SV to hold the contents. 79 is the SV's initial length.
10411 What a random number. */
10412 sv = newSV_type(SVt_PVIV);
10414 SvIV_set(sv, termcode);
10415 (void)SvPOK_only(sv); /* validate pointer */
10417 /* move past delimiter and try to read a complete string */
10419 sv_catpvn(sv, s, termlen);
10422 tstart = SvPVX(PL_linestr) + stuffstart;
10423 if (PL_madskills && !PL_thisopen && !keep_delims) {
10424 PL_thisopen = newSVpvn(tstart, s - tstart);
10425 stuffstart = s - SvPVX(PL_linestr);
10429 if (PL_encoding && !UTF && !re_reparse) {
10433 int offset = s - SvPVX_const(PL_linestr);
10434 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10435 &offset, (char*)termstr, termlen);
10436 const char * const ns = SvPVX_const(PL_linestr) + offset;
10437 char * const svlast = SvEND(sv) - 1;
10439 for (; s < ns; s++) {
10440 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10441 COPLINE_INC_WITH_HERELINES;
10444 goto read_more_line;
10446 /* handle quoted delimiters */
10447 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10449 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10451 if ((svlast-1 - t) % 2) {
10452 if (!keep_quoted) {
10453 *(svlast-1) = term;
10455 SvCUR_set(sv, SvCUR(sv) - 1);
10460 if (PL_multi_open == PL_multi_close) {
10466 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10467 /* At here, all closes are "was quoted" one,
10468 so we don't check PL_multi_close. */
10470 if (!keep_quoted && *(t+1) == PL_multi_open)
10475 else if (*t == PL_multi_open)
10483 SvCUR_set(sv, w - SvPVX_const(sv));
10485 last_off = w - SvPVX(sv);
10486 if (--brackets <= 0)
10491 if (!keep_delims) {
10492 SvCUR_set(sv, SvCUR(sv) - 1);
10498 /* extend sv if need be */
10499 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10500 /* set 'to' to the next character in the sv's string */
10501 to = SvPVX(sv)+SvCUR(sv);
10503 /* if open delimiter is the close delimiter read unbridle */
10504 if (PL_multi_open == PL_multi_close) {
10505 for (; s < PL_bufend; s++,to++) {
10506 /* embedded newlines increment the current line number */
10507 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10508 COPLINE_INC_WITH_HERELINES;
10509 /* handle quoted delimiters */
10510 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10513 || (re_reparse && s[1] == '\\'))
10516 /* any other quotes are simply copied straight through */
10520 /* terminate when run out of buffer (the for() condition), or
10521 have found the terminator */
10522 else if (*s == term) {
10525 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10528 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10534 /* if the terminator isn't the same as the start character (e.g.,
10535 matched brackets), we have to allow more in the quoting, and
10536 be prepared for nested brackets.
10539 /* read until we run out of string, or we find the terminator */
10540 for (; s < PL_bufend; s++,to++) {
10541 /* embedded newlines increment the line count */
10542 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10543 COPLINE_INC_WITH_HERELINES;
10544 /* backslashes can escape the open or closing characters */
10545 if (*s == '\\' && s+1 < PL_bufend) {
10546 if (!keep_quoted &&
10547 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10551 /* Here, 'deprecate_escaped_meta' is true iff the
10552 * delimiters are paired metacharacters, and 's' points
10553 * to an occurrence of one of them within the string,
10554 * which was preceded by a backslash. If this is a
10555 * context where the delimiter is also a metacharacter,
10556 * the backslash is useless, and deprecated. () and []
10557 * are meta in any context. {} are meta only when
10558 * appearing in a quantifier or in things like '\p{'.
10559 * They also aren't meta unless there is a matching
10560 * closed, escaped char later on within the string.
10561 * If 's' points to an open, set a flag; if to a close,
10562 * test that flag, and raise a warning if it was set */
10564 if (deprecate_escaped_meta) {
10565 if (*s == PL_multi_open) {
10569 else if (regcurly(s,
10570 TRUE /* Look for a closing
10572 || (s - start > 2 /* Look for e.g.
10574 && _generic_isCC(*(s-2), _CC_BACKSLASH_FOO_LBRACE_IS_META)))
10579 else if (escaped_open) {
10580 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10581 "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open);
10582 escaped_open = NULL;
10589 /* allow nested opens and closes */
10590 else if (*s == PL_multi_close && --brackets <= 0)
10592 else if (*s == PL_multi_open)
10594 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10599 /* terminate the copied string and update the sv's end-of-string */
10601 SvCUR_set(sv, to - SvPVX_const(sv));
10604 * this next chunk reads more into the buffer if we're not done yet
10608 break; /* handle case where we are done yet :-) */
10610 #ifndef PERL_STRICT_CR
10611 if (to - SvPVX_const(sv) >= 2) {
10612 if ((to[-2] == '\r' && to[-1] == '\n') ||
10613 (to[-2] == '\n' && to[-1] == '\r'))
10617 SvCUR_set(sv, to - SvPVX_const(sv));
10619 else if (to[-1] == '\r')
10622 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10627 /* if we're out of file, or a read fails, bail and reset the current
10628 line marker so we can report where the unterminated string began
10631 if (PL_madskills) {
10632 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10634 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10636 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10639 COPLINE_INC_WITH_HERELINES;
10640 PL_bufptr = PL_bufend;
10641 if (!lex_next_chunk(0)) {
10643 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10652 /* at this point, we have successfully read the delimited string */
10654 if (!PL_encoding || UTF || re_reparse) {
10656 if (PL_madskills) {
10657 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10658 const int len = s - tstart;
10660 sv_catpvn(PL_thisstuff, tstart, len);
10662 PL_thisstuff = newSVpvn(tstart, len);
10663 if (!PL_thisclose && !keep_delims)
10664 PL_thisclose = newSVpvn(s,termlen);
10669 sv_catpvn(sv, s, termlen);
10674 if (PL_madskills) {
10675 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10676 const int len = s - tstart - termlen;
10678 sv_catpvn(PL_thisstuff, tstart, len);
10680 PL_thisstuff = newSVpvn(tstart, len);
10681 if (!PL_thisclose && !keep_delims)
10682 PL_thisclose = newSVpvn(s - termlen,termlen);
10686 if (has_utf8 || (PL_encoding && !re_reparse))
10689 PL_multi_end = CopLINE(PL_curcop);
10691 /* if we allocated too much space, give some back */
10692 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10693 SvLEN_set(sv, SvCUR(sv) + 1);
10694 SvPV_renew(sv, SvLEN(sv));
10697 /* decide whether this is the first or second quoted string we've read
10702 PL_sublex_info.repl = sv;
10710 takes: pointer to position in buffer
10711 returns: pointer to new position in buffer
10712 side-effects: builds ops for the constant in pl_yylval.op
10714 Read a number in any of the formats that Perl accepts:
10716 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10717 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10720 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10722 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10725 If it reads a number without a decimal point or an exponent, it will
10726 try converting the number to an integer and see if it can do so
10727 without loss of precision.
10731 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10734 const char *s = start; /* current position in buffer */
10735 char *d; /* destination in temp buffer */
10736 char *e; /* end of temp buffer */
10737 NV nv; /* number read, as a double */
10738 SV *sv = NULL; /* place to put the converted number */
10739 bool floatit; /* boolean: int or float? */
10740 const char *lastub = NULL; /* position of last underbar */
10741 static const char* const number_too_long = "Number too long";
10743 PERL_ARGS_ASSERT_SCAN_NUM;
10745 /* We use the first character to decide what type of number this is */
10749 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10751 /* if it starts with a 0, it could be an octal number, a decimal in
10752 0.13 disguise, or a hexadecimal number, or a binary number. */
10756 u holds the "number so far"
10757 shift the power of 2 of the base
10758 (hex == 4, octal == 3, binary == 1)
10759 overflowed was the number more than we can hold?
10761 Shift is used when we add a digit. It also serves as an "are
10762 we in octal/hex/binary?" indicator to disallow hex characters
10763 when in octal mode.
10768 bool overflowed = FALSE;
10769 bool just_zero = TRUE; /* just plain 0 or binary number? */
10770 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10771 static const char* const bases[5] =
10772 { "", "binary", "", "octal", "hexadecimal" };
10773 static const char* const Bases[5] =
10774 { "", "Binary", "", "Octal", "Hexadecimal" };
10775 static const char* const maxima[5] =
10777 "0b11111111111111111111111111111111",
10781 const char *base, *Base, *max;
10783 /* check for hex */
10784 if (s[1] == 'x' || s[1] == 'X') {
10788 } else if (s[1] == 'b' || s[1] == 'B') {
10793 /* check for a decimal in disguise */
10794 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10796 /* so it must be octal */
10803 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10804 "Misplaced _ in number");
10808 base = bases[shift];
10809 Base = Bases[shift];
10810 max = maxima[shift];
10812 /* read the rest of the number */
10814 /* x is used in the overflow test,
10815 b is the digit we're adding on. */
10820 /* if we don't mention it, we're done */
10824 /* _ are ignored -- but warned about if consecutive */
10826 if (lastub && s == lastub + 1)
10827 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10828 "Misplaced _ in number");
10832 /* 8 and 9 are not octal */
10833 case '8': case '9':
10835 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10839 case '2': case '3': case '4':
10840 case '5': case '6': case '7':
10842 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10845 case '0': case '1':
10846 b = *s++ & 15; /* ASCII digit -> value of digit */
10850 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10851 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10852 /* make sure they said 0x */
10855 b = (*s++ & 7) + 9;
10857 /* Prepare to put the digit we have onto the end
10858 of the number so far. We check for overflows.
10864 x = u << shift; /* make room for the digit */
10866 if ((x >> shift) != u
10867 && !(PL_hints & HINT_NEW_BINARY)) {
10870 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10871 "Integer overflow in %s number",
10874 u = x | b; /* add the digit to the end */
10877 n *= nvshift[shift];
10878 /* If an NV has not enough bits in its
10879 * mantissa to represent an UV this summing of
10880 * small low-order numbers is a waste of time
10881 * (because the NV cannot preserve the
10882 * low-order bits anyway): we could just
10883 * remember when did we overflow and in the
10884 * end just multiply n by the right
10892 /* if we get here, we had success: make a scalar value from
10897 /* final misplaced underbar check */
10898 if (s[-1] == '_') {
10899 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10903 if (n > 4294967295.0)
10904 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10905 "%s number > %s non-portable",
10911 if (u > 0xffffffff)
10912 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10913 "%s number > %s non-portable",
10918 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10919 sv = new_constant(start, s - start, "integer",
10920 sv, NULL, NULL, 0);
10921 else if (PL_hints & HINT_NEW_BINARY)
10922 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10927 handle decimal numbers.
10928 we're also sent here when we read a 0 as the first digit
10930 case '1': case '2': case '3': case '4': case '5':
10931 case '6': case '7': case '8': case '9': case '.':
10934 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10937 /* read next group of digits and _ and copy into d */
10938 while (isDIGIT(*s) || *s == '_') {
10939 /* skip underscores, checking for misplaced ones
10943 if (lastub && s == lastub + 1)
10944 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10945 "Misplaced _ in number");
10949 /* check for end of fixed-length buffer */
10951 Perl_croak(aTHX_ "%s", number_too_long);
10952 /* if we're ok, copy the character */
10957 /* final misplaced underbar check */
10958 if (lastub && s == lastub + 1) {
10959 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10962 /* read a decimal portion if there is one. avoid
10963 3..5 being interpreted as the number 3. followed
10966 if (*s == '.' && s[1] != '.') {
10971 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10972 "Misplaced _ in number");
10976 /* copy, ignoring underbars, until we run out of digits.
10978 for (; isDIGIT(*s) || *s == '_'; s++) {
10979 /* fixed length buffer check */
10981 Perl_croak(aTHX_ "%s", number_too_long);
10983 if (lastub && s == lastub + 1)
10984 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10985 "Misplaced _ in number");
10991 /* fractional part ending in underbar? */
10992 if (s[-1] == '_') {
10993 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10994 "Misplaced _ in number");
10996 if (*s == '.' && isDIGIT(s[1])) {
10997 /* oops, it's really a v-string, but without the "v" */
11003 /* read exponent part, if present */
11004 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
11008 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
11009 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
11011 /* stray preinitial _ */
11013 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11014 "Misplaced _ in number");
11018 /* allow positive or negative exponent */
11019 if (*s == '+' || *s == '-')
11022 /* stray initial _ */
11024 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11025 "Misplaced _ in number");
11029 /* read digits of exponent */
11030 while (isDIGIT(*s) || *s == '_') {
11033 Perl_croak(aTHX_ "%s", number_too_long);
11037 if (((lastub && s == lastub + 1) ||
11038 (!isDIGIT(s[1]) && s[1] != '_')))
11039 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11040 "Misplaced _ in number");
11048 We try to do an integer conversion first if no characters
11049 indicating "float" have been found.
11054 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11056 if (flags == IS_NUMBER_IN_UV) {
11058 sv = newSViv(uv); /* Prefer IVs over UVs. */
11061 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11062 if (uv <= (UV) IV_MIN)
11063 sv = newSViv(-(IV)uv);
11070 /* terminate the string */
11072 nv = Atof(PL_tokenbuf);
11077 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11078 const char *const key = floatit ? "float" : "integer";
11079 const STRLEN keylen = floatit ? 5 : 7;
11080 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11081 key, keylen, sv, NULL, NULL, 0);
11085 /* if it starts with a v, it could be a v-string */
11088 sv = newSV(5); /* preallocate storage space */
11089 ENTER_with_name("scan_vstring");
11091 s = scan_vstring(s, PL_bufend, sv);
11092 SvREFCNT_inc_simple_void_NN(sv);
11093 LEAVE_with_name("scan_vstring");
11097 /* make the op for the constant and return */
11100 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11102 lvalp->opval = NULL;
11108 S_scan_formline(pTHX_ char *s)
11113 SV * const stuff = newSVpvs("");
11114 bool needargs = FALSE;
11115 bool eofmt = FALSE;
11117 char *tokenstart = s;
11118 SV* savewhite = NULL;
11120 if (PL_madskills) {
11121 savewhite = PL_thiswhite;
11126 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11128 while (!needargs) {
11131 #ifdef PERL_STRICT_CR
11132 while (SPACE_OR_TAB(*t))
11135 while (SPACE_OR_TAB(*t) || *t == '\r')
11138 if (*t == '\n' || t == PL_bufend) {
11143 eol = (char *) memchr(s,'\n',PL_bufend-s);
11147 for (t = s; t < eol; t++) {
11148 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11150 goto enough; /* ~~ must be first line in formline */
11152 if (*t == '@' || *t == '^')
11156 sv_catpvn(stuff, s, eol-s);
11157 #ifndef PERL_STRICT_CR
11158 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11159 char *end = SvPVX(stuff) + SvCUR(stuff);
11162 SvCUR_set(stuff, SvCUR(stuff) - 1);
11170 if ((PL_rsfp || PL_parser->filtered)
11171 && PL_parser->form_lex_state == LEX_NORMAL) {
11174 if (PL_madskills) {
11176 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
11178 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
11181 PL_bufptr = PL_bufend;
11182 COPLINE_INC_WITH_HERELINES;
11183 got_some = lex_next_chunk(0);
11184 CopLINE_dec(PL_curcop);
11187 tokenstart = PL_bufptr;
11195 if (!SvCUR(stuff) || needargs)
11196 PL_lex_state = PL_parser->form_lex_state;
11197 if (SvCUR(stuff)) {
11198 PL_expect = XSTATE;
11200 start_force(PL_curforce);
11201 NEXTVAL_NEXTTOKE.ival = 0;
11202 force_next(FORMLBRACK);
11205 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11207 else if (PL_encoding)
11208 sv_recode_to_utf8(stuff, PL_encoding);
11210 start_force(PL_curforce);
11211 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
11215 SvREFCNT_dec(stuff);
11217 PL_lex_formbrack = 0;
11220 if (PL_madskills) {
11222 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
11224 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
11225 PL_thiswhite = savewhite;
11232 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11235 const I32 oldsavestack_ix = PL_savestack_ix;
11236 CV* const outsidecv = PL_compcv;
11238 SAVEI32(PL_subline);
11239 save_item(PL_subname);
11240 SAVESPTR(PL_compcv);
11242 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11243 CvFLAGS(PL_compcv) |= flags;
11245 PL_subline = CopLINE(PL_curcop);
11246 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11247 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11248 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11249 if (outsidecv && CvPADLIST(outsidecv))
11250 CvPADLIST(PL_compcv)->xpadl_outid =
11251 PadlistNAMES(CvPADLIST(outsidecv));
11253 return oldsavestack_ix;
11257 #pragma segment Perl_yylex
11260 S_yywarn(pTHX_ const char *const s, U32 flags)
11264 PERL_ARGS_ASSERT_YYWARN;
11266 PL_in_eval |= EVAL_WARNONLY;
11267 yyerror_pv(s, flags);
11268 PL_in_eval &= ~EVAL_WARNONLY;
11273 Perl_yyerror(pTHX_ const char *const s)
11275 PERL_ARGS_ASSERT_YYERROR;
11276 return yyerror_pvn(s, strlen(s), 0);
11280 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11282 PERL_ARGS_ASSERT_YYERROR_PV;
11283 return yyerror_pvn(s, strlen(s), flags);
11287 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11290 const char *context = NULL;
11293 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11294 int yychar = PL_parser->yychar;
11296 PERL_ARGS_ASSERT_YYERROR_PVN;
11298 if (!yychar || (yychar == ';' && !PL_rsfp))
11299 sv_catpvs(where_sv, "at EOF");
11300 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
11301 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
11302 PL_oldbufptr != PL_bufptr) {
11305 The code below is removed for NetWare because it abends/crashes on NetWare
11306 when the script has error such as not having the closing quotes like:
11307 if ($var eq "value)
11308 Checking of white spaces is anyway done in NetWare code.
11311 while (isSPACE(*PL_oldoldbufptr))
11314 context = PL_oldoldbufptr;
11315 contlen = PL_bufptr - PL_oldoldbufptr;
11317 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
11318 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
11321 The code below is removed for NetWare because it abends/crashes on NetWare
11322 when the script has error such as not having the closing quotes like:
11323 if ($var eq "value)
11324 Checking of white spaces is anyway done in NetWare code.
11327 while (isSPACE(*PL_oldbufptr))
11330 context = PL_oldbufptr;
11331 contlen = PL_bufptr - PL_oldbufptr;
11333 else if (yychar > 255)
11334 sv_catpvs(where_sv, "next token ???");
11335 else if (yychar == -2) { /* YYEMPTY */
11336 if (PL_lex_state == LEX_NORMAL ||
11337 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11338 sv_catpvs(where_sv, "at end of line");
11339 else if (PL_lex_inpat)
11340 sv_catpvs(where_sv, "within pattern");
11342 sv_catpvs(where_sv, "within string");
11345 sv_catpvs(where_sv, "next char ");
11347 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11348 else if (isPRINT_LC(yychar)) {
11349 const char string = yychar;
11350 sv_catpvn(where_sv, &string, 1);
11353 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11355 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11356 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11357 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11359 Perl_sv_catpvf(aTHX_ msg, "near \"%"SVf"\"\n",
11360 SVfARG(newSVpvn_flags(context, contlen,
11361 SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
11363 Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
11364 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
11365 Perl_sv_catpvf(aTHX_ msg,
11366 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11367 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11370 if (PL_in_eval & EVAL_WARNONLY) {
11371 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
11375 if (PL_error_count >= 10) {
11377 if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
11378 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11379 SVfARG(errsv), OutCopFILE(PL_curcop));
11381 Perl_croak(aTHX_ "%s has too many errors.\n",
11382 OutCopFILE(PL_curcop));
11385 PL_in_my_stash = NULL;
11389 #pragma segment Main
11393 S_swallow_bom(pTHX_ U8 *s)
11396 const STRLEN slen = SvCUR(PL_linestr);
11398 PERL_ARGS_ASSERT_SWALLOW_BOM;
11402 if (s[1] == 0xFE) {
11403 /* UTF-16 little-endian? (or UTF-32LE?) */
11404 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11405 /* diag_listed_as: Unsupported script encoding %s */
11406 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11407 #ifndef PERL_NO_UTF16_FILTER
11408 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11410 if (PL_bufend > (char*)s) {
11411 s = add_utf16_textfilter(s, TRUE);
11414 /* diag_listed_as: Unsupported script encoding %s */
11415 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11420 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11421 #ifndef PERL_NO_UTF16_FILTER
11422 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11424 if (PL_bufend > (char *)s) {
11425 s = add_utf16_textfilter(s, FALSE);
11428 /* diag_listed_as: Unsupported script encoding %s */
11429 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11434 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
11435 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11436 s += 3; /* UTF-8 */
11442 if (s[2] == 0xFE && s[3] == 0xFF) {
11443 /* UTF-32 big-endian */
11444 /* diag_listed_as: Unsupported script encoding %s */
11445 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11448 else if (s[2] == 0 && s[3] != 0) {
11451 * are a good indicator of UTF-16BE. */
11452 #ifndef PERL_NO_UTF16_FILTER
11453 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11454 s = add_utf16_textfilter(s, FALSE);
11456 /* diag_listed_as: Unsupported script encoding %s */
11457 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11463 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
11464 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11465 s += 4; /* UTF-8 */
11471 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11474 * are a good indicator of UTF-16LE. */
11475 #ifndef PERL_NO_UTF16_FILTER
11476 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11477 s = add_utf16_textfilter(s, TRUE);
11479 /* diag_listed_as: Unsupported script encoding %s */
11480 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11488 #ifndef PERL_NO_UTF16_FILTER
11490 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11493 SV *const filter = FILTER_DATA(idx);
11494 /* We re-use this each time round, throwing the contents away before we
11496 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11497 SV *const utf8_buffer = filter;
11498 IV status = IoPAGE(filter);
11499 const bool reverse = cBOOL(IoLINES(filter));
11502 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11504 /* As we're automatically added, at the lowest level, and hence only called
11505 from this file, we can be sure that we're not called in block mode. Hence
11506 don't bother writing code to deal with block mode. */
11508 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11511 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11513 DEBUG_P(PerlIO_printf(Perl_debug_log,
11514 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11515 FPTR2DPTR(void *, S_utf16_textfilter),
11516 reverse ? 'l' : 'b', idx, maxlen, status,
11517 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11524 /* First, look in our buffer of existing UTF-8 data: */
11525 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11529 } else if (status == 0) {
11531 IoPAGE(filter) = 0;
11532 nl = SvEND(utf8_buffer);
11535 STRLEN got = nl - SvPVX(utf8_buffer);
11536 /* Did we have anything to append? */
11538 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11539 /* Everything else in this code works just fine if SVp_POK isn't
11540 set. This, however, needs it, and we need it to work, else
11541 we loop infinitely because the buffer is never consumed. */
11542 sv_chop(utf8_buffer, nl);
11546 /* OK, not a complete line there, so need to read some more UTF-16.
11547 Read an extra octect if the buffer currently has an odd number. */
11551 if (SvCUR(utf16_buffer) >= 2) {
11552 /* Location of the high octet of the last complete code point.
11553 Gosh, UTF-16 is a pain. All the benefits of variable length,
11554 *coupled* with all the benefits of partial reads and
11556 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11557 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11559 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11563 /* We have the first half of a surrogate. Read more. */
11564 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11567 status = FILTER_READ(idx + 1, utf16_buffer,
11568 160 + (SvCUR(utf16_buffer) & 1));
11569 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11570 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11573 IoPAGE(filter) = status;
11578 chars = SvCUR(utf16_buffer) >> 1;
11579 have = SvCUR(utf8_buffer);
11580 SvGROW(utf8_buffer, have + chars * 3 + 1);
11583 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11584 (U8*)SvPVX_const(utf8_buffer) + have,
11585 chars * 2, &newlen);
11587 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11588 (U8*)SvPVX_const(utf8_buffer) + have,
11589 chars * 2, &newlen);
11591 SvCUR_set(utf8_buffer, have + newlen);
11594 /* No need to keep this SV "well-formed" with a '\0' after the end, as
11595 it's private to us, and utf16_to_utf8{,reversed} take a
11596 (pointer,length) pair, rather than a NUL-terminated string. */
11597 if(SvCUR(utf16_buffer) & 1) {
11598 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11599 SvCUR_set(utf16_buffer, 1);
11601 SvCUR_set(utf16_buffer, 0);
11604 DEBUG_P(PerlIO_printf(Perl_debug_log,
11605 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11607 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11608 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11613 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11615 SV *filter = filter_add(S_utf16_textfilter, NULL);
11617 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11619 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11620 sv_setpvs(filter, "");
11621 IoLINES(filter) = reversed;
11622 IoPAGE(filter) = 1; /* Not EOF */
11624 /* Sadly, we have to return a valid pointer, come what may, so we have to
11625 ignore any error return from this. */
11626 SvCUR_set(PL_linestr, 0);
11627 if (FILTER_READ(0, PL_linestr, 0)) {
11628 SvUTF8_on(PL_linestr);
11630 SvUTF8_on(PL_linestr);
11632 PL_bufend = SvEND(PL_linestr);
11633 return (U8*)SvPVX(PL_linestr);
11638 Returns a pointer to the next character after the parsed
11639 vstring, as well as updating the passed in sv.
11641 Function must be called like
11643 sv = sv_2mortal(newSV(5));
11644 s = scan_vstring(s,e,sv);
11646 where s and e are the start and end of the string.
11647 The sv should already be large enough to store the vstring
11648 passed in, for performance reasons.
11650 This function may croak if fatal warnings are enabled in the
11651 calling scope, hence the sv_2mortal in the example (to prevent
11652 a leak). Make sure to do SvREFCNT_inc afterwards if you use
11658 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11661 const char *pos = s;
11662 const char *start = s;
11664 PERL_ARGS_ASSERT_SCAN_VSTRING;
11666 if (*pos == 'v') pos++; /* get past 'v' */
11667 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11669 if ( *pos != '.') {
11670 /* this may not be a v-string if followed by => */
11671 const char *next = pos;
11672 while (next < e && isSPACE(*next))
11674 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11675 /* return string not v-string */
11676 sv_setpvn(sv,(char *)s,pos-s);
11677 return (char *)pos;
11681 if (!isALPHA(*pos)) {
11682 U8 tmpbuf[UTF8_MAXBYTES+1];
11685 s++; /* get past 'v' */
11690 /* this is atoi() that tolerates underscores */
11693 const char *end = pos;
11695 while (--end >= s) {
11697 const UV orev = rev;
11698 rev += (*end - '0') * mult;
11701 /* diag_listed_as: Integer overflow in %s number */
11702 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11703 "Integer overflow in decimal number");
11707 if (rev > 0x7FFFFFFF)
11708 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11710 /* Append native character for the rev point */
11711 tmpend = uvchr_to_utf8(tmpbuf, rev);
11712 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11713 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11715 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11721 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11725 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11732 Perl_keyword_plugin_standard(pTHX_
11733 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11735 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11736 PERL_UNUSED_CONTEXT;
11737 PERL_UNUSED_ARG(keyword_ptr);
11738 PERL_UNUSED_ARG(keyword_len);
11739 PERL_UNUSED_ARG(op_ptr);
11740 return KEYWORD_PLUGIN_DECLINE;
11743 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11745 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11747 SAVEI32(PL_lex_brackets);
11748 if (PL_lex_brackets > 100)
11749 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11750 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11751 SAVEI32(PL_lex_allbrackets);
11752 PL_lex_allbrackets = 0;
11753 SAVEI8(PL_lex_fakeeof);
11754 PL_lex_fakeeof = (U8)fakeeof;
11755 if(yyparse(gramtype) && !PL_parser->error_count)
11756 qerror(Perl_mess(aTHX_ "Parse error"));
11759 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11761 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11765 SAVEVPTR(PL_eval_root);
11766 PL_eval_root = NULL;
11767 parse_recdescent(gramtype, fakeeof);
11773 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11775 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11778 if (flags & ~PARSE_OPTIONAL)
11779 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11780 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11781 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11782 if (!PL_parser->error_count)
11783 qerror(Perl_mess(aTHX_ "Parse error"));
11784 exprop = newOP(OP_NULL, 0);
11790 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11792 Parse a Perl arithmetic expression. This may contain operators of precedence
11793 down to the bit shift operators. The expression must be followed (and thus
11794 terminated) either by a comparison or lower-precedence operator or by
11795 something that would normally terminate an expression such as semicolon.
11796 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11797 otherwise it is mandatory. It is up to the caller to ensure that the
11798 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11799 the source of the code to be parsed and the lexical context for the
11802 The op tree representing the expression is returned. If an optional
11803 expression is absent, a null pointer is returned, otherwise the pointer
11806 If an error occurs in parsing or compilation, in most cases a valid op
11807 tree is returned anyway. The error is reflected in the parser state,
11808 normally resulting in a single exception at the top level of parsing
11809 which covers all the compilation errors that occurred. Some compilation
11810 errors, however, will throw an exception immediately.
11816 Perl_parse_arithexpr(pTHX_ U32 flags)
11818 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11822 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11824 Parse a Perl term expression. This may contain operators of precedence
11825 down to the assignment operators. The expression must be followed (and thus
11826 terminated) either by a comma or lower-precedence operator or by
11827 something that would normally terminate an expression such as semicolon.
11828 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11829 otherwise it is mandatory. It is up to the caller to ensure that the
11830 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11831 the source of the code to be parsed and the lexical context for the
11834 The op tree representing the expression is returned. If an optional
11835 expression is absent, a null pointer is returned, otherwise the pointer
11838 If an error occurs in parsing or compilation, in most cases a valid op
11839 tree is returned anyway. The error is reflected in the parser state,
11840 normally resulting in a single exception at the top level of parsing
11841 which covers all the compilation errors that occurred. Some compilation
11842 errors, however, will throw an exception immediately.
11848 Perl_parse_termexpr(pTHX_ U32 flags)
11850 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11854 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11856 Parse a Perl list expression. This may contain operators of precedence
11857 down to the comma operator. The expression must be followed (and thus
11858 terminated) either by a low-precedence logic operator such as C<or> or by
11859 something that would normally terminate an expression such as semicolon.
11860 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11861 otherwise it is mandatory. It is up to the caller to ensure that the
11862 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11863 the source of the code to be parsed and the lexical context for the
11866 The op tree representing the expression is returned. If an optional
11867 expression is absent, a null pointer is returned, otherwise the pointer
11870 If an error occurs in parsing or compilation, in most cases a valid op
11871 tree is returned anyway. The error is reflected in the parser state,
11872 normally resulting in a single exception at the top level of parsing
11873 which covers all the compilation errors that occurred. Some compilation
11874 errors, however, will throw an exception immediately.
11880 Perl_parse_listexpr(pTHX_ U32 flags)
11882 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11886 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11888 Parse a single complete Perl expression. This allows the full
11889 expression grammar, including the lowest-precedence operators such
11890 as C<or>. The expression must be followed (and thus terminated) by a
11891 token that an expression would normally be terminated by: end-of-file,
11892 closing bracketing punctuation, semicolon, or one of the keywords that
11893 signals a postfix expression-statement modifier. If I<flags> includes
11894 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11895 mandatory. It is up to the caller to ensure that the dynamic parser
11896 state (L</PL_parser> et al) is correctly set to reflect the source of
11897 the code to be parsed and the lexical context for the expression.
11899 The op tree representing the expression is returned. If an optional
11900 expression is absent, a null pointer is returned, otherwise the pointer
11903 If an error occurs in parsing or compilation, in most cases a valid op
11904 tree is returned anyway. The error is reflected in the parser state,
11905 normally resulting in a single exception at the top level of parsing
11906 which covers all the compilation errors that occurred. Some compilation
11907 errors, however, will throw an exception immediately.
11913 Perl_parse_fullexpr(pTHX_ U32 flags)
11915 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11919 =for apidoc Amx|OP *|parse_block|U32 flags
11921 Parse a single complete Perl code block. This consists of an opening
11922 brace, a sequence of statements, and a closing brace. The block
11923 constitutes a lexical scope, so C<my> variables and various compile-time
11924 effects can be contained within it. It is up to the caller to ensure
11925 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11926 reflect the source of the code to be parsed and the lexical context for
11929 The op tree representing the code block is returned. This is always a
11930 real op, never a null pointer. It will normally be a C<lineseq> list,
11931 including C<nextstate> or equivalent ops. No ops to construct any kind
11932 of runtime scope are included by virtue of it being a block.
11934 If an error occurs in parsing or compilation, in most cases a valid op
11935 tree (most likely null) is returned anyway. The error is reflected in
11936 the parser state, normally resulting in a single exception at the top
11937 level of parsing which covers all the compilation errors that occurred.
11938 Some compilation errors, however, will throw an exception immediately.
11940 The I<flags> parameter is reserved for future use, and must always
11947 Perl_parse_block(pTHX_ U32 flags)
11950 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11951 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11955 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11957 Parse a single unadorned Perl statement. This may be a normal imperative
11958 statement or a declaration that has compile-time effect. It does not
11959 include any label or other affixture. It is up to the caller to ensure
11960 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11961 reflect the source of the code to be parsed and the lexical context for
11964 The op tree representing the statement is returned. This may be a
11965 null pointer if the statement is null, for example if it was actually
11966 a subroutine definition (which has compile-time side effects). If not
11967 null, it will be ops directly implementing the statement, suitable to
11968 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11969 equivalent op (except for those embedded in a scope contained entirely
11970 within the statement).
11972 If an error occurs in parsing or compilation, in most cases a valid op
11973 tree (most likely null) is returned anyway. The error is reflected in
11974 the parser state, normally resulting in a single exception at the top
11975 level of parsing which covers all the compilation errors that occurred.
11976 Some compilation errors, however, will throw an exception immediately.
11978 The I<flags> parameter is reserved for future use, and must always
11985 Perl_parse_barestmt(pTHX_ U32 flags)
11988 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11989 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11993 =for apidoc Amx|SV *|parse_label|U32 flags
11995 Parse a single label, possibly optional, of the type that may prefix a
11996 Perl statement. It is up to the caller to ensure that the dynamic parser
11997 state (L</PL_parser> et al) is correctly set to reflect the source of
11998 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11999 label is optional, otherwise it is mandatory.
12001 The name of the label is returned in the form of a fresh scalar. If an
12002 optional label is absent, a null pointer is returned.
12004 If an error occurs in parsing, which can only occur if the label is
12005 mandatory, a valid label is returned anyway. The error is reflected in
12006 the parser state, normally resulting in a single exception at the top
12007 level of parsing which covers all the compilation errors that occurred.
12013 Perl_parse_label(pTHX_ U32 flags)
12015 if (flags & ~PARSE_OPTIONAL)
12016 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12017 if (PL_lex_state == LEX_KNOWNEXT) {
12018 PL_parser->yychar = yylex();
12019 if (PL_parser->yychar == LABEL) {
12020 char * const lpv = pl_yylval.pval;
12021 STRLEN llen = strlen(lpv);
12022 PL_parser->yychar = YYEMPTY;
12023 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12030 STRLEN wlen, bufptr_pos;
12033 if (!isIDFIRST_lazy_if(s, UTF))
12035 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12036 if (word_takes_any_delimeter(s, wlen))
12038 bufptr_pos = s - SvPVX(PL_linestr);
12040 lex_read_space(LEX_KEEP_PREVIOUS);
12042 s = SvPVX(PL_linestr) + bufptr_pos;
12043 if (t[0] == ':' && t[1] != ':') {
12044 PL_oldoldbufptr = PL_oldbufptr;
12047 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12051 if (flags & PARSE_OPTIONAL) {
12054 qerror(Perl_mess(aTHX_ "Parse error"));
12055 return newSVpvs("x");
12062 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12064 Parse a single complete Perl statement. This may be a normal imperative
12065 statement or a declaration that has compile-time effect, and may include
12066 optional labels. It is up to the caller to ensure that the dynamic
12067 parser state (L</PL_parser> et al) is correctly set to reflect the source
12068 of the code to be parsed and the lexical context for the statement.
12070 The op tree representing the statement is returned. This may be a
12071 null pointer if the statement is null, for example if it was actually
12072 a subroutine definition (which has compile-time side effects). If not
12073 null, it will be the result of a L</newSTATEOP> call, normally including
12074 a C<nextstate> or equivalent op.
12076 If an error occurs in parsing or compilation, in most cases a valid op
12077 tree (most likely null) is returned anyway. The error is reflected in
12078 the parser state, normally resulting in a single exception at the top
12079 level of parsing which covers all the compilation errors that occurred.
12080 Some compilation errors, however, will throw an exception immediately.
12082 The I<flags> parameter is reserved for future use, and must always
12089 Perl_parse_fullstmt(pTHX_ U32 flags)
12092 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12093 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12097 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12099 Parse a sequence of zero or more Perl statements. These may be normal
12100 imperative statements, including optional labels, or declarations
12101 that have compile-time effect, or any mixture thereof. The statement
12102 sequence ends when a closing brace or end-of-file is encountered in a
12103 place where a new statement could have validly started. It is up to
12104 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12105 is correctly set to reflect the source of the code to be parsed and the
12106 lexical context for the statements.
12108 The op tree representing the statement sequence is returned. This may
12109 be a null pointer if the statements were all null, for example if there
12110 were no statements or if there were only subroutine definitions (which
12111 have compile-time side effects). If not null, it will be a C<lineseq>
12112 list, normally including C<nextstate> or equivalent ops.
12114 If an error occurs in parsing or compilation, in most cases a valid op
12115 tree is returned anyway. The error is reflected in the parser state,
12116 normally resulting in a single exception at the top level of parsing
12117 which covers all the compilation errors that occurred. Some compilation
12118 errors, however, will throw an exception immediately.
12120 The I<flags> parameter is reserved for future use, and must always
12127 Perl_parse_stmtseq(pTHX_ U32 flags)
12132 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12133 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12134 c = lex_peek_unichar(0);
12135 if (c != -1 && c != /*{*/'}')
12136 qerror(Perl_mess(aTHX_ "Parse error"));
12142 * c-indentation-style: bsd
12143 * c-basic-offset: 4
12144 * indent-tabs-mode: nil
12147 * ex: set ts=8 sts=4 sw=4 et: