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_pending_ident (PL_parser->pending_ident)
70 #define PL_preambled (PL_parser->preambled)
71 #define PL_sublex_info (PL_parser->sublex_info)
72 #define PL_linestr (PL_parser->linestr)
73 #define PL_expect (PL_parser->expect)
74 #define PL_copline (PL_parser->copline)
75 #define PL_bufptr (PL_parser->bufptr)
76 #define PL_oldbufptr (PL_parser->oldbufptr)
77 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
78 #define PL_linestart (PL_parser->linestart)
79 #define PL_bufend (PL_parser->bufend)
80 #define PL_last_uni (PL_parser->last_uni)
81 #define PL_last_lop (PL_parser->last_lop)
82 #define PL_last_lop_op (PL_parser->last_lop_op)
83 #define PL_lex_state (PL_parser->lex_state)
84 #define PL_rsfp (PL_parser->rsfp)
85 #define PL_rsfp_filters (PL_parser->rsfp_filters)
86 #define PL_in_my (PL_parser->in_my)
87 #define PL_in_my_stash (PL_parser->in_my_stash)
88 #define PL_tokenbuf (PL_parser->tokenbuf)
89 #define PL_multi_end (PL_parser->multi_end)
90 #define PL_error_count (PL_parser->error_count)
93 # define PL_endwhite (PL_parser->endwhite)
94 # define PL_faketokens (PL_parser->faketokens)
95 # define PL_lasttoke (PL_parser->lasttoke)
96 # define PL_nextwhite (PL_parser->nextwhite)
97 # define PL_realtokenstart (PL_parser->realtokenstart)
98 # define PL_skipwhite (PL_parser->skipwhite)
99 # define PL_thisclose (PL_parser->thisclose)
100 # define PL_thismad (PL_parser->thismad)
101 # define PL_thisopen (PL_parser->thisopen)
102 # define PL_thisstuff (PL_parser->thisstuff)
103 # define PL_thistoken (PL_parser->thistoken)
104 # define PL_thiswhite (PL_parser->thiswhite)
105 # define PL_thiswhite (PL_parser->thiswhite)
106 # define PL_nexttoke (PL_parser->nexttoke)
107 # define PL_curforce (PL_parser->curforce)
109 # define PL_nexttoke (PL_parser->nexttoke)
110 # define PL_nexttype (PL_parser->nexttype)
111 # define PL_nextval (PL_parser->nextval)
114 /* This can't be done with embed.fnc, because struct yy_parser contains a
115 member named pending_ident, which clashes with the generated #define */
117 S_pending_ident(pTHX);
119 static const char ident_too_long[] = "Identifier too long";
122 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
123 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
125 # define CURMAD(slot,sv)
126 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
129 #define XENUMMASK 0x3f
130 #define XFAKEEOF 0x40
131 #define XFAKEBRACK 0x80
133 #ifdef USE_UTF8_SCRIPTS
134 # define UTF (!IN_BYTES)
136 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
139 /* The maximum number of characters preceding the unrecognized one to display */
140 #define UNRECOGNIZED_PRECEDE_COUNT 10
142 /* In variables named $^X, these are the legal values for X.
143 * 1999-02-27 mjd-perl-patch@plover.com */
144 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
146 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
148 /* LEX_* are values for PL_lex_state, the state of the lexer.
149 * They are arranged oddly so that the guard on the switch statement
150 * can get by with a single comparison (if the compiler is smart enough).
153 /* #define LEX_NOTPARSING 11 is done in perl.h. */
155 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
156 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
157 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
158 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
159 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
161 /* at end of code, eg "$x" followed by: */
162 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
163 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
165 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
166 string or after \E, $foo, etc */
167 #define LEX_INTERPCONST 2 /* NOT USED */
168 #define LEX_FORMLINE 1 /* expecting a format line */
169 #define LEX_KNOWNEXT 0 /* next token known; just return it */
173 static const char* const lex_state_names[] = {
192 #include "keywords.h"
194 /* CLINE is a macro that ensures PL_copline has a sane value */
199 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
202 # define SKIPSPACE0(s) skipspace0(s)
203 # define SKIPSPACE1(s) skipspace1(s)
204 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
205 # define PEEKSPACE(s) skipspace2(s,0)
207 # define SKIPSPACE0(s) skipspace(s)
208 # define SKIPSPACE1(s) skipspace(s)
209 # define SKIPSPACE2(s,tsv) skipspace(s)
210 # define PEEKSPACE(s) skipspace(s)
214 * Convenience functions to return different tokens and prime the
215 * lexer for the next token. They all take an argument.
217 * TOKEN : generic token (used for '(', DOLSHARP, etc)
218 * OPERATOR : generic operator
219 * AOPERATOR : assignment operator
220 * PREBLOCK : beginning the block after an if, while, foreach, ...
221 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
222 * PREREF : *EXPR where EXPR is not a simple identifier
223 * TERM : expression term
224 * LOOPX : loop exiting command (goto, last, dump, etc)
225 * FTST : file test operator
226 * FUN0 : zero-argument function
227 * FUN0OP : zero-argument function, with its op created in this file
228 * FUN1 : not used, except for not, which isn't a UNIOP
229 * BOop : bitwise or or xor
231 * SHop : shift operator
232 * PWop : power operator
233 * PMop : pattern-matching operator
234 * Aop : addition-level operator
235 * Mop : multiplication-level operator
236 * Eop : equality-testing operator
237 * Rop : relational operator <= != gt
239 * Also see LOP and lop() below.
242 #ifdef DEBUGGING /* Serve -DT. */
243 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
245 # define REPORT(retval) (retval)
248 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
249 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
250 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
251 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
252 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
253 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
254 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
255 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
256 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
257 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
258 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
259 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
260 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
261 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
262 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
263 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
264 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
265 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
266 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
267 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
268 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
270 /* This bit of chicanery makes a unary function followed by
271 * a parenthesis into a function with one argument, highest precedence.
272 * The UNIDOR macro is for unary functions that can be followed by the //
273 * operator (such as C<shift // 0>).
275 #define UNI2(f,x) { \
276 pl_yylval.ival = f; \
279 PL_last_uni = PL_oldbufptr; \
280 PL_last_lop_op = f; \
282 return REPORT( (int)FUNC1 ); \
284 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
286 #define UNI(f) UNI2(f,XTERM)
287 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
289 #define UNIBRACK(f) { \
290 pl_yylval.ival = f; \
292 PL_last_uni = PL_oldbufptr; \
294 return REPORT( (int)FUNC1 ); \
296 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
299 /* grandfather return to old style */
302 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
303 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
304 pl_yylval.ival = (f); \
312 /* how to interpret the pl_yylval associated with the token */
316 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
322 static struct debug_tokens {
324 enum token_type type;
326 } const debug_tokens[] =
328 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
329 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
330 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
331 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
332 { ARROW, TOKENTYPE_NONE, "ARROW" },
333 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
334 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
335 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
336 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
337 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
338 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
339 { DO, TOKENTYPE_NONE, "DO" },
340 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
341 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
342 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
343 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
344 { ELSE, TOKENTYPE_NONE, "ELSE" },
345 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
346 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
347 { FOR, TOKENTYPE_IVAL, "FOR" },
348 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
349 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
350 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
351 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
352 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
353 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
354 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
355 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
356 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
357 { IF, TOKENTYPE_IVAL, "IF" },
358 { LABEL, TOKENTYPE_PVAL, "LABEL" },
359 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
360 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
361 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
362 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
363 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
364 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
365 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
366 { MY, TOKENTYPE_IVAL, "MY" },
367 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
368 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
369 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
370 { OROP, TOKENTYPE_IVAL, "OROP" },
371 { OROR, TOKENTYPE_NONE, "OROR" },
372 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
373 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
374 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
375 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
376 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
377 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
378 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
379 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
380 { PREINC, TOKENTYPE_NONE, "PREINC" },
381 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
382 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
383 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
384 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
385 { SUB, TOKENTYPE_NONE, "SUB" },
386 { THING, TOKENTYPE_OPVAL, "THING" },
387 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
388 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
389 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
390 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
391 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
392 { USE, TOKENTYPE_IVAL, "USE" },
393 { WHEN, TOKENTYPE_IVAL, "WHEN" },
394 { WHILE, TOKENTYPE_IVAL, "WHILE" },
395 { WORD, TOKENTYPE_OPVAL, "WORD" },
396 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
397 { 0, TOKENTYPE_NONE, NULL }
400 /* dump the returned token in rv, plus any optional arg in pl_yylval */
403 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
407 PERL_ARGS_ASSERT_TOKEREPORT;
410 const char *name = NULL;
411 enum token_type type = TOKENTYPE_NONE;
412 const struct debug_tokens *p;
413 SV* const report = newSVpvs("<== ");
415 for (p = debug_tokens; p->token; p++) {
416 if (p->token == (int)rv) {
423 Perl_sv_catpv(aTHX_ report, name);
424 else if ((char)rv > ' ' && (char)rv < '~')
425 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
427 sv_catpvs(report, "EOF");
429 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
432 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
435 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
437 case TOKENTYPE_OPNUM:
438 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
439 PL_op_name[lvalp->ival]);
442 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
444 case TOKENTYPE_OPVAL:
446 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
447 PL_op_name[lvalp->opval->op_type]);
448 if (lvalp->opval->op_type == OP_CONST) {
449 Perl_sv_catpvf(aTHX_ report, " %s",
450 SvPEEK(cSVOPx_sv(lvalp->opval)));
455 sv_catpvs(report, "(opval=null)");
458 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
464 /* print the buffer with suitable escapes */
467 S_printbuf(pTHX_ const char *const fmt, const char *const s)
469 SV* const tmp = newSVpvs("");
471 PERL_ARGS_ASSERT_PRINTBUF;
473 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
480 S_deprecate_commaless_var_list(pTHX) {
482 deprecate("comma-less variable list");
483 return REPORT(','); /* grandfather non-comma-format format */
489 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
490 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
494 S_ao(pTHX_ int toketype)
497 if (*PL_bufptr == '=') {
499 if (toketype == ANDAND)
500 pl_yylval.ival = OP_ANDASSIGN;
501 else if (toketype == OROR)
502 pl_yylval.ival = OP_ORASSIGN;
503 else if (toketype == DORDOR)
504 pl_yylval.ival = OP_DORASSIGN;
512 * When Perl expects an operator and finds something else, no_op
513 * prints the warning. It always prints "<something> found where
514 * operator expected. It prints "Missing semicolon on previous line?"
515 * if the surprise occurs at the start of the line. "do you need to
516 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
517 * where the compiler doesn't know if foo is a method call or a function.
518 * It prints "Missing operator before end of line" if there's nothing
519 * after the missing operator, or "... before <...>" if there is something
520 * after the missing operator.
524 S_no_op(pTHX_ const char *const what, char *s)
527 char * const oldbp = PL_bufptr;
528 const bool is_first = (PL_oldbufptr == PL_linestart);
530 PERL_ARGS_ASSERT_NO_OP;
536 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
537 if (ckWARN_d(WARN_SYNTAX)) {
539 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
540 "\t(Missing semicolon on previous line?)\n");
541 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
543 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
545 if (t < PL_bufptr && isSPACE(*t))
546 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
547 "\t(Do you need to predeclare %.*s?)\n",
548 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
552 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
553 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
561 * Complain about missing quote/regexp/heredoc terminator.
562 * If it's called with NULL then it cauterizes the line buffer.
563 * If we're in a delimited string and the delimiter is a control
564 * character, it's reformatted into a two-char sequence like ^C.
569 S_missingterm(pTHX_ char *s)
575 char * const nl = strrchr(s,'\n');
579 else if (isCNTRL(PL_multi_close)) {
581 tmpbuf[1] = (char)toCTRL(PL_multi_close);
586 *tmpbuf = (char)PL_multi_close;
590 q = strchr(s,'"') ? '\'' : '"';
591 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
595 * Check whether the named feature is enabled.
598 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
601 HV * const hinthv = GvHV(PL_hintgv);
602 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
604 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
606 if (namelen > MAX_FEATURE_LEN)
608 memcpy(&he_name[8], name, namelen);
610 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
614 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
615 * utf16-to-utf8-reversed.
618 #ifdef PERL_CR_FILTER
622 register const char *s = SvPVX_const(sv);
623 register const char * const e = s + SvCUR(sv);
625 PERL_ARGS_ASSERT_STRIP_RETURN;
627 /* outer loop optimized to do nothing if there are no CR-LFs */
629 if (*s++ == '\r' && *s == '\n') {
630 /* hit a CR-LF, need to copy the rest */
631 register char *d = s - 1;
634 if (*s == '\r' && s[1] == '\n')
645 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
647 const I32 count = FILTER_READ(idx+1, sv, maxlen);
648 if (count > 0 && !maxlen)
655 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
657 Creates and initialises a new lexer/parser state object, supplying
658 a context in which to lex and parse from a new source of Perl code.
659 A pointer to the new state object is placed in L</PL_parser>. An entry
660 is made on the save stack so that upon unwinding the new state object
661 will be destroyed and the former value of L</PL_parser> will be restored.
662 Nothing else need be done to clean up the parsing context.
664 The code to be parsed comes from I<line> and I<rsfp>. I<line>, if
665 non-null, provides a string (in SV form) containing code to be parsed.
666 A copy of the string is made, so subsequent modification of I<line>
667 does not affect parsing. I<rsfp>, if non-null, provides an input stream
668 from which code will be read to be parsed. If both are non-null, the
669 code in I<line> comes first and must consist of complete lines of input,
670 and I<rsfp> supplies the remainder of the source.
672 The I<flags> parameter is reserved for future use, and must always
673 be zero, except for one flag that is currently reserved for perl's internal
679 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
680 can share filters with the current parser. */
683 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
686 const char *s = NULL;
688 yy_parser *parser, *oparser;
689 if (flags && flags != LEX_START_SAME_FILTER)
690 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
692 /* create and initialise a parser */
694 Newxz(parser, 1, yy_parser);
695 parser->old_parser = oparser = PL_parser;
698 parser->stack = NULL;
700 parser->stack_size = 0;
702 /* on scope exit, free this parser and restore any outer one */
704 parser->saved_curcop = PL_curcop;
706 /* initialise lexer state */
709 parser->curforce = -1;
711 parser->nexttoke = 0;
713 parser->error_count = oparser ? oparser->error_count : 0;
714 parser->copline = NOLINE;
715 parser->lex_state = LEX_NORMAL;
716 parser->expect = XSTATE;
718 parser->rsfp_filters =
719 !(flags & LEX_START_SAME_FILTER) || !oparser
721 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
723 Newx(parser->lex_brackstack, 120, char);
724 Newx(parser->lex_casestack, 12, char);
725 *parser->lex_casestack = '\0';
728 s = SvPV_const(line, len);
734 parser->linestr = newSVpvs("\n;");
736 parser->linestr = newSVpvn_flags(s, len, SvUTF8(line));
738 sv_catpvs(parser->linestr, "\n;");
740 parser->oldoldbufptr =
743 parser->linestart = SvPVX(parser->linestr);
744 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
745 parser->last_lop = parser->last_uni = NULL;
751 /* delete a parser object */
754 Perl_parser_free(pTHX_ const yy_parser *parser)
756 PERL_ARGS_ASSERT_PARSER_FREE;
758 PL_curcop = parser->saved_curcop;
759 SvREFCNT_dec(parser->linestr);
761 if (parser->rsfp == PerlIO_stdin())
762 PerlIO_clearerr(parser->rsfp);
763 else if (parser->rsfp && (!parser->old_parser ||
764 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
765 PerlIO_close(parser->rsfp);
766 SvREFCNT_dec(parser->rsfp_filters);
768 Safefree(parser->lex_brackstack);
769 Safefree(parser->lex_casestack);
770 PL_parser = parser->old_parser;
776 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
778 Buffer scalar containing the chunk currently under consideration of the
779 text currently being lexed. This is always a plain string scalar (for
780 which C<SvPOK> is true). It is not intended to be used as a scalar by
781 normal scalar means; instead refer to the buffer directly by the pointer
782 variables described below.
784 The lexer maintains various C<char*> pointers to things in the
785 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
786 reallocated, all of these pointers must be updated. Don't attempt to
787 do this manually, but rather use L</lex_grow_linestr> if you need to
788 reallocate the buffer.
790 The content of the text chunk in the buffer is commonly exactly one
791 complete line of input, up to and including a newline terminator,
792 but there are situations where it is otherwise. The octets of the
793 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
794 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
795 flag on this scalar, which may disagree with it.
797 For direct examination of the buffer, the variable
798 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
799 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
800 of these pointers is usually preferable to examination of the scalar
801 through normal scalar means.
803 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
805 Direct pointer to the end of the chunk of text currently being lexed, the
806 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
807 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
808 always located at the end of the buffer, and does not count as part of
809 the buffer's contents.
811 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
813 Points to the current position of lexing inside the lexer buffer.
814 Characters around this point may be freely examined, within
815 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
816 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
817 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
819 Lexing code (whether in the Perl core or not) moves this pointer past
820 the characters that it consumes. It is also expected to perform some
821 bookkeeping whenever a newline character is consumed. This movement
822 can be more conveniently performed by the function L</lex_read_to>,
823 which handles newlines appropriately.
825 Interpretation of the buffer's octets can be abstracted out by
826 using the slightly higher-level functions L</lex_peek_unichar> and
827 L</lex_read_unichar>.
829 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
831 Points to the start of the current line inside the lexer buffer.
832 This is useful for indicating at which column an error occurred, and
833 not much else. This must be updated by any lexing code that consumes
834 a newline; the function L</lex_read_to> handles this detail.
840 =for apidoc Amx|bool|lex_bufutf8
842 Indicates whether the octets in the lexer buffer
843 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
844 of Unicode characters. If not, they should be interpreted as Latin-1
845 characters. This is analogous to the C<SvUTF8> flag for scalars.
847 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
848 contains valid UTF-8. Lexing code must be robust in the face of invalid
851 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
852 is significant, but not the whole story regarding the input character
853 encoding. Normally, when a file is being read, the scalar contains octets
854 and its C<SvUTF8> flag is off, but the octets should be interpreted as
855 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
856 however, the scalar may have the C<SvUTF8> flag on, and in this case its
857 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
858 is in effect. This logic may change in the future; use this function
859 instead of implementing the logic yourself.
865 Perl_lex_bufutf8(pTHX)
871 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
873 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
874 at least I<len> octets (including terminating NUL). Returns a
875 pointer to the reallocated buffer. This is necessary before making
876 any direct modification of the buffer that would increase its length.
877 L</lex_stuff_pvn> provides a more convenient way to insert text into
880 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
881 this function updates all of the lexer's variables that point directly
888 Perl_lex_grow_linestr(pTHX_ STRLEN len)
892 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
893 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
894 linestr = PL_parser->linestr;
895 buf = SvPVX(linestr);
896 if (len <= SvLEN(linestr))
898 bufend_pos = PL_parser->bufend - buf;
899 bufptr_pos = PL_parser->bufptr - buf;
900 oldbufptr_pos = PL_parser->oldbufptr - buf;
901 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
902 linestart_pos = PL_parser->linestart - buf;
903 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
904 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
905 buf = sv_grow(linestr, len);
906 PL_parser->bufend = buf + bufend_pos;
907 PL_parser->bufptr = buf + bufptr_pos;
908 PL_parser->oldbufptr = buf + oldbufptr_pos;
909 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
910 PL_parser->linestart = buf + linestart_pos;
911 if (PL_parser->last_uni)
912 PL_parser->last_uni = buf + last_uni_pos;
913 if (PL_parser->last_lop)
914 PL_parser->last_lop = buf + last_lop_pos;
919 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
921 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
922 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
923 reallocating the buffer if necessary. This means that lexing code that
924 runs later will see the characters as if they had appeared in the input.
925 It is not recommended to do this as part of normal parsing, and most
926 uses of this facility run the risk of the inserted characters being
927 interpreted in an unintended manner.
929 The string to be inserted is represented by I<len> octets starting
930 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
931 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
932 The characters are recoded for the lexer buffer, according to how the
933 buffer is currently being interpreted (L</lex_bufutf8>). If a string
934 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
935 function is more convenient.
941 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
945 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
946 if (flags & ~(LEX_STUFF_UTF8))
947 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
949 if (flags & LEX_STUFF_UTF8) {
953 const char *p, *e = pv+len;
954 for (p = pv; p != e; p++)
955 highhalf += !!(((U8)*p) & 0x80);
958 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
959 bufptr = PL_parser->bufptr;
960 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
961 SvCUR_set(PL_parser->linestr,
962 SvCUR(PL_parser->linestr) + len+highhalf);
963 PL_parser->bufend += len+highhalf;
964 for (p = pv; p != e; p++) {
967 *bufptr++ = (char)(0xc0 | (c >> 6));
968 *bufptr++ = (char)(0x80 | (c & 0x3f));
975 if (flags & LEX_STUFF_UTF8) {
977 const char *p, *e = pv+len;
978 for (p = pv; p != e; p++) {
981 Perl_croak(aTHX_ "Lexing code attempted to stuff "
982 "non-Latin-1 character into Latin-1 input");
983 } else if (c >= 0xc2 && p+1 != e &&
984 (((U8)p[1]) & 0xc0) == 0x80) {
987 } else if (c >= 0x80) {
988 /* malformed UTF-8 */
990 SAVESPTR(PL_warnhook);
991 PL_warnhook = PERL_WARNHOOK_FATAL;
992 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
998 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
999 bufptr = PL_parser->bufptr;
1000 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1001 SvCUR_set(PL_parser->linestr,
1002 SvCUR(PL_parser->linestr) + len-highhalf);
1003 PL_parser->bufend += len-highhalf;
1004 for (p = pv; p != e; p++) {
1007 *bufptr++ = (char)(((c & 0x3) << 6) | (p[1] & 0x3f));
1010 *bufptr++ = (char)c;
1015 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1016 bufptr = PL_parser->bufptr;
1017 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1018 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1019 PL_parser->bufend += len;
1020 Copy(pv, bufptr, len, char);
1026 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1028 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1029 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1030 reallocating the buffer if necessary. This means that lexing code that
1031 runs later will see the characters as if they had appeared in the input.
1032 It is not recommended to do this as part of normal parsing, and most
1033 uses of this facility run the risk of the inserted characters being
1034 interpreted in an unintended manner.
1036 The string to be inserted is represented by octets starting at I<pv>
1037 and continuing to the first nul. These octets are interpreted as either
1038 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1039 in I<flags>. The characters are recoded for the lexer buffer, according
1040 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1041 If it is not convenient to nul-terminate a string to be inserted, the
1042 L</lex_stuff_pvn> function is more appropriate.
1048 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1050 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1051 lex_stuff_pvn(pv, strlen(pv), flags);
1055 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1057 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1058 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1059 reallocating the buffer if necessary. This means that lexing code that
1060 runs later will see the characters as if they had appeared in the input.
1061 It is not recommended to do this as part of normal parsing, and most
1062 uses of this facility run the risk of the inserted characters being
1063 interpreted in an unintended manner.
1065 The string to be inserted is the string value of I<sv>. The characters
1066 are recoded for the lexer buffer, according to how the buffer is currently
1067 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1068 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1069 need to construct a scalar.
1075 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1079 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1081 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1083 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1087 =for apidoc Amx|void|lex_unstuff|char *ptr
1089 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1090 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1091 This hides the discarded text from any lexing code that runs later,
1092 as if the text had never appeared.
1094 This is not the normal way to consume lexed text. For that, use
1101 Perl_lex_unstuff(pTHX_ char *ptr)
1105 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1106 buf = PL_parser->bufptr;
1108 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1111 bufend = PL_parser->bufend;
1113 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1114 unstuff_len = ptr - buf;
1115 Move(ptr, buf, bufend+1-ptr, char);
1116 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1117 PL_parser->bufend = bufend - unstuff_len;
1121 =for apidoc Amx|void|lex_read_to|char *ptr
1123 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1124 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1125 performing the correct bookkeeping whenever a newline character is passed.
1126 This is the normal way to consume lexed text.
1128 Interpretation of the buffer's octets can be abstracted out by
1129 using the slightly higher-level functions L</lex_peek_unichar> and
1130 L</lex_read_unichar>.
1136 Perl_lex_read_to(pTHX_ char *ptr)
1139 PERL_ARGS_ASSERT_LEX_READ_TO;
1140 s = PL_parser->bufptr;
1141 if (ptr < s || ptr > PL_parser->bufend)
1142 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1143 for (; s != ptr; s++)
1145 CopLINE_inc(PL_curcop);
1146 PL_parser->linestart = s+1;
1148 PL_parser->bufptr = ptr;
1152 =for apidoc Amx|void|lex_discard_to|char *ptr
1154 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1155 up to I<ptr>. The remaining content of the buffer will be moved, and
1156 all pointers into the buffer updated appropriately. I<ptr> must not
1157 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1158 it is not permitted to discard text that has yet to be lexed.
1160 Normally it is not necessarily to do this directly, because it suffices to
1161 use the implicit discarding behaviour of L</lex_next_chunk> and things
1162 based on it. However, if a token stretches across multiple lines,
1163 and the lexing code has kept multiple lines of text in the buffer for
1164 that purpose, then after completion of the token it would be wise to
1165 explicitly discard the now-unneeded earlier lines, to avoid future
1166 multi-line tokens growing the buffer without bound.
1172 Perl_lex_discard_to(pTHX_ char *ptr)
1176 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1177 buf = SvPVX(PL_parser->linestr);
1179 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1182 if (ptr > PL_parser->bufptr)
1183 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1184 discard_len = ptr - buf;
1185 if (PL_parser->oldbufptr < ptr)
1186 PL_parser->oldbufptr = ptr;
1187 if (PL_parser->oldoldbufptr < ptr)
1188 PL_parser->oldoldbufptr = ptr;
1189 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1190 PL_parser->last_uni = NULL;
1191 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1192 PL_parser->last_lop = NULL;
1193 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1194 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1195 PL_parser->bufend -= discard_len;
1196 PL_parser->bufptr -= discard_len;
1197 PL_parser->oldbufptr -= discard_len;
1198 PL_parser->oldoldbufptr -= discard_len;
1199 if (PL_parser->last_uni)
1200 PL_parser->last_uni -= discard_len;
1201 if (PL_parser->last_lop)
1202 PL_parser->last_lop -= discard_len;
1206 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1208 Reads in the next chunk of text to be lexed, appending it to
1209 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1210 looked to the end of the current chunk and wants to know more. It is
1211 usual, but not necessary, for lexing to have consumed the entirety of
1212 the current chunk at this time.
1214 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1215 chunk (i.e., the current chunk has been entirely consumed), normally the
1216 current chunk will be discarded at the same time that the new chunk is
1217 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1218 will not be discarded. If the current chunk has not been entirely
1219 consumed, then it will not be discarded regardless of the flag.
1221 Returns true if some new text was added to the buffer, or false if the
1222 buffer has reached the end of the input text.
1227 #define LEX_FAKE_EOF 0x80000000
1230 Perl_lex_next_chunk(pTHX_ U32 flags)
1234 STRLEN old_bufend_pos, new_bufend_pos;
1235 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1236 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1237 bool got_some_for_debugger = 0;
1239 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF))
1240 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1241 linestr = PL_parser->linestr;
1242 buf = SvPVX(linestr);
1243 if (!(flags & LEX_KEEP_PREVIOUS) &&
1244 PL_parser->bufptr == PL_parser->bufend) {
1245 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1247 if (PL_parser->last_uni != PL_parser->bufend)
1248 PL_parser->last_uni = NULL;
1249 if (PL_parser->last_lop != PL_parser->bufend)
1250 PL_parser->last_lop = NULL;
1251 last_uni_pos = last_lop_pos = 0;
1255 old_bufend_pos = PL_parser->bufend - buf;
1256 bufptr_pos = PL_parser->bufptr - buf;
1257 oldbufptr_pos = PL_parser->oldbufptr - buf;
1258 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1259 linestart_pos = PL_parser->linestart - buf;
1260 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1261 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1263 if (flags & LEX_FAKE_EOF) {
1265 } else if (!PL_parser->rsfp) {
1267 } else if (filter_gets(linestr, old_bufend_pos)) {
1269 got_some_for_debugger = 1;
1271 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1272 sv_setpvs(linestr, "");
1274 /* End of real input. Close filehandle (unless it was STDIN),
1275 * then add implicit termination.
1277 if ((PerlIO*)PL_parser->rsfp == PerlIO_stdin())
1278 PerlIO_clearerr(PL_parser->rsfp);
1279 else if (PL_parser->rsfp)
1280 (void)PerlIO_close(PL_parser->rsfp);
1281 PL_parser->rsfp = NULL;
1282 PL_parser->in_pod = 0;
1284 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1287 if (!PL_in_eval && PL_minus_p) {
1289 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1290 PL_minus_n = PL_minus_p = 0;
1291 } else if (!PL_in_eval && PL_minus_n) {
1292 sv_catpvs(linestr, /*{*/";}");
1295 sv_catpvs(linestr, ";");
1298 buf = SvPVX(linestr);
1299 new_bufend_pos = SvCUR(linestr);
1300 PL_parser->bufend = buf + new_bufend_pos;
1301 PL_parser->bufptr = buf + bufptr_pos;
1302 PL_parser->oldbufptr = buf + oldbufptr_pos;
1303 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1304 PL_parser->linestart = buf + linestart_pos;
1305 if (PL_parser->last_uni)
1306 PL_parser->last_uni = buf + last_uni_pos;
1307 if (PL_parser->last_lop)
1308 PL_parser->last_lop = buf + last_lop_pos;
1309 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1310 PL_curstash != PL_debstash) {
1311 /* debugger active and we're not compiling the debugger code,
1312 * so store the line into the debugger's array of lines
1314 update_debugger_info(NULL, buf+old_bufend_pos,
1315 new_bufend_pos-old_bufend_pos);
1321 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1323 Looks ahead one (Unicode) character in the text currently being lexed.
1324 Returns the codepoint (unsigned integer value) of the next character,
1325 or -1 if lexing has reached the end of the input text. To consume the
1326 peeked character, use L</lex_read_unichar>.
1328 If the next character is in (or extends into) the next chunk of input
1329 text, the next chunk will be read in. Normally the current chunk will be
1330 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1331 then the current chunk will not be discarded.
1333 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1334 is encountered, an exception is generated.
1340 Perl_lex_peek_unichar(pTHX_ U32 flags)
1344 if (flags & ~(LEX_KEEP_PREVIOUS))
1345 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1346 s = PL_parser->bufptr;
1347 bufend = PL_parser->bufend;
1353 if (!lex_next_chunk(flags))
1355 s = PL_parser->bufptr;
1356 bufend = PL_parser->bufend;
1362 len = PL_utf8skip[head];
1363 while ((STRLEN)(bufend-s) < len) {
1364 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1366 s = PL_parser->bufptr;
1367 bufend = PL_parser->bufend;
1370 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1371 if (retlen == (STRLEN)-1) {
1372 /* malformed UTF-8 */
1374 SAVESPTR(PL_warnhook);
1375 PL_warnhook = PERL_WARNHOOK_FATAL;
1376 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1382 if (!lex_next_chunk(flags))
1384 s = PL_parser->bufptr;
1391 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1393 Reads the next (Unicode) character in the text currently being lexed.
1394 Returns the codepoint (unsigned integer value) of the character read,
1395 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1396 if lexing has reached the end of the input text. To non-destructively
1397 examine the next character, use L</lex_peek_unichar> instead.
1399 If the next character is in (or extends into) the next chunk of input
1400 text, the next chunk will be read in. Normally the current chunk will be
1401 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1402 then the current chunk will not be discarded.
1404 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1405 is encountered, an exception is generated.
1411 Perl_lex_read_unichar(pTHX_ U32 flags)
1414 if (flags & ~(LEX_KEEP_PREVIOUS))
1415 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1416 c = lex_peek_unichar(flags);
1419 CopLINE_inc(PL_curcop);
1421 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1423 ++(PL_parser->bufptr);
1429 =for apidoc Amx|void|lex_read_space|U32 flags
1431 Reads optional spaces, in Perl style, in the text currently being
1432 lexed. The spaces may include ordinary whitespace characters and
1433 Perl-style comments. C<#line> directives are processed if encountered.
1434 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1435 at a non-space character (or the end of the input text).
1437 If spaces extend into the next chunk of input text, the next chunk will
1438 be read in. Normally the current chunk will be discarded at the same
1439 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1440 chunk will not be discarded.
1445 #define LEX_NO_NEXT_CHUNK 0x80000000
1448 Perl_lex_read_space(pTHX_ U32 flags)
1451 bool need_incline = 0;
1452 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
1453 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1456 sv_free(PL_skipwhite);
1457 PL_skipwhite = NULL;
1460 PL_skipwhite = newSVpvs("");
1461 #endif /* PERL_MAD */
1462 s = PL_parser->bufptr;
1463 bufend = PL_parser->bufend;
1469 } while (!(c == '\n' || (c == 0 && s == bufend)));
1470 } else if (c == '\n') {
1472 PL_parser->linestart = s;
1477 } else if (isSPACE(c)) {
1479 } else if (c == 0 && s == bufend) {
1483 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1484 #endif /* PERL_MAD */
1485 if (flags & LEX_NO_NEXT_CHUNK)
1487 PL_parser->bufptr = s;
1488 CopLINE_inc(PL_curcop);
1489 got_more = lex_next_chunk(flags);
1490 CopLINE_dec(PL_curcop);
1491 s = PL_parser->bufptr;
1492 bufend = PL_parser->bufend;
1495 if (need_incline && PL_parser->rsfp) {
1505 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1506 #endif /* PERL_MAD */
1507 PL_parser->bufptr = s;
1512 * This subroutine has nothing to do with tilting, whether at windmills
1513 * or pinball tables. Its name is short for "increment line". It
1514 * increments the current line number in CopLINE(PL_curcop) and checks
1515 * to see whether the line starts with a comment of the form
1516 * # line 500 "foo.pm"
1517 * If so, it sets the current line number and file to the values in the comment.
1521 S_incline(pTHX_ const char *s)
1529 PERL_ARGS_ASSERT_INCLINE;
1531 CopLINE_inc(PL_curcop);
1534 while (SPACE_OR_TAB(*s))
1536 if (strnEQ(s, "line", 4))
1540 if (SPACE_OR_TAB(*s))
1544 while (SPACE_OR_TAB(*s))
1552 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1554 while (SPACE_OR_TAB(*s))
1556 if (*s == '"' && (t = strchr(s+1, '"'))) {
1562 while (!isSPACE(*t))
1566 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1568 if (*e != '\n' && *e != '\0')
1569 return; /* false alarm */
1571 line_num = atoi(n)-1;
1574 const STRLEN len = t - s;
1575 SV *const temp_sv = CopFILESV(PL_curcop);
1580 cf = SvPVX(temp_sv);
1581 tmplen = SvCUR(temp_sv);
1587 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
1588 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1589 * to *{"::_<newfilename"} */
1590 /* However, the long form of evals is only turned on by the
1591 debugger - usually they're "(eval %lu)" */
1595 STRLEN tmplen2 = len;
1596 if (tmplen + 2 <= sizeof smallbuf)
1599 Newx(tmpbuf, tmplen + 2, char);
1602 memcpy(tmpbuf + 2, cf, tmplen);
1604 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1609 if (tmplen2 + 2 <= sizeof smallbuf)
1612 Newx(tmpbuf2, tmplen2 + 2, char);
1614 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1615 /* Either they malloc'd it, or we malloc'd it,
1616 so no prefix is present in ours. */
1621 memcpy(tmpbuf2 + 2, s, tmplen2);
1624 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1626 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1627 /* adjust ${"::_<newfilename"} to store the new file name */
1628 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1629 /* The line number may differ. If that is the case,
1630 alias the saved lines that are in the array.
1631 Otherwise alias the whole array. */
1632 if (CopLINE(PL_curcop) == line_num) {
1633 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1634 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1636 else if (GvAV(*gvp)) {
1637 AV * const av = GvAV(*gvp);
1638 const I32 start = CopLINE(PL_curcop)+1;
1639 I32 items = AvFILLp(av) - start;
1641 AV * const av2 = GvAVn(gv2);
1642 SV **svp = AvARRAY(av) + start;
1643 I32 l = (I32)line_num+1;
1645 av_store(av2, l++, SvREFCNT_inc(*svp++));
1650 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1652 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1654 CopFILE_free(PL_curcop);
1655 CopFILE_setn(PL_curcop, s, len);
1657 CopLINE_set(PL_curcop, line_num);
1661 /* skip space before PL_thistoken */
1664 S_skipspace0(pTHX_ register char *s)
1666 PERL_ARGS_ASSERT_SKIPSPACE0;
1673 PL_thiswhite = newSVpvs("");
1674 sv_catsv(PL_thiswhite, PL_skipwhite);
1675 sv_free(PL_skipwhite);
1678 PL_realtokenstart = s - SvPVX(PL_linestr);
1682 /* skip space after PL_thistoken */
1685 S_skipspace1(pTHX_ register char *s)
1687 const char *start = s;
1688 I32 startoff = start - SvPVX(PL_linestr);
1690 PERL_ARGS_ASSERT_SKIPSPACE1;
1695 start = SvPVX(PL_linestr) + startoff;
1696 if (!PL_thistoken && PL_realtokenstart >= 0) {
1697 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1698 PL_thistoken = newSVpvn(tstart, start - tstart);
1700 PL_realtokenstart = -1;
1703 PL_nextwhite = newSVpvs("");
1704 sv_catsv(PL_nextwhite, PL_skipwhite);
1705 sv_free(PL_skipwhite);
1712 S_skipspace2(pTHX_ register char *s, SV **svp)
1715 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1716 const I32 startoff = s - SvPVX(PL_linestr);
1718 PERL_ARGS_ASSERT_SKIPSPACE2;
1721 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1722 if (!PL_madskills || !svp)
1724 start = SvPVX(PL_linestr) + startoff;
1725 if (!PL_thistoken && PL_realtokenstart >= 0) {
1726 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1727 PL_thistoken = newSVpvn(tstart, start - tstart);
1728 PL_realtokenstart = -1;
1732 *svp = newSVpvs("");
1733 sv_setsv(*svp, PL_skipwhite);
1734 sv_free(PL_skipwhite);
1743 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1745 AV *av = CopFILEAVx(PL_curcop);
1747 SV * const sv = newSV_type(SVt_PVMG);
1749 sv_setsv(sv, orig_sv);
1751 sv_setpvn(sv, buf, len);
1754 av_store(av, (I32)CopLINE(PL_curcop), sv);
1760 * Called to gobble the appropriate amount and type of whitespace.
1761 * Skips comments as well.
1765 S_skipspace(pTHX_ register char *s)
1769 #endif /* PERL_MAD */
1770 PERL_ARGS_ASSERT_SKIPSPACE;
1773 sv_free(PL_skipwhite);
1774 PL_skipwhite = NULL;
1776 #endif /* PERL_MAD */
1777 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1778 while (s < PL_bufend && SPACE_OR_TAB(*s))
1781 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1783 lex_read_space(LEX_KEEP_PREVIOUS |
1784 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1785 LEX_NO_NEXT_CHUNK : 0));
1787 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1788 if (PL_linestart > PL_bufptr)
1789 PL_bufptr = PL_linestart;
1794 PL_skipwhite = newSVpvn(start, s-start);
1795 #endif /* PERL_MAD */
1801 * Check the unary operators to ensure there's no ambiguity in how they're
1802 * used. An ambiguous piece of code would be:
1804 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1805 * the +5 is its argument.
1815 if (PL_oldoldbufptr != PL_last_uni)
1817 while (isSPACE(*PL_last_uni))
1820 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1822 if ((t = strchr(s, '(')) && t < PL_bufptr)
1825 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1826 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1827 (int)(s - PL_last_uni), PL_last_uni);
1831 * LOP : macro to build a list operator. Its behaviour has been replaced
1832 * with a subroutine, S_lop() for which LOP is just another name.
1835 #define LOP(f,x) return lop(f,x,s)
1839 * Build a list operator (or something that might be one). The rules:
1840 * - if we have a next token, then it's a list operator [why?]
1841 * - if the next thing is an opening paren, then it's a function
1842 * - else it's a list operator
1846 S_lop(pTHX_ I32 f, int x, char *s)
1850 PERL_ARGS_ASSERT_LOP;
1856 PL_last_lop = PL_oldbufptr;
1857 PL_last_lop_op = (OPCODE)f;
1866 return REPORT(FUNC);
1869 return REPORT(FUNC);
1872 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1873 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1874 return REPORT(LSTOP);
1881 * Sets up for an eventual force_next(). start_force(0) basically does
1882 * an unshift, while start_force(-1) does a push. yylex removes items
1887 S_start_force(pTHX_ int where)
1891 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1892 where = PL_lasttoke;
1893 assert(PL_curforce < 0 || PL_curforce == where);
1894 if (PL_curforce != where) {
1895 for (i = PL_lasttoke; i > where; --i) {
1896 PL_nexttoke[i] = PL_nexttoke[i-1];
1900 if (PL_curforce < 0) /* in case of duplicate start_force() */
1901 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1902 PL_curforce = where;
1905 curmad('^', newSVpvs(""));
1906 CURMAD('_', PL_nextwhite);
1911 S_curmad(pTHX_ char slot, SV *sv)
1917 if (PL_curforce < 0)
1918 where = &PL_thismad;
1920 where = &PL_nexttoke[PL_curforce].next_mad;
1926 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1928 else if (PL_encoding) {
1929 sv_recode_to_utf8(sv, PL_encoding);
1934 /* keep a slot open for the head of the list? */
1935 if (slot != '_' && *where && (*where)->mad_key == '^') {
1936 (*where)->mad_key = slot;
1937 sv_free(MUTABLE_SV(((*where)->mad_val)));
1938 (*where)->mad_val = (void*)sv;
1941 addmad(newMADsv(slot, sv), where, 0);
1944 # define start_force(where) NOOP
1945 # define curmad(slot, sv) NOOP
1950 * When the lexer realizes it knows the next token (for instance,
1951 * it is reordering tokens for the parser) then it can call S_force_next
1952 * to know what token to return the next time the lexer is called. Caller
1953 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1954 * and possibly PL_expect to ensure the lexer handles the token correctly.
1958 S_force_next(pTHX_ I32 type)
1963 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1964 tokereport(type, &NEXTVAL_NEXTTOKE);
1968 if (PL_curforce < 0)
1969 start_force(PL_lasttoke);
1970 PL_nexttoke[PL_curforce].next_type = type;
1971 if (PL_lex_state != LEX_KNOWNEXT)
1972 PL_lex_defer = PL_lex_state;
1973 PL_lex_state = LEX_KNOWNEXT;
1974 PL_lex_expect = PL_expect;
1977 PL_nexttype[PL_nexttoke] = type;
1979 if (PL_lex_state != LEX_KNOWNEXT) {
1980 PL_lex_defer = PL_lex_state;
1981 PL_lex_expect = PL_expect;
1982 PL_lex_state = LEX_KNOWNEXT;
1990 int yyc = PL_parser->yychar;
1991 if (yyc != YYEMPTY) {
1994 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1995 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1996 PL_lex_allbrackets--;
1998 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
1999 } else if (yyc == '('/*)*/) {
2000 PL_lex_allbrackets--;
2005 PL_parser->yychar = YYEMPTY;
2010 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2013 SV * const sv = newSVpvn_utf8(start, len,
2016 && !is_ascii_string((const U8*)start, len)
2017 && is_utf8_string((const U8*)start, len));
2023 * When the lexer knows the next thing is a word (for instance, it has
2024 * just seen -> and it knows that the next char is a word char, then
2025 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2029 * char *start : buffer position (must be within PL_linestr)
2030 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2031 * int check_keyword : if true, Perl checks to make sure the word isn't
2032 * a keyword (do this if the word is a label, e.g. goto FOO)
2033 * int allow_pack : if true, : characters will also be allowed (require,
2034 * use, etc. do this)
2035 * int allow_initial_tick : used by the "sub" lexer only.
2039 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
2045 PERL_ARGS_ASSERT_FORCE_WORD;
2047 start = SKIPSPACE1(start);
2049 if (isIDFIRST_lazy_if(s,UTF) ||
2050 (allow_pack && *s == ':') ||
2051 (allow_initial_tick && *s == '\'') )
2053 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2054 if (check_keyword && keyword(PL_tokenbuf, len, 0))
2056 start_force(PL_curforce);
2058 curmad('X', newSVpvn(start,s-start));
2059 if (token == METHOD) {
2064 PL_expect = XOPERATOR;
2068 curmad('g', newSVpvs( "forced" ));
2069 NEXTVAL_NEXTTOKE.opval
2070 = (OP*)newSVOP(OP_CONST,0,
2071 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2072 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2080 * Called when the lexer wants $foo *foo &foo etc, but the program
2081 * text only contains the "foo" portion. The first argument is a pointer
2082 * to the "foo", and the second argument is the type symbol to prefix.
2083 * Forces the next token to be a "WORD".
2084 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2088 S_force_ident(pTHX_ register const char *s, int kind)
2092 PERL_ARGS_ASSERT_FORCE_IDENT;
2095 const STRLEN len = strlen(s);
2096 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2097 UTF ? SVf_UTF8 : 0));
2098 start_force(PL_curforce);
2099 NEXTVAL_NEXTTOKE.opval = o;
2102 o->op_private = OPpCONST_ENTERED;
2103 /* XXX see note in pp_entereval() for why we forgo typo
2104 warnings if the symbol must be introduced in an eval.
2106 gv_fetchpvn_flags(s, len,
2107 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2108 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2109 kind == '$' ? SVt_PV :
2110 kind == '@' ? SVt_PVAV :
2111 kind == '%' ? SVt_PVHV :
2119 Perl_str_to_version(pTHX_ SV *sv)
2124 const char *start = SvPV_const(sv,len);
2125 const char * const end = start + len;
2126 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2128 PERL_ARGS_ASSERT_STR_TO_VERSION;
2130 while (start < end) {
2134 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2139 retval += ((NV)n)/nshift;
2148 * Forces the next token to be a version number.
2149 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2150 * and if "guessing" is TRUE, then no new token is created (and the caller
2151 * must use an alternative parsing method).
2155 S_force_version(pTHX_ char *s, int guessing)
2161 I32 startoff = s - SvPVX(PL_linestr);
2164 PERL_ARGS_ASSERT_FORCE_VERSION;
2172 while (isDIGIT(*d) || *d == '_' || *d == '.')
2176 start_force(PL_curforce);
2177 curmad('X', newSVpvn(s,d-s));
2180 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2182 #ifdef USE_LOCALE_NUMERIC
2183 char *loc = setlocale(LC_NUMERIC, "C");
2185 s = scan_num(s, &pl_yylval);
2186 #ifdef USE_LOCALE_NUMERIC
2187 setlocale(LC_NUMERIC, loc);
2189 version = pl_yylval.opval;
2190 ver = cSVOPx(version)->op_sv;
2191 if (SvPOK(ver) && !SvNIOK(ver)) {
2192 SvUPGRADE(ver, SVt_PVNV);
2193 SvNV_set(ver, str_to_version(ver));
2194 SvNOK_on(ver); /* hint that it is a version */
2197 else if (guessing) {
2200 sv_free(PL_nextwhite); /* let next token collect whitespace */
2202 s = SvPVX(PL_linestr) + startoff;
2210 if (PL_madskills && !version) {
2211 sv_free(PL_nextwhite); /* let next token collect whitespace */
2213 s = SvPVX(PL_linestr) + startoff;
2216 /* NOTE: The parser sees the package name and the VERSION swapped */
2217 start_force(PL_curforce);
2218 NEXTVAL_NEXTTOKE.opval = version;
2225 * S_force_strict_version
2226 * Forces the next token to be a version number using strict syntax rules.
2230 S_force_strict_version(pTHX_ char *s)
2235 I32 startoff = s - SvPVX(PL_linestr);
2237 const char *errstr = NULL;
2239 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2241 while (isSPACE(*s)) /* leading whitespace */
2244 if (is_STRICT_VERSION(s,&errstr)) {
2246 s = (char *)scan_version(s, ver, 0);
2247 version = newSVOP(OP_CONST, 0, ver);
2249 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2250 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2254 yyerror(errstr); /* version required */
2259 if (PL_madskills && !version) {
2260 sv_free(PL_nextwhite); /* let next token collect whitespace */
2262 s = SvPVX(PL_linestr) + startoff;
2265 /* NOTE: The parser sees the package name and the VERSION swapped */
2266 start_force(PL_curforce);
2267 NEXTVAL_NEXTTOKE.opval = version;
2275 * Tokenize a quoted string passed in as an SV. It finds the next
2276 * chunk, up to end of string or a backslash. It may make a new
2277 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2282 S_tokeq(pTHX_ SV *sv)
2286 register char *send;
2291 PERL_ARGS_ASSERT_TOKEQ;
2296 s = SvPV_force(sv, len);
2297 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2300 /* This is relying on the SV being "well formed" with a trailing '\0' */
2301 while (s < send && !(*s == '\\' && s[1] == '\\'))
2306 if ( PL_hints & HINT_NEW_STRING ) {
2307 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2311 if (s + 1 < send && (s[1] == '\\'))
2312 s++; /* all that, just for this */
2317 SvCUR_set(sv, d - SvPVX_const(sv));
2319 if ( PL_hints & HINT_NEW_STRING )
2320 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2325 * Now come three functions related to double-quote context,
2326 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2327 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2328 * interact with PL_lex_state, and create fake ( ... ) argument lists
2329 * to handle functions and concatenation.
2330 * They assume that whoever calls them will be setting up a fake
2331 * join call, because each subthing puts a ',' after it. This lets
2334 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
2336 * (I'm not sure whether the spurious commas at the end of lcfirst's
2337 * arguments and join's arguments are created or not).
2342 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2344 * Pattern matching will set PL_lex_op to the pattern-matching op to
2345 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2347 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2349 * Everything else becomes a FUNC.
2351 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2352 * had an OP_CONST or OP_READLINE). This just sets us up for a
2353 * call to S_sublex_push().
2357 S_sublex_start(pTHX)
2360 register const I32 op_type = pl_yylval.ival;
2362 if (op_type == OP_NULL) {
2363 pl_yylval.opval = PL_lex_op;
2367 if (op_type == OP_CONST || op_type == OP_READLINE) {
2368 SV *sv = tokeq(PL_lex_stuff);
2370 if (SvTYPE(sv) == SVt_PVIV) {
2371 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2373 const char * const p = SvPV_const(sv, len);
2374 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2378 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2379 PL_lex_stuff = NULL;
2380 /* Allow <FH> // "foo" */
2381 if (op_type == OP_READLINE)
2382 PL_expect = XTERMORDORDOR;
2385 else if (op_type == OP_BACKTICK && PL_lex_op) {
2386 /* readpipe() vas overriden */
2387 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2388 pl_yylval.opval = PL_lex_op;
2390 PL_lex_stuff = NULL;
2394 PL_sublex_info.super_state = PL_lex_state;
2395 PL_sublex_info.sub_inwhat = (U16)op_type;
2396 PL_sublex_info.sub_op = PL_lex_op;
2397 PL_lex_state = LEX_INTERPPUSH;
2401 pl_yylval.opval = PL_lex_op;
2411 * Create a new scope to save the lexing state. The scope will be
2412 * ended in S_sublex_done. Returns a '(', starting the function arguments
2413 * to the uc, lc, etc. found before.
2414 * Sets PL_lex_state to LEX_INTERPCONCAT.
2423 PL_lex_state = PL_sublex_info.super_state;
2424 SAVEBOOL(PL_lex_dojoin);
2425 SAVEI32(PL_lex_brackets);
2426 SAVEI32(PL_lex_allbrackets);
2427 SAVEI8(PL_lex_fakeeof);
2428 SAVEI32(PL_lex_casemods);
2429 SAVEI32(PL_lex_starts);
2430 SAVEI8(PL_lex_state);
2431 SAVEVPTR(PL_lex_inpat);
2432 SAVEI16(PL_lex_inwhat);
2433 SAVECOPLINE(PL_curcop);
2434 SAVEPPTR(PL_bufptr);
2435 SAVEPPTR(PL_bufend);
2436 SAVEPPTR(PL_oldbufptr);
2437 SAVEPPTR(PL_oldoldbufptr);
2438 SAVEPPTR(PL_last_lop);
2439 SAVEPPTR(PL_last_uni);
2440 SAVEPPTR(PL_linestart);
2441 SAVESPTR(PL_linestr);
2442 SAVEGENERICPV(PL_lex_brackstack);
2443 SAVEGENERICPV(PL_lex_casestack);
2445 PL_linestr = PL_lex_stuff;
2446 PL_lex_stuff = NULL;
2448 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2449 = SvPVX(PL_linestr);
2450 PL_bufend += SvCUR(PL_linestr);
2451 PL_last_lop = PL_last_uni = NULL;
2452 SAVEFREESV(PL_linestr);
2454 PL_lex_dojoin = FALSE;
2455 PL_lex_brackets = 0;
2456 PL_lex_allbrackets = 0;
2457 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2458 Newx(PL_lex_brackstack, 120, char);
2459 Newx(PL_lex_casestack, 12, char);
2460 PL_lex_casemods = 0;
2461 *PL_lex_casestack = '\0';
2463 PL_lex_state = LEX_INTERPCONCAT;
2464 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2466 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2467 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2468 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2469 PL_lex_inpat = PL_sublex_info.sub_op;
2471 PL_lex_inpat = NULL;
2478 * Restores lexer state after a S_sublex_push.
2485 if (!PL_lex_starts++) {
2486 SV * const sv = newSVpvs("");
2487 if (SvUTF8(PL_linestr))
2489 PL_expect = XOPERATOR;
2490 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2494 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2495 PL_lex_state = LEX_INTERPCASEMOD;
2499 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2500 assert(PL_lex_inwhat != OP_TRANSR);
2501 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2502 PL_linestr = PL_lex_repl;
2504 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2505 PL_bufend += SvCUR(PL_linestr);
2506 PL_last_lop = PL_last_uni = NULL;
2507 SAVEFREESV(PL_linestr);
2508 PL_lex_dojoin = FALSE;
2509 PL_lex_brackets = 0;
2510 PL_lex_allbrackets = 0;
2511 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2512 PL_lex_casemods = 0;
2513 *PL_lex_casestack = '\0';
2515 if (SvEVALED(PL_lex_repl)) {
2516 PL_lex_state = LEX_INTERPNORMAL;
2518 /* we don't clear PL_lex_repl here, so that we can check later
2519 whether this is an evalled subst; that means we rely on the
2520 logic to ensure sublex_done() is called again only via the
2521 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2524 PL_lex_state = LEX_INTERPCONCAT;
2534 PL_endwhite = newSVpvs("");
2535 sv_catsv(PL_endwhite, PL_thiswhite);
2539 sv_setpvs(PL_thistoken,"");
2541 PL_realtokenstart = -1;
2545 PL_bufend = SvPVX(PL_linestr);
2546 PL_bufend += SvCUR(PL_linestr);
2547 PL_expect = XOPERATOR;
2548 PL_sublex_info.sub_inwhat = 0;
2556 Extracts a pattern, double-quoted string, or transliteration. This
2559 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2560 processing a pattern (PL_lex_inpat is true), a transliteration
2561 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2563 Returns a pointer to the character scanned up to. If this is
2564 advanced from the start pointer supplied (i.e. if anything was
2565 successfully parsed), will leave an OP for the substring scanned
2566 in pl_yylval. Caller must intuit reason for not parsing further
2567 by looking at the next characters herself.
2571 constants: \N{NAME} only
2572 case and quoting: \U \Q \E
2573 stops on @ and $, but not for $ as tail anchor
2575 In transliterations:
2576 characters are VERY literal, except for - not at the start or end
2577 of the string, which indicates a range. If the range is in bytes,
2578 scan_const expands the range to the full set of intermediate
2579 characters. If the range is in utf8, the hyphen is replaced with
2580 a certain range mark which will be handled by pmtrans() in op.c.
2582 In double-quoted strings:
2584 double-quoted style: \r and \n
2585 constants: \x31, etc.
2586 deprecated backrefs: \1 (in substitution replacements)
2587 case and quoting: \U \Q \E
2590 scan_const does *not* construct ops to handle interpolated strings.
2591 It stops processing as soon as it finds an embedded $ or @ variable
2592 and leaves it to the caller to work out what's going on.
2594 embedded arrays (whether in pattern or not) could be:
2595 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2597 $ in double-quoted strings must be the symbol of an embedded scalar.
2599 $ in pattern could be $foo or could be tail anchor. Assumption:
2600 it's a tail anchor if $ is the last thing in the string, or if it's
2601 followed by one of "()| \r\n\t"
2603 \1 (backreferences) are turned into $1
2605 The structure of the code is
2606 while (there's a character to process) {
2607 handle transliteration ranges
2608 skip regexp comments /(?#comment)/ and codes /(?{code})/
2609 skip #-initiated comments in //x patterns
2610 check for embedded arrays
2611 check for embedded scalars
2613 deprecate \1 in substitution replacements
2614 handle string-changing backslashes \l \U \Q \E, etc.
2615 switch (what was escaped) {
2616 handle \- in a transliteration (becomes a literal -)
2617 if a pattern and not \N{, go treat as regular character
2618 handle \132 (octal characters)
2619 handle \x15 and \x{1234} (hex characters)
2620 handle \N{name} (named characters, also \N{3,5} in a pattern)
2621 handle \cV (control characters)
2622 handle printf-style backslashes (\f, \r, \n, etc)
2625 } (end if backslash)
2626 handle regular character
2627 } (end while character to read)
2632 S_scan_const(pTHX_ char *start)
2635 register char *send = PL_bufend; /* end of the constant */
2636 SV *sv = newSV(send - start); /* sv for the constant. See
2637 note below on sizing. */
2638 register char *s = start; /* start of the constant */
2639 register char *d = SvPVX(sv); /* destination for copies */
2640 bool dorange = FALSE; /* are we in a translit range? */
2641 bool didrange = FALSE; /* did we just finish a range? */
2642 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2643 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2644 to be UTF8? But, this can
2645 show as true when the source
2646 isn't utf8, as for example
2647 when it is entirely composed
2650 /* Note on sizing: The scanned constant is placed into sv, which is
2651 * initialized by newSV() assuming one byte of output for every byte of
2652 * input. This routine expects newSV() to allocate an extra byte for a
2653 * trailing NUL, which this routine will append if it gets to the end of
2654 * the input. There may be more bytes of input than output (eg., \N{LATIN
2655 * CAPITAL LETTER A}), or more output than input if the constant ends up
2656 * recoded to utf8, but each time a construct is found that might increase
2657 * the needed size, SvGROW() is called. Its size parameter each time is
2658 * based on the best guess estimate at the time, namely the length used so
2659 * far, plus the length the current construct will occupy, plus room for
2660 * the trailing NUL, plus one byte for every input byte still unscanned */
2664 UV literal_endpoint = 0;
2665 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2668 PERL_ARGS_ASSERT_SCAN_CONST;
2670 assert(PL_lex_inwhat != OP_TRANSR);
2671 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2672 /* If we are doing a trans and we know we want UTF8 set expectation */
2673 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2674 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2678 while (s < send || dorange) {
2680 /* get transliterations out of the way (they're most literal) */
2681 if (PL_lex_inwhat == OP_TRANS) {
2682 /* expand a range A-Z to the full set of characters. AIE! */
2684 I32 i; /* current expanded character */
2685 I32 min; /* first character in range */
2686 I32 max; /* last character in range */
2697 char * const c = (char*)utf8_hop((U8*)d, -1);
2701 *c = (char)UTF_TO_NATIVE(0xff);
2702 /* mark the range as done, and continue */
2708 i = d - SvPVX_const(sv); /* remember current offset */
2711 SvLEN(sv) + (has_utf8 ?
2712 (512 - UTF_CONTINUATION_MARK +
2715 /* How many two-byte within 0..255: 128 in UTF-8,
2716 * 96 in UTF-8-mod. */
2718 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2720 d = SvPVX(sv) + i; /* refresh d after realloc */
2724 for (j = 0; j <= 1; j++) {
2725 char * const c = (char*)utf8_hop((U8*)d, -1);
2726 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2732 max = (U8)0xff; /* only to \xff */
2733 uvmax = uv; /* \x{100} to uvmax */
2735 d = c; /* eat endpoint chars */
2740 d -= 2; /* eat the first char and the - */
2741 min = (U8)*d; /* first char in range */
2742 max = (U8)d[1]; /* last char in range */
2749 "Invalid range \"%c-%c\" in transliteration operator",
2750 (char)min, (char)max);
2754 if (literal_endpoint == 2 &&
2755 ((isLOWER(min) && isLOWER(max)) ||
2756 (isUPPER(min) && isUPPER(max)))) {
2758 for (i = min; i <= max; i++)
2760 *d++ = NATIVE_TO_NEED(has_utf8,i);
2762 for (i = min; i <= max; i++)
2764 *d++ = NATIVE_TO_NEED(has_utf8,i);
2769 for (i = min; i <= max; i++)
2772 const U8 ch = (U8)NATIVE_TO_UTF(i);
2773 if (UNI_IS_INVARIANT(ch))
2776 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2777 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2786 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2788 *d++ = (char)UTF_TO_NATIVE(0xff);
2790 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2794 /* mark the range as done, and continue */
2798 literal_endpoint = 0;
2803 /* range begins (ignore - as first or last char) */
2804 else if (*s == '-' && s+1 < send && s != start) {
2806 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2813 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2823 literal_endpoint = 0;
2824 native_range = TRUE;
2829 /* if we get here, we're not doing a transliteration */
2831 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2832 except for the last char, which will be done separately. */
2833 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2835 while (s+1 < send && *s != ')')
2836 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2838 else if (s[2] == '{' /* This should match regcomp.c */
2839 || (s[2] == '?' && s[3] == '{'))
2842 char *regparse = s + (s[2] == '{' ? 3 : 4);
2845 while (count && (c = *regparse)) {
2846 if (c == '\\' && regparse[1])
2854 if (*regparse != ')')
2855 regparse--; /* Leave one char for continuation. */
2856 while (s < regparse)
2857 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2861 /* likewise skip #-initiated comments in //x patterns */
2862 else if (*s == '#' && PL_lex_inpat &&
2863 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
2864 while (s+1 < send && *s != '\n')
2865 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2868 /* check for embedded arrays
2869 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2871 else if (*s == '@' && s[1]) {
2872 if (isALNUM_lazy_if(s+1,UTF))
2874 if (strchr(":'{$", s[1]))
2876 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2877 break; /* in regexp, neither @+ nor @- are interpolated */
2880 /* check for embedded scalars. only stop if we're sure it's a
2883 else if (*s == '$') {
2884 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2886 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2888 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2889 "Possible unintended interpolation of $\\ in regex");
2891 break; /* in regexp, $ might be tail anchor */
2895 /* End of else if chain - OP_TRANS rejoin rest */
2898 if (*s == '\\' && s+1 < send) {
2899 char* e; /* Can be used for ending '}', etc. */
2903 /* warn on \1 - \9 in substitution replacements, but note that \11
2904 * is an octal; and \19 is \1 followed by '9' */
2905 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2906 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2908 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2913 /* string-change backslash escapes */
2914 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2918 /* In a pattern, process \N, but skip any other backslash escapes.
2919 * This is because we don't want to translate an escape sequence
2920 * into a meta symbol and have the regex compiler use the meta
2921 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
2922 * in spite of this, we do have to process \N here while the proper
2923 * charnames handler is in scope. See bugs #56444 and #62056.
2924 * There is a complication because \N in a pattern may also stand
2925 * for 'match a non-nl', and not mean a charname, in which case its
2926 * processing should be deferred to the regex compiler. To be a
2927 * charname it must be followed immediately by a '{', and not look
2928 * like \N followed by a curly quantifier, i.e., not something like
2929 * \N{3,}. regcurly returns a boolean indicating if it is a legal
2931 else if (PL_lex_inpat
2934 || regcurly(s + 1)))
2936 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2937 goto default_action;
2942 /* quoted - in transliterations */
2944 if (PL_lex_inwhat == OP_TRANS) {
2951 if ((isALPHA(*s) || isDIGIT(*s)))
2952 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2953 "Unrecognized escape \\%c passed through",
2955 /* default action is to copy the quoted character */
2956 goto default_action;
2959 /* eg. \132 indicates the octal constant 0132 */
2960 case '0': case '1': case '2': case '3':
2961 case '4': case '5': case '6': case '7':
2965 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2968 goto NUM_ESCAPE_INSERT;
2970 /* eg. \o{24} indicates the octal constant \024 */
2976 bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
2982 goto NUM_ESCAPE_INSERT;
2985 /* eg. \x24 indicates the hex constant 0x24 */
2989 char* const e = strchr(s, '}');
2990 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2991 PERL_SCAN_DISALLOW_PREFIX;
2996 yyerror("Missing right brace on \\x{}");
3000 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
3006 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3007 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
3013 /* Insert oct or hex escaped character. There will always be
3014 * enough room in sv since such escapes will be longer than any
3015 * UTF-8 sequence they can end up as, except if they force us
3016 * to recode the rest of the string into utf8 */
3018 /* Here uv is the ordinal of the next character being added in
3019 * unicode (converted from native). */
3020 if (!UNI_IS_INVARIANT(uv)) {
3021 if (!has_utf8 && uv > 255) {
3022 /* Might need to recode whatever we have accumulated so
3023 * far if it contains any chars variant in utf8 or
3026 SvCUR_set(sv, d - SvPVX_const(sv));
3029 /* See Note on sizing above. */
3030 sv_utf8_upgrade_flags_grow(sv,
3031 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3032 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3033 d = SvPVX(sv) + SvCUR(sv);
3038 d = (char*)uvuni_to_utf8((U8*)d, uv);
3039 if (PL_lex_inwhat == OP_TRANS &&
3040 PL_sublex_info.sub_op) {
3041 PL_sublex_info.sub_op->op_private |=
3042 (PL_lex_repl ? OPpTRANS_FROM_UTF
3046 if (uv > 255 && !dorange)
3047 native_range = FALSE;
3060 /* In a non-pattern \N must be a named character, like \N{LATIN
3061 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3062 * mean to match a non-newline. For non-patterns, named
3063 * characters are converted to their string equivalents. In
3064 * patterns, named characters are not converted to their
3065 * ultimate forms for the same reasons that other escapes
3066 * aren't. Instead, they are converted to the \N{U+...} form
3067 * to get the value from the charnames that is in effect right
3068 * now, while preserving the fact that it was a named character
3069 * so that the regex compiler knows this */
3071 /* This section of code doesn't generally use the
3072 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3073 * a close examination of this macro and determined it is a
3074 * no-op except on utfebcdic variant characters. Every
3075 * character generated by this that would normally need to be
3076 * enclosed by this macro is invariant, so the macro is not
3077 * needed, and would complicate use of copy(). XXX There are
3078 * other parts of this file where the macro is used
3079 * inconsistently, but are saved by it being a no-op */
3081 /* The structure of this section of code (besides checking for
3082 * errors and upgrading to utf8) is:
3083 * Further disambiguate between the two meanings of \N, and if
3084 * not a charname, go process it elsewhere
3085 * If of form \N{U+...}, pass it through if a pattern;
3086 * otherwise convert to utf8
3087 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3088 * pattern; otherwise convert to utf8 */
3090 /* Here, s points to the 'N'; the test below is guaranteed to
3091 * succeed if we are being called on a pattern as we already
3092 * know from a test above that the next character is a '{'.
3093 * On a non-pattern \N must mean 'named sequence, which
3094 * requires braces */
3097 yyerror("Missing braces on \\N{}");
3102 /* If there is no matching '}', it is an error. */
3103 if (! (e = strchr(s, '}'))) {
3104 if (! PL_lex_inpat) {
3105 yyerror("Missing right brace on \\N{}");
3107 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3112 /* Here it looks like a named character */
3116 /* XXX This block is temporary code. \N{} implies that the
3117 * pattern is to have Unicode semantics, and therefore
3118 * currently has to be encoded in utf8. By putting it in
3119 * utf8 now, we save a whole pass in the regular expression
3120 * compiler. Once that code is changed so Unicode
3121 * semantics doesn't necessarily have to be in utf8, this
3122 * block should be removed. However, the code that parses
3123 * the output of this would have to be changed to not
3124 * necessarily expect utf8 */
3126 SvCUR_set(sv, d - SvPVX_const(sv));
3129 /* See Note on sizing above. */
3130 sv_utf8_upgrade_flags_grow(sv,
3131 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3132 /* 5 = '\N{' + cur char + NUL */
3133 (STRLEN)(send - s) + 5);
3134 d = SvPVX(sv) + SvCUR(sv);
3139 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3140 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3141 | PERL_SCAN_DISALLOW_PREFIX;
3144 /* For \N{U+...}, the '...' is a unicode value even on
3145 * EBCDIC machines */
3146 s += 2; /* Skip to next char after the 'U+' */
3148 uv = grok_hex(s, &len, &flags, NULL);
3149 if (len == 0 || len != (STRLEN)(e - s)) {
3150 yyerror("Invalid hexadecimal number in \\N{U+...}");
3157 /* On non-EBCDIC platforms, pass through to the regex
3158 * compiler unchanged. The reason we evaluated the
3159 * number above is to make sure there wasn't a syntax
3160 * error. But on EBCDIC we convert to native so
3161 * downstream code can continue to assume it's native
3163 s -= 5; /* Include the '\N{U+' */
3165 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3168 (unsigned int) UNI_TO_NATIVE(uv));
3170 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3174 else { /* Not a pattern: convert the hex to string */
3176 /* If destination is not in utf8, unconditionally
3177 * recode it to be so. This is because \N{} implies
3178 * Unicode semantics, and scalars have to be in utf8
3179 * to guarantee those semantics */
3181 SvCUR_set(sv, d - SvPVX_const(sv));
3184 /* See Note on sizing above. */
3185 sv_utf8_upgrade_flags_grow(
3187 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3188 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3189 d = SvPVX(sv) + SvCUR(sv);
3193 /* Add the string to the output */
3194 if (UNI_IS_INVARIANT(uv)) {
3197 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3200 else { /* Here is \N{NAME} but not \N{U+...}. */
3202 SV *res; /* result from charnames */
3203 const char *str; /* the string in 'res' */
3204 STRLEN len; /* its length */
3206 /* Get the value for NAME */
3207 res = newSVpvn(s, e - s);
3208 res = new_constant( NULL, 0, "charnames",
3209 /* includes all of: \N{...} */
3210 res, NULL, s - 3, e - s + 4 );
3212 /* Most likely res will be in utf8 already since the
3213 * standard charnames uses pack U, but a custom translator
3214 * can leave it otherwise, so make sure. XXX This can be
3215 * revisited to not have charnames use utf8 for characters
3216 * that don't need it when regexes don't have to be in utf8
3217 * for Unicode semantics. If doing so, remember EBCDIC */
3218 sv_utf8_upgrade(res);
3219 str = SvPV_const(res, len);
3221 /* Don't accept malformed input */
3222 if (! is_utf8_string((U8 *) str, len)) {
3223 yyerror("Malformed UTF-8 returned by \\N");
3225 else if (PL_lex_inpat) {
3227 if (! len) { /* The name resolved to an empty string */
3228 Copy("\\N{}", d, 4, char);
3232 /* In order to not lose information for the regex
3233 * compiler, pass the result in the specially made
3234 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3235 * the code points in hex of each character
3236 * returned by charnames */
3238 const char *str_end = str + len;
3239 STRLEN char_length; /* cur char's byte length */
3240 STRLEN output_length; /* and the number of bytes
3241 after this is translated
3243 const STRLEN off = d - SvPVX_const(sv);
3245 /* 2 hex per byte; 2 chars for '\N'; 2 chars for
3246 * max('U+', '.'); and 1 for NUL */
3247 char hex_string[2 * UTF8_MAXBYTES + 5];
3249 /* Get the first character of the result. */
3250 U32 uv = utf8n_to_uvuni((U8 *) str,
3255 /* The call to is_utf8_string() above hopefully
3256 * guarantees that there won't be an error. But
3257 * it's easy here to make sure. The function just
3258 * above warns and returns 0 if invalid utf8, but
3259 * it can also return 0 if the input is validly a
3260 * NUL. Disambiguate */
3261 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3262 uv = UNICODE_REPLACEMENT;
3265 /* Convert first code point to hex, including the
3266 * boiler plate before it. For all these, we
3267 * convert to native format so that downstream code
3268 * can continue to assume the input is native */
3270 my_snprintf(hex_string, sizeof(hex_string),
3272 (unsigned int) UNI_TO_NATIVE(uv));
3274 /* Make sure there is enough space to hold it */
3275 d = off + SvGROW(sv, off
3277 + (STRLEN)(send - e)
3278 + 2); /* '}' + NUL */
3280 Copy(hex_string, d, output_length, char);
3283 /* For each subsequent character, append dot and
3284 * its ordinal in hex */
3285 while ((str += char_length) < str_end) {
3286 const STRLEN off = d - SvPVX_const(sv);
3287 U32 uv = utf8n_to_uvuni((U8 *) str,
3291 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3292 uv = UNICODE_REPLACEMENT;
3296 my_snprintf(hex_string, sizeof(hex_string),
3298 (unsigned int) UNI_TO_NATIVE(uv));
3300 d = off + SvGROW(sv, off
3302 + (STRLEN)(send - e)
3303 + 2); /* '}' + NUL */
3304 Copy(hex_string, d, output_length, char);
3308 *d++ = '}'; /* Done. Add the trailing brace */
3311 else { /* Here, not in a pattern. Convert the name to a
3314 /* If destination is not in utf8, unconditionally
3315 * recode it to be so. This is because \N{} implies
3316 * Unicode semantics, and scalars have to be in utf8
3317 * to guarantee those semantics */
3319 SvCUR_set(sv, d - SvPVX_const(sv));
3322 /* See Note on sizing above. */
3323 sv_utf8_upgrade_flags_grow(sv,
3324 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3325 len + (STRLEN)(send - s) + 1);
3326 d = SvPVX(sv) + SvCUR(sv);
3328 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3330 /* See Note on sizing above. (NOTE: SvCUR() is not
3331 * set correctly here). */
3332 const STRLEN off = d - SvPVX_const(sv);
3333 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3335 Copy(str, d, len, char);
3340 /* Deprecate non-approved name syntax */
3341 if (ckWARN_d(WARN_DEPRECATED)) {
3342 bool problematic = FALSE;
3345 /* For non-ut8 input, look to see that the first
3346 * character is an alpha, then loop through the rest
3347 * checking that each is a continuation */
3349 if (! isALPHAU(*i)) problematic = TRUE;
3350 else for (i = s + 1; i < e; i++) {
3351 if (isCHARNAME_CONT(*i)) continue;
3357 /* Similarly for utf8. For invariants can check
3358 * directly. We accept anything above the latin1
3359 * range because it is immaterial to Perl if it is
3360 * correct or not, and is expensive to check. But
3361 * it is fairly easy in the latin1 range to convert
3362 * the variants into a single character and check
3364 if (UTF8_IS_INVARIANT(*i)) {
3365 if (! isALPHAU(*i)) problematic = TRUE;
3366 } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
3367 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
3373 if (! problematic) for (i = s + UTF8SKIP(s);
3377 if (UTF8_IS_INVARIANT(*i)) {
3378 if (isCHARNAME_CONT(*i)) continue;
3379 } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
3381 } else if (isCHARNAME_CONT(
3383 TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
3392 /* The e-i passed to the final %.*s makes sure that
3393 * should the trailing NUL be missing that this
3394 * print won't run off the end of the string */
3395 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3396 "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
3397 (int)(i - s + 1), s, (int)(e - i), i + 1);
3400 } /* End \N{NAME} */
3403 native_range = FALSE; /* \N{} is defined to be Unicode */
3405 s = e + 1; /* Point to just after the '}' */
3408 /* \c is a control character */
3412 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3415 yyerror("Missing control char name in \\c");
3419 /* printf-style backslashes, formfeeds, newlines, etc */
3421 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3424 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3427 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3430 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3433 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3436 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3439 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3445 } /* end if (backslash) */
3452 /* If we started with encoded form, or already know we want it,
3453 then encode the next character */
3454 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3458 /* One might think that it is wasted effort in the case of the
3459 * source being utf8 (this_utf8 == TRUE) to take the next character
3460 * in the source, convert it to an unsigned value, and then convert
3461 * it back again. But the source has not been validated here. The
3462 * routine that does the conversion checks for errors like
3465 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3466 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3468 SvCUR_set(sv, d - SvPVX_const(sv));
3471 /* See Note on sizing above. */
3472 sv_utf8_upgrade_flags_grow(sv,
3473 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3474 need + (STRLEN)(send - s) + 1);
3475 d = SvPVX(sv) + SvCUR(sv);
3477 } else if (need > len) {
3478 /* encoded value larger than old, may need extra space (NOTE:
3479 * SvCUR() is not set correctly here). See Note on sizing
3481 const STRLEN off = d - SvPVX_const(sv);
3482 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3486 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3488 if (uv > 255 && !dorange)
3489 native_range = FALSE;
3493 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3495 } /* while loop to process each character */
3497 /* terminate the string and set up the sv */
3499 SvCUR_set(sv, d - SvPVX_const(sv));
3500 if (SvCUR(sv) >= SvLEN(sv))
3501 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
3504 if (PL_encoding && !has_utf8) {
3505 sv_recode_to_utf8(sv, PL_encoding);
3511 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3512 PL_sublex_info.sub_op->op_private |=
3513 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3517 /* shrink the sv if we allocated more than we used */
3518 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3519 SvPV_shrink_to_cur(sv);
3522 /* return the substring (via pl_yylval) only if we parsed anything */
3523 if (s > PL_bufptr) {
3524 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
3525 const char *const key = PL_lex_inpat ? "qr" : "q";
3526 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3530 if (PL_lex_inwhat == OP_TRANS) {
3533 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3541 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3544 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3551 * Returns TRUE if there's more to the expression (e.g., a subscript),
3554 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3556 * ->[ and ->{ return TRUE
3557 * { and [ outside a pattern are always subscripts, so return TRUE
3558 * if we're outside a pattern and it's not { or [, then return FALSE
3559 * if we're in a pattern and the first char is a {
3560 * {4,5} (any digits around the comma) returns FALSE
3561 * if we're in a pattern and the first char is a [
3563 * [SOMETHING] has a funky algorithm to decide whether it's a
3564 * character class or not. It has to deal with things like
3565 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3566 * anything else returns TRUE
3569 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3572 S_intuit_more(pTHX_ register char *s)
3576 PERL_ARGS_ASSERT_INTUIT_MORE;
3578 if (PL_lex_brackets)
3580 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3582 if (*s != '{' && *s != '[')
3587 /* In a pattern, so maybe we have {n,m}. */
3595 /* On the other hand, maybe we have a character class */
3598 if (*s == ']' || *s == '^')
3601 /* this is terrifying, and it works */
3602 int weight = 2; /* let's weigh the evidence */
3604 unsigned char un_char = 255, last_un_char;
3605 const char * const send = strchr(s,']');
3606 char tmpbuf[sizeof PL_tokenbuf * 4];
3608 if (!send) /* has to be an expression */
3611 Zero(seen,256,char);
3614 else if (isDIGIT(*s)) {
3616 if (isDIGIT(s[1]) && s[2] == ']')
3622 for (; s < send; s++) {
3623 last_un_char = un_char;
3624 un_char = (unsigned char)*s;
3629 weight -= seen[un_char] * 10;
3630 if (isALNUM_lazy_if(s+1,UTF)) {
3632 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3633 len = (int)strlen(tmpbuf);
3634 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3635 UTF ? SVf_UTF8 : 0, SVt_PV))
3640 else if (*s == '$' && s[1] &&
3641 strchr("[#!%*<>()-=",s[1])) {
3642 if (/*{*/ strchr("])} =",s[2]))
3651 if (strchr("wds]",s[1]))
3653 else if (seen[(U8)'\''] || seen[(U8)'"'])
3655 else if (strchr("rnftbxcav",s[1]))
3657 else if (isDIGIT(s[1])) {
3659 while (s[1] && isDIGIT(s[1]))
3669 if (strchr("aA01! ",last_un_char))
3671 if (strchr("zZ79~",s[1]))
3673 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3674 weight -= 5; /* cope with negative subscript */
3677 if (!isALNUM(last_un_char)
3678 && !(last_un_char == '$' || last_un_char == '@'
3679 || last_un_char == '&')
3680 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3685 if (keyword(tmpbuf, d - tmpbuf, 0))
3688 if (un_char == last_un_char + 1)
3690 weight -= seen[un_char];
3695 if (weight >= 0) /* probably a character class */
3705 * Does all the checking to disambiguate
3707 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3708 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3710 * First argument is the stuff after the first token, e.g. "bar".
3712 * Not a method if bar is a filehandle.
3713 * Not a method if foo is a subroutine prototyped to take a filehandle.
3714 * Not a method if it's really "Foo $bar"
3715 * Method if it's "foo $bar"
3716 * Not a method if it's really "print foo $bar"
3717 * Method if it's really "foo package::" (interpreted as package->foo)
3718 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3719 * Not a method if bar is a filehandle or package, but is quoted with
3724 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3727 char *s = start + (*start == '$');
3728 char tmpbuf[sizeof PL_tokenbuf];
3735 PERL_ARGS_ASSERT_INTUIT_METHOD;
3738 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3742 const char *proto = CvPROTO(cv);
3753 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3754 /* start is the beginning of the possible filehandle/object,
3755 * and s is the end of it
3756 * tmpbuf is a copy of it
3759 if (*start == '$') {
3760 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3761 isUPPER(*PL_tokenbuf))
3764 len = start - SvPVX(PL_linestr);
3768 start = SvPVX(PL_linestr) + len;
3772 return *s == '(' ? FUNCMETH : METHOD;
3774 if (!keyword(tmpbuf, len, 0)) {
3775 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3779 soff = s - SvPVX(PL_linestr);
3783 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3784 if (indirgv && GvCVu(indirgv))
3786 /* filehandle or package name makes it a method */
3787 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3789 soff = s - SvPVX(PL_linestr);
3792 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3793 return 0; /* no assumptions -- "=>" quotes bareword */
3795 start_force(PL_curforce);
3796 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3797 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3798 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3800 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
3801 ( UTF ? SVf_UTF8 : 0 )));
3806 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
3808 return *s == '(' ? FUNCMETH : METHOD;
3814 /* Encoded script support. filter_add() effectively inserts a
3815 * 'pre-processing' function into the current source input stream.
3816 * Note that the filter function only applies to the current source file
3817 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3819 * The datasv parameter (which may be NULL) can be used to pass
3820 * private data to this instance of the filter. The filter function
3821 * can recover the SV using the FILTER_DATA macro and use it to
3822 * store private buffers and state information.
3824 * The supplied datasv parameter is upgraded to a PVIO type
3825 * and the IoDIRP/IoANY field is used to store the function pointer,
3826 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3827 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3828 * private use must be set using malloc'd pointers.
3832 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3841 if (!PL_rsfp_filters)
3842 PL_rsfp_filters = newAV();
3845 SvUPGRADE(datasv, SVt_PVIO);
3846 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3847 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3848 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3849 FPTR2DPTR(void *, IoANY(datasv)),
3850 SvPV_nolen(datasv)));
3851 av_unshift(PL_rsfp_filters, 1);
3852 av_store(PL_rsfp_filters, 0, datasv) ;
3857 /* Delete most recently added instance of this filter function. */
3859 Perl_filter_del(pTHX_ filter_t funcp)
3864 PERL_ARGS_ASSERT_FILTER_DEL;
3867 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3868 FPTR2DPTR(void*, funcp)));
3870 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3872 /* if filter is on top of stack (usual case) just pop it off */
3873 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3874 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3875 sv_free(av_pop(PL_rsfp_filters));
3879 /* we need to search for the correct entry and clear it */
3880 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3884 /* Invoke the idxth filter function for the current rsfp. */
3885 /* maxlen 0 = read one text line */
3887 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
3892 /* This API is bad. It should have been using unsigned int for maxlen.
3893 Not sure if we want to change the API, but if not we should sanity
3894 check the value here. */
3895 const unsigned int correct_length
3904 PERL_ARGS_ASSERT_FILTER_READ;
3906 if (!PL_parser || !PL_rsfp_filters)
3908 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
3909 /* Provide a default input filter to make life easy. */
3910 /* Note that we append to the line. This is handy. */
3911 DEBUG_P(PerlIO_printf(Perl_debug_log,
3912 "filter_read %d: from rsfp\n", idx));
3913 if (correct_length) {
3916 const int old_len = SvCUR(buf_sv);
3918 /* ensure buf_sv is large enough */
3919 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
3920 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
3921 correct_length)) <= 0) {
3922 if (PerlIO_error(PL_rsfp))
3923 return -1; /* error */
3925 return 0 ; /* end of file */
3927 SvCUR_set(buf_sv, old_len + len) ;
3928 SvPVX(buf_sv)[old_len + len] = '\0';
3931 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
3932 if (PerlIO_error(PL_rsfp))
3933 return -1; /* error */
3935 return 0 ; /* end of file */
3938 return SvCUR(buf_sv);
3940 /* Skip this filter slot if filter has been deleted */
3941 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
3942 DEBUG_P(PerlIO_printf(Perl_debug_log,
3943 "filter_read %d: skipped (filter deleted)\n",
3945 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
3947 /* Get function pointer hidden within datasv */
3948 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
3949 DEBUG_P(PerlIO_printf(Perl_debug_log,
3950 "filter_read %d: via function %p (%s)\n",
3951 idx, (void*)datasv, SvPV_nolen_const(datasv)));
3952 /* Call function. The function is expected to */
3953 /* call "FILTER_READ(idx+1, buf_sv)" first. */
3954 /* Return: <0:error, =0:eof, >0:not eof */
3955 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
3959 S_filter_gets(pTHX_ register SV *sv, STRLEN append)
3963 PERL_ARGS_ASSERT_FILTER_GETS;
3965 #ifdef PERL_CR_FILTER
3966 if (!PL_rsfp_filters) {
3967 filter_add(S_cr_textfilter,NULL);
3970 if (PL_rsfp_filters) {
3972 SvCUR_set(sv, 0); /* start with empty line */
3973 if (FILTER_READ(0, sv, 0) > 0)
3974 return ( SvPVX(sv) ) ;
3979 return (sv_gets(sv, PL_rsfp, append));
3983 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
3988 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
3990 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3994 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3995 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
3997 return GvHV(gv); /* Foo:: */
4000 /* use constant CLASS => 'MyClass' */
4001 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4002 if (gv && GvCV(gv)) {
4003 SV * const sv = cv_const_sv(GvCV(gv));
4005 pkgname = SvPV_const(sv, len);
4008 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4012 * S_readpipe_override
4013 * Check whether readpipe() is overridden, and generates the appropriate
4014 * optree, provided sublex_start() is called afterwards.
4017 S_readpipe_override(pTHX)
4020 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4021 pl_yylval.ival = OP_BACKTICK;
4023 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4025 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4026 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4027 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4029 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4030 op_append_elem(OP_LIST,
4031 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4032 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4039 * The intent of this yylex wrapper is to minimize the changes to the
4040 * tokener when we aren't interested in collecting madprops. It remains
4041 * to be seen how successful this strategy will be...
4048 char *s = PL_bufptr;
4050 /* make sure PL_thiswhite is initialized */
4054 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
4055 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4056 return S_pending_ident(aTHX);
4058 /* previous token ate up our whitespace? */
4059 if (!PL_lasttoke && PL_nextwhite) {
4060 PL_thiswhite = PL_nextwhite;
4064 /* isolate the token, and figure out where it is without whitespace */
4065 PL_realtokenstart = -1;
4069 assert(PL_curforce < 0);
4071 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4072 if (!PL_thistoken) {
4073 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4074 PL_thistoken = newSVpvs("");
4076 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4077 PL_thistoken = newSVpvn(tstart, s - tstart);
4080 if (PL_thismad) /* install head */
4081 CURMAD('X', PL_thistoken);
4084 /* last whitespace of a sublex? */
4085 if (optype == ')' && PL_endwhite) {
4086 CURMAD('X', PL_endwhite);
4091 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4092 if (!PL_thiswhite && !PL_endwhite && !optype) {
4093 sv_free(PL_thistoken);
4098 /* put off final whitespace till peg */
4099 if (optype == ';' && !PL_rsfp) {
4100 PL_nextwhite = PL_thiswhite;
4103 else if (PL_thisopen) {
4104 CURMAD('q', PL_thisopen);
4106 sv_free(PL_thistoken);
4110 /* Store actual token text as madprop X */
4111 CURMAD('X', PL_thistoken);
4115 /* add preceding whitespace as madprop _ */
4116 CURMAD('_', PL_thiswhite);
4120 /* add quoted material as madprop = */
4121 CURMAD('=', PL_thisstuff);
4125 /* add terminating quote as madprop Q */
4126 CURMAD('Q', PL_thisclose);
4130 /* special processing based on optype */
4134 /* opval doesn't need a TOKEN since it can already store mp */
4144 if (pl_yylval.opval)
4145 append_madprops(PL_thismad, pl_yylval.opval, 0);
4153 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4162 /* remember any fake bracket that lexer is about to discard */
4163 if (PL_lex_brackets == 1 &&
4164 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4167 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4170 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4171 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4174 break; /* don't bother looking for trailing comment */
4183 /* attach a trailing comment to its statement instead of next token */
4187 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4189 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4191 if (*s == '\n' || *s == '#') {
4192 while (s < PL_bufend && *s != '\n')
4196 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4197 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4214 /* Create new token struct. Note: opvals return early above. */
4215 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4222 S_tokenize_use(pTHX_ int is_use, char *s) {
4225 PERL_ARGS_ASSERT_TOKENIZE_USE;
4227 if (PL_expect != XSTATE)
4228 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4229 is_use ? "use" : "no"));
4231 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4232 s = force_version(s, TRUE);
4233 if (*s == ';' || *s == '}'
4234 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4235 start_force(PL_curforce);
4236 NEXTVAL_NEXTTOKE.opval = NULL;
4239 else if (*s == 'v') {
4240 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4241 s = force_version(s, FALSE);
4245 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4246 s = force_version(s, FALSE);
4248 pl_yylval.ival = is_use;
4252 static const char* const exp_name[] =
4253 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4254 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4258 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4260 S_word_takes_any_delimeter(char *p, STRLEN len)
4262 return (len == 1 && strchr("msyq", p[0])) ||
4264 (p[0] == 't' && p[1] == 'r') ||
4265 (p[0] == 'q' && strchr("qwxr", p[1]))));
4271 Works out what to call the token just pulled out of the input
4272 stream. The yacc parser takes care of taking the ops we return and
4273 stitching them into a tree.
4279 if read an identifier
4280 if we're in a my declaration
4281 croak if they tried to say my($foo::bar)
4282 build the ops for a my() declaration
4283 if it's an access to a my() variable
4284 are we in a sort block?
4285 croak if my($a); $a <=> $b
4286 build ops for access to a my() variable
4287 if in a dq string, and they've said @foo and we can't find @foo
4289 build ops for a bareword
4290 if we already built the token before, use it.
4295 #pragma segment Perl_yylex
4301 register char *s = PL_bufptr;
4307 /* orig_keyword, gvp, and gv are initialized here because
4308 * jump to the label just_a_word_zero can bypass their
4309 * initialization later. */
4310 I32 orig_keyword = 0;
4315 SV* tmp = newSVpvs("");
4316 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4317 (IV)CopLINE(PL_curcop),
4318 lex_state_names[PL_lex_state],
4319 exp_name[PL_expect],
4320 pv_display(tmp, s, strlen(s), 0, 60));
4323 /* check if there's an identifier for us to look at */
4324 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4325 return REPORT(S_pending_ident(aTHX));
4327 /* no identifier pending identification */
4329 switch (PL_lex_state) {
4331 case LEX_NORMAL: /* Some compilers will produce faster */
4332 case LEX_INTERPNORMAL: /* code if we comment these out. */
4336 /* when we've already built the next token, just pull it out of the queue */
4340 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4342 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4343 PL_nexttoke[PL_lasttoke].next_mad = 0;
4344 if (PL_thismad && PL_thismad->mad_key == '_') {
4345 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4346 PL_thismad->mad_val = 0;
4347 mad_free(PL_thismad);
4352 PL_lex_state = PL_lex_defer;
4353 PL_expect = PL_lex_expect;
4354 PL_lex_defer = LEX_NORMAL;
4355 if (!PL_nexttoke[PL_lasttoke].next_type)
4360 pl_yylval = PL_nextval[PL_nexttoke];
4362 PL_lex_state = PL_lex_defer;
4363 PL_expect = PL_lex_expect;
4364 PL_lex_defer = LEX_NORMAL;
4370 next_type = PL_nexttoke[PL_lasttoke].next_type;
4372 next_type = PL_nexttype[PL_nexttoke];
4374 if (next_type & (7<<24)) {
4375 if (next_type & (1<<24)) {
4376 if (PL_lex_brackets > 100)
4377 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4378 PL_lex_brackstack[PL_lex_brackets++] =
4379 (char) ((next_type >> 16) & 0xff);
4381 if (next_type & (2<<24))
4382 PL_lex_allbrackets++;
4383 if (next_type & (4<<24))
4384 PL_lex_allbrackets--;
4385 next_type &= 0xffff;
4388 /* FIXME - can these be merged? */
4391 return REPORT(next_type);
4395 /* interpolated case modifiers like \L \U, including \Q and \E.
4396 when we get here, PL_bufptr is at the \
4398 case LEX_INTERPCASEMOD:
4400 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4401 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
4403 /* handle \E or end of string */
4404 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4406 if (PL_lex_casemods) {
4407 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4408 PL_lex_casestack[PL_lex_casemods] = '\0';
4410 if (PL_bufptr != PL_bufend
4411 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
4413 PL_lex_state = LEX_INTERPCONCAT;
4416 PL_thistoken = newSVpvs("\\E");
4419 PL_lex_allbrackets--;
4423 while (PL_bufptr != PL_bufend &&
4424 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4426 PL_thiswhite = newSVpvs("");
4427 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4431 if (PL_bufptr != PL_bufend)
4434 PL_lex_state = LEX_INTERPCONCAT;
4438 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4439 "### Saw case modifier\n"); });
4441 if (s[1] == '\\' && s[2] == 'E') {
4444 PL_thiswhite = newSVpvs("");
4445 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4448 PL_lex_state = LEX_INTERPCONCAT;
4453 if (!PL_madskills) /* when just compiling don't need correct */
4454 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4455 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4456 if ((*s == 'L' || *s == 'U') &&
4457 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
4458 PL_lex_casestack[--PL_lex_casemods] = '\0';
4459 PL_lex_allbrackets--;
4462 if (PL_lex_casemods > 10)
4463 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4464 PL_lex_casestack[PL_lex_casemods++] = *s;
4465 PL_lex_casestack[PL_lex_casemods] = '\0';
4466 PL_lex_state = LEX_INTERPCONCAT;
4467 start_force(PL_curforce);
4468 NEXTVAL_NEXTTOKE.ival = 0;
4469 force_next((2<<24)|'(');
4470 start_force(PL_curforce);
4472 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4474 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4476 NEXTVAL_NEXTTOKE.ival = OP_LC;
4478 NEXTVAL_NEXTTOKE.ival = OP_UC;
4480 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4482 Perl_croak(aTHX_ "panic: yylex");
4484 SV* const tmpsv = newSVpvs("\\ ");
4485 /* replace the space with the character we want to escape
4487 SvPVX(tmpsv)[1] = *s;
4493 if (PL_lex_starts) {
4499 sv_free(PL_thistoken);
4500 PL_thistoken = newSVpvs("");
4503 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4504 if (PL_lex_casemods == 1 && PL_lex_inpat)
4513 case LEX_INTERPPUSH:
4514 return REPORT(sublex_push());
4516 case LEX_INTERPSTART:
4517 if (PL_bufptr == PL_bufend)
4518 return REPORT(sublex_done());
4519 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4520 "### Interpolated variable\n"); });
4522 PL_lex_dojoin = (*PL_bufptr == '@');
4523 PL_lex_state = LEX_INTERPNORMAL;
4524 if (PL_lex_dojoin) {
4525 start_force(PL_curforce);
4526 NEXTVAL_NEXTTOKE.ival = 0;
4528 start_force(PL_curforce);
4529 force_ident("\"", '$');
4530 start_force(PL_curforce);
4531 NEXTVAL_NEXTTOKE.ival = 0;
4533 start_force(PL_curforce);
4534 NEXTVAL_NEXTTOKE.ival = 0;
4535 force_next((2<<24)|'(');
4536 start_force(PL_curforce);
4537 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4540 if (PL_lex_starts++) {
4545 sv_free(PL_thistoken);
4546 PL_thistoken = newSVpvs("");
4549 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4550 if (!PL_lex_casemods && PL_lex_inpat)
4557 case LEX_INTERPENDMAYBE:
4558 if (intuit_more(PL_bufptr)) {
4559 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4565 if (PL_lex_dojoin) {
4566 PL_lex_dojoin = FALSE;
4567 PL_lex_state = LEX_INTERPCONCAT;
4571 sv_free(PL_thistoken);
4572 PL_thistoken = newSVpvs("");
4575 PL_lex_allbrackets--;
4578 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4579 && SvEVALED(PL_lex_repl))
4581 if (PL_bufptr != PL_bufend)
4582 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4586 case LEX_INTERPCONCAT:
4588 if (PL_lex_brackets)
4589 Perl_croak(aTHX_ "panic: INTERPCONCAT");
4591 if (PL_bufptr == PL_bufend)
4592 return REPORT(sublex_done());
4594 if (SvIVX(PL_linestr) == '\'') {
4595 SV *sv = newSVsv(PL_linestr);
4598 else if ( PL_hints & HINT_NEW_RE )
4599 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
4600 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4604 s = scan_const(PL_bufptr);
4606 PL_lex_state = LEX_INTERPCASEMOD;
4608 PL_lex_state = LEX_INTERPSTART;
4611 if (s != PL_bufptr) {
4612 start_force(PL_curforce);
4614 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
4616 NEXTVAL_NEXTTOKE = pl_yylval;
4619 if (PL_lex_starts++) {
4623 sv_free(PL_thistoken);
4624 PL_thistoken = newSVpvs("");
4627 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4628 if (!PL_lex_casemods && PL_lex_inpat)
4641 PL_lex_state = LEX_NORMAL;
4642 s = scan_formline(PL_bufptr);
4643 if (!PL_lex_formbrack)
4649 PL_oldoldbufptr = PL_oldbufptr;
4655 sv_free(PL_thistoken);
4658 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
4662 if (isIDFIRST_lazy_if(s,UTF))
4665 unsigned char c = *s;
4666 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4667 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4668 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4673 Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
4677 goto fake_eof; /* emulate EOF on ^D or ^Z */
4686 if (PL_lex_brackets &&
4687 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4688 yyerror((const char *)
4690 ? "Format not terminated"
4691 : "Missing right curly or square bracket"));
4693 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4694 "### Tokener got EOF\n");
4698 if (s++ < PL_bufend)
4699 goto retry; /* ignore stray nulls */
4702 if (!PL_in_eval && !PL_preambled) {
4703 PL_preambled = TRUE;
4709 /* Generate a string of Perl code to load the debugger.
4710 * If PERL5DB is set, it will return the contents of that,
4711 * otherwise a compile-time require of perl5db.pl. */
4713 const char * const pdb = PerlEnv_getenv("PERL5DB");
4716 sv_setpv(PL_linestr, pdb);
4717 sv_catpvs(PL_linestr,";");
4719 SETERRNO(0,SS_NORMAL);
4720 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4723 sv_setpvs(PL_linestr,"");
4724 if (PL_preambleav) {
4725 SV **svp = AvARRAY(PL_preambleav);
4726 SV **const end = svp + AvFILLp(PL_preambleav);
4728 sv_catsv(PL_linestr, *svp);
4730 sv_catpvs(PL_linestr, ";");
4732 sv_free(MUTABLE_SV(PL_preambleav));
4733 PL_preambleav = NULL;
4736 sv_catpvs(PL_linestr,
4737 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4738 if (PL_minus_n || PL_minus_p) {
4739 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4741 sv_catpvs(PL_linestr,"chomp;");
4744 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4745 || *PL_splitstr == '"')
4746 && strchr(PL_splitstr + 1, *PL_splitstr))
4747 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4749 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4750 bytes can be used as quoting characters. :-) */
4751 const char *splits = PL_splitstr;
4752 sv_catpvs(PL_linestr, "our @F=split(q\0");
4755 if (*splits == '\\')
4756 sv_catpvn(PL_linestr, splits, 1);
4757 sv_catpvn(PL_linestr, splits, 1);
4758 } while (*splits++);
4759 /* This loop will embed the trailing NUL of
4760 PL_linestr as the last thing it does before
4762 sv_catpvs(PL_linestr, ");");
4766 sv_catpvs(PL_linestr,"our @F=split(' ');");
4769 sv_catpvs(PL_linestr, "\n");
4770 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4771 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4772 PL_last_lop = PL_last_uni = NULL;
4773 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4774 update_debugger_info(PL_linestr, NULL, 0);
4779 bof = PL_rsfp ? TRUE : FALSE;
4782 fake_eof = LEX_FAKE_EOF;
4784 PL_bufptr = PL_bufend;
4785 CopLINE_inc(PL_curcop);
4786 if (!lex_next_chunk(fake_eof)) {
4787 CopLINE_dec(PL_curcop);
4789 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4791 CopLINE_dec(PL_curcop);
4794 PL_realtokenstart = -1;
4797 /* If it looks like the start of a BOM or raw UTF-16,
4798 * check if it in fact is. */
4799 if (bof && PL_rsfp &&
4804 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4805 bof = (offset == (Off_t)SvCUR(PL_linestr));
4806 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4807 /* offset may include swallowed CR */
4809 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4812 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4813 s = swallow_bom((U8*)s);
4816 if (PL_parser->in_pod) {
4817 /* Incest with pod. */
4820 sv_catsv(PL_thiswhite, PL_linestr);
4822 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4823 sv_setpvs(PL_linestr, "");
4824 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4825 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4826 PL_last_lop = PL_last_uni = NULL;
4827 PL_parser->in_pod = 0;
4832 } while (PL_parser->in_pod);
4833 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4834 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4835 PL_last_lop = PL_last_uni = NULL;
4836 if (CopLINE(PL_curcop) == 1) {
4837 while (s < PL_bufend && isSPACE(*s))
4839 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4843 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
4847 if (*s == '#' && *(s+1) == '!')
4849 #ifdef ALTERNATE_SHEBANG
4851 static char const as[] = ALTERNATE_SHEBANG;
4852 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4853 d = s + (sizeof(as) - 1);
4855 #endif /* ALTERNATE_SHEBANG */
4864 while (*d && !isSPACE(*d))
4868 #ifdef ARG_ZERO_IS_SCRIPT
4869 if (ipathend > ipath) {
4871 * HP-UX (at least) sets argv[0] to the script name,
4872 * which makes $^X incorrect. And Digital UNIX and Linux,
4873 * at least, set argv[0] to the basename of the Perl
4874 * interpreter. So, having found "#!", we'll set it right.
4876 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4878 assert(SvPOK(x) || SvGMAGICAL(x));
4879 if (sv_eq(x, CopFILESV(PL_curcop))) {
4880 sv_setpvn(x, ipath, ipathend - ipath);
4886 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
4887 const char * const lstart = SvPV_const(x,llen);
4889 bstart += blen - llen;
4890 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4891 sv_setpvn(x, ipath, ipathend - ipath);
4896 TAINT_NOT; /* $^X is always tainted, but that's OK */
4898 #endif /* ARG_ZERO_IS_SCRIPT */
4903 d = instr(s,"perl -");
4905 d = instr(s,"perl");
4907 /* avoid getting into infinite loops when shebang
4908 * line contains "Perl" rather than "perl" */
4910 for (d = ipathend-4; d >= ipath; --d) {
4911 if ((*d == 'p' || *d == 'P')
4912 && !ibcmp(d, "perl", 4))
4922 #ifdef ALTERNATE_SHEBANG
4924 * If the ALTERNATE_SHEBANG on this system starts with a
4925 * character that can be part of a Perl expression, then if
4926 * we see it but not "perl", we're probably looking at the
4927 * start of Perl code, not a request to hand off to some
4928 * other interpreter. Similarly, if "perl" is there, but
4929 * not in the first 'word' of the line, we assume the line
4930 * contains the start of the Perl program.
4932 if (d && *s != '#') {
4933 const char *c = ipath;
4934 while (*c && !strchr("; \t\r\n\f\v#", *c))
4937 d = NULL; /* "perl" not in first word; ignore */
4939 *s = '#'; /* Don't try to parse shebang line */
4941 #endif /* ALTERNATE_SHEBANG */
4946 !instr(s,"indir") &&
4947 instr(PL_origargv[0],"perl"))
4954 while (s < PL_bufend && isSPACE(*s))
4956 if (s < PL_bufend) {
4957 Newx(newargv,PL_origargc+3,char*);
4959 while (s < PL_bufend && !isSPACE(*s))
4962 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4965 newargv = PL_origargv;
4968 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4970 Perl_croak(aTHX_ "Can't exec %s", ipath);
4973 while (*d && !isSPACE(*d))
4975 while (SPACE_OR_TAB(*d))
4979 const bool switches_done = PL_doswitches;
4980 const U32 oldpdb = PL_perldb;
4981 const bool oldn = PL_minus_n;
4982 const bool oldp = PL_minus_p;
4986 bool baduni = FALSE;
4988 const char *d2 = d1 + 1;
4989 if (parse_unicode_opts((const char **)&d2)
4993 if (baduni || *d1 == 'M' || *d1 == 'm') {
4994 const char * const m = d1;
4995 while (*d1 && !isSPACE(*d1))
4997 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5000 d1 = moreswitches(d1);
5002 if (PL_doswitches && !switches_done) {
5003 int argc = PL_origargc;
5004 char **argv = PL_origargv;
5007 } while (argc && argv[0][0] == '-' && argv[0][1]);
5008 init_argv_symbols(argc,argv);
5010 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5011 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5012 /* if we have already added "LINE: while (<>) {",
5013 we must not do it again */
5015 sv_setpvs(PL_linestr, "");
5016 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5017 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5018 PL_last_lop = PL_last_uni = NULL;
5019 PL_preambled = FALSE;
5020 if (PERLDB_LINE || PERLDB_SAVESRC)
5021 (void)gv_fetchfile(PL_origfilename);
5028 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5030 PL_lex_state = LEX_FORMLINE;
5035 #ifdef PERL_STRICT_CR
5036 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5038 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5040 case ' ': case '\t': case '\f': case 013:
5042 PL_realtokenstart = -1;
5044 PL_thiswhite = newSVpvs("");
5045 sv_catpvn(PL_thiswhite, s, 1);
5052 PL_realtokenstart = -1;
5056 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
5057 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
5058 /* handle eval qq[#line 1 "foo"\n ...] */
5059 CopLINE_dec(PL_curcop);
5062 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5064 if (!PL_in_eval || PL_rsfp)
5069 while (d < PL_bufend && *d != '\n')
5073 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5074 Perl_croak(aTHX_ "panic: input overflow");
5077 PL_thiswhite = newSVpvn(s, d - s);
5082 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5084 PL_lex_state = LEX_FORMLINE;
5090 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5091 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5094 TOKEN(PEG); /* make sure any #! line is accessible */
5099 /* if (PL_madskills && PL_lex_formbrack) { */
5101 while (d < PL_bufend && *d != '\n')
5105 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5106 Perl_croak(aTHX_ "panic: input overflow");
5107 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5109 PL_thiswhite = newSVpvs("");
5110 if (CopLINE(PL_curcop) == 1) {
5111 sv_setpvs(PL_thiswhite, "");
5114 sv_catpvn(PL_thiswhite, s, d - s);
5128 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
5136 while (s < PL_bufend && SPACE_OR_TAB(*s))
5139 if (strnEQ(s,"=>",2)) {
5140 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
5141 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5142 OPERATOR('-'); /* unary minus */
5144 PL_last_uni = PL_oldbufptr;
5146 case 'r': ftst = OP_FTEREAD; break;
5147 case 'w': ftst = OP_FTEWRITE; break;
5148 case 'x': ftst = OP_FTEEXEC; break;
5149 case 'o': ftst = OP_FTEOWNED; break;
5150 case 'R': ftst = OP_FTRREAD; break;
5151 case 'W': ftst = OP_FTRWRITE; break;
5152 case 'X': ftst = OP_FTREXEC; break;
5153 case 'O': ftst = OP_FTROWNED; break;
5154 case 'e': ftst = OP_FTIS; break;
5155 case 'z': ftst = OP_FTZERO; break;
5156 case 's': ftst = OP_FTSIZE; break;
5157 case 'f': ftst = OP_FTFILE; break;
5158 case 'd': ftst = OP_FTDIR; break;
5159 case 'l': ftst = OP_FTLINK; break;
5160 case 'p': ftst = OP_FTPIPE; break;
5161 case 'S': ftst = OP_FTSOCK; break;
5162 case 'u': ftst = OP_FTSUID; break;
5163 case 'g': ftst = OP_FTSGID; break;
5164 case 'k': ftst = OP_FTSVTX; break;
5165 case 'b': ftst = OP_FTBLK; break;
5166 case 'c': ftst = OP_FTCHR; break;
5167 case 't': ftst = OP_FTTTY; break;
5168 case 'T': ftst = OP_FTTEXT; break;
5169 case 'B': ftst = OP_FTBINARY; break;
5170 case 'M': case 'A': case 'C':
5171 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5173 case 'M': ftst = OP_FTMTIME; break;
5174 case 'A': ftst = OP_FTATIME; break;
5175 case 'C': ftst = OP_FTCTIME; break;
5183 PL_last_lop_op = (OPCODE)ftst;
5184 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5185 "### Saw file test %c\n", (int)tmp);
5190 /* Assume it was a minus followed by a one-letter named
5191 * subroutine call (or a -bareword), then. */
5192 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5193 "### '-%c' looked like a file test but was not\n",
5200 const char tmp = *s++;
5203 if (PL_expect == XOPERATOR)
5208 else if (*s == '>') {
5211 if (isIDFIRST_lazy_if(s,UTF)) {
5212 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
5220 if (PL_expect == XOPERATOR) {
5221 if (*s == '=' && !PL_lex_allbrackets &&
5222 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5229 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5231 OPERATOR('-'); /* unary minus */
5237 const char tmp = *s++;
5240 if (PL_expect == XOPERATOR)
5245 if (PL_expect == XOPERATOR) {
5246 if (*s == '=' && !PL_lex_allbrackets &&
5247 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5254 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5261 if (PL_expect != XOPERATOR) {
5262 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5263 PL_expect = XOPERATOR;
5264 force_ident(PL_tokenbuf, '*');
5272 if (*s == '=' && !PL_lex_allbrackets &&
5273 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5279 if (*s == '=' && !PL_lex_allbrackets &&
5280 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5287 if (PL_expect == XOPERATOR) {
5288 if (s[1] == '=' && !PL_lex_allbrackets &&
5289 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5294 PL_tokenbuf[0] = '%';
5295 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5296 sizeof PL_tokenbuf - 1, FALSE);
5297 if (!PL_tokenbuf[1]) {
5300 PL_pending_ident = '%';
5304 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5305 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5310 if (PL_lex_brackets > 100)
5311 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5312 PL_lex_brackstack[PL_lex_brackets++] = 0;
5313 PL_lex_allbrackets++;
5315 const char tmp = *s++;
5320 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5322 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5330 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5337 goto just_a_word_zero_gv;
5340 switch (PL_expect) {
5346 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5348 PL_bufptr = s; /* update in case we back off */
5351 "Use of := for an empty attribute list is not allowed");
5358 PL_expect = XTERMBLOCK;
5361 stuffstart = s - SvPVX(PL_linestr) - 1;
5365 while (isIDFIRST_lazy_if(s,UTF)) {
5368 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5369 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5370 if (tmp < 0) tmp = -tmp;
5385 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5387 d = scan_str(d,TRUE,TRUE);
5389 /* MUST advance bufptr here to avoid bogus
5390 "at end of line" context messages from yyerror().
5392 PL_bufptr = s + len;
5393 yyerror("Unterminated attribute parameter in attribute list");
5397 return REPORT(0); /* EOF indicator */
5401 sv_catsv(sv, PL_lex_stuff);
5402 attrs = op_append_elem(OP_LIST, attrs,
5403 newSVOP(OP_CONST, 0, sv));
5404 SvREFCNT_dec(PL_lex_stuff);
5405 PL_lex_stuff = NULL;
5408 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5410 if (PL_in_my == KEY_our) {
5411 deprecate(":unique");
5414 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5417 /* NOTE: any CV attrs applied here need to be part of
5418 the CVf_BUILTIN_ATTRS define in cv.h! */
5419 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5421 CvLVALUE_on(PL_compcv);
5423 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5425 deprecate(":locked");
5427 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5429 CvMETHOD_on(PL_compcv);
5431 /* After we've set the flags, it could be argued that
5432 we don't need to do the attributes.pm-based setting
5433 process, and shouldn't bother appending recognized
5434 flags. To experiment with that, uncomment the
5435 following "else". (Note that's already been
5436 uncommented. That keeps the above-applied built-in
5437 attributes from being intercepted (and possibly
5438 rejected) by a package's attribute routines, but is
5439 justified by the performance win for the common case
5440 of applying only built-in attributes.) */
5442 attrs = op_append_elem(OP_LIST, attrs,
5443 newSVOP(OP_CONST, 0,
5447 if (*s == ':' && s[1] != ':')
5450 break; /* require real whitespace or :'s */
5451 /* XXX losing whitespace on sequential attributes here */
5455 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5456 if (*s != ';' && *s != '}' && *s != tmp
5457 && (tmp != '=' || *s != ')')) {
5458 const char q = ((*s == '\'') ? '"' : '\'');
5459 /* If here for an expression, and parsed no attrs, back
5461 if (tmp == '=' && !attrs) {
5465 /* MUST advance bufptr here to avoid bogus "at end of line"
5466 context messages from yyerror().
5469 yyerror( (const char *)
5471 ? Perl_form(aTHX_ "Invalid separator character "
5472 "%c%c%c in attribute list", q, *s, q)
5473 : "Unterminated attribute list" ) );
5481 start_force(PL_curforce);
5482 NEXTVAL_NEXTTOKE.opval = attrs;
5483 CURMAD('_', PL_nextwhite);
5488 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
5489 (s - SvPVX(PL_linestr)) - stuffstart);
5494 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5498 PL_lex_allbrackets--;
5502 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5503 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5507 PL_lex_allbrackets++;
5510 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5516 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5519 PL_lex_allbrackets--;
5525 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5528 if (PL_lex_brackets <= 0)
5529 yyerror("Unmatched right square bracket");
5532 PL_lex_allbrackets--;
5533 if (PL_lex_state == LEX_INTERPNORMAL) {
5534 if (PL_lex_brackets == 0) {
5535 if (*s == '-' && s[1] == '>')
5536 PL_lex_state = LEX_INTERPENDMAYBE;
5537 else if (*s != '[' && *s != '{')
5538 PL_lex_state = LEX_INTERPEND;
5545 if (PL_lex_brackets > 100) {
5546 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5548 switch (PL_expect) {
5550 if (PL_lex_formbrack) {
5554 if (PL_oldoldbufptr == PL_last_lop)
5555 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5557 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5558 PL_lex_allbrackets++;
5559 OPERATOR(HASHBRACK);
5561 while (s < PL_bufend && SPACE_OR_TAB(*s))
5564 PL_tokenbuf[0] = '\0';
5565 if (d < PL_bufend && *d == '-') {
5566 PL_tokenbuf[0] = '-';
5568 while (d < PL_bufend && SPACE_OR_TAB(*d))
5571 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5572 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5574 while (d < PL_bufend && SPACE_OR_TAB(*d))
5577 const char minus = (PL_tokenbuf[0] == '-');
5578 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
5586 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5587 PL_lex_allbrackets++;
5592 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5593 PL_lex_allbrackets++;
5598 if (PL_oldoldbufptr == PL_last_lop)
5599 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5601 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5602 PL_lex_allbrackets++;
5605 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5607 /* This hack is to get the ${} in the message. */
5609 yyerror("syntax error");
5612 OPERATOR(HASHBRACK);
5614 /* This hack serves to disambiguate a pair of curlies
5615 * as being a block or an anon hash. Normally, expectation
5616 * determines that, but in cases where we're not in a
5617 * position to expect anything in particular (like inside
5618 * eval"") we have to resolve the ambiguity. This code
5619 * covers the case where the first term in the curlies is a
5620 * quoted string. Most other cases need to be explicitly
5621 * disambiguated by prepending a "+" before the opening
5622 * curly in order to force resolution as an anon hash.
5624 * XXX should probably propagate the outer expectation
5625 * into eval"" to rely less on this hack, but that could
5626 * potentially break current behavior of eval"".
5630 if (*s == '\'' || *s == '"' || *s == '`') {
5631 /* common case: get past first string, handling escapes */
5632 for (t++; t < PL_bufend && *t != *s;)
5633 if (*t++ == '\\' && (*t == '\\' || *t == *s))
5637 else if (*s == 'q') {
5640 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5643 /* skip q//-like construct */
5645 char open, close, term;
5648 while (t < PL_bufend && isSPACE(*t))
5650 /* check for q => */
5651 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5652 OPERATOR(HASHBRACK);
5656 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5660 for (t++; t < PL_bufend; t++) {
5661 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5663 else if (*t == open)
5667 for (t++; t < PL_bufend; t++) {
5668 if (*t == '\\' && t+1 < PL_bufend)
5670 else if (*t == close && --brackets <= 0)
5672 else if (*t == open)
5679 /* skip plain q word */
5680 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5683 else if (isALNUM_lazy_if(t,UTF)) {
5685 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5688 while (t < PL_bufend && isSPACE(*t))
5690 /* if comma follows first term, call it an anon hash */
5691 /* XXX it could be a comma expression with loop modifiers */
5692 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5693 || (*t == '=' && t[1] == '>')))
5694 OPERATOR(HASHBRACK);
5695 if (PL_expect == XREF)
5698 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5704 pl_yylval.ival = CopLINE(PL_curcop);
5705 if (isSPACE(*s) || *s == '#')
5706 PL_copline = NOLINE; /* invalidate current command line number */
5709 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5713 if (PL_lex_brackets <= 0)
5714 yyerror("Unmatched right curly bracket");
5716 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5717 PL_lex_allbrackets--;
5718 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
5719 PL_lex_formbrack = 0;
5720 if (PL_lex_state == LEX_INTERPNORMAL) {
5721 if (PL_lex_brackets == 0) {
5722 if (PL_expect & XFAKEBRACK) {
5723 PL_expect &= XENUMMASK;
5724 PL_lex_state = LEX_INTERPEND;
5729 PL_thiswhite = newSVpvs("");
5730 sv_catpvs(PL_thiswhite,"}");
5733 return yylex(); /* ignore fake brackets */
5735 if (*s == '-' && s[1] == '>')
5736 PL_lex_state = LEX_INTERPENDMAYBE;
5737 else if (*s != '[' && *s != '{')
5738 PL_lex_state = LEX_INTERPEND;
5741 if (PL_expect & XFAKEBRACK) {
5742 PL_expect &= XENUMMASK;
5744 return yylex(); /* ignore fake brackets */
5746 start_force(PL_curforce);
5748 curmad('X', newSVpvn(s-1,1));
5749 CURMAD('_', PL_thiswhite);
5754 PL_thistoken = newSVpvs("");
5760 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5761 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5768 if (PL_expect == XOPERATOR) {
5769 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5770 && isIDFIRST_lazy_if(s,UTF))
5772 CopLINE_dec(PL_curcop);
5773 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5774 CopLINE_inc(PL_curcop);
5776 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5777 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5784 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5786 PL_expect = XOPERATOR;
5787 force_ident(PL_tokenbuf, '&');
5791 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5797 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5798 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5805 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5806 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5814 const char tmp = *s++;
5816 if (!PL_lex_allbrackets &&
5817 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5824 if (!PL_lex_allbrackets &&
5825 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5833 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5834 && strchr("+-*/%.^&|<",tmp))
5835 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5836 "Reversed %c= operator",(int)tmp);
5838 if (PL_expect == XSTATE && isALPHA(tmp) &&
5839 (s == PL_linestart+1 || s[-2] == '\n') )
5841 if (PL_in_eval && !PL_rsfp) {
5846 if (strnEQ(s,"=cut",4)) {
5862 PL_thiswhite = newSVpvs("");
5863 sv_catpvn(PL_thiswhite, PL_linestart,
5864 PL_bufend - PL_linestart);
5868 PL_parser->in_pod = 1;
5872 if (PL_lex_brackets < PL_lex_formbrack) {
5874 #ifdef PERL_STRICT_CR
5875 while (SPACE_OR_TAB(*t))
5877 while (SPACE_OR_TAB(*t) || *t == '\r')
5880 if (*t == '\n' || *t == '#') {
5886 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5895 const char tmp = *s++;
5897 /* was this !=~ where !~ was meant?
5898 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5900 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5901 const char *t = s+1;
5903 while (t < PL_bufend && isSPACE(*t))
5906 if (*t == '/' || *t == '?' ||
5907 ((*t == 'm' || *t == 's' || *t == 'y')
5908 && !isALNUM(t[1])) ||
5909 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
5910 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5911 "!=~ should be !~");
5913 if (!PL_lex_allbrackets &&
5914 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5926 if (PL_expect != XOPERATOR) {
5927 if (s[1] != '<' && !strchr(s,'>'))
5930 s = scan_heredoc(s);
5932 s = scan_inputsymbol(s);
5933 TERM(sublex_start());
5939 if (*s == '=' && !PL_lex_allbrackets &&
5940 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5944 SHop(OP_LEFT_SHIFT);
5949 if (!PL_lex_allbrackets &&
5950 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5957 if (!PL_lex_allbrackets &&
5958 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5966 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5974 const char tmp = *s++;
5976 if (*s == '=' && !PL_lex_allbrackets &&
5977 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5981 SHop(OP_RIGHT_SHIFT);
5983 else if (tmp == '=') {
5984 if (!PL_lex_allbrackets &&
5985 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5993 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6002 if (PL_expect == XOPERATOR) {
6003 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6004 return deprecate_commaless_var_list();
6008 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6009 PL_tokenbuf[0] = '@';
6010 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6011 sizeof PL_tokenbuf - 1, FALSE);
6012 if (PL_expect == XOPERATOR)
6013 no_op("Array length", s);
6014 if (!PL_tokenbuf[1])
6016 PL_expect = XOPERATOR;
6017 PL_pending_ident = '#';
6021 PL_tokenbuf[0] = '$';
6022 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6023 sizeof PL_tokenbuf - 1, FALSE);
6024 if (PL_expect == XOPERATOR)
6026 if (!PL_tokenbuf[1]) {
6028 yyerror("Final $ should be \\$ or $name");
6034 const char tmp = *s;
6035 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6038 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6039 && intuit_more(s)) {
6041 PL_tokenbuf[0] = '@';
6042 if (ckWARN(WARN_SYNTAX)) {
6045 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
6048 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6049 while (t < PL_bufend && *t != ']')
6051 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6052 "Multidimensional syntax %.*s not supported",
6053 (int)((t - PL_bufptr) + 1), PL_bufptr);
6057 else if (*s == '{') {
6059 PL_tokenbuf[0] = '%';
6060 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6061 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6063 char tmpbuf[sizeof PL_tokenbuf];
6066 } while (isSPACE(*t));
6067 if (isIDFIRST_lazy_if(t,UTF)) {
6069 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6073 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
6074 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6075 "You need to quote \"%s\"",
6082 PL_expect = XOPERATOR;
6083 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6084 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6085 if (!islop || PL_last_lop_op == OP_GREPSTART)
6086 PL_expect = XOPERATOR;
6087 else if (strchr("$@\"'`q", *s))
6088 PL_expect = XTERM; /* e.g. print $fh "foo" */
6089 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6090 PL_expect = XTERM; /* e.g. print $fh &sub */
6091 else if (isIDFIRST_lazy_if(s,UTF)) {
6092 char tmpbuf[sizeof PL_tokenbuf];
6094 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6095 if ((t2 = keyword(tmpbuf, len, 0))) {
6096 /* binary operators exclude handle interpretations */
6108 PL_expect = XTERM; /* e.g. print $fh length() */
6113 PL_expect = XTERM; /* e.g. print $fh subr() */
6116 else if (isDIGIT(*s))
6117 PL_expect = XTERM; /* e.g. print $fh 3 */
6118 else if (*s == '.' && isDIGIT(s[1]))
6119 PL_expect = XTERM; /* e.g. print $fh .3 */
6120 else if ((*s == '?' || *s == '-' || *s == '+')
6121 && !isSPACE(s[1]) && s[1] != '=')
6122 PL_expect = XTERM; /* e.g. print $fh -1 */
6123 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6125 PL_expect = XTERM; /* e.g. print $fh /.../
6126 XXX except DORDOR operator
6128 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6130 PL_expect = XTERM; /* print $fh <<"EOF" */
6133 PL_pending_ident = '$';
6137 if (PL_expect == XOPERATOR)
6139 PL_tokenbuf[0] = '@';
6140 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6141 if (!PL_tokenbuf[1]) {
6144 if (PL_lex_state == LEX_NORMAL)
6146 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6148 PL_tokenbuf[0] = '%';
6150 /* Warn about @ where they meant $. */
6151 if (*s == '[' || *s == '{') {
6152 if (ckWARN(WARN_SYNTAX)) {
6153 const char *t = s + 1;
6154 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6156 if (*t == '}' || *t == ']') {
6158 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6159 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6160 "Scalar value %.*s better written as $%.*s",
6161 (int)(t-PL_bufptr), PL_bufptr,
6162 (int)(t-PL_bufptr-1), PL_bufptr+1);
6167 PL_pending_ident = '@';
6170 case '/': /* may be division, defined-or, or pattern */
6171 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6172 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6173 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6178 case '?': /* may either be conditional or pattern */
6179 if (PL_expect == XOPERATOR) {
6182 if (!PL_lex_allbrackets &&
6183 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6187 PL_lex_allbrackets++;
6193 /* A // operator. */
6194 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6195 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6196 LEX_FAKEEOF_LOGIC)) {
6204 if (*s == '=' && !PL_lex_allbrackets &&
6205 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6214 /* Disable warning on "study /blah/" */
6215 if (PL_oldoldbufptr == PL_last_uni
6216 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6217 || memNE(PL_last_uni, "study", 5)
6218 || isALNUM_lazy_if(PL_last_uni+5,UTF)
6222 deprecate("?PATTERN? without explicit operator");
6223 s = scan_pat(s,OP_MATCH);
6224 TERM(sublex_start());
6228 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6229 #ifdef PERL_STRICT_CR
6232 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6234 && (s == PL_linestart || s[-1] == '\n') )
6236 PL_lex_formbrack = 0;
6240 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6244 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6247 if (!PL_lex_allbrackets &&
6248 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6255 pl_yylval.ival = OPf_SPECIAL;
6261 if (*s == '=' && !PL_lex_allbrackets &&
6262 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6269 case '0': case '1': case '2': case '3': case '4':
6270 case '5': case '6': case '7': case '8': case '9':
6271 s = scan_num(s, &pl_yylval);
6272 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6273 if (PL_expect == XOPERATOR)
6278 s = scan_str(s,!!PL_madskills,FALSE);
6279 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6280 if (PL_expect == XOPERATOR) {
6281 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6282 return deprecate_commaless_var_list();
6289 pl_yylval.ival = OP_CONST;
6290 TERM(sublex_start());
6293 s = scan_str(s,!!PL_madskills,FALSE);
6294 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6295 if (PL_expect == XOPERATOR) {
6296 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6297 return deprecate_commaless_var_list();
6304 pl_yylval.ival = OP_CONST;
6305 /* FIXME. I think that this can be const if char *d is replaced by
6306 more localised variables. */
6307 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6308 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6309 pl_yylval.ival = OP_STRINGIFY;
6313 TERM(sublex_start());
6316 s = scan_str(s,!!PL_madskills,FALSE);
6317 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6318 if (PL_expect == XOPERATOR)
6319 no_op("Backticks",s);
6322 readpipe_override();
6323 TERM(sublex_start());
6327 if (PL_lex_inwhat && isDIGIT(*s))
6328 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6330 if (PL_expect == XOPERATOR)
6331 no_op("Backslash",s);
6335 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6336 char *start = s + 2;
6337 while (isDIGIT(*start) || *start == '_')
6339 if (*start == '.' && isDIGIT(start[1])) {
6340 s = scan_num(s, &pl_yylval);
6343 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6344 else if (!isALPHA(*start) && (PL_expect == XTERM
6345 || PL_expect == XREF || PL_expect == XSTATE
6346 || PL_expect == XTERMORDORDOR)) {
6347 GV *const gv = gv_fetchpvn_flags(s, start - s,
6348 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6350 s = scan_num(s, &pl_yylval);
6357 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6400 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6402 /* Some keywords can be followed by any delimiter, including ':' */
6403 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6405 /* x::* is just a word, unless x is "CORE" */
6406 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6410 while (d < PL_bufend && isSPACE(*d))
6411 d++; /* no comments skipped here, or s### is misparsed */
6413 /* Is this a word before a => operator? */
6414 if (*d == '=' && d[1] == '>') {
6417 = (OP*)newSVOP(OP_CONST, 0,
6418 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6419 pl_yylval.opval->op_private = OPpCONST_BARE;
6423 /* Check for plugged-in keyword */
6427 char *saved_bufptr = PL_bufptr;
6429 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6431 if (result == KEYWORD_PLUGIN_DECLINE) {
6432 /* not a plugged-in keyword */
6433 PL_bufptr = saved_bufptr;
6434 } else if (result == KEYWORD_PLUGIN_STMT) {
6435 pl_yylval.opval = o;
6438 return REPORT(PLUGSTMT);
6439 } else if (result == KEYWORD_PLUGIN_EXPR) {
6440 pl_yylval.opval = o;
6442 PL_expect = XOPERATOR;
6443 return REPORT(PLUGEXPR);
6445 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6450 /* Check for built-in keyword */
6451 tmp = keyword(PL_tokenbuf, len, 0);
6453 /* Is this a label? */
6454 if (!anydelim && PL_expect == XSTATE
6455 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6457 pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
6462 if (tmp < 0) { /* second-class keyword? */
6463 GV *ogv = NULL; /* override (winner) */
6464 GV *hgv = NULL; /* hidden (loser) */
6465 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6467 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6468 UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
6471 if (GvIMPORTED_CV(gv))
6473 else if (! CvMETHOD(cv))
6477 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6478 UTF ? -(I32)len : (I32)len, FALSE)) &&
6479 (gv = *gvp) && isGV_with_GP(gv) &&
6480 GvCVu(gv) && GvIMPORTED_CV(gv))
6487 tmp = 0; /* overridden by import or by GLOBAL */
6490 && -tmp==KEY_lock /* XXX generalizable kludge */
6493 tmp = 0; /* any sub overrides "weak" keyword */
6495 else { /* no override */
6497 if (tmp == KEY_dump) {
6498 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6499 "dump() better written as CORE::dump()");
6503 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
6504 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6505 "Ambiguous call resolved as CORE::%s(), "
6506 "qualify as such or use &",
6514 default: /* not a keyword */
6515 /* Trade off - by using this evil construction we can pull the
6516 variable gv into the block labelled keylookup. If not, then
6517 we have to give it function scope so that the goto from the
6518 earlier ':' case doesn't bypass the initialisation. */
6520 just_a_word_zero_gv:
6528 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6532 SV *nextPL_nextwhite = 0;
6536 /* Get the rest if it looks like a package qualifier */
6538 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6540 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6543 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
6544 *s == '\'' ? "'" : "::");
6549 if (PL_expect == XOPERATOR) {
6550 if (PL_bufptr == PL_linestart) {
6551 CopLINE_dec(PL_curcop);
6552 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6553 CopLINE_inc(PL_curcop);
6556 no_op("Bareword",s);
6559 /* Look for a subroutine with this name in current package,
6560 unless name is "Foo::", in which case Foo is a bareword
6561 (and a package name). */
6563 if (len > 2 && !PL_madskills &&
6564 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6566 if (ckWARN(WARN_BAREWORD)
6567 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6568 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6569 "Bareword \"%s\" refers to nonexistent package",
6572 PL_tokenbuf[len] = '\0';
6578 /* Mustn't actually add anything to a symbol table.
6579 But also don't want to "initialise" any placeholder
6580 constants that might already be there into full
6581 blown PVGVs with attached PVCV. */
6582 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6583 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
6589 /* if we saw a global override before, get the right name */
6591 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6592 len ? len : strlen(PL_tokenbuf));
6594 SV * const tmp_sv = sv;
6595 sv = newSVpvs("CORE::GLOBAL::");
6596 sv_catsv(sv, tmp_sv);
6597 SvREFCNT_dec(tmp_sv);
6601 if (PL_madskills && !PL_thistoken) {
6602 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
6603 PL_thistoken = newSVpvn(start,s - start);
6604 PL_realtokenstart = s - SvPVX(PL_linestr);
6608 /* Presume this is going to be a bareword of some sort. */
6610 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6611 pl_yylval.opval->op_private = OPpCONST_BARE;
6613 /* And if "Foo::", then that's what it certainly is. */
6618 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6619 const_op->op_private = OPpCONST_BARE;
6620 rv2cv_op = newCVREF(0, const_op);
6622 cv = rv2cv_op_cv(rv2cv_op, 0);
6624 /* See if it's the indirect object for a list operator. */
6626 if (PL_oldoldbufptr &&
6627 PL_oldoldbufptr < PL_bufptr &&
6628 (PL_oldoldbufptr == PL_last_lop
6629 || PL_oldoldbufptr == PL_last_uni) &&
6630 /* NO SKIPSPACE BEFORE HERE! */
6631 (PL_expect == XREF ||
6632 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6634 bool immediate_paren = *s == '(';
6636 /* (Now we can afford to cross potential line boundary.) */
6637 s = SKIPSPACE2(s,nextPL_nextwhite);
6639 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
6642 /* Two barewords in a row may indicate method call. */
6644 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6645 (tmp = intuit_method(s, gv, cv))) {
6647 if (tmp == METHOD && !PL_lex_allbrackets &&
6648 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6649 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6653 /* If not a declared subroutine, it's an indirect object. */
6654 /* (But it's an indir obj regardless for sort.) */
6655 /* Also, if "_" follows a filetest operator, it's a bareword */
6658 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6660 (PL_last_lop_op != OP_MAPSTART &&
6661 PL_last_lop_op != OP_GREPSTART))))
6662 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6663 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6666 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6671 PL_expect = XOPERATOR;
6674 s = SKIPSPACE2(s,nextPL_nextwhite);
6675 PL_nextwhite = nextPL_nextwhite;
6680 /* Is this a word before a => operator? */
6681 if (*s == '=' && s[1] == '>' && !pkgname) {
6684 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
6685 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
6686 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
6690 /* If followed by a paren, it's certainly a subroutine. */
6695 while (SPACE_OR_TAB(*d))
6697 if (*d == ')' && (sv = cv_const_sv(cv))) {
6704 PL_nextwhite = PL_thiswhite;
6707 start_force(PL_curforce);
6709 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6710 PL_expect = XOPERATOR;
6713 PL_nextwhite = nextPL_nextwhite;
6714 curmad('X', PL_thistoken);
6715 PL_thistoken = newSVpvs("");
6724 /* If followed by var or block, call it a method (unless sub) */
6726 if ((*s == '$' || *s == '{') && !cv) {
6728 PL_last_lop = PL_oldbufptr;
6729 PL_last_lop_op = OP_METHOD;
6730 if (!PL_lex_allbrackets &&
6731 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6732 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6736 /* If followed by a bareword, see if it looks like indir obj. */
6739 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6740 && (tmp = intuit_method(s, gv, cv))) {
6742 if (tmp == METHOD && !PL_lex_allbrackets &&
6743 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6744 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6748 /* Not a method, so call it a subroutine (if defined) */
6751 if (lastchar == '-')
6752 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6753 "Ambiguous use of -%s resolved as -&%s()",
6754 PL_tokenbuf, PL_tokenbuf);
6755 /* Check for a constant sub */
6756 if ((sv = cv_const_sv(cv))) {
6759 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6760 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6761 pl_yylval.opval->op_private = 0;
6762 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6766 op_free(pl_yylval.opval);
6767 pl_yylval.opval = rv2cv_op;
6768 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6769 PL_last_lop = PL_oldbufptr;
6770 PL_last_lop_op = OP_ENTERSUB;
6771 /* Is there a prototype? */
6778 STRLEN protolen = CvPROTOLEN(cv);
6779 const char *proto = CvPROTO(cv);
6782 while (*proto == ';')
6787 *proto == '$' || *proto == '_'
6788 || *proto == '*' || *proto == '+'
6793 *proto == '\\' && proto[1] && proto[2] == '\0'
6797 if (*proto == '\\' && proto[1] == '[') {
6798 const char *p = proto + 2;
6799 while(*p && *p != ']')
6801 if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
6803 if (*proto == '&' && *s == '{') {
6805 sv_setpvs(PL_subname, "__ANON__");
6807 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6808 if (!PL_lex_allbrackets &&
6809 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6810 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6817 PL_nextwhite = PL_thiswhite;
6820 start_force(PL_curforce);
6821 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6824 PL_nextwhite = nextPL_nextwhite;
6825 curmad('X', PL_thistoken);
6826 PL_thistoken = newSVpvs("");
6829 if (!PL_lex_allbrackets &&
6830 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6831 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6836 /* Guess harder when madskills require "best effort". */
6837 if (PL_madskills && (!gv || !GvCVu(gv))) {
6838 int probable_sub = 0;
6839 if (strchr("\"'`$@%0123456789!*+{[<", *s))
6841 else if (isALPHA(*s)) {
6845 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
6846 if (!keyword(tmpbuf, tmplen, 0))
6849 while (d < PL_bufend && isSPACE(*d))
6851 if (*d == '=' && d[1] == '>')
6856 gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
6858 op_free(pl_yylval.opval);
6859 pl_yylval.opval = rv2cv_op;
6860 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6861 PL_last_lop = PL_oldbufptr;
6862 PL_last_lop_op = OP_ENTERSUB;
6863 PL_nextwhite = PL_thiswhite;
6865 start_force(PL_curforce);
6866 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6868 PL_nextwhite = nextPL_nextwhite;
6869 curmad('X', PL_thistoken);
6870 PL_thistoken = newSVpvs("");
6872 if (!PL_lex_allbrackets &&
6873 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6874 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6878 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6881 if (!PL_lex_allbrackets &&
6882 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6883 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6888 /* Call it a bare word */
6890 if (PL_hints & HINT_STRICT_SUBS)
6891 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6894 /* after "print" and similar functions (corresponding to
6895 * "F? L" in opcode.pl), whatever wasn't already parsed as
6896 * a filehandle should be subject to "strict subs".
6897 * Likewise for the optional indirect-object argument to system
6898 * or exec, which can't be a bareword */
6899 if ((PL_last_lop_op == OP_PRINT
6900 || PL_last_lop_op == OP_PRTF
6901 || PL_last_lop_op == OP_SAY
6902 || PL_last_lop_op == OP_SYSTEM
6903 || PL_last_lop_op == OP_EXEC)
6904 && (PL_hints & HINT_STRICT_SUBS))
6905 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6906 if (lastchar != '-') {
6907 if (ckWARN(WARN_RESERVED)) {
6911 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6912 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6920 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
6921 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6922 "Operator or semicolon missing before %c%s",
6923 lastchar, PL_tokenbuf);
6924 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6925 "Ambiguous use of %c resolved as operator %c",
6926 lastchar, lastchar);
6933 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6938 (OP*)newSVOP(OP_CONST, 0,
6939 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6942 case KEY___PACKAGE__:
6944 (OP*)newSVOP(OP_CONST, 0,
6946 ? newSVhek(HvNAME_HEK(PL_curstash))
6953 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6954 const char *pname = "main";
6957 if (PL_tokenbuf[2] == 'D')
6960 PL_curstash ? PL_curstash : PL_defstash;
6961 pname = HvNAME_get(stash);
6962 plen = HvNAMELEN (stash);
6963 if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
6965 gv = gv_fetchpvn_flags(
6966 Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
6967 plen+6, GV_ADD|putf8, SVt_PVIO
6971 GvIOp(gv) = newIO();
6972 IoIFP(GvIOp(gv)) = PL_rsfp;
6973 #if defined(HAS_FCNTL) && defined(F_SETFD)
6975 const int fd = PerlIO_fileno(PL_rsfp);
6976 fcntl(fd,F_SETFD,fd >= 3);
6979 /* Mark this internal pseudo-handle as clean */
6980 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6981 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6982 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6984 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6985 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6986 /* if the script was opened in binmode, we need to revert
6987 * it to text mode for compatibility; but only iff it has CRs
6988 * XXX this is a questionable hack at best. */
6989 if (PL_bufend-PL_bufptr > 2
6990 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6993 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6994 loc = PerlIO_tell(PL_rsfp);
6995 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6998 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7000 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7001 #endif /* NETWARE */
7003 PerlIO_seek(PL_rsfp, loc, 0);
7007 #ifdef PERLIO_LAYERS
7010 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7011 else if (PL_encoding) {
7018 XPUSHs(PL_encoding);
7020 call_method("name", G_SCALAR);
7024 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7025 Perl_form(aTHX_ ":encoding(%"SVf")",
7034 if (PL_realtokenstart >= 0) {
7035 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7037 PL_endwhite = newSVpvs("");
7038 sv_catsv(PL_endwhite, PL_thiswhite);
7040 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7041 PL_realtokenstart = -1;
7043 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7059 if (PL_expect == XSTATE) {
7066 if (*s == ':' && s[1] == ':') {
7069 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7070 if (!(tmp = keyword(PL_tokenbuf, len, 1)))
7071 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
7074 else if (tmp == KEY_require || tmp == KEY_do
7076 /* that's a way to remember we saw "CORE::" */
7089 LOP(OP_ACCEPT,XTERM);
7092 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7097 LOP(OP_ATAN2,XTERM);
7103 LOP(OP_BINMODE,XTERM);
7106 LOP(OP_BLESS,XTERM);
7115 /* We have to disambiguate the two senses of
7116 "continue". If the next token is a '{' then
7117 treat it as the start of a continue block;
7118 otherwise treat it as a control operator.
7128 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7138 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7147 if (!PL_cryptseen) {
7148 PL_cryptseen = TRUE;
7152 LOP(OP_CRYPT,XTERM);
7155 LOP(OP_CHMOD,XTERM);
7158 LOP(OP_CHOWN,XTERM);
7161 LOP(OP_CONNECT,XTERM);
7180 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7181 if (orig_keyword == KEY_do) {
7190 PL_hints |= HINT_BLOCK_SCOPE;
7200 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7201 STR_WITH_LEN("NDBM_File::"),
7202 STR_WITH_LEN("DB_File::"),
7203 STR_WITH_LEN("GDBM_File::"),
7204 STR_WITH_LEN("SDBM_File::"),
7205 STR_WITH_LEN("ODBM_File::"),
7207 LOP(OP_DBMOPEN,XTERM);
7213 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7220 pl_yylval.ival = CopLINE(PL_curcop);
7224 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7238 if (*s == '{') { /* block eval */
7239 PL_expect = XTERMBLOCK;
7240 UNIBRACK(OP_ENTERTRY);
7242 else { /* string eval */
7244 UNIBRACK(OP_ENTEREVAL);
7259 case KEY_endhostent:
7265 case KEY_endservent:
7268 case KEY_endprotoent:
7279 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7281 pl_yylval.ival = CopLINE(PL_curcop);
7283 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7286 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7289 if ((PL_bufend - p) >= 3 &&
7290 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7292 else if ((PL_bufend - p) >= 4 &&
7293 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7296 if (isIDFIRST_lazy_if(p,UTF)) {
7297 p = scan_ident(p, PL_bufend,
7298 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7302 Perl_croak(aTHX_ "Missing $ on loop variable");
7304 s = SvPVX(PL_linestr) + soff;
7310 LOP(OP_FORMLINE,XTERM);
7316 LOP(OP_FCNTL,XTERM);
7322 LOP(OP_FLOCK,XTERM);
7325 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7330 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7335 LOP(OP_GREPSTART, XREF);
7338 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7353 case KEY_getpriority:
7354 LOP(OP_GETPRIORITY,XTERM);
7356 case KEY_getprotobyname:
7359 case KEY_getprotobynumber:
7360 LOP(OP_GPBYNUMBER,XTERM);
7362 case KEY_getprotoent:
7374 case KEY_getpeername:
7375 UNI(OP_GETPEERNAME);
7377 case KEY_gethostbyname:
7380 case KEY_gethostbyaddr:
7381 LOP(OP_GHBYADDR,XTERM);
7383 case KEY_gethostent:
7386 case KEY_getnetbyname:
7389 case KEY_getnetbyaddr:
7390 LOP(OP_GNBYADDR,XTERM);
7395 case KEY_getservbyname:
7396 LOP(OP_GSBYNAME,XTERM);
7398 case KEY_getservbyport:
7399 LOP(OP_GSBYPORT,XTERM);
7401 case KEY_getservent:
7404 case KEY_getsockname:
7405 UNI(OP_GETSOCKNAME);
7407 case KEY_getsockopt:
7408 LOP(OP_GSOCKOPT,XTERM);
7423 pl_yylval.ival = CopLINE(PL_curcop);
7428 orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
7436 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7438 pl_yylval.ival = CopLINE(PL_curcop);
7442 LOP(OP_INDEX,XTERM);
7448 LOP(OP_IOCTL,XTERM);
7460 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7477 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7482 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7496 LOP(OP_LISTEN,XTERM);
7505 s = scan_pat(s,OP_MATCH);
7506 TERM(sublex_start());
7509 LOP(OP_MAPSTART, XREF);
7512 LOP(OP_MKDIR,XTERM);
7515 LOP(OP_MSGCTL,XTERM);
7518 LOP(OP_MSGGET,XTERM);
7521 LOP(OP_MSGRCV,XTERM);
7524 LOP(OP_MSGSND,XTERM);
7529 PL_in_my = (U16)tmp;
7531 if (isIDFIRST_lazy_if(s,UTF)) {
7535 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7536 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7538 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7539 if (!PL_in_my_stash) {
7542 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7546 if (PL_madskills) { /* just add type to declarator token */
7547 sv_catsv(PL_thistoken, PL_nextwhite);
7549 sv_catpvn(PL_thistoken, start, s - start);
7557 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7561 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7566 s = tokenize_use(0, s);
7570 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
7573 if (!PL_lex_allbrackets &&
7574 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7575 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7581 if (isIDFIRST_lazy_if(s,UTF)) {
7583 for (d = s; isALNUM_lazy_if(d,UTF);)
7585 for (t=d; isSPACE(*t);)
7587 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7589 && !(t[0] == '=' && t[1] == '>')
7591 int parms_len = (int)(d-s);
7592 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7593 "Precedence problem: open %.*s should be open(%.*s)",
7594 parms_len, s, parms_len, s);
7600 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7602 pl_yylval.ival = OP_OR;
7612 LOP(OP_OPEN_DIR,XTERM);
7615 checkcomma(s,PL_tokenbuf,"filehandle");
7619 checkcomma(s,PL_tokenbuf,"filehandle");
7638 s = force_word(s,WORD,FALSE,TRUE,FALSE);
7640 s = force_strict_version(s);
7641 PL_lex_expect = XBLOCK;
7645 LOP(OP_PIPE_OP,XTERM);
7648 s = scan_str(s,!!PL_madskills,FALSE);
7651 pl_yylval.ival = OP_CONST;
7652 TERM(sublex_start());
7659 s = scan_str(s,!!PL_madskills,FALSE);
7662 PL_expect = XOPERATOR;
7663 if (SvCUR(PL_lex_stuff)) {
7664 int warned_comma = !ckWARN(WARN_QW);
7665 int warned_comment = warned_comma;
7666 d = SvPV_force(PL_lex_stuff, len);
7668 for (; isSPACE(*d) && len; --len, ++d)
7673 if (!warned_comma || !warned_comment) {
7674 for (; !isSPACE(*d) && len; --len, ++d) {
7675 if (!warned_comma && *d == ',') {
7676 Perl_warner(aTHX_ packWARN(WARN_QW),
7677 "Possible attempt to separate words with commas");
7680 else if (!warned_comment && *d == '#') {
7681 Perl_warner(aTHX_ packWARN(WARN_QW),
7682 "Possible attempt to put comments in qw() list");
7688 for (; !isSPACE(*d) && len; --len, ++d)
7691 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7692 words = op_append_elem(OP_LIST, words,
7693 newSVOP(OP_CONST, 0, tokeq(sv)));
7698 words = newNULLLIST();
7700 SvREFCNT_dec(PL_lex_stuff);
7701 PL_lex_stuff = NULL;
7703 PL_expect = XOPERATOR;
7704 pl_yylval.opval = sawparens(words);
7709 s = scan_str(s,!!PL_madskills,FALSE);
7712 pl_yylval.ival = OP_STRINGIFY;
7713 if (SvIVX(PL_lex_stuff) == '\'')
7714 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7715 TERM(sublex_start());
7718 s = scan_pat(s,OP_QR);
7719 TERM(sublex_start());
7722 s = scan_str(s,!!PL_madskills,FALSE);
7725 readpipe_override();
7726 TERM(sublex_start());
7734 s = force_version(s, FALSE);
7736 else if (*s != 'v' || !isDIGIT(s[1])
7737 || (s = force_version(s, TRUE), *s == 'v'))
7739 *PL_tokenbuf = '\0';
7740 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7741 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7742 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7743 GV_ADD | (UTF ? SVf_UTF8 : 0));
7745 yyerror("<> should be quotes");
7747 if (orig_keyword == KEY_require) {
7755 PL_last_uni = PL_oldbufptr;
7756 PL_last_lop_op = OP_REQUIRE;
7758 return REPORT( (int)REQUIRE );
7764 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7768 LOP(OP_RENAME,XTERM);
7777 LOP(OP_RINDEX,XTERM);
7786 UNIDOR(OP_READLINE);
7789 UNIDOR(OP_BACKTICK);
7798 LOP(OP_REVERSE,XTERM);
7801 UNIDOR(OP_READLINK);
7808 if (pl_yylval.opval)
7809 TERM(sublex_start());
7811 TOKEN(1); /* force error */
7814 checkcomma(s,PL_tokenbuf,"filehandle");
7824 LOP(OP_SELECT,XTERM);
7830 LOP(OP_SEMCTL,XTERM);
7833 LOP(OP_SEMGET,XTERM);
7836 LOP(OP_SEMOP,XTERM);
7842 LOP(OP_SETPGRP,XTERM);
7844 case KEY_setpriority:
7845 LOP(OP_SETPRIORITY,XTERM);
7847 case KEY_sethostent:
7853 case KEY_setservent:
7856 case KEY_setprotoent:
7866 LOP(OP_SEEKDIR,XTERM);
7868 case KEY_setsockopt:
7869 LOP(OP_SSOCKOPT,XTERM);
7875 LOP(OP_SHMCTL,XTERM);
7878 LOP(OP_SHMGET,XTERM);
7881 LOP(OP_SHMREAD,XTERM);
7884 LOP(OP_SHMWRITE,XTERM);
7887 LOP(OP_SHUTDOWN,XTERM);
7896 LOP(OP_SOCKET,XTERM);
7898 case KEY_socketpair:
7899 LOP(OP_SOCKPAIR,XTERM);
7902 checkcomma(s,PL_tokenbuf,"subroutine name");
7904 if (*s == ';' || *s == ')') /* probably a close */
7905 Perl_croak(aTHX_ "sort is now a reserved word");
7907 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7911 LOP(OP_SPLIT,XTERM);
7914 LOP(OP_SPRINTF,XTERM);
7917 LOP(OP_SPLICE,XTERM);
7932 LOP(OP_SUBSTR,XTERM);
7938 char tmpbuf[sizeof PL_tokenbuf];
7939 SSize_t tboffset = 0;
7940 expectation attrful;
7941 bool have_name, have_proto;
7942 const int key = tmp;
7947 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7948 SV *subtoken = newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr));
7952 s = SKIPSPACE2(s,tmpwhite);
7957 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7958 (*s == ':' && s[1] == ':'))
7961 SV *nametoke = NULL;
7965 attrful = XATTRBLOCK;
7966 /* remember buffer pos'n for later force_word */
7967 tboffset = s - PL_oldbufptr;
7968 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
7971 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
7973 if (memchr(tmpbuf, ':', len))
7974 sv_setpvn(PL_subname, tmpbuf, len);
7976 sv_setsv(PL_subname,PL_curstname);
7977 sv_catpvs(PL_subname,"::");
7978 sv_catpvn(PL_subname,tmpbuf,len);
7980 if (SvUTF8(PL_linestr))
7981 SvUTF8_on(PL_subname);
7987 CURMAD('X', nametoke);
7988 CURMAD('_', tmpwhite);
7989 (void) force_word(PL_oldbufptr + tboffset, WORD,
7992 s = SKIPSPACE2(d,tmpwhite);
7999 Perl_croak(aTHX_ "Missing name in \"my sub\"");
8000 PL_expect = XTERMBLOCK;
8001 attrful = XATTRTERM;
8002 sv_setpvs(PL_subname,"?");
8006 if (key == KEY_format) {
8008 PL_lex_formbrack = PL_lex_brackets + 1;
8010 PL_thistoken = subtoken;
8014 (void) force_word(PL_oldbufptr + tboffset, WORD,
8020 /* Look for a prototype */
8023 bool bad_proto = FALSE;
8024 bool in_brackets = FALSE;
8025 char greedy_proto = ' ';
8026 bool proto_after_greedy_proto = FALSE;
8027 bool must_be_last = FALSE;
8028 bool underscore = FALSE;
8029 bool seen_underscore = FALSE;
8030 const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
8033 s = scan_str(s,!!PL_madskills,FALSE);
8035 Perl_croak(aTHX_ "Prototype not terminated");
8036 /* strip spaces and check for bad characters */
8037 d = SvPV(PL_lex_stuff, tmplen);
8039 for (p = d; tmplen; tmplen--, ++p) {
8043 if (warnillegalproto) {
8045 proto_after_greedy_proto = TRUE;
8046 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
8058 else if ( *p == ']' ) {
8059 in_brackets = FALSE;
8061 else if ( (*p == '@' || *p == '%') &&
8062 ( tmp < 2 || d[tmp-2] != '\\' ) &&
8064 must_be_last = TRUE;
8067 else if ( *p == '_' ) {
8068 underscore = seen_underscore = TRUE;
8075 if (proto_after_greedy_proto)
8076 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8077 "Prototype after '%c' for %"SVf" : %s",
8078 greedy_proto, SVfARG(PL_subname), d);
8080 SV *dsv = newSVpvs_flags("", SVs_TEMP);
8081 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8082 "Illegal character %sin prototype for %"SVf" : %s",
8083 seen_underscore ? "after '_' " : "",
8086 newSVpvn_flags(d, tmp, SVs_TEMP | SvUTF8(PL_lex_stuff)),
8087 tmp, UNI_DISPLAY_ISPRINT));
8089 SvCUR_set(PL_lex_stuff, tmp);
8094 CURMAD('q', PL_thisopen);
8095 CURMAD('_', tmpwhite);
8096 CURMAD('=', PL_thisstuff);
8097 CURMAD('Q', PL_thisclose);
8098 NEXTVAL_NEXTTOKE.opval =
8099 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8100 PL_lex_stuff = NULL;
8103 s = SKIPSPACE2(s,tmpwhite);
8111 if (*s == ':' && s[1] != ':')
8112 PL_expect = attrful;
8113 else if (*s != '{' && key == KEY_sub) {
8115 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8116 else if (*s != ';' && *s != '}')
8117 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8124 curmad('^', newSVpvs(""));
8125 CURMAD('_', tmpwhite);
8129 PL_thistoken = subtoken;
8132 NEXTVAL_NEXTTOKE.opval =
8133 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8134 PL_lex_stuff = NULL;
8140 sv_setpvs(PL_subname, "__ANON__");
8142 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8146 (void) force_word(PL_oldbufptr + tboffset, WORD,
8155 LOP(OP_SYSTEM,XREF);
8158 LOP(OP_SYMLINK,XTERM);
8161 LOP(OP_SYSCALL,XTERM);
8164 LOP(OP_SYSOPEN,XTERM);
8167 LOP(OP_SYSSEEK,XTERM);
8170 LOP(OP_SYSREAD,XTERM);
8173 LOP(OP_SYSWRITE,XTERM);
8177 TERM(sublex_start());
8198 LOP(OP_TRUNCATE,XTERM);
8210 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8212 pl_yylval.ival = CopLINE(PL_curcop);
8216 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8218 pl_yylval.ival = CopLINE(PL_curcop);
8222 LOP(OP_UNLINK,XTERM);
8228 LOP(OP_UNPACK,XTERM);
8231 LOP(OP_UTIME,XTERM);
8237 LOP(OP_UNSHIFT,XTERM);
8240 s = tokenize_use(1, s);
8250 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8252 pl_yylval.ival = CopLINE(PL_curcop);
8256 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8258 pl_yylval.ival = CopLINE(PL_curcop);
8262 PL_hints |= HINT_BLOCK_SCOPE;
8269 LOP(OP_WAITPID,XTERM);
8278 ctl_l[0] = toCTRL('L');
8280 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8283 /* Make sure $^L is defined */
8284 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8289 if (PL_expect == XOPERATOR) {
8290 if (*s == '=' && !PL_lex_allbrackets &&
8291 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8299 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8301 pl_yylval.ival = OP_XOR;
8306 TERM(sublex_start());
8311 #pragma segment Main
8315 S_pending_ident(pTHX)
8320 /* pit holds the identifier we read and pending_ident is reset */
8321 char pit = PL_pending_ident;
8322 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8323 /* All routes through this function want to know if there is a colon. */
8324 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8325 PL_pending_ident = 0;
8327 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
8328 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8329 "### Pending identifier '%s'\n", PL_tokenbuf); });
8331 /* if we're in a my(), we can't allow dynamics here.
8332 $foo'bar has already been turned into $foo::bar, so
8333 just check for colons.
8335 if it's a legal name, the OP is a PADANY.
8338 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8340 yyerror(Perl_form(aTHX_ "No package name allowed for "
8341 "variable %s in \"our\"",
8343 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8347 yyerror(Perl_form(aTHX_ PL_no_myglob,
8348 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
8350 pl_yylval.opval = newOP(OP_PADANY, 0);
8351 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8352 UTF ? SVf_UTF8 : 0);
8358 build the ops for accesses to a my() variable.
8360 Deny my($a) or my($b) in a sort block, *if* $a or $b is
8361 then used in a comparison. This catches most, but not
8362 all cases. For instance, it catches
8363 sort { my($a); $a <=> $b }
8365 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
8366 (although why you'd do that is anyone's guess).
8371 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8372 UTF ? SVf_UTF8 : 0);
8373 if (tmp != NOT_IN_PAD) {
8374 /* might be an "our" variable" */
8375 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8376 /* build ops for a bareword */
8377 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8378 HEK * const stashname = HvNAME_HEK(stash);
8379 SV * const sym = newSVhek(stashname);
8380 sv_catpvs(sym, "::");
8381 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8382 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8383 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8386 ? (GV_ADDMULTI | GV_ADDINEVAL)
8389 ((PL_tokenbuf[0] == '$') ? SVt_PV
8390 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8395 /* if it's a sort block and they're naming $a or $b */
8396 if (PL_last_lop_op == OP_SORT &&
8397 PL_tokenbuf[0] == '$' &&
8398 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
8401 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
8402 d < PL_bufend && *d != '\n';
8405 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
8406 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
8412 pl_yylval.opval = newOP(OP_PADANY, 0);
8413 pl_yylval.opval->op_targ = tmp;
8419 Whine if they've said @foo in a doublequoted string,
8420 and @foo isn't a variable we can find in the symbol
8423 if (ckWARN(WARN_AMBIGUOUS) &&
8424 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8425 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8426 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8427 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8428 /* DO NOT warn for @- and @+ */
8429 && !( PL_tokenbuf[2] == '\0' &&
8430 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8433 /* Downgraded from fatal to warning 20000522 mjd */
8434 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8435 "Possible unintended interpolation of %s in string",
8440 /* build ops for a bareword */
8441 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(PL_tokenbuf + 1,
8443 UTF ? SVf_UTF8 : 0 ));
8444 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8445 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8446 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
8447 | ( UTF ? SVf_UTF8 : 0 ),
8448 ((PL_tokenbuf[0] == '$') ? SVt_PV
8449 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8455 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8459 PERL_ARGS_ASSERT_CHECKCOMMA;
8461 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8462 if (ckWARN(WARN_SYNTAX)) {
8465 for (w = s+2; *w && level; w++) {
8473 /* the list of chars below is for end of statements or
8474 * block / parens, boolean operators (&&, ||, //) and branch
8475 * constructs (or, and, if, until, unless, while, err, for).
8476 * Not a very solid hack... */
8477 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8478 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8479 "%s (...) interpreted as function",name);
8482 while (s < PL_bufend && isSPACE(*s))
8486 while (s < PL_bufend && isSPACE(*s))
8488 if (isIDFIRST_lazy_if(s,UTF)) {
8489 const char * const w = s++;
8490 while (isALNUM_lazy_if(s,UTF))
8492 while (s < PL_bufend && isSPACE(*s))
8496 if (keyword(w, s - w, 0))
8499 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8500 if (gv && GvCVu(gv))
8502 Perl_croak(aTHX_ "No comma allowed after %s", what);
8507 /* Either returns sv, or mortalizes sv and returns a new SV*.
8508 Best used as sv=new_constant(..., sv, ...).
8509 If s, pv are NULL, calls subroutine with one argument,
8510 and type is used with error messages only. */
8513 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8514 SV *sv, SV *pv, const char *type, STRLEN typelen)
8517 HV * const table = GvHV(PL_hintgv); /* ^H */
8521 const char *why1 = "", *why2 = "", *why3 = "";
8523 PERL_ARGS_ASSERT_NEW_CONSTANT;
8525 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8528 why2 = (const char *)
8529 (strEQ(key,"charnames")
8530 ? "(possibly a missing \"use charnames ...\")"
8532 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
8533 (type ? type: "undef"), why2);
8535 /* This is convoluted and evil ("goto considered harmful")
8536 * but I do not understand the intricacies of all the different
8537 * failure modes of %^H in here. The goal here is to make
8538 * the most probable error message user-friendly. --jhi */
8543 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
8544 (type ? type: "undef"), why1, why2, why3);
8546 yyerror(SvPVX_const(msg));
8551 /* charnames doesn't work well if there have been errors found */
8552 if (PL_error_count > 0 && strEQ(key,"charnames"))
8553 return &PL_sv_undef;
8555 cvp = hv_fetch(table, key, keylen, FALSE);
8556 if (!cvp || !SvOK(*cvp)) {
8559 why3 = "} is not defined";
8562 sv_2mortal(sv); /* Parent created it permanently */
8565 pv = newSVpvn_flags(s, len, SVs_TEMP);
8567 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8569 typesv = &PL_sv_undef;
8571 PUSHSTACKi(PERLSI_OVERLOAD);
8583 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8587 /* Check the eval first */
8588 if (!PL_in_eval && SvTRUE(ERRSV)) {
8589 sv_catpvs(ERRSV, "Propagated");
8590 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
8592 res = SvREFCNT_inc_simple(sv);
8596 SvREFCNT_inc_simple_void(res);
8605 why1 = "Call to &{$^H{";
8607 why3 = "}} did not return a defined value";
8615 /* Returns a NUL terminated string, with the length of the string written to
8619 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8622 register char *d = dest;
8623 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8625 PERL_ARGS_ASSERT_SCAN_WORD;
8629 Perl_croak(aTHX_ ident_too_long);
8630 if (isALNUM(*s)) /* UTF handled below */
8632 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
8637 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
8641 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8642 char *t = s + UTF8SKIP(s);
8644 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8648 Perl_croak(aTHX_ ident_too_long);
8649 Copy(s, d, len, char);
8662 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
8665 char *bracket = NULL;
8667 register char *d = dest;
8668 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8670 PERL_ARGS_ASSERT_SCAN_IDENT;
8675 while (isDIGIT(*s)) {
8677 Perl_croak(aTHX_ ident_too_long);
8684 Perl_croak(aTHX_ ident_too_long);
8685 if (isALNUM(*s)) /* UTF handled below */
8687 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
8692 else if (*s == ':' && s[1] == ':') {
8696 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8697 char *t = s + UTF8SKIP(s);
8698 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8700 if (d + (t - s) > e)
8701 Perl_croak(aTHX_ ident_too_long);
8702 Copy(s, d, t - s, char);
8713 if (PL_lex_state != LEX_NORMAL)
8714 PL_lex_state = LEX_INTERPENDMAYBE;
8717 if (*s == '$' && s[1] &&
8718 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
8730 const STRLEN skip = UTF8SKIP(s);
8733 for ( i = 0; i < skip; i++ )
8741 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8746 if (isSPACE(s[-1])) {
8748 const char ch = *s++;
8749 if (!SPACE_OR_TAB(ch)) {
8755 if (isIDFIRST_lazy_if(d,UTF)) {
8759 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
8760 end += UTF8SKIP(end);
8761 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
8762 end += UTF8SKIP(end);
8764 Copy(s, d, end - s, char);
8769 while ((isALNUM(*s) || *s == ':') && d < e)
8772 Perl_croak(aTHX_ ident_too_long);
8775 while (s < send && SPACE_OR_TAB(*s))
8777 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8778 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8779 const char * const brack =
8781 ((*s == '[') ? "[...]" : "{...}");
8782 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8783 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8784 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8785 funny, dest, brack, funny, dest, brack);
8788 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8789 PL_lex_allbrackets++;
8793 /* Handle extended ${^Foo} variables
8794 * 1999-02-27 mjd-perl-patch@plover.com */
8795 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
8799 while (isALNUM(*s) && d < e) {
8803 Perl_croak(aTHX_ ident_too_long);
8808 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8809 PL_lex_state = LEX_INTERPEND;
8812 if (PL_lex_state == LEX_NORMAL) {
8813 if (ckWARN(WARN_AMBIGUOUS) &&
8814 (keyword(dest, d - dest, 0)
8815 || get_cvn_flags(dest, d - dest, 0)))
8819 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8820 "Ambiguous use of %c{%s} resolved to %c%s",
8821 funny, dest, funny, dest);
8826 s = bracket; /* let the parser handle it */
8830 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8831 PL_lex_state = LEX_INTERPEND;
8836 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
8838 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
8839 * the parse starting at 's', based on the subset that are valid in this
8840 * context input to this routine in 'valid_flags'. Advances s. Returns
8841 * TRUE if the input was a valid flag, so the next char may be as well;
8842 * otherwise FALSE. 'charset' should point to a NUL upon first call on the
8843 * current regex. This routine will set it to any charset modifier found.
8844 * The caller shouldn't change it. This way, another charset modifier
8845 * encountered in the parse can be detected as an error, as we have decided
8850 if (! strchr(valid_flags, c)) {
8859 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
8860 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8861 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8862 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8863 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8864 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8865 case LOCALE_PAT_MOD:
8867 /* In 5.14, qr//lt is legal but deprecated; the 't' means they
8868 * can't be regex modifiers.
8869 * In 5.14, s///le is legal and ambiguous. Try to disambiguate as
8870 * much as easily done. s///lei, for example, has to mean regex
8871 * modifiers if it's not an error (as does any word character
8872 * following the 'e'). Otherwise, we resolve to the backwards-
8873 * compatible, but less likely 's/// le ...', i.e. as meaning
8874 * less-than-or-equal. The reason it's not likely is that s//
8875 * returns a number for code in the field (/r returns a string, but
8876 * that wasn't added until the 5.13 series), and so '<=' should be
8877 * used for comparing, not 'le'. */
8878 if (*((*s) + 1) == 't') {
8881 else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) {
8883 /* 'e' is valid only for substitutes, s///e. If it is not
8884 * valid in the current context, then 'm//le' must mean the
8885 * comparison operator, so use the regular deprecation message.
8887 if (! strchr(valid_flags, 'e')) {
8890 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
8891 "Ambiguous use of 's//le...' resolved as 's// le...'; Rewrite as 's//el' if you meant 'use locale rules and evaluate rhs as an expression'. In Perl 5.16, it will be resolved the other way");
8895 goto multiple_charsets;
8897 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8900 case UNICODE_PAT_MOD:
8901 /* In 5.14, qr//unless and qr//until are legal but deprecated; the
8902 * 'n' means they can't be regex modifiers */
8903 if (*((*s) + 1) == 'n') {
8907 goto multiple_charsets;
8909 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8912 case ASCII_RESTRICT_PAT_MOD:
8913 /* In 5.14, qr//and is legal but deprecated; the 'n' means they
8914 * can't be regex modifiers */
8915 if (*((*s) + 1) == 'n') {
8920 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8924 /* Error if previous modifier wasn't an 'a', but if it was, see
8925 * if, and accept, a second occurrence (only) */
8927 || get_regex_charset(*pmfl)
8928 != REGEX_ASCII_RESTRICTED_CHARSET)
8930 goto multiple_charsets;
8932 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8936 case DEPENDS_PAT_MOD:
8938 goto multiple_charsets;
8940 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8949 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
8950 "Having no space between pattern and following word is deprecated");
8954 if (*charset != c) {
8955 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8957 else if (c == 'a') {
8958 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8961 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8964 /* Pretend that it worked, so will continue processing before dieing */
8970 S_scan_pat(pTHX_ char *start, I32 type)
8974 char *s = scan_str(start,!!PL_madskills,FALSE);
8975 const char * const valid_flags =
8976 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8977 char charset = '\0'; /* character set modifier */
8982 PERL_ARGS_ASSERT_SCAN_PAT;
8985 const char * const delimiter = skipspace(start);
8989 ? "Search pattern not terminated or ternary operator parsed as search pattern"
8990 : "Search pattern not terminated" ));
8993 pm = (PMOP*)newPMOP(type, 0);
8994 if (PL_multi_open == '?') {
8995 /* This is the only point in the code that sets PMf_ONCE: */
8996 pm->op_pmflags |= PMf_ONCE;
8998 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8999 allows us to restrict the list needed by reset to just the ??
9001 assert(type != OP_TRANS);
9003 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9006 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9009 elements = mg->mg_len / sizeof(PMOP**);
9010 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9011 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9012 mg->mg_len = elements * sizeof(PMOP**);
9013 PmopSTASH_set(pm,PL_curstash);
9019 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9021 if (PL_madskills && modstart != s) {
9022 SV* tmptoken = newSVpvn(modstart, s - modstart);
9023 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9026 /* issue a warning if /c is specified,but /g is not */
9027 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9029 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9030 "Use of /c modifier is meaningless without /g" );
9033 PL_lex_op = (OP*)pm;
9034 pl_yylval.ival = OP_MATCH;
9039 S_scan_subst(pTHX_ char *start)
9046 char charset = '\0'; /* character set modifier */
9051 PERL_ARGS_ASSERT_SCAN_SUBST;
9053 pl_yylval.ival = OP_NULL;
9055 s = scan_str(start,!!PL_madskills,FALSE);
9058 Perl_croak(aTHX_ "Substitution pattern not terminated");
9060 if (s[-1] == PL_multi_open)
9064 CURMAD('q', PL_thisopen);
9065 CURMAD('_', PL_thiswhite);
9066 CURMAD('E', PL_thisstuff);
9067 CURMAD('Q', PL_thisclose);
9068 PL_realtokenstart = s - SvPVX(PL_linestr);
9072 first_start = PL_multi_start;
9073 s = scan_str(s,!!PL_madskills,FALSE);
9076 SvREFCNT_dec(PL_lex_stuff);
9077 PL_lex_stuff = NULL;
9079 Perl_croak(aTHX_ "Substitution replacement not terminated");
9081 PL_multi_start = first_start; /* so whole substitution is taken together */
9083 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9087 CURMAD('z', PL_thisopen);
9088 CURMAD('R', PL_thisstuff);
9089 CURMAD('Z', PL_thisclose);
9095 if (*s == EXEC_PAT_MOD) {
9099 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9108 curmad('m', newSVpvn(modstart, s - modstart));
9109 append_madprops(PL_thismad, (OP*)pm, 0);
9113 if ((pm->op_pmflags & PMf_CONTINUE)) {
9114 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9118 SV * const repl = newSVpvs("");
9120 PL_sublex_info.super_bufptr = s;
9121 PL_sublex_info.super_bufend = PL_bufend;
9123 pm->op_pmflags |= PMf_EVAL;
9126 sv_catpvs(repl, "eval ");
9128 sv_catpvs(repl, "do ");
9130 sv_catpvs(repl, "{");
9131 sv_catsv(repl, PL_lex_repl);
9132 if (strchr(SvPVX(PL_lex_repl), '#'))
9133 sv_catpvs(repl, "\n");
9134 sv_catpvs(repl, "}");
9136 SvREFCNT_dec(PL_lex_repl);
9140 PL_lex_op = (OP*)pm;
9141 pl_yylval.ival = OP_SUBST;
9146 S_scan_trans(pTHX_ char *start)
9155 bool nondestruct = 0;
9160 PERL_ARGS_ASSERT_SCAN_TRANS;
9162 pl_yylval.ival = OP_NULL;
9164 s = scan_str(start,!!PL_madskills,FALSE);
9166 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9168 if (s[-1] == PL_multi_open)
9172 CURMAD('q', PL_thisopen);
9173 CURMAD('_', PL_thiswhite);
9174 CURMAD('E', PL_thisstuff);
9175 CURMAD('Q', PL_thisclose);
9176 PL_realtokenstart = s - SvPVX(PL_linestr);
9180 s = scan_str(s,!!PL_madskills,FALSE);
9183 SvREFCNT_dec(PL_lex_stuff);
9184 PL_lex_stuff = NULL;
9186 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9189 CURMAD('z', PL_thisopen);
9190 CURMAD('R', PL_thisstuff);
9191 CURMAD('Z', PL_thisclose);
9194 complement = del = squash = 0;
9201 complement = OPpTRANS_COMPLEMENT;
9204 del = OPpTRANS_DELETE;
9207 squash = OPpTRANS_SQUASH;
9219 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
9220 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
9221 o->op_private &= ~OPpTRANS_ALL;
9222 o->op_private |= del|squash|complement|
9223 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9224 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9227 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9232 curmad('m', newSVpvn(modstart, s - modstart));
9233 append_madprops(PL_thismad, o, 0);
9242 S_scan_heredoc(pTHX_ register char *s)
9246 I32 op_type = OP_SCALAR;
9250 const char *found_newline;
9254 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9256 I32 stuffstart = s - SvPVX(PL_linestr);
9259 PL_realtokenstart = -1;
9262 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9266 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9270 while (SPACE_OR_TAB(*peek))
9272 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9275 s = delimcpy(d, e, s, PL_bufend, term, &len);
9285 if (!isALNUM_lazy_if(s,UTF))
9286 deprecate("bare << to mean <<\"\"");
9287 for (; isALNUM_lazy_if(s,UTF); s++) {
9292 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9293 Perl_croak(aTHX_ "Delimiter for here document is too long");
9296 len = d - PL_tokenbuf;
9300 tstart = PL_tokenbuf + !outer;
9301 PL_thisclose = newSVpvn(tstart, len - !outer);
9302 tstart = SvPVX(PL_linestr) + stuffstart;
9303 PL_thisopen = newSVpvn(tstart, s - tstart);
9304 stuffstart = s - SvPVX(PL_linestr);
9307 #ifndef PERL_STRICT_CR
9308 d = strchr(s, '\r');
9310 char * const olds = s;
9312 while (s < PL_bufend) {
9318 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9327 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9334 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
9335 herewas = newSVpvn(s,PL_bufend-s);
9339 herewas = newSVpvn(s-1,found_newline-s+1);
9342 herewas = newSVpvn(s,found_newline-s);
9347 tstart = SvPVX(PL_linestr) + stuffstart;
9349 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9351 PL_thisstuff = newSVpvn(tstart, s - tstart);
9354 s += SvCUR(herewas);
9357 stuffstart = s - SvPVX(PL_linestr);
9363 tmpstr = newSV_type(SVt_PVIV);
9367 SvIV_set(tmpstr, -1);
9369 else if (term == '`') {
9370 op_type = OP_BACKTICK;
9371 SvIV_set(tmpstr, '\\');
9375 PL_multi_start = CopLINE(PL_curcop);
9376 PL_multi_open = PL_multi_close = '<';
9377 term = *PL_tokenbuf;
9378 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9379 char * const bufptr = PL_sublex_info.super_bufptr;
9380 char * const bufend = PL_sublex_info.super_bufend;
9381 char * const olds = s - SvCUR(herewas);
9382 s = strchr(bufptr, '\n');
9386 while (s < bufend &&
9387 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9389 CopLINE_inc(PL_curcop);
9392 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9393 missingterm(PL_tokenbuf);
9395 sv_setpvn(herewas,bufptr,d-bufptr+1);
9396 sv_setpvn(tmpstr,d+1,s-d);
9398 sv_catpvn(herewas,s,bufend-s);
9399 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9406 while (s < PL_bufend &&
9407 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9409 CopLINE_inc(PL_curcop);
9411 if (s >= PL_bufend) {
9412 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9413 missingterm(PL_tokenbuf);
9415 sv_setpvn(tmpstr,d+1,s-d);
9419 sv_catpvn(PL_thisstuff, d + 1, s - d);
9421 PL_thisstuff = newSVpvn(d + 1, s - d);
9422 stuffstart = s - SvPVX(PL_linestr);
9426 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9428 sv_catpvn(herewas,s,PL_bufend-s);
9429 sv_setsv(PL_linestr,herewas);
9430 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9431 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9432 PL_last_lop = PL_last_uni = NULL;
9435 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9436 while (s >= PL_bufend) { /* multiple line string? */
9439 tstart = SvPVX(PL_linestr) + stuffstart;
9441 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9443 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9447 CopLINE_inc(PL_curcop);
9448 if (!outer || !lex_next_chunk(0)) {
9449 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9450 missingterm(PL_tokenbuf);
9452 CopLINE_dec(PL_curcop);
9455 stuffstart = s - SvPVX(PL_linestr);
9457 CopLINE_inc(PL_curcop);
9458 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9459 PL_last_lop = PL_last_uni = NULL;
9460 #ifndef PERL_STRICT_CR
9461 if (PL_bufend - PL_linestart >= 2) {
9462 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9463 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9465 PL_bufend[-2] = '\n';
9467 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9469 else if (PL_bufend[-1] == '\r')
9470 PL_bufend[-1] = '\n';
9472 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9473 PL_bufend[-1] = '\n';
9475 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9476 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9477 *(SvPVX(PL_linestr) + off ) = ' ';
9478 lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1);
9479 sv_catsv(PL_linestr,herewas);
9480 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9481 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9485 sv_catsv(tmpstr,PL_linestr);
9490 PL_multi_end = CopLINE(PL_curcop);
9491 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9492 SvPV_shrink_to_cur(tmpstr);
9494 SvREFCNT_dec(herewas);
9496 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9498 else if (PL_encoding)
9499 sv_recode_to_utf8(tmpstr, PL_encoding);
9501 PL_lex_stuff = tmpstr;
9502 pl_yylval.ival = op_type;
9507 takes: current position in input buffer
9508 returns: new position in input buffer
9509 side-effects: pl_yylval and lex_op are set.
9514 <FH> read from filehandle
9515 <pkg::FH> read from package qualified filehandle
9516 <pkg'FH> read from package qualified filehandle
9517 <$fh> read from filehandle in $fh
9523 S_scan_inputsymbol(pTHX_ char *start)
9526 register char *s = start; /* current position in buffer */
9529 char *d = PL_tokenbuf; /* start of temp holding space */
9530 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9532 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9534 end = strchr(s, '\n');
9537 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9539 /* die if we didn't have space for the contents of the <>,
9540 or if it didn't end, or if we see a newline
9543 if (len >= (I32)sizeof PL_tokenbuf)
9544 Perl_croak(aTHX_ "Excessively long <> operator");
9546 Perl_croak(aTHX_ "Unterminated <> operator");
9551 Remember, only scalar variables are interpreted as filehandles by
9552 this code. Anything more complex (e.g., <$fh{$num}>) will be
9553 treated as a glob() call.
9554 This code makes use of the fact that except for the $ at the front,
9555 a scalar variable and a filehandle look the same.
9557 if (*d == '$' && d[1]) d++;
9559 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9560 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9561 d += UTF ? UTF8SKIP(d) : 1;
9563 /* If we've tried to read what we allow filehandles to look like, and
9564 there's still text left, then it must be a glob() and not a getline.
9565 Use scan_str to pull out the stuff between the <> and treat it
9566 as nothing more than a string.
9569 if (d - PL_tokenbuf != len) {
9570 pl_yylval.ival = OP_GLOB;
9571 s = scan_str(start,!!PL_madskills,FALSE);
9573 Perl_croak(aTHX_ "Glob not terminated");
9577 bool readline_overriden = FALSE;
9580 /* we're in a filehandle read situation */
9583 /* turn <> into <ARGV> */
9585 Copy("ARGV",d,5,char);
9587 /* Check whether readline() is overriden */
9588 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
9590 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9592 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
9593 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
9594 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9595 readline_overriden = TRUE;
9597 /* if <$fh>, create the ops to turn the variable into a
9601 /* try to find it in the pad for this block, otherwise find
9602 add symbol table ops
9604 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
9605 if (tmp != NOT_IN_PAD) {
9606 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9607 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9608 HEK * const stashname = HvNAME_HEK(stash);
9609 SV * const sym = sv_2mortal(newSVhek(stashname));
9610 sv_catpvs(sym, "::");
9616 OP * const o = newOP(OP_PADSV, 0);
9618 PL_lex_op = readline_overriden
9619 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9620 op_append_elem(OP_LIST, o,
9621 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9622 : (OP*)newUNOP(OP_READLINE, 0, o);
9631 ? (GV_ADDMULTI | GV_ADDINEVAL)
9632 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
9634 PL_lex_op = readline_overriden
9635 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9636 op_append_elem(OP_LIST,
9637 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9638 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9639 : (OP*)newUNOP(OP_READLINE, 0,
9640 newUNOP(OP_RV2SV, 0,
9641 newGVOP(OP_GV, 0, gv)));
9643 if (!readline_overriden)
9644 PL_lex_op->op_flags |= OPf_SPECIAL;
9645 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9646 pl_yylval.ival = OP_NULL;
9649 /* If it's none of the above, it must be a literal filehandle
9650 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9652 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9653 PL_lex_op = readline_overriden
9654 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9655 op_append_elem(OP_LIST,
9656 newGVOP(OP_GV, 0, gv),
9657 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9658 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9659 pl_yylval.ival = OP_NULL;
9668 takes: start position in buffer
9669 keep_quoted preserve \ on the embedded delimiter(s)
9670 keep_delims preserve the delimiters around the string
9671 returns: position to continue reading from buffer
9672 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9673 updates the read buffer.
9675 This subroutine pulls a string out of the input. It is called for:
9676 q single quotes q(literal text)
9677 ' single quotes 'literal text'
9678 qq double quotes qq(interpolate $here please)
9679 " double quotes "interpolate $here please"
9680 qx backticks qx(/bin/ls -l)
9681 ` backticks `/bin/ls -l`
9682 qw quote words @EXPORT_OK = qw( func() $spam )
9683 m// regexp match m/this/
9684 s/// regexp substitute s/this/that/
9685 tr/// string transliterate tr/this/that/
9686 y/// string transliterate y/this/that/
9687 ($*@) sub prototypes sub foo ($)
9688 (stuff) sub attr parameters sub foo : attr(stuff)
9689 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9691 In most of these cases (all but <>, patterns and transliterate)
9692 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9693 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9694 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9697 It skips whitespace before the string starts, and treats the first
9698 character as the delimiter. If the delimiter is one of ([{< then
9699 the corresponding "close" character )]}> is used as the closing
9700 delimiter. It allows quoting of delimiters, and if the string has
9701 balanced delimiters ([{<>}]) it allows nesting.
9703 On success, the SV with the resulting string is put into lex_stuff or,
9704 if that is already non-NULL, into lex_repl. The second case occurs only
9705 when parsing the RHS of the special constructs s/// and tr/// (y///).
9706 For convenience, the terminating delimiter character is stuffed into
9711 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9714 SV *sv; /* scalar value: string */
9715 const char *tmps; /* temp string, used for delimiter matching */
9716 register char *s = start; /* current position in the buffer */
9717 register char term; /* terminating character */
9718 register char *to; /* current position in the sv's data */
9719 I32 brackets = 1; /* bracket nesting level */
9720 bool has_utf8 = FALSE; /* is there any utf8 content? */
9721 I32 termcode; /* terminating char. code */
9722 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9723 STRLEN termlen; /* length of terminating string */
9724 int last_off = 0; /* last position for nesting bracket */
9730 PERL_ARGS_ASSERT_SCAN_STR;
9732 /* skip space before the delimiter */
9738 if (PL_realtokenstart >= 0) {
9739 stuffstart = PL_realtokenstart;
9740 PL_realtokenstart = -1;
9743 stuffstart = start - SvPVX(PL_linestr);
9745 /* mark where we are, in case we need to report errors */
9748 /* after skipping whitespace, the next character is the terminator */
9751 termcode = termstr[0] = term;
9755 termcode = utf8_to_uvchr((U8*)s, &termlen);
9756 Copy(s, termstr, termlen, U8);
9757 if (!UTF8_IS_INVARIANT(term))
9761 /* mark where we are */
9762 PL_multi_start = CopLINE(PL_curcop);
9763 PL_multi_open = term;
9765 /* find corresponding closing delimiter */
9766 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9767 termcode = termstr[0] = term = tmps[5];
9769 PL_multi_close = term;
9771 /* create a new SV to hold the contents. 79 is the SV's initial length.
9772 What a random number. */
9773 sv = newSV_type(SVt_PVIV);
9775 SvIV_set(sv, termcode);
9776 (void)SvPOK_only(sv); /* validate pointer */
9778 /* move past delimiter and try to read a complete string */
9780 sv_catpvn(sv, s, termlen);
9783 tstart = SvPVX(PL_linestr) + stuffstart;
9784 if (!PL_thisopen && !keep_delims) {
9785 PL_thisopen = newSVpvn(tstart, s - tstart);
9786 stuffstart = s - SvPVX(PL_linestr);
9790 if (PL_encoding && !UTF) {
9794 int offset = s - SvPVX_const(PL_linestr);
9795 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9796 &offset, (char*)termstr, termlen);
9797 const char * const ns = SvPVX_const(PL_linestr) + offset;
9798 char * const svlast = SvEND(sv) - 1;
9800 for (; s < ns; s++) {
9801 if (*s == '\n' && !PL_rsfp)
9802 CopLINE_inc(PL_curcop);
9805 goto read_more_line;
9807 /* handle quoted delimiters */
9808 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9810 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9812 if ((svlast-1 - t) % 2) {
9816 SvCUR_set(sv, SvCUR(sv) - 1);
9821 if (PL_multi_open == PL_multi_close) {
9827 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9828 /* At here, all closes are "was quoted" one,
9829 so we don't check PL_multi_close. */
9831 if (!keep_quoted && *(t+1) == PL_multi_open)
9836 else if (*t == PL_multi_open)
9844 SvCUR_set(sv, w - SvPVX_const(sv));
9846 last_off = w - SvPVX(sv);
9847 if (--brackets <= 0)
9853 SvCUR_set(sv, SvCUR(sv) - 1);
9859 /* extend sv if need be */
9860 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9861 /* set 'to' to the next character in the sv's string */
9862 to = SvPVX(sv)+SvCUR(sv);
9864 /* if open delimiter is the close delimiter read unbridle */
9865 if (PL_multi_open == PL_multi_close) {
9866 for (; s < PL_bufend; s++,to++) {
9867 /* embedded newlines increment the current line number */
9868 if (*s == '\n' && !PL_rsfp)
9869 CopLINE_inc(PL_curcop);
9870 /* handle quoted delimiters */
9871 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9872 if (!keep_quoted && s[1] == term)
9874 /* any other quotes are simply copied straight through */
9878 /* terminate when run out of buffer (the for() condition), or
9879 have found the terminator */
9880 else if (*s == term) {
9883 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9886 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9892 /* if the terminator isn't the same as the start character (e.g.,
9893 matched brackets), we have to allow more in the quoting, and
9894 be prepared for nested brackets.
9897 /* read until we run out of string, or we find the terminator */
9898 for (; s < PL_bufend; s++,to++) {
9899 /* embedded newlines increment the line count */
9900 if (*s == '\n' && !PL_rsfp)
9901 CopLINE_inc(PL_curcop);
9902 /* backslashes can escape the open or closing characters */
9903 if (*s == '\\' && s+1 < PL_bufend) {
9905 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9910 /* allow nested opens and closes */
9911 else if (*s == PL_multi_close && --brackets <= 0)
9913 else if (*s == PL_multi_open)
9915 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9920 /* terminate the copied string and update the sv's end-of-string */
9922 SvCUR_set(sv, to - SvPVX_const(sv));
9925 * this next chunk reads more into the buffer if we're not done yet
9929 break; /* handle case where we are done yet :-) */
9931 #ifndef PERL_STRICT_CR
9932 if (to - SvPVX_const(sv) >= 2) {
9933 if ((to[-2] == '\r' && to[-1] == '\n') ||
9934 (to[-2] == '\n' && to[-1] == '\r'))
9938 SvCUR_set(sv, to - SvPVX_const(sv));
9940 else if (to[-1] == '\r')
9943 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9948 /* if we're out of file, or a read fails, bail and reset the current
9949 line marker so we can report where the unterminated string began
9953 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9955 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9957 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9960 CopLINE_inc(PL_curcop);
9961 PL_bufptr = PL_bufend;
9962 if (!lex_next_chunk(0)) {
9964 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9973 /* at this point, we have successfully read the delimited string */
9975 if (!PL_encoding || UTF) {
9978 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9979 const int len = s - tstart;
9981 sv_catpvn(PL_thisstuff, tstart, len);
9983 PL_thisstuff = newSVpvn(tstart, len);
9984 if (!PL_thisclose && !keep_delims)
9985 PL_thisclose = newSVpvn(s,termlen);
9990 sv_catpvn(sv, s, termlen);
9996 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9997 const int len = s - tstart - termlen;
9999 sv_catpvn(PL_thisstuff, tstart, len);
10001 PL_thisstuff = newSVpvn(tstart, len);
10002 if (!PL_thisclose && !keep_delims)
10003 PL_thisclose = newSVpvn(s - termlen,termlen);
10007 if (has_utf8 || PL_encoding)
10010 PL_multi_end = CopLINE(PL_curcop);
10012 /* if we allocated too much space, give some back */
10013 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10014 SvLEN_set(sv, SvCUR(sv) + 1);
10015 SvPV_renew(sv, SvLEN(sv));
10018 /* decide whether this is the first or second quoted string we've read
10031 takes: pointer to position in buffer
10032 returns: pointer to new position in buffer
10033 side-effects: builds ops for the constant in pl_yylval.op
10035 Read a number in any of the formats that Perl accepts:
10037 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10038 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10041 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10043 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10046 If it reads a number without a decimal point or an exponent, it will
10047 try converting the number to an integer and see if it can do so
10048 without loss of precision.
10052 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10055 register const char *s = start; /* current position in buffer */
10056 register char *d; /* destination in temp buffer */
10057 register char *e; /* end of temp buffer */
10058 NV nv; /* number read, as a double */
10059 SV *sv = NULL; /* place to put the converted number */
10060 bool floatit; /* boolean: int or float? */
10061 const char *lastub = NULL; /* position of last underbar */
10062 static char const number_too_long[] = "Number too long";
10064 PERL_ARGS_ASSERT_SCAN_NUM;
10066 /* We use the first character to decide what type of number this is */
10070 Perl_croak(aTHX_ "panic: scan_num");
10072 /* if it starts with a 0, it could be an octal number, a decimal in
10073 0.13 disguise, or a hexadecimal number, or a binary number. */
10077 u holds the "number so far"
10078 shift the power of 2 of the base
10079 (hex == 4, octal == 3, binary == 1)
10080 overflowed was the number more than we can hold?
10082 Shift is used when we add a digit. It also serves as an "are
10083 we in octal/hex/binary?" indicator to disallow hex characters
10084 when in octal mode.
10089 bool overflowed = FALSE;
10090 bool just_zero = TRUE; /* just plain 0 or binary number? */
10091 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10092 static const char* const bases[5] =
10093 { "", "binary", "", "octal", "hexadecimal" };
10094 static const char* const Bases[5] =
10095 { "", "Binary", "", "Octal", "Hexadecimal" };
10096 static const char* const maxima[5] =
10098 "0b11111111111111111111111111111111",
10102 const char *base, *Base, *max;
10104 /* check for hex */
10105 if (s[1] == 'x' || s[1] == 'X') {
10109 } else if (s[1] == 'b' || s[1] == 'B') {
10114 /* check for a decimal in disguise */
10115 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10117 /* so it must be octal */
10124 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10125 "Misplaced _ in number");
10129 base = bases[shift];
10130 Base = Bases[shift];
10131 max = maxima[shift];
10133 /* read the rest of the number */
10135 /* x is used in the overflow test,
10136 b is the digit we're adding on. */
10141 /* if we don't mention it, we're done */
10145 /* _ are ignored -- but warned about if consecutive */
10147 if (lastub && s == lastub + 1)
10148 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10149 "Misplaced _ in number");
10153 /* 8 and 9 are not octal */
10154 case '8': case '9':
10156 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10160 case '2': case '3': case '4':
10161 case '5': case '6': case '7':
10163 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10166 case '0': case '1':
10167 b = *s++ & 15; /* ASCII digit -> value of digit */
10171 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10172 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10173 /* make sure they said 0x */
10176 b = (*s++ & 7) + 9;
10178 /* Prepare to put the digit we have onto the end
10179 of the number so far. We check for overflows.
10185 x = u << shift; /* make room for the digit */
10187 if ((x >> shift) != u
10188 && !(PL_hints & HINT_NEW_BINARY)) {
10191 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10192 "Integer overflow in %s number",
10195 u = x | b; /* add the digit to the end */
10198 n *= nvshift[shift];
10199 /* If an NV has not enough bits in its
10200 * mantissa to represent an UV this summing of
10201 * small low-order numbers is a waste of time
10202 * (because the NV cannot preserve the
10203 * low-order bits anyway): we could just
10204 * remember when did we overflow and in the
10205 * end just multiply n by the right
10213 /* if we get here, we had success: make a scalar value from
10218 /* final misplaced underbar check */
10219 if (s[-1] == '_') {
10220 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10224 if (n > 4294967295.0)
10225 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10226 "%s number > %s non-portable",
10232 if (u > 0xffffffff)
10233 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10234 "%s number > %s non-portable",
10239 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10240 sv = new_constant(start, s - start, "integer",
10241 sv, NULL, NULL, 0);
10242 else if (PL_hints & HINT_NEW_BINARY)
10243 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10248 handle decimal numbers.
10249 we're also sent here when we read a 0 as the first digit
10251 case '1': case '2': case '3': case '4': case '5':
10252 case '6': case '7': case '8': case '9': case '.':
10255 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10258 /* read next group of digits and _ and copy into d */
10259 while (isDIGIT(*s) || *s == '_') {
10260 /* skip underscores, checking for misplaced ones
10264 if (lastub && s == lastub + 1)
10265 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10266 "Misplaced _ in number");
10270 /* check for end of fixed-length buffer */
10272 Perl_croak(aTHX_ number_too_long);
10273 /* if we're ok, copy the character */
10278 /* final misplaced underbar check */
10279 if (lastub && s == lastub + 1) {
10280 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10283 /* read a decimal portion if there is one. avoid
10284 3..5 being interpreted as the number 3. followed
10287 if (*s == '.' && s[1] != '.') {
10292 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10293 "Misplaced _ in number");
10297 /* copy, ignoring underbars, until we run out of digits.
10299 for (; isDIGIT(*s) || *s == '_'; s++) {
10300 /* fixed length buffer check */
10302 Perl_croak(aTHX_ number_too_long);
10304 if (lastub && s == lastub + 1)
10305 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10306 "Misplaced _ in number");
10312 /* fractional part ending in underbar? */
10313 if (s[-1] == '_') {
10314 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10315 "Misplaced _ in number");
10317 if (*s == '.' && isDIGIT(s[1])) {
10318 /* oops, it's really a v-string, but without the "v" */
10324 /* read exponent part, if present */
10325 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10329 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10330 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10332 /* stray preinitial _ */
10334 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10335 "Misplaced _ in number");
10339 /* allow positive or negative exponent */
10340 if (*s == '+' || *s == '-')
10343 /* stray initial _ */
10345 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10346 "Misplaced _ in number");
10350 /* read digits of exponent */
10351 while (isDIGIT(*s) || *s == '_') {
10354 Perl_croak(aTHX_ number_too_long);
10358 if (((lastub && s == lastub + 1) ||
10359 (!isDIGIT(s[1]) && s[1] != '_')))
10360 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10361 "Misplaced _ in number");
10369 We try to do an integer conversion first if no characters
10370 indicating "float" have been found.
10375 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10377 if (flags == IS_NUMBER_IN_UV) {
10379 sv = newSViv(uv); /* Prefer IVs over UVs. */
10382 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10383 if (uv <= (UV) IV_MIN)
10384 sv = newSViv(-(IV)uv);
10391 /* terminate the string */
10393 nv = Atof(PL_tokenbuf);
10398 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10399 const char *const key = floatit ? "float" : "integer";
10400 const STRLEN keylen = floatit ? 5 : 7;
10401 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10402 key, keylen, sv, NULL, NULL, 0);
10406 /* if it starts with a v, it could be a v-string */
10409 sv = newSV(5); /* preallocate storage space */
10410 s = scan_vstring(s, PL_bufend, sv);
10414 /* make the op for the constant and return */
10417 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10419 lvalp->opval = NULL;
10425 S_scan_formline(pTHX_ register char *s)
10428 register char *eol;
10430 SV * const stuff = newSVpvs("");
10431 bool needargs = FALSE;
10432 bool eofmt = FALSE;
10434 char *tokenstart = s;
10435 SV* savewhite = NULL;
10437 if (PL_madskills) {
10438 savewhite = PL_thiswhite;
10443 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10445 while (!needargs) {
10448 #ifdef PERL_STRICT_CR
10449 while (SPACE_OR_TAB(*t))
10452 while (SPACE_OR_TAB(*t) || *t == '\r')
10455 if (*t == '\n' || t == PL_bufend) {
10460 if (PL_in_eval && !PL_rsfp) {
10461 eol = (char *) memchr(s,'\n',PL_bufend-s);
10466 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10468 for (t = s; t < eol; t++) {
10469 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10471 goto enough; /* ~~ must be first line in formline */
10473 if (*t == '@' || *t == '^')
10477 sv_catpvn(stuff, s, eol-s);
10478 #ifndef PERL_STRICT_CR
10479 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10480 char *end = SvPVX(stuff) + SvCUR(stuff);
10483 SvCUR_set(stuff, SvCUR(stuff) - 1);
10494 if (PL_madskills) {
10496 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
10498 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
10501 PL_bufptr = PL_bufend;
10502 CopLINE_inc(PL_curcop);
10503 got_some = lex_next_chunk(0);
10504 CopLINE_dec(PL_curcop);
10507 tokenstart = PL_bufptr;
10515 if (SvCUR(stuff)) {
10518 PL_lex_state = LEX_NORMAL;
10519 start_force(PL_curforce);
10520 NEXTVAL_NEXTTOKE.ival = 0;
10524 PL_lex_state = LEX_FORMLINE;
10526 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10528 else if (PL_encoding)
10529 sv_recode_to_utf8(stuff, PL_encoding);
10531 start_force(PL_curforce);
10532 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10534 start_force(PL_curforce);
10535 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
10539 SvREFCNT_dec(stuff);
10541 PL_lex_formbrack = 0;
10545 if (PL_madskills) {
10547 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
10549 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
10550 PL_thiswhite = savewhite;
10557 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10560 const I32 oldsavestack_ix = PL_savestack_ix;
10561 CV* const outsidecv = PL_compcv;
10564 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10566 SAVEI32(PL_subline);
10567 save_item(PL_subname);
10568 SAVESPTR(PL_compcv);
10570 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10571 CvFLAGS(PL_compcv) |= flags;
10573 PL_subline = CopLINE(PL_curcop);
10574 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10575 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10576 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10578 return oldsavestack_ix;
10582 #pragma segment Perl_yylex
10585 S_yywarn(pTHX_ const char *const s)
10589 PERL_ARGS_ASSERT_YYWARN;
10591 PL_in_eval |= EVAL_WARNONLY;
10593 PL_in_eval &= ~EVAL_WARNONLY;
10598 Perl_yyerror(pTHX_ const char *const s)
10601 const char *where = NULL;
10602 const char *context = NULL;
10605 int yychar = PL_parser->yychar;
10607 PERL_ARGS_ASSERT_YYERROR;
10609 if (!yychar || (yychar == ';' && !PL_rsfp))
10611 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10612 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10613 PL_oldbufptr != PL_bufptr) {
10616 The code below is removed for NetWare because it abends/crashes on NetWare
10617 when the script has error such as not having the closing quotes like:
10618 if ($var eq "value)
10619 Checking of white spaces is anyway done in NetWare code.
10622 while (isSPACE(*PL_oldoldbufptr))
10625 context = PL_oldoldbufptr;
10626 contlen = PL_bufptr - PL_oldoldbufptr;
10628 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10629 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10632 The code below is removed for NetWare because it abends/crashes on NetWare
10633 when the script has error such as not having the closing quotes like:
10634 if ($var eq "value)
10635 Checking of white spaces is anyway done in NetWare code.
10638 while (isSPACE(*PL_oldbufptr))
10641 context = PL_oldbufptr;
10642 contlen = PL_bufptr - PL_oldbufptr;
10644 else if (yychar > 255)
10645 where = "next token ???";
10646 else if (yychar == -2) { /* YYEMPTY */
10647 if (PL_lex_state == LEX_NORMAL ||
10648 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10649 where = "at end of line";
10650 else if (PL_lex_inpat)
10651 where = "within pattern";
10653 where = "within string";
10656 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
10658 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10659 else if (isPRINT_LC(yychar)) {
10660 const char string = yychar;
10661 sv_catpvn(where_sv, &string, 1);
10664 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10665 where = SvPVX_const(where_sv);
10667 msg = sv_2mortal(newSVpv(s, 0));
10668 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10669 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10671 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10673 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10674 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10675 Perl_sv_catpvf(aTHX_ msg,
10676 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10677 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10680 if (PL_in_eval & EVAL_WARNONLY) {
10681 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10685 if (PL_error_count >= 10) {
10686 if (PL_in_eval && SvCUR(ERRSV))
10687 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10688 SVfARG(ERRSV), OutCopFILE(PL_curcop));
10690 Perl_croak(aTHX_ "%s has too many errors.\n",
10691 OutCopFILE(PL_curcop));
10694 PL_in_my_stash = NULL;
10698 #pragma segment Main
10702 S_swallow_bom(pTHX_ U8 *s)
10705 const STRLEN slen = SvCUR(PL_linestr);
10707 PERL_ARGS_ASSERT_SWALLOW_BOM;
10711 if (s[1] == 0xFE) {
10712 /* UTF-16 little-endian? (or UTF-32LE?) */
10713 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10714 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10715 #ifndef PERL_NO_UTF16_FILTER
10716 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10718 if (PL_bufend > (char*)s) {
10719 s = add_utf16_textfilter(s, TRUE);
10722 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10727 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10728 #ifndef PERL_NO_UTF16_FILTER
10729 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10731 if (PL_bufend > (char *)s) {
10732 s = add_utf16_textfilter(s, FALSE);
10735 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10740 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10741 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10742 s += 3; /* UTF-8 */
10748 if (s[2] == 0xFE && s[3] == 0xFF) {
10749 /* UTF-32 big-endian */
10750 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10753 else if (s[2] == 0 && s[3] != 0) {
10756 * are a good indicator of UTF-16BE. */
10757 #ifndef PERL_NO_UTF16_FILTER
10758 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10759 s = add_utf16_textfilter(s, FALSE);
10761 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10767 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
10768 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10769 s += 4; /* UTF-8 */
10775 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10778 * are a good indicator of UTF-16LE. */
10779 #ifndef PERL_NO_UTF16_FILTER
10780 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10781 s = add_utf16_textfilter(s, TRUE);
10783 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10791 #ifndef PERL_NO_UTF16_FILTER
10793 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10796 SV *const filter = FILTER_DATA(idx);
10797 /* We re-use this each time round, throwing the contents away before we
10799 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10800 SV *const utf8_buffer = filter;
10801 IV status = IoPAGE(filter);
10802 const bool reverse = cBOOL(IoLINES(filter));
10805 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10807 /* As we're automatically added, at the lowest level, and hence only called
10808 from this file, we can be sure that we're not called in block mode. Hence
10809 don't bother writing code to deal with block mode. */
10811 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10814 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10816 DEBUG_P(PerlIO_printf(Perl_debug_log,
10817 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10818 FPTR2DPTR(void *, S_utf16_textfilter),
10819 reverse ? 'l' : 'b', idx, maxlen, status,
10820 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10827 /* First, look in our buffer of existing UTF-8 data: */
10828 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10832 } else if (status == 0) {
10834 IoPAGE(filter) = 0;
10835 nl = SvEND(utf8_buffer);
10838 STRLEN got = nl - SvPVX(utf8_buffer);
10839 /* Did we have anything to append? */
10841 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10842 /* Everything else in this code works just fine if SVp_POK isn't
10843 set. This, however, needs it, and we need it to work, else
10844 we loop infinitely because the buffer is never consumed. */
10845 sv_chop(utf8_buffer, nl);
10849 /* OK, not a complete line there, so need to read some more UTF-16.
10850 Read an extra octect if the buffer currently has an odd number. */
10854 if (SvCUR(utf16_buffer) >= 2) {
10855 /* Location of the high octet of the last complete code point.
10856 Gosh, UTF-16 is a pain. All the benefits of variable length,
10857 *coupled* with all the benefits of partial reads and
10859 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10860 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10862 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10866 /* We have the first half of a surrogate. Read more. */
10867 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10870 status = FILTER_READ(idx + 1, utf16_buffer,
10871 160 + (SvCUR(utf16_buffer) & 1));
10872 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10873 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10876 IoPAGE(filter) = status;
10881 chars = SvCUR(utf16_buffer) >> 1;
10882 have = SvCUR(utf8_buffer);
10883 SvGROW(utf8_buffer, have + chars * 3 + 1);
10886 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10887 (U8*)SvPVX_const(utf8_buffer) + have,
10888 chars * 2, &newlen);
10890 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10891 (U8*)SvPVX_const(utf8_buffer) + have,
10892 chars * 2, &newlen);
10894 SvCUR_set(utf8_buffer, have + newlen);
10897 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10898 it's private to us, and utf16_to_utf8{,reversed} take a
10899 (pointer,length) pair, rather than a NUL-terminated string. */
10900 if(SvCUR(utf16_buffer) & 1) {
10901 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10902 SvCUR_set(utf16_buffer, 1);
10904 SvCUR_set(utf16_buffer, 0);
10907 DEBUG_P(PerlIO_printf(Perl_debug_log,
10908 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10910 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10911 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10916 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10918 SV *filter = filter_add(S_utf16_textfilter, NULL);
10920 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10922 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10923 sv_setpvs(filter, "");
10924 IoLINES(filter) = reversed;
10925 IoPAGE(filter) = 1; /* Not EOF */
10927 /* Sadly, we have to return a valid pointer, come what may, so we have to
10928 ignore any error return from this. */
10929 SvCUR_set(PL_linestr, 0);
10930 if (FILTER_READ(0, PL_linestr, 0)) {
10931 SvUTF8_on(PL_linestr);
10933 SvUTF8_on(PL_linestr);
10935 PL_bufend = SvEND(PL_linestr);
10936 return (U8*)SvPVX(PL_linestr);
10941 Returns a pointer to the next character after the parsed
10942 vstring, as well as updating the passed in sv.
10944 Function must be called like
10947 s = scan_vstring(s,e,sv);
10949 where s and e are the start and end of the string.
10950 The sv should already be large enough to store the vstring
10951 passed in, for performance reasons.
10956 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
10959 const char *pos = s;
10960 const char *start = s;
10962 PERL_ARGS_ASSERT_SCAN_VSTRING;
10964 if (*pos == 'v') pos++; /* get past 'v' */
10965 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10967 if ( *pos != '.') {
10968 /* this may not be a v-string if followed by => */
10969 const char *next = pos;
10970 while (next < e && isSPACE(*next))
10972 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
10973 /* return string not v-string */
10974 sv_setpvn(sv,(char *)s,pos-s);
10975 return (char *)pos;
10979 if (!isALPHA(*pos)) {
10980 U8 tmpbuf[UTF8_MAXBYTES+1];
10983 s++; /* get past 'v' */
10988 /* this is atoi() that tolerates underscores */
10991 const char *end = pos;
10993 while (--end >= s) {
10995 const UV orev = rev;
10996 rev += (*end - '0') * mult;
10999 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11000 "Integer overflow in decimal number");
11004 if (rev > 0x7FFFFFFF)
11005 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11007 /* Append native character for the rev point */
11008 tmpend = uvchr_to_utf8(tmpbuf, rev);
11009 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11010 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11012 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11018 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11022 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11029 Perl_keyword_plugin_standard(pTHX_
11030 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11032 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11033 PERL_UNUSED_CONTEXT;
11034 PERL_UNUSED_ARG(keyword_ptr);
11035 PERL_UNUSED_ARG(keyword_len);
11036 PERL_UNUSED_ARG(op_ptr);
11037 return KEYWORD_PLUGIN_DECLINE;
11040 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11042 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11044 SAVEI32(PL_lex_brackets);
11045 if (PL_lex_brackets > 100)
11046 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11047 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11048 SAVEI32(PL_lex_allbrackets);
11049 PL_lex_allbrackets = 0;
11050 SAVEI8(PL_lex_fakeeof);
11051 PL_lex_fakeeof = (U8)fakeeof;
11052 if(yyparse(gramtype) && !PL_parser->error_count)
11053 qerror(Perl_mess(aTHX_ "Parse error"));
11056 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11058 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11062 SAVEVPTR(PL_eval_root);
11063 PL_eval_root = NULL;
11064 parse_recdescent(gramtype, fakeeof);
11070 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11072 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11075 if (flags & ~PARSE_OPTIONAL)
11076 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11077 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11078 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11079 if (!PL_parser->error_count)
11080 qerror(Perl_mess(aTHX_ "Parse error"));
11081 exprop = newOP(OP_NULL, 0);
11087 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11089 Parse a Perl arithmetic expression. This may contain operators of precedence
11090 down to the bit shift operators. The expression must be followed (and thus
11091 terminated) either by a comparison or lower-precedence operator or by
11092 something that would normally terminate an expression such as semicolon.
11093 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11094 otherwise it is mandatory. It is up to the caller to ensure that the
11095 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11096 the source of the code to be parsed and the lexical context for the
11099 The op tree representing the expression is returned. If an optional
11100 expression is absent, a null pointer is returned, otherwise the pointer
11103 If an error occurs in parsing or compilation, in most cases a valid op
11104 tree is returned anyway. The error is reflected in the parser state,
11105 normally resulting in a single exception at the top level of parsing
11106 which covers all the compilation errors that occurred. Some compilation
11107 errors, however, will throw an exception immediately.
11113 Perl_parse_arithexpr(pTHX_ U32 flags)
11115 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11119 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11121 Parse a Perl term expression. This may contain operators of precedence
11122 down to the assignment operators. The expression must be followed (and thus
11123 terminated) either by a comma or lower-precedence operator or by
11124 something that would normally terminate an expression such as semicolon.
11125 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11126 otherwise it is mandatory. It is up to the caller to ensure that the
11127 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11128 the source of the code to be parsed and the lexical context for the
11131 The op tree representing the expression is returned. If an optional
11132 expression is absent, a null pointer is returned, otherwise the pointer
11135 If an error occurs in parsing or compilation, in most cases a valid op
11136 tree is returned anyway. The error is reflected in the parser state,
11137 normally resulting in a single exception at the top level of parsing
11138 which covers all the compilation errors that occurred. Some compilation
11139 errors, however, will throw an exception immediately.
11145 Perl_parse_termexpr(pTHX_ U32 flags)
11147 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11151 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11153 Parse a Perl list expression. This may contain operators of precedence
11154 down to the comma operator. The expression must be followed (and thus
11155 terminated) either by a low-precedence logic operator such as C<or> or by
11156 something that would normally terminate an expression such as semicolon.
11157 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11158 otherwise it is mandatory. It is up to the caller to ensure that the
11159 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11160 the source of the code to be parsed and the lexical context for the
11163 The op tree representing the expression is returned. If an optional
11164 expression is absent, a null pointer is returned, otherwise the pointer
11167 If an error occurs in parsing or compilation, in most cases a valid op
11168 tree is returned anyway. The error is reflected in the parser state,
11169 normally resulting in a single exception at the top level of parsing
11170 which covers all the compilation errors that occurred. Some compilation
11171 errors, however, will throw an exception immediately.
11177 Perl_parse_listexpr(pTHX_ U32 flags)
11179 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11183 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11185 Parse a single complete Perl expression. This allows the full
11186 expression grammar, including the lowest-precedence operators such
11187 as C<or>. The expression must be followed (and thus terminated) by a
11188 token that an expression would normally be terminated by: end-of-file,
11189 closing bracketing punctuation, semicolon, or one of the keywords that
11190 signals a postfix expression-statement modifier. If I<flags> includes
11191 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11192 mandatory. It is up to the caller to ensure that the dynamic parser
11193 state (L</PL_parser> et al) is correctly set to reflect the source of
11194 the code to be parsed and the lexical context for the expression.
11196 The op tree representing the expression is returned. If an optional
11197 expression is absent, a null pointer is returned, otherwise the pointer
11200 If an error occurs in parsing or compilation, in most cases a valid op
11201 tree is returned anyway. The error is reflected in the parser state,
11202 normally resulting in a single exception at the top level of parsing
11203 which covers all the compilation errors that occurred. Some compilation
11204 errors, however, will throw an exception immediately.
11210 Perl_parse_fullexpr(pTHX_ U32 flags)
11212 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11216 =for apidoc Amx|OP *|parse_block|U32 flags
11218 Parse a single complete Perl code block. This consists of an opening
11219 brace, a sequence of statements, and a closing brace. The block
11220 constitutes a lexical scope, so C<my> variables and various compile-time
11221 effects can be contained within it. It is up to the caller to ensure
11222 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11223 reflect the source of the code to be parsed and the lexical context for
11226 The op tree representing the code block is returned. This is always a
11227 real op, never a null pointer. It will normally be a C<lineseq> list,
11228 including C<nextstate> or equivalent ops. No ops to construct any kind
11229 of runtime scope are included by virtue of it being a block.
11231 If an error occurs in parsing or compilation, in most cases a valid op
11232 tree (most likely null) is returned anyway. The error is reflected in
11233 the parser state, normally resulting in a single exception at the top
11234 level of parsing which covers all the compilation errors that occurred.
11235 Some compilation errors, however, will throw an exception immediately.
11237 The I<flags> parameter is reserved for future use, and must always
11244 Perl_parse_block(pTHX_ U32 flags)
11247 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11248 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11252 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11254 Parse a single unadorned Perl statement. This may be a normal imperative
11255 statement or a declaration that has compile-time effect. It does not
11256 include any label or other affixture. It is up to the caller to ensure
11257 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11258 reflect the source of the code to be parsed and the lexical context for
11261 The op tree representing the statement is returned. This may be a
11262 null pointer if the statement is null, for example if it was actually
11263 a subroutine definition (which has compile-time side effects). If not
11264 null, it will be ops directly implementing the statement, suitable to
11265 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11266 equivalent op (except for those embedded in a scope contained entirely
11267 within the statement).
11269 If an error occurs in parsing or compilation, in most cases a valid op
11270 tree (most likely null) is returned anyway. The error is reflected in
11271 the parser state, normally resulting in a single exception at the top
11272 level of parsing which covers all the compilation errors that occurred.
11273 Some compilation errors, however, will throw an exception immediately.
11275 The I<flags> parameter is reserved for future use, and must always
11282 Perl_parse_barestmt(pTHX_ U32 flags)
11285 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11286 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11290 =for apidoc Amx|SV *|parse_label|U32 flags
11292 Parse a single label, possibly optional, of the type that may prefix a
11293 Perl statement. It is up to the caller to ensure that the dynamic parser
11294 state (L</PL_parser> et al) is correctly set to reflect the source of
11295 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11296 label is optional, otherwise it is mandatory.
11298 The name of the label is returned in the form of a fresh scalar. If an
11299 optional label is absent, a null pointer is returned.
11301 If an error occurs in parsing, which can only occur if the label is
11302 mandatory, a valid label is returned anyway. The error is reflected in
11303 the parser state, normally resulting in a single exception at the top
11304 level of parsing which covers all the compilation errors that occurred.
11310 Perl_parse_label(pTHX_ U32 flags)
11312 if (flags & ~PARSE_OPTIONAL)
11313 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11314 if (PL_lex_state == LEX_KNOWNEXT) {
11315 PL_parser->yychar = yylex();
11316 if (PL_parser->yychar == LABEL) {
11317 char *lpv = pl_yylval.pval;
11318 STRLEN llen = strlen(lpv);
11320 PL_parser->yychar = YYEMPTY;
11321 lsv = newSV_type(SVt_PV);
11322 SvPV_set(lsv, lpv);
11323 SvCUR_set(lsv, llen);
11324 SvLEN_set(lsv, llen+1);
11334 STRLEN wlen, bufptr_pos;
11338 if (!isIDFIRST_A(c))
11342 } while(isWORDCHAR_A(c));
11344 if (word_takes_any_delimeter(s, wlen))
11346 bufptr_pos = s - SvPVX(PL_linestr);
11348 lex_read_space(LEX_KEEP_PREVIOUS);
11350 s = SvPVX(PL_linestr) + bufptr_pos;
11351 if (t[0] == ':' && t[1] != ':') {
11352 PL_oldoldbufptr = PL_oldbufptr;
11355 return newSVpvn(s, wlen);
11359 if (flags & PARSE_OPTIONAL) {
11362 qerror(Perl_mess(aTHX_ "Parse error"));
11363 return newSVpvs("x");
11370 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11372 Parse a single complete Perl statement. This may be a normal imperative
11373 statement or a declaration that has compile-time effect, and may include
11374 optional labels. It is up to the caller to ensure that the dynamic
11375 parser state (L</PL_parser> et al) is correctly set to reflect the source
11376 of the code to be parsed and the lexical context for the statement.
11378 The op tree representing the statement is returned. This may be a
11379 null pointer if the statement is null, for example if it was actually
11380 a subroutine definition (which has compile-time side effects). If not
11381 null, it will be the result of a L</newSTATEOP> call, normally including
11382 a C<nextstate> or equivalent op.
11384 If an error occurs in parsing or compilation, in most cases a valid op
11385 tree (most likely null) is returned anyway. The error is reflected in
11386 the parser state, normally resulting in a single exception at the top
11387 level of parsing which covers all the compilation errors that occurred.
11388 Some compilation errors, however, will throw an exception immediately.
11390 The I<flags> parameter is reserved for future use, and must always
11397 Perl_parse_fullstmt(pTHX_ U32 flags)
11400 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11401 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11405 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11407 Parse a sequence of zero or more Perl statements. These may be normal
11408 imperative statements, including optional labels, or declarations
11409 that have compile-time effect, or any mixture thereof. The statement
11410 sequence ends when a closing brace or end-of-file is encountered in a
11411 place where a new statement could have validly started. It is up to
11412 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11413 is correctly set to reflect the source of the code to be parsed and the
11414 lexical context for the statements.
11416 The op tree representing the statement sequence is returned. This may
11417 be a null pointer if the statements were all null, for example if there
11418 were no statements or if there were only subroutine definitions (which
11419 have compile-time side effects). If not null, it will be a C<lineseq>
11420 list, normally including C<nextstate> or equivalent ops.
11422 If an error occurs in parsing or compilation, in most cases a valid op
11423 tree is returned anyway. The error is reflected in the parser state,
11424 normally resulting in a single exception at the top level of parsing
11425 which covers all the compilation errors that occurred. Some compilation
11426 errors, however, will throw an exception immediately.
11428 The I<flags> parameter is reserved for future use, and must always
11435 Perl_parse_stmtseq(pTHX_ U32 flags)
11440 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11441 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11442 c = lex_peek_unichar(0);
11443 if (c != -1 && c != /*{*/'}')
11444 qerror(Perl_mess(aTHX_ "Parse error"));
11449 Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist)
11451 PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
11452 deprecate("qw(...) as parentheses");
11453 force_next((4<<24)|')');
11454 if (qwlist->op_type == OP_STUB) {
11458 start_force(PL_curforce);
11459 NEXTVAL_NEXTTOKE.opval = qwlist;
11462 force_next((2<<24)|'(');
11467 * c-indentation-style: bsd
11468 * c-basic-offset: 4
11469 * indent-tabs-mode: t
11472 * ex: set ts=8 sts=4 sw=4 noet: