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)
7075 /* that's a way to remember we saw "CORE::" */
7088 LOP(OP_ACCEPT,XTERM);
7091 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7096 LOP(OP_ATAN2,XTERM);
7102 LOP(OP_BINMODE,XTERM);
7105 LOP(OP_BLESS,XTERM);
7114 /* We have to disambiguate the two senses of
7115 "continue". If the next token is a '{' then
7116 treat it as the start of a continue block;
7117 otherwise treat it as a control operator.
7127 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7137 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7146 if (!PL_cryptseen) {
7147 PL_cryptseen = TRUE;
7151 LOP(OP_CRYPT,XTERM);
7154 LOP(OP_CHMOD,XTERM);
7157 LOP(OP_CHOWN,XTERM);
7160 LOP(OP_CONNECT,XTERM);
7179 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7180 if (orig_keyword == KEY_do) {
7189 PL_hints |= HINT_BLOCK_SCOPE;
7199 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7200 STR_WITH_LEN("NDBM_File::"),
7201 STR_WITH_LEN("DB_File::"),
7202 STR_WITH_LEN("GDBM_File::"),
7203 STR_WITH_LEN("SDBM_File::"),
7204 STR_WITH_LEN("ODBM_File::"),
7206 LOP(OP_DBMOPEN,XTERM);
7212 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7219 pl_yylval.ival = CopLINE(PL_curcop);
7223 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7237 if (*s == '{') { /* block eval */
7238 PL_expect = XTERMBLOCK;
7239 UNIBRACK(OP_ENTERTRY);
7241 else { /* string eval */
7243 UNIBRACK(OP_ENTEREVAL);
7258 case KEY_endhostent:
7264 case KEY_endservent:
7267 case KEY_endprotoent:
7278 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7280 pl_yylval.ival = CopLINE(PL_curcop);
7282 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7285 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7288 if ((PL_bufend - p) >= 3 &&
7289 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7291 else if ((PL_bufend - p) >= 4 &&
7292 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7295 if (isIDFIRST_lazy_if(p,UTF)) {
7296 p = scan_ident(p, PL_bufend,
7297 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7301 Perl_croak(aTHX_ "Missing $ on loop variable");
7303 s = SvPVX(PL_linestr) + soff;
7309 LOP(OP_FORMLINE,XTERM);
7315 LOP(OP_FCNTL,XTERM);
7321 LOP(OP_FLOCK,XTERM);
7324 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7329 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7334 LOP(OP_GREPSTART, XREF);
7337 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7352 case KEY_getpriority:
7353 LOP(OP_GETPRIORITY,XTERM);
7355 case KEY_getprotobyname:
7358 case KEY_getprotobynumber:
7359 LOP(OP_GPBYNUMBER,XTERM);
7361 case KEY_getprotoent:
7373 case KEY_getpeername:
7374 UNI(OP_GETPEERNAME);
7376 case KEY_gethostbyname:
7379 case KEY_gethostbyaddr:
7380 LOP(OP_GHBYADDR,XTERM);
7382 case KEY_gethostent:
7385 case KEY_getnetbyname:
7388 case KEY_getnetbyaddr:
7389 LOP(OP_GNBYADDR,XTERM);
7394 case KEY_getservbyname:
7395 LOP(OP_GSBYNAME,XTERM);
7397 case KEY_getservbyport:
7398 LOP(OP_GSBYPORT,XTERM);
7400 case KEY_getservent:
7403 case KEY_getsockname:
7404 UNI(OP_GETSOCKNAME);
7406 case KEY_getsockopt:
7407 LOP(OP_GSOCKOPT,XTERM);
7422 pl_yylval.ival = CopLINE(PL_curcop);
7432 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7434 pl_yylval.ival = CopLINE(PL_curcop);
7438 LOP(OP_INDEX,XTERM);
7444 LOP(OP_IOCTL,XTERM);
7456 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7473 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7478 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7492 LOP(OP_LISTEN,XTERM);
7501 s = scan_pat(s,OP_MATCH);
7502 TERM(sublex_start());
7505 LOP(OP_MAPSTART, XREF);
7508 LOP(OP_MKDIR,XTERM);
7511 LOP(OP_MSGCTL,XTERM);
7514 LOP(OP_MSGGET,XTERM);
7517 LOP(OP_MSGRCV,XTERM);
7520 LOP(OP_MSGSND,XTERM);
7525 PL_in_my = (U16)tmp;
7527 if (isIDFIRST_lazy_if(s,UTF)) {
7531 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7532 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7534 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7535 if (!PL_in_my_stash) {
7538 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7542 if (PL_madskills) { /* just add type to declarator token */
7543 sv_catsv(PL_thistoken, PL_nextwhite);
7545 sv_catpvn(PL_thistoken, start, s - start);
7553 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7557 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7562 s = tokenize_use(0, s);
7566 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
7569 if (!PL_lex_allbrackets &&
7570 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7571 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7577 if (isIDFIRST_lazy_if(s,UTF)) {
7579 for (d = s; isALNUM_lazy_if(d,UTF);)
7581 for (t=d; isSPACE(*t);)
7583 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7585 && !(t[0] == '=' && t[1] == '>')
7587 int parms_len = (int)(d-s);
7588 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7589 "Precedence problem: open %.*s should be open(%.*s)",
7590 parms_len, s, parms_len, s);
7596 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7598 pl_yylval.ival = OP_OR;
7608 LOP(OP_OPEN_DIR,XTERM);
7611 checkcomma(s,PL_tokenbuf,"filehandle");
7615 checkcomma(s,PL_tokenbuf,"filehandle");
7634 s = force_word(s,WORD,FALSE,TRUE,FALSE);
7636 s = force_strict_version(s);
7637 PL_lex_expect = XBLOCK;
7641 LOP(OP_PIPE_OP,XTERM);
7644 s = scan_str(s,!!PL_madskills,FALSE);
7647 pl_yylval.ival = OP_CONST;
7648 TERM(sublex_start());
7655 s = scan_str(s,!!PL_madskills,FALSE);
7658 PL_expect = XOPERATOR;
7659 if (SvCUR(PL_lex_stuff)) {
7660 int warned_comma = !ckWARN(WARN_QW);
7661 int warned_comment = warned_comma;
7662 d = SvPV_force(PL_lex_stuff, len);
7664 for (; isSPACE(*d) && len; --len, ++d)
7669 if (!warned_comma || !warned_comment) {
7670 for (; !isSPACE(*d) && len; --len, ++d) {
7671 if (!warned_comma && *d == ',') {
7672 Perl_warner(aTHX_ packWARN(WARN_QW),
7673 "Possible attempt to separate words with commas");
7676 else if (!warned_comment && *d == '#') {
7677 Perl_warner(aTHX_ packWARN(WARN_QW),
7678 "Possible attempt to put comments in qw() list");
7684 for (; !isSPACE(*d) && len; --len, ++d)
7687 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7688 words = op_append_elem(OP_LIST, words,
7689 newSVOP(OP_CONST, 0, tokeq(sv)));
7694 words = newNULLLIST();
7696 SvREFCNT_dec(PL_lex_stuff);
7697 PL_lex_stuff = NULL;
7699 PL_expect = XOPERATOR;
7700 pl_yylval.opval = sawparens(words);
7705 s = scan_str(s,!!PL_madskills,FALSE);
7708 pl_yylval.ival = OP_STRINGIFY;
7709 if (SvIVX(PL_lex_stuff) == '\'')
7710 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7711 TERM(sublex_start());
7714 s = scan_pat(s,OP_QR);
7715 TERM(sublex_start());
7718 s = scan_str(s,!!PL_madskills,FALSE);
7721 readpipe_override();
7722 TERM(sublex_start());
7730 s = force_version(s, FALSE);
7732 else if (*s != 'v' || !isDIGIT(s[1])
7733 || (s = force_version(s, TRUE), *s == 'v'))
7735 *PL_tokenbuf = '\0';
7736 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7737 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7738 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7739 GV_ADD | (UTF ? SVf_UTF8 : 0));
7741 yyerror("<> should be quotes");
7743 if (orig_keyword == KEY_require) {
7751 PL_last_uni = PL_oldbufptr;
7752 PL_last_lop_op = OP_REQUIRE;
7754 return REPORT( (int)REQUIRE );
7760 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7764 LOP(OP_RENAME,XTERM);
7773 LOP(OP_RINDEX,XTERM);
7782 UNIDOR(OP_READLINE);
7785 UNIDOR(OP_BACKTICK);
7794 LOP(OP_REVERSE,XTERM);
7797 UNIDOR(OP_READLINK);
7804 if (pl_yylval.opval)
7805 TERM(sublex_start());
7807 TOKEN(1); /* force error */
7810 checkcomma(s,PL_tokenbuf,"filehandle");
7820 LOP(OP_SELECT,XTERM);
7826 LOP(OP_SEMCTL,XTERM);
7829 LOP(OP_SEMGET,XTERM);
7832 LOP(OP_SEMOP,XTERM);
7838 LOP(OP_SETPGRP,XTERM);
7840 case KEY_setpriority:
7841 LOP(OP_SETPRIORITY,XTERM);
7843 case KEY_sethostent:
7849 case KEY_setservent:
7852 case KEY_setprotoent:
7862 LOP(OP_SEEKDIR,XTERM);
7864 case KEY_setsockopt:
7865 LOP(OP_SSOCKOPT,XTERM);
7871 LOP(OP_SHMCTL,XTERM);
7874 LOP(OP_SHMGET,XTERM);
7877 LOP(OP_SHMREAD,XTERM);
7880 LOP(OP_SHMWRITE,XTERM);
7883 LOP(OP_SHUTDOWN,XTERM);
7892 LOP(OP_SOCKET,XTERM);
7894 case KEY_socketpair:
7895 LOP(OP_SOCKPAIR,XTERM);
7898 checkcomma(s,PL_tokenbuf,"subroutine name");
7900 if (*s == ';' || *s == ')') /* probably a close */
7901 Perl_croak(aTHX_ "sort is now a reserved word");
7903 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7907 LOP(OP_SPLIT,XTERM);
7910 LOP(OP_SPRINTF,XTERM);
7913 LOP(OP_SPLICE,XTERM);
7928 LOP(OP_SUBSTR,XTERM);
7934 char tmpbuf[sizeof PL_tokenbuf];
7935 SSize_t tboffset = 0;
7936 expectation attrful;
7937 bool have_name, have_proto;
7938 const int key = tmp;
7943 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7944 SV *subtoken = newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr));
7948 s = SKIPSPACE2(s,tmpwhite);
7953 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7954 (*s == ':' && s[1] == ':'))
7957 SV *nametoke = NULL;
7961 attrful = XATTRBLOCK;
7962 /* remember buffer pos'n for later force_word */
7963 tboffset = s - PL_oldbufptr;
7964 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
7967 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
7969 if (memchr(tmpbuf, ':', len))
7970 sv_setpvn(PL_subname, tmpbuf, len);
7972 sv_setsv(PL_subname,PL_curstname);
7973 sv_catpvs(PL_subname,"::");
7974 sv_catpvn(PL_subname,tmpbuf,len);
7976 if (SvUTF8(PL_linestr))
7977 SvUTF8_on(PL_subname);
7983 CURMAD('X', nametoke);
7984 CURMAD('_', tmpwhite);
7985 (void) force_word(PL_oldbufptr + tboffset, WORD,
7988 s = SKIPSPACE2(d,tmpwhite);
7995 Perl_croak(aTHX_ "Missing name in \"my sub\"");
7996 PL_expect = XTERMBLOCK;
7997 attrful = XATTRTERM;
7998 sv_setpvs(PL_subname,"?");
8002 if (key == KEY_format) {
8004 PL_lex_formbrack = PL_lex_brackets + 1;
8006 PL_thistoken = subtoken;
8010 (void) force_word(PL_oldbufptr + tboffset, WORD,
8016 /* Look for a prototype */
8019 bool bad_proto = FALSE;
8020 bool in_brackets = FALSE;
8021 char greedy_proto = ' ';
8022 bool proto_after_greedy_proto = FALSE;
8023 bool must_be_last = FALSE;
8024 bool underscore = FALSE;
8025 bool seen_underscore = FALSE;
8026 const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
8029 s = scan_str(s,!!PL_madskills,FALSE);
8031 Perl_croak(aTHX_ "Prototype not terminated");
8032 /* strip spaces and check for bad characters */
8033 d = SvPV(PL_lex_stuff, tmplen);
8035 for (p = d; tmplen; tmplen--, ++p) {
8039 if (warnillegalproto) {
8041 proto_after_greedy_proto = TRUE;
8042 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
8054 else if ( *p == ']' ) {
8055 in_brackets = FALSE;
8057 else if ( (*p == '@' || *p == '%') &&
8058 ( tmp < 2 || d[tmp-2] != '\\' ) &&
8060 must_be_last = TRUE;
8063 else if ( *p == '_' ) {
8064 underscore = seen_underscore = TRUE;
8071 if (proto_after_greedy_proto)
8072 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8073 "Prototype after '%c' for %"SVf" : %s",
8074 greedy_proto, SVfARG(PL_subname), d);
8076 SV *dsv = newSVpvs_flags("", SVs_TEMP);
8077 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8078 "Illegal character %sin prototype for %"SVf" : %s",
8079 seen_underscore ? "after '_' " : "",
8082 newSVpvn_flags(d, tmp, SVs_TEMP | SvUTF8(PL_lex_stuff)),
8083 tmp, UNI_DISPLAY_ISPRINT));
8085 SvCUR_set(PL_lex_stuff, tmp);
8090 CURMAD('q', PL_thisopen);
8091 CURMAD('_', tmpwhite);
8092 CURMAD('=', PL_thisstuff);
8093 CURMAD('Q', PL_thisclose);
8094 NEXTVAL_NEXTTOKE.opval =
8095 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8096 PL_lex_stuff = NULL;
8099 s = SKIPSPACE2(s,tmpwhite);
8107 if (*s == ':' && s[1] != ':')
8108 PL_expect = attrful;
8109 else if (*s != '{' && key == KEY_sub) {
8111 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8112 else if (*s != ';' && *s != '}')
8113 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8120 curmad('^', newSVpvs(""));
8121 CURMAD('_', tmpwhite);
8125 PL_thistoken = subtoken;
8128 NEXTVAL_NEXTTOKE.opval =
8129 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8130 PL_lex_stuff = NULL;
8136 sv_setpvs(PL_subname, "__ANON__");
8138 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8142 (void) force_word(PL_oldbufptr + tboffset, WORD,
8151 LOP(OP_SYSTEM,XREF);
8154 LOP(OP_SYMLINK,XTERM);
8157 LOP(OP_SYSCALL,XTERM);
8160 LOP(OP_SYSOPEN,XTERM);
8163 LOP(OP_SYSSEEK,XTERM);
8166 LOP(OP_SYSREAD,XTERM);
8169 LOP(OP_SYSWRITE,XTERM);
8173 TERM(sublex_start());
8194 LOP(OP_TRUNCATE,XTERM);
8206 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8208 pl_yylval.ival = CopLINE(PL_curcop);
8212 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8214 pl_yylval.ival = CopLINE(PL_curcop);
8218 LOP(OP_UNLINK,XTERM);
8224 LOP(OP_UNPACK,XTERM);
8227 LOP(OP_UTIME,XTERM);
8233 LOP(OP_UNSHIFT,XTERM);
8236 s = tokenize_use(1, s);
8246 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8248 pl_yylval.ival = CopLINE(PL_curcop);
8252 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8254 pl_yylval.ival = CopLINE(PL_curcop);
8258 PL_hints |= HINT_BLOCK_SCOPE;
8265 LOP(OP_WAITPID,XTERM);
8274 ctl_l[0] = toCTRL('L');
8276 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8279 /* Make sure $^L is defined */
8280 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8285 if (PL_expect == XOPERATOR) {
8286 if (*s == '=' && !PL_lex_allbrackets &&
8287 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8295 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8297 pl_yylval.ival = OP_XOR;
8302 TERM(sublex_start());
8307 #pragma segment Main
8311 S_pending_ident(pTHX)
8316 /* pit holds the identifier we read and pending_ident is reset */
8317 char pit = PL_pending_ident;
8318 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8319 /* All routes through this function want to know if there is a colon. */
8320 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8321 PL_pending_ident = 0;
8323 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
8324 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8325 "### Pending identifier '%s'\n", PL_tokenbuf); });
8327 /* if we're in a my(), we can't allow dynamics here.
8328 $foo'bar has already been turned into $foo::bar, so
8329 just check for colons.
8331 if it's a legal name, the OP is a PADANY.
8334 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8336 yyerror(Perl_form(aTHX_ "No package name allowed for "
8337 "variable %s in \"our\"",
8339 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8343 yyerror(Perl_form(aTHX_ PL_no_myglob,
8344 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
8346 pl_yylval.opval = newOP(OP_PADANY, 0);
8347 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8348 UTF ? SVf_UTF8 : 0);
8354 build the ops for accesses to a my() variable.
8356 Deny my($a) or my($b) in a sort block, *if* $a or $b is
8357 then used in a comparison. This catches most, but not
8358 all cases. For instance, it catches
8359 sort { my($a); $a <=> $b }
8361 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
8362 (although why you'd do that is anyone's guess).
8367 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8368 UTF ? SVf_UTF8 : 0);
8369 if (tmp != NOT_IN_PAD) {
8370 /* might be an "our" variable" */
8371 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8372 /* build ops for a bareword */
8373 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8374 HEK * const stashname = HvNAME_HEK(stash);
8375 SV * const sym = newSVhek(stashname);
8376 sv_catpvs(sym, "::");
8377 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8378 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8379 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8382 ? (GV_ADDMULTI | GV_ADDINEVAL)
8385 ((PL_tokenbuf[0] == '$') ? SVt_PV
8386 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8391 /* if it's a sort block and they're naming $a or $b */
8392 if (PL_last_lop_op == OP_SORT &&
8393 PL_tokenbuf[0] == '$' &&
8394 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
8397 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
8398 d < PL_bufend && *d != '\n';
8401 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
8402 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
8408 pl_yylval.opval = newOP(OP_PADANY, 0);
8409 pl_yylval.opval->op_targ = tmp;
8415 Whine if they've said @foo in a doublequoted string,
8416 and @foo isn't a variable we can find in the symbol
8419 if (ckWARN(WARN_AMBIGUOUS) &&
8420 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8421 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8422 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8423 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8424 /* DO NOT warn for @- and @+ */
8425 && !( PL_tokenbuf[2] == '\0' &&
8426 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8429 /* Downgraded from fatal to warning 20000522 mjd */
8430 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8431 "Possible unintended interpolation of %s in string",
8436 /* build ops for a bareword */
8437 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(PL_tokenbuf + 1,
8439 UTF ? SVf_UTF8 : 0 ));
8440 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8441 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8442 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
8443 | ( UTF ? SVf_UTF8 : 0 ),
8444 ((PL_tokenbuf[0] == '$') ? SVt_PV
8445 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8451 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8455 PERL_ARGS_ASSERT_CHECKCOMMA;
8457 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8458 if (ckWARN(WARN_SYNTAX)) {
8461 for (w = s+2; *w && level; w++) {
8469 /* the list of chars below is for end of statements or
8470 * block / parens, boolean operators (&&, ||, //) and branch
8471 * constructs (or, and, if, until, unless, while, err, for).
8472 * Not a very solid hack... */
8473 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8474 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8475 "%s (...) interpreted as function",name);
8478 while (s < PL_bufend && isSPACE(*s))
8482 while (s < PL_bufend && isSPACE(*s))
8484 if (isIDFIRST_lazy_if(s,UTF)) {
8485 const char * const w = s++;
8486 while (isALNUM_lazy_if(s,UTF))
8488 while (s < PL_bufend && isSPACE(*s))
8492 if (keyword(w, s - w, 0))
8495 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8496 if (gv && GvCVu(gv))
8498 Perl_croak(aTHX_ "No comma allowed after %s", what);
8503 /* Either returns sv, or mortalizes sv and returns a new SV*.
8504 Best used as sv=new_constant(..., sv, ...).
8505 If s, pv are NULL, calls subroutine with one argument,
8506 and type is used with error messages only. */
8509 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8510 SV *sv, SV *pv, const char *type, STRLEN typelen)
8513 HV * const table = GvHV(PL_hintgv); /* ^H */
8517 const char *why1 = "", *why2 = "", *why3 = "";
8519 PERL_ARGS_ASSERT_NEW_CONSTANT;
8521 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8524 why2 = (const char *)
8525 (strEQ(key,"charnames")
8526 ? "(possibly a missing \"use charnames ...\")"
8528 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
8529 (type ? type: "undef"), why2);
8531 /* This is convoluted and evil ("goto considered harmful")
8532 * but I do not understand the intricacies of all the different
8533 * failure modes of %^H in here. The goal here is to make
8534 * the most probable error message user-friendly. --jhi */
8539 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
8540 (type ? type: "undef"), why1, why2, why3);
8542 yyerror(SvPVX_const(msg));
8547 /* charnames doesn't work well if there have been errors found */
8548 if (PL_error_count > 0 && strEQ(key,"charnames"))
8549 return &PL_sv_undef;
8551 cvp = hv_fetch(table, key, keylen, FALSE);
8552 if (!cvp || !SvOK(*cvp)) {
8555 why3 = "} is not defined";
8558 sv_2mortal(sv); /* Parent created it permanently */
8561 pv = newSVpvn_flags(s, len, SVs_TEMP);
8563 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8565 typesv = &PL_sv_undef;
8567 PUSHSTACKi(PERLSI_OVERLOAD);
8579 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8583 /* Check the eval first */
8584 if (!PL_in_eval && SvTRUE(ERRSV)) {
8585 sv_catpvs(ERRSV, "Propagated");
8586 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
8588 res = SvREFCNT_inc_simple(sv);
8592 SvREFCNT_inc_simple_void(res);
8601 why1 = "Call to &{$^H{";
8603 why3 = "}} did not return a defined value";
8611 /* Returns a NUL terminated string, with the length of the string written to
8615 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8618 register char *d = dest;
8619 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8621 PERL_ARGS_ASSERT_SCAN_WORD;
8625 Perl_croak(aTHX_ ident_too_long);
8626 if (isALNUM(*s)) /* UTF handled below */
8628 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
8633 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
8637 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8638 char *t = s + UTF8SKIP(s);
8640 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8644 Perl_croak(aTHX_ ident_too_long);
8645 Copy(s, d, len, char);
8658 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
8661 char *bracket = NULL;
8663 register char *d = dest;
8664 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8666 PERL_ARGS_ASSERT_SCAN_IDENT;
8671 while (isDIGIT(*s)) {
8673 Perl_croak(aTHX_ ident_too_long);
8680 Perl_croak(aTHX_ ident_too_long);
8681 if (isALNUM(*s)) /* UTF handled below */
8683 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
8688 else if (*s == ':' && s[1] == ':') {
8692 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8693 char *t = s + UTF8SKIP(s);
8694 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8696 if (d + (t - s) > e)
8697 Perl_croak(aTHX_ ident_too_long);
8698 Copy(s, d, t - s, char);
8709 if (PL_lex_state != LEX_NORMAL)
8710 PL_lex_state = LEX_INTERPENDMAYBE;
8713 if (*s == '$' && s[1] &&
8714 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
8726 const STRLEN skip = UTF8SKIP(s);
8729 for ( i = 0; i < skip; i++ )
8737 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8742 if (isSPACE(s[-1])) {
8744 const char ch = *s++;
8745 if (!SPACE_OR_TAB(ch)) {
8751 if (isIDFIRST_lazy_if(d,UTF)) {
8755 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
8756 end += UTF8SKIP(end);
8757 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
8758 end += UTF8SKIP(end);
8760 Copy(s, d, end - s, char);
8765 while ((isALNUM(*s) || *s == ':') && d < e)
8768 Perl_croak(aTHX_ ident_too_long);
8771 while (s < send && SPACE_OR_TAB(*s))
8773 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8774 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8775 const char * const brack =
8777 ((*s == '[') ? "[...]" : "{...}");
8778 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8779 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8780 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8781 funny, dest, brack, funny, dest, brack);
8784 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8785 PL_lex_allbrackets++;
8789 /* Handle extended ${^Foo} variables
8790 * 1999-02-27 mjd-perl-patch@plover.com */
8791 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
8795 while (isALNUM(*s) && d < e) {
8799 Perl_croak(aTHX_ ident_too_long);
8804 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8805 PL_lex_state = LEX_INTERPEND;
8808 if (PL_lex_state == LEX_NORMAL) {
8809 if (ckWARN(WARN_AMBIGUOUS) &&
8810 (keyword(dest, d - dest, 0)
8811 || get_cvn_flags(dest, d - dest, 0)))
8815 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8816 "Ambiguous use of %c{%s} resolved to %c%s",
8817 funny, dest, funny, dest);
8822 s = bracket; /* let the parser handle it */
8826 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8827 PL_lex_state = LEX_INTERPEND;
8832 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
8834 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
8835 * the parse starting at 's', based on the subset that are valid in this
8836 * context input to this routine in 'valid_flags'. Advances s. Returns
8837 * TRUE if the input was a valid flag, so the next char may be as well;
8838 * otherwise FALSE. 'charset' should point to a NUL upon first call on the
8839 * current regex. This routine will set it to any charset modifier found.
8840 * The caller shouldn't change it. This way, another charset modifier
8841 * encountered in the parse can be detected as an error, as we have decided
8846 if (! strchr(valid_flags, c)) {
8855 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
8856 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8857 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8858 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8859 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8860 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8861 case LOCALE_PAT_MOD:
8863 /* In 5.14, qr//lt is legal but deprecated; the 't' means they
8864 * can't be regex modifiers.
8865 * In 5.14, s///le is legal and ambiguous. Try to disambiguate as
8866 * much as easily done. s///lei, for example, has to mean regex
8867 * modifiers if it's not an error (as does any word character
8868 * following the 'e'). Otherwise, we resolve to the backwards-
8869 * compatible, but less likely 's/// le ...', i.e. as meaning
8870 * less-than-or-equal. The reason it's not likely is that s//
8871 * returns a number for code in the field (/r returns a string, but
8872 * that wasn't added until the 5.13 series), and so '<=' should be
8873 * used for comparing, not 'le'. */
8874 if (*((*s) + 1) == 't') {
8877 else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) {
8879 /* 'e' is valid only for substitutes, s///e. If it is not
8880 * valid in the current context, then 'm//le' must mean the
8881 * comparison operator, so use the regular deprecation message.
8883 if (! strchr(valid_flags, 'e')) {
8886 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
8887 "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");
8891 goto multiple_charsets;
8893 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8896 case UNICODE_PAT_MOD:
8897 /* In 5.14, qr//unless and qr//until are legal but deprecated; the
8898 * 'n' means they can't be regex modifiers */
8899 if (*((*s) + 1) == 'n') {
8903 goto multiple_charsets;
8905 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8908 case ASCII_RESTRICT_PAT_MOD:
8909 /* In 5.14, qr//and is legal but deprecated; the 'n' means they
8910 * can't be regex modifiers */
8911 if (*((*s) + 1) == 'n') {
8916 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8920 /* Error if previous modifier wasn't an 'a', but if it was, see
8921 * if, and accept, a second occurrence (only) */
8923 || get_regex_charset(*pmfl)
8924 != REGEX_ASCII_RESTRICTED_CHARSET)
8926 goto multiple_charsets;
8928 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8932 case DEPENDS_PAT_MOD:
8934 goto multiple_charsets;
8936 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8945 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
8946 "Having no space between pattern and following word is deprecated");
8950 if (*charset != c) {
8951 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8953 else if (c == 'a') {
8954 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8957 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8960 /* Pretend that it worked, so will continue processing before dieing */
8966 S_scan_pat(pTHX_ char *start, I32 type)
8970 char *s = scan_str(start,!!PL_madskills,FALSE);
8971 const char * const valid_flags =
8972 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8973 char charset = '\0'; /* character set modifier */
8978 PERL_ARGS_ASSERT_SCAN_PAT;
8981 const char * const delimiter = skipspace(start);
8985 ? "Search pattern not terminated or ternary operator parsed as search pattern"
8986 : "Search pattern not terminated" ));
8989 pm = (PMOP*)newPMOP(type, 0);
8990 if (PL_multi_open == '?') {
8991 /* This is the only point in the code that sets PMf_ONCE: */
8992 pm->op_pmflags |= PMf_ONCE;
8994 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8995 allows us to restrict the list needed by reset to just the ??
8997 assert(type != OP_TRANS);
8999 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9002 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9005 elements = mg->mg_len / sizeof(PMOP**);
9006 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9007 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9008 mg->mg_len = elements * sizeof(PMOP**);
9009 PmopSTASH_set(pm,PL_curstash);
9015 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9017 if (PL_madskills && modstart != s) {
9018 SV* tmptoken = newSVpvn(modstart, s - modstart);
9019 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9022 /* issue a warning if /c is specified,but /g is not */
9023 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9025 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9026 "Use of /c modifier is meaningless without /g" );
9029 PL_lex_op = (OP*)pm;
9030 pl_yylval.ival = OP_MATCH;
9035 S_scan_subst(pTHX_ char *start)
9042 char charset = '\0'; /* character set modifier */
9047 PERL_ARGS_ASSERT_SCAN_SUBST;
9049 pl_yylval.ival = OP_NULL;
9051 s = scan_str(start,!!PL_madskills,FALSE);
9054 Perl_croak(aTHX_ "Substitution pattern not terminated");
9056 if (s[-1] == PL_multi_open)
9060 CURMAD('q', PL_thisopen);
9061 CURMAD('_', PL_thiswhite);
9062 CURMAD('E', PL_thisstuff);
9063 CURMAD('Q', PL_thisclose);
9064 PL_realtokenstart = s - SvPVX(PL_linestr);
9068 first_start = PL_multi_start;
9069 s = scan_str(s,!!PL_madskills,FALSE);
9072 SvREFCNT_dec(PL_lex_stuff);
9073 PL_lex_stuff = NULL;
9075 Perl_croak(aTHX_ "Substitution replacement not terminated");
9077 PL_multi_start = first_start; /* so whole substitution is taken together */
9079 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9083 CURMAD('z', PL_thisopen);
9084 CURMAD('R', PL_thisstuff);
9085 CURMAD('Z', PL_thisclose);
9091 if (*s == EXEC_PAT_MOD) {
9095 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9104 curmad('m', newSVpvn(modstart, s - modstart));
9105 append_madprops(PL_thismad, (OP*)pm, 0);
9109 if ((pm->op_pmflags & PMf_CONTINUE)) {
9110 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9114 SV * const repl = newSVpvs("");
9116 PL_sublex_info.super_bufptr = s;
9117 PL_sublex_info.super_bufend = PL_bufend;
9119 pm->op_pmflags |= PMf_EVAL;
9122 sv_catpvs(repl, "eval ");
9124 sv_catpvs(repl, "do ");
9126 sv_catpvs(repl, "{");
9127 sv_catsv(repl, PL_lex_repl);
9128 if (strchr(SvPVX(PL_lex_repl), '#'))
9129 sv_catpvs(repl, "\n");
9130 sv_catpvs(repl, "}");
9132 SvREFCNT_dec(PL_lex_repl);
9136 PL_lex_op = (OP*)pm;
9137 pl_yylval.ival = OP_SUBST;
9142 S_scan_trans(pTHX_ char *start)
9151 bool nondestruct = 0;
9156 PERL_ARGS_ASSERT_SCAN_TRANS;
9158 pl_yylval.ival = OP_NULL;
9160 s = scan_str(start,!!PL_madskills,FALSE);
9162 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9164 if (s[-1] == PL_multi_open)
9168 CURMAD('q', PL_thisopen);
9169 CURMAD('_', PL_thiswhite);
9170 CURMAD('E', PL_thisstuff);
9171 CURMAD('Q', PL_thisclose);
9172 PL_realtokenstart = s - SvPVX(PL_linestr);
9176 s = scan_str(s,!!PL_madskills,FALSE);
9179 SvREFCNT_dec(PL_lex_stuff);
9180 PL_lex_stuff = NULL;
9182 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9185 CURMAD('z', PL_thisopen);
9186 CURMAD('R', PL_thisstuff);
9187 CURMAD('Z', PL_thisclose);
9190 complement = del = squash = 0;
9197 complement = OPpTRANS_COMPLEMENT;
9200 del = OPpTRANS_DELETE;
9203 squash = OPpTRANS_SQUASH;
9215 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
9216 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
9217 o->op_private &= ~OPpTRANS_ALL;
9218 o->op_private |= del|squash|complement|
9219 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9220 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9223 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9228 curmad('m', newSVpvn(modstart, s - modstart));
9229 append_madprops(PL_thismad, o, 0);
9238 S_scan_heredoc(pTHX_ register char *s)
9242 I32 op_type = OP_SCALAR;
9246 const char *found_newline;
9250 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9252 I32 stuffstart = s - SvPVX(PL_linestr);
9255 PL_realtokenstart = -1;
9258 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9262 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9266 while (SPACE_OR_TAB(*peek))
9268 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9271 s = delimcpy(d, e, s, PL_bufend, term, &len);
9281 if (!isALNUM_lazy_if(s,UTF))
9282 deprecate("bare << to mean <<\"\"");
9283 for (; isALNUM_lazy_if(s,UTF); s++) {
9288 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9289 Perl_croak(aTHX_ "Delimiter for here document is too long");
9292 len = d - PL_tokenbuf;
9296 tstart = PL_tokenbuf + !outer;
9297 PL_thisclose = newSVpvn(tstart, len - !outer);
9298 tstart = SvPVX(PL_linestr) + stuffstart;
9299 PL_thisopen = newSVpvn(tstart, s - tstart);
9300 stuffstart = s - SvPVX(PL_linestr);
9303 #ifndef PERL_STRICT_CR
9304 d = strchr(s, '\r');
9306 char * const olds = s;
9308 while (s < PL_bufend) {
9314 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9323 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9330 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
9331 herewas = newSVpvn(s,PL_bufend-s);
9335 herewas = newSVpvn(s-1,found_newline-s+1);
9338 herewas = newSVpvn(s,found_newline-s);
9343 tstart = SvPVX(PL_linestr) + stuffstart;
9345 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9347 PL_thisstuff = newSVpvn(tstart, s - tstart);
9350 s += SvCUR(herewas);
9353 stuffstart = s - SvPVX(PL_linestr);
9359 tmpstr = newSV_type(SVt_PVIV);
9363 SvIV_set(tmpstr, -1);
9365 else if (term == '`') {
9366 op_type = OP_BACKTICK;
9367 SvIV_set(tmpstr, '\\');
9371 PL_multi_start = CopLINE(PL_curcop);
9372 PL_multi_open = PL_multi_close = '<';
9373 term = *PL_tokenbuf;
9374 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9375 char * const bufptr = PL_sublex_info.super_bufptr;
9376 char * const bufend = PL_sublex_info.super_bufend;
9377 char * const olds = s - SvCUR(herewas);
9378 s = strchr(bufptr, '\n');
9382 while (s < bufend &&
9383 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9385 CopLINE_inc(PL_curcop);
9388 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9389 missingterm(PL_tokenbuf);
9391 sv_setpvn(herewas,bufptr,d-bufptr+1);
9392 sv_setpvn(tmpstr,d+1,s-d);
9394 sv_catpvn(herewas,s,bufend-s);
9395 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9402 while (s < PL_bufend &&
9403 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9405 CopLINE_inc(PL_curcop);
9407 if (s >= PL_bufend) {
9408 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9409 missingterm(PL_tokenbuf);
9411 sv_setpvn(tmpstr,d+1,s-d);
9415 sv_catpvn(PL_thisstuff, d + 1, s - d);
9417 PL_thisstuff = newSVpvn(d + 1, s - d);
9418 stuffstart = s - SvPVX(PL_linestr);
9422 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9424 sv_catpvn(herewas,s,PL_bufend-s);
9425 sv_setsv(PL_linestr,herewas);
9426 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9427 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9428 PL_last_lop = PL_last_uni = NULL;
9431 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9432 while (s >= PL_bufend) { /* multiple line string? */
9435 tstart = SvPVX(PL_linestr) + stuffstart;
9437 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9439 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9443 CopLINE_inc(PL_curcop);
9444 if (!outer || !lex_next_chunk(0)) {
9445 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9446 missingterm(PL_tokenbuf);
9448 CopLINE_dec(PL_curcop);
9451 stuffstart = s - SvPVX(PL_linestr);
9453 CopLINE_inc(PL_curcop);
9454 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9455 PL_last_lop = PL_last_uni = NULL;
9456 #ifndef PERL_STRICT_CR
9457 if (PL_bufend - PL_linestart >= 2) {
9458 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9459 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9461 PL_bufend[-2] = '\n';
9463 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9465 else if (PL_bufend[-1] == '\r')
9466 PL_bufend[-1] = '\n';
9468 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9469 PL_bufend[-1] = '\n';
9471 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9472 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9473 *(SvPVX(PL_linestr) + off ) = ' ';
9474 lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1);
9475 sv_catsv(PL_linestr,herewas);
9476 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9477 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9481 sv_catsv(tmpstr,PL_linestr);
9486 PL_multi_end = CopLINE(PL_curcop);
9487 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9488 SvPV_shrink_to_cur(tmpstr);
9490 SvREFCNT_dec(herewas);
9492 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9494 else if (PL_encoding)
9495 sv_recode_to_utf8(tmpstr, PL_encoding);
9497 PL_lex_stuff = tmpstr;
9498 pl_yylval.ival = op_type;
9503 takes: current position in input buffer
9504 returns: new position in input buffer
9505 side-effects: pl_yylval and lex_op are set.
9510 <FH> read from filehandle
9511 <pkg::FH> read from package qualified filehandle
9512 <pkg'FH> read from package qualified filehandle
9513 <$fh> read from filehandle in $fh
9519 S_scan_inputsymbol(pTHX_ char *start)
9522 register char *s = start; /* current position in buffer */
9525 char *d = PL_tokenbuf; /* start of temp holding space */
9526 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9528 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9530 end = strchr(s, '\n');
9533 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9535 /* die if we didn't have space for the contents of the <>,
9536 or if it didn't end, or if we see a newline
9539 if (len >= (I32)sizeof PL_tokenbuf)
9540 Perl_croak(aTHX_ "Excessively long <> operator");
9542 Perl_croak(aTHX_ "Unterminated <> operator");
9547 Remember, only scalar variables are interpreted as filehandles by
9548 this code. Anything more complex (e.g., <$fh{$num}>) will be
9549 treated as a glob() call.
9550 This code makes use of the fact that except for the $ at the front,
9551 a scalar variable and a filehandle look the same.
9553 if (*d == '$' && d[1]) d++;
9555 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9556 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9557 d += UTF ? UTF8SKIP(d) : 1;
9559 /* If we've tried to read what we allow filehandles to look like, and
9560 there's still text left, then it must be a glob() and not a getline.
9561 Use scan_str to pull out the stuff between the <> and treat it
9562 as nothing more than a string.
9565 if (d - PL_tokenbuf != len) {
9566 pl_yylval.ival = OP_GLOB;
9567 s = scan_str(start,!!PL_madskills,FALSE);
9569 Perl_croak(aTHX_ "Glob not terminated");
9573 bool readline_overriden = FALSE;
9576 /* we're in a filehandle read situation */
9579 /* turn <> into <ARGV> */
9581 Copy("ARGV",d,5,char);
9583 /* Check whether readline() is overriden */
9584 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
9586 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9588 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
9589 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
9590 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9591 readline_overriden = TRUE;
9593 /* if <$fh>, create the ops to turn the variable into a
9597 /* try to find it in the pad for this block, otherwise find
9598 add symbol table ops
9600 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
9601 if (tmp != NOT_IN_PAD) {
9602 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9603 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9604 HEK * const stashname = HvNAME_HEK(stash);
9605 SV * const sym = sv_2mortal(newSVhek(stashname));
9606 sv_catpvs(sym, "::");
9612 OP * const o = newOP(OP_PADSV, 0);
9614 PL_lex_op = readline_overriden
9615 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9616 op_append_elem(OP_LIST, o,
9617 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9618 : (OP*)newUNOP(OP_READLINE, 0, o);
9627 ? (GV_ADDMULTI | GV_ADDINEVAL)
9628 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
9630 PL_lex_op = readline_overriden
9631 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9632 op_append_elem(OP_LIST,
9633 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9634 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9635 : (OP*)newUNOP(OP_READLINE, 0,
9636 newUNOP(OP_RV2SV, 0,
9637 newGVOP(OP_GV, 0, gv)));
9639 if (!readline_overriden)
9640 PL_lex_op->op_flags |= OPf_SPECIAL;
9641 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9642 pl_yylval.ival = OP_NULL;
9645 /* If it's none of the above, it must be a literal filehandle
9646 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9648 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9649 PL_lex_op = readline_overriden
9650 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9651 op_append_elem(OP_LIST,
9652 newGVOP(OP_GV, 0, gv),
9653 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9654 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9655 pl_yylval.ival = OP_NULL;
9664 takes: start position in buffer
9665 keep_quoted preserve \ on the embedded delimiter(s)
9666 keep_delims preserve the delimiters around the string
9667 returns: position to continue reading from buffer
9668 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9669 updates the read buffer.
9671 This subroutine pulls a string out of the input. It is called for:
9672 q single quotes q(literal text)
9673 ' single quotes 'literal text'
9674 qq double quotes qq(interpolate $here please)
9675 " double quotes "interpolate $here please"
9676 qx backticks qx(/bin/ls -l)
9677 ` backticks `/bin/ls -l`
9678 qw quote words @EXPORT_OK = qw( func() $spam )
9679 m// regexp match m/this/
9680 s/// regexp substitute s/this/that/
9681 tr/// string transliterate tr/this/that/
9682 y/// string transliterate y/this/that/
9683 ($*@) sub prototypes sub foo ($)
9684 (stuff) sub attr parameters sub foo : attr(stuff)
9685 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9687 In most of these cases (all but <>, patterns and transliterate)
9688 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9689 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9690 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9693 It skips whitespace before the string starts, and treats the first
9694 character as the delimiter. If the delimiter is one of ([{< then
9695 the corresponding "close" character )]}> is used as the closing
9696 delimiter. It allows quoting of delimiters, and if the string has
9697 balanced delimiters ([{<>}]) it allows nesting.
9699 On success, the SV with the resulting string is put into lex_stuff or,
9700 if that is already non-NULL, into lex_repl. The second case occurs only
9701 when parsing the RHS of the special constructs s/// and tr/// (y///).
9702 For convenience, the terminating delimiter character is stuffed into
9707 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9710 SV *sv; /* scalar value: string */
9711 const char *tmps; /* temp string, used for delimiter matching */
9712 register char *s = start; /* current position in the buffer */
9713 register char term; /* terminating character */
9714 register char *to; /* current position in the sv's data */
9715 I32 brackets = 1; /* bracket nesting level */
9716 bool has_utf8 = FALSE; /* is there any utf8 content? */
9717 I32 termcode; /* terminating char. code */
9718 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9719 STRLEN termlen; /* length of terminating string */
9720 int last_off = 0; /* last position for nesting bracket */
9726 PERL_ARGS_ASSERT_SCAN_STR;
9728 /* skip space before the delimiter */
9734 if (PL_realtokenstart >= 0) {
9735 stuffstart = PL_realtokenstart;
9736 PL_realtokenstart = -1;
9739 stuffstart = start - SvPVX(PL_linestr);
9741 /* mark where we are, in case we need to report errors */
9744 /* after skipping whitespace, the next character is the terminator */
9747 termcode = termstr[0] = term;
9751 termcode = utf8_to_uvchr((U8*)s, &termlen);
9752 Copy(s, termstr, termlen, U8);
9753 if (!UTF8_IS_INVARIANT(term))
9757 /* mark where we are */
9758 PL_multi_start = CopLINE(PL_curcop);
9759 PL_multi_open = term;
9761 /* find corresponding closing delimiter */
9762 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9763 termcode = termstr[0] = term = tmps[5];
9765 PL_multi_close = term;
9767 /* create a new SV to hold the contents. 79 is the SV's initial length.
9768 What a random number. */
9769 sv = newSV_type(SVt_PVIV);
9771 SvIV_set(sv, termcode);
9772 (void)SvPOK_only(sv); /* validate pointer */
9774 /* move past delimiter and try to read a complete string */
9776 sv_catpvn(sv, s, termlen);
9779 tstart = SvPVX(PL_linestr) + stuffstart;
9780 if (!PL_thisopen && !keep_delims) {
9781 PL_thisopen = newSVpvn(tstart, s - tstart);
9782 stuffstart = s - SvPVX(PL_linestr);
9786 if (PL_encoding && !UTF) {
9790 int offset = s - SvPVX_const(PL_linestr);
9791 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9792 &offset, (char*)termstr, termlen);
9793 const char * const ns = SvPVX_const(PL_linestr) + offset;
9794 char * const svlast = SvEND(sv) - 1;
9796 for (; s < ns; s++) {
9797 if (*s == '\n' && !PL_rsfp)
9798 CopLINE_inc(PL_curcop);
9801 goto read_more_line;
9803 /* handle quoted delimiters */
9804 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9806 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9808 if ((svlast-1 - t) % 2) {
9812 SvCUR_set(sv, SvCUR(sv) - 1);
9817 if (PL_multi_open == PL_multi_close) {
9823 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9824 /* At here, all closes are "was quoted" one,
9825 so we don't check PL_multi_close. */
9827 if (!keep_quoted && *(t+1) == PL_multi_open)
9832 else if (*t == PL_multi_open)
9840 SvCUR_set(sv, w - SvPVX_const(sv));
9842 last_off = w - SvPVX(sv);
9843 if (--brackets <= 0)
9849 SvCUR_set(sv, SvCUR(sv) - 1);
9855 /* extend sv if need be */
9856 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9857 /* set 'to' to the next character in the sv's string */
9858 to = SvPVX(sv)+SvCUR(sv);
9860 /* if open delimiter is the close delimiter read unbridle */
9861 if (PL_multi_open == PL_multi_close) {
9862 for (; s < PL_bufend; s++,to++) {
9863 /* embedded newlines increment the current line number */
9864 if (*s == '\n' && !PL_rsfp)
9865 CopLINE_inc(PL_curcop);
9866 /* handle quoted delimiters */
9867 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9868 if (!keep_quoted && s[1] == term)
9870 /* any other quotes are simply copied straight through */
9874 /* terminate when run out of buffer (the for() condition), or
9875 have found the terminator */
9876 else if (*s == term) {
9879 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9882 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9888 /* if the terminator isn't the same as the start character (e.g.,
9889 matched brackets), we have to allow more in the quoting, and
9890 be prepared for nested brackets.
9893 /* read until we run out of string, or we find the terminator */
9894 for (; s < PL_bufend; s++,to++) {
9895 /* embedded newlines increment the line count */
9896 if (*s == '\n' && !PL_rsfp)
9897 CopLINE_inc(PL_curcop);
9898 /* backslashes can escape the open or closing characters */
9899 if (*s == '\\' && s+1 < PL_bufend) {
9901 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9906 /* allow nested opens and closes */
9907 else if (*s == PL_multi_close && --brackets <= 0)
9909 else if (*s == PL_multi_open)
9911 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9916 /* terminate the copied string and update the sv's end-of-string */
9918 SvCUR_set(sv, to - SvPVX_const(sv));
9921 * this next chunk reads more into the buffer if we're not done yet
9925 break; /* handle case where we are done yet :-) */
9927 #ifndef PERL_STRICT_CR
9928 if (to - SvPVX_const(sv) >= 2) {
9929 if ((to[-2] == '\r' && to[-1] == '\n') ||
9930 (to[-2] == '\n' && to[-1] == '\r'))
9934 SvCUR_set(sv, to - SvPVX_const(sv));
9936 else if (to[-1] == '\r')
9939 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9944 /* if we're out of file, or a read fails, bail and reset the current
9945 line marker so we can report where the unterminated string began
9949 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9951 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9953 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9956 CopLINE_inc(PL_curcop);
9957 PL_bufptr = PL_bufend;
9958 if (!lex_next_chunk(0)) {
9960 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9969 /* at this point, we have successfully read the delimited string */
9971 if (!PL_encoding || UTF) {
9974 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9975 const int len = s - tstart;
9977 sv_catpvn(PL_thisstuff, tstart, len);
9979 PL_thisstuff = newSVpvn(tstart, len);
9980 if (!PL_thisclose && !keep_delims)
9981 PL_thisclose = newSVpvn(s,termlen);
9986 sv_catpvn(sv, s, termlen);
9992 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9993 const int len = s - tstart - termlen;
9995 sv_catpvn(PL_thisstuff, tstart, len);
9997 PL_thisstuff = newSVpvn(tstart, len);
9998 if (!PL_thisclose && !keep_delims)
9999 PL_thisclose = newSVpvn(s - termlen,termlen);
10003 if (has_utf8 || PL_encoding)
10006 PL_multi_end = CopLINE(PL_curcop);
10008 /* if we allocated too much space, give some back */
10009 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10010 SvLEN_set(sv, SvCUR(sv) + 1);
10011 SvPV_renew(sv, SvLEN(sv));
10014 /* decide whether this is the first or second quoted string we've read
10027 takes: pointer to position in buffer
10028 returns: pointer to new position in buffer
10029 side-effects: builds ops for the constant in pl_yylval.op
10031 Read a number in any of the formats that Perl accepts:
10033 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10034 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10037 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10039 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10042 If it reads a number without a decimal point or an exponent, it will
10043 try converting the number to an integer and see if it can do so
10044 without loss of precision.
10048 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10051 register const char *s = start; /* current position in buffer */
10052 register char *d; /* destination in temp buffer */
10053 register char *e; /* end of temp buffer */
10054 NV nv; /* number read, as a double */
10055 SV *sv = NULL; /* place to put the converted number */
10056 bool floatit; /* boolean: int or float? */
10057 const char *lastub = NULL; /* position of last underbar */
10058 static char const number_too_long[] = "Number too long";
10060 PERL_ARGS_ASSERT_SCAN_NUM;
10062 /* We use the first character to decide what type of number this is */
10066 Perl_croak(aTHX_ "panic: scan_num");
10068 /* if it starts with a 0, it could be an octal number, a decimal in
10069 0.13 disguise, or a hexadecimal number, or a binary number. */
10073 u holds the "number so far"
10074 shift the power of 2 of the base
10075 (hex == 4, octal == 3, binary == 1)
10076 overflowed was the number more than we can hold?
10078 Shift is used when we add a digit. It also serves as an "are
10079 we in octal/hex/binary?" indicator to disallow hex characters
10080 when in octal mode.
10085 bool overflowed = FALSE;
10086 bool just_zero = TRUE; /* just plain 0 or binary number? */
10087 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10088 static const char* const bases[5] =
10089 { "", "binary", "", "octal", "hexadecimal" };
10090 static const char* const Bases[5] =
10091 { "", "Binary", "", "Octal", "Hexadecimal" };
10092 static const char* const maxima[5] =
10094 "0b11111111111111111111111111111111",
10098 const char *base, *Base, *max;
10100 /* check for hex */
10101 if (s[1] == 'x' || s[1] == 'X') {
10105 } else if (s[1] == 'b' || s[1] == 'B') {
10110 /* check for a decimal in disguise */
10111 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10113 /* so it must be octal */
10120 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10121 "Misplaced _ in number");
10125 base = bases[shift];
10126 Base = Bases[shift];
10127 max = maxima[shift];
10129 /* read the rest of the number */
10131 /* x is used in the overflow test,
10132 b is the digit we're adding on. */
10137 /* if we don't mention it, we're done */
10141 /* _ are ignored -- but warned about if consecutive */
10143 if (lastub && s == lastub + 1)
10144 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10145 "Misplaced _ in number");
10149 /* 8 and 9 are not octal */
10150 case '8': case '9':
10152 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10156 case '2': case '3': case '4':
10157 case '5': case '6': case '7':
10159 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10162 case '0': case '1':
10163 b = *s++ & 15; /* ASCII digit -> value of digit */
10167 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10168 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10169 /* make sure they said 0x */
10172 b = (*s++ & 7) + 9;
10174 /* Prepare to put the digit we have onto the end
10175 of the number so far. We check for overflows.
10181 x = u << shift; /* make room for the digit */
10183 if ((x >> shift) != u
10184 && !(PL_hints & HINT_NEW_BINARY)) {
10187 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10188 "Integer overflow in %s number",
10191 u = x | b; /* add the digit to the end */
10194 n *= nvshift[shift];
10195 /* If an NV has not enough bits in its
10196 * mantissa to represent an UV this summing of
10197 * small low-order numbers is a waste of time
10198 * (because the NV cannot preserve the
10199 * low-order bits anyway): we could just
10200 * remember when did we overflow and in the
10201 * end just multiply n by the right
10209 /* if we get here, we had success: make a scalar value from
10214 /* final misplaced underbar check */
10215 if (s[-1] == '_') {
10216 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10220 if (n > 4294967295.0)
10221 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10222 "%s number > %s non-portable",
10228 if (u > 0xffffffff)
10229 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10230 "%s number > %s non-portable",
10235 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10236 sv = new_constant(start, s - start, "integer",
10237 sv, NULL, NULL, 0);
10238 else if (PL_hints & HINT_NEW_BINARY)
10239 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10244 handle decimal numbers.
10245 we're also sent here when we read a 0 as the first digit
10247 case '1': case '2': case '3': case '4': case '5':
10248 case '6': case '7': case '8': case '9': case '.':
10251 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10254 /* read next group of digits and _ and copy into d */
10255 while (isDIGIT(*s) || *s == '_') {
10256 /* skip underscores, checking for misplaced ones
10260 if (lastub && s == lastub + 1)
10261 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10262 "Misplaced _ in number");
10266 /* check for end of fixed-length buffer */
10268 Perl_croak(aTHX_ number_too_long);
10269 /* if we're ok, copy the character */
10274 /* final misplaced underbar check */
10275 if (lastub && s == lastub + 1) {
10276 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10279 /* read a decimal portion if there is one. avoid
10280 3..5 being interpreted as the number 3. followed
10283 if (*s == '.' && s[1] != '.') {
10288 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10289 "Misplaced _ in number");
10293 /* copy, ignoring underbars, until we run out of digits.
10295 for (; isDIGIT(*s) || *s == '_'; s++) {
10296 /* fixed length buffer check */
10298 Perl_croak(aTHX_ number_too_long);
10300 if (lastub && s == lastub + 1)
10301 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10302 "Misplaced _ in number");
10308 /* fractional part ending in underbar? */
10309 if (s[-1] == '_') {
10310 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10311 "Misplaced _ in number");
10313 if (*s == '.' && isDIGIT(s[1])) {
10314 /* oops, it's really a v-string, but without the "v" */
10320 /* read exponent part, if present */
10321 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10325 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10326 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10328 /* stray preinitial _ */
10330 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10331 "Misplaced _ in number");
10335 /* allow positive or negative exponent */
10336 if (*s == '+' || *s == '-')
10339 /* stray initial _ */
10341 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10342 "Misplaced _ in number");
10346 /* read digits of exponent */
10347 while (isDIGIT(*s) || *s == '_') {
10350 Perl_croak(aTHX_ number_too_long);
10354 if (((lastub && s == lastub + 1) ||
10355 (!isDIGIT(s[1]) && s[1] != '_')))
10356 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10357 "Misplaced _ in number");
10365 We try to do an integer conversion first if no characters
10366 indicating "float" have been found.
10371 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10373 if (flags == IS_NUMBER_IN_UV) {
10375 sv = newSViv(uv); /* Prefer IVs over UVs. */
10378 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10379 if (uv <= (UV) IV_MIN)
10380 sv = newSViv(-(IV)uv);
10387 /* terminate the string */
10389 nv = Atof(PL_tokenbuf);
10394 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10395 const char *const key = floatit ? "float" : "integer";
10396 const STRLEN keylen = floatit ? 5 : 7;
10397 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10398 key, keylen, sv, NULL, NULL, 0);
10402 /* if it starts with a v, it could be a v-string */
10405 sv = newSV(5); /* preallocate storage space */
10406 s = scan_vstring(s, PL_bufend, sv);
10410 /* make the op for the constant and return */
10413 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10415 lvalp->opval = NULL;
10421 S_scan_formline(pTHX_ register char *s)
10424 register char *eol;
10426 SV * const stuff = newSVpvs("");
10427 bool needargs = FALSE;
10428 bool eofmt = FALSE;
10430 char *tokenstart = s;
10431 SV* savewhite = NULL;
10433 if (PL_madskills) {
10434 savewhite = PL_thiswhite;
10439 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10441 while (!needargs) {
10444 #ifdef PERL_STRICT_CR
10445 while (SPACE_OR_TAB(*t))
10448 while (SPACE_OR_TAB(*t) || *t == '\r')
10451 if (*t == '\n' || t == PL_bufend) {
10456 if (PL_in_eval && !PL_rsfp) {
10457 eol = (char *) memchr(s,'\n',PL_bufend-s);
10462 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10464 for (t = s; t < eol; t++) {
10465 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10467 goto enough; /* ~~ must be first line in formline */
10469 if (*t == '@' || *t == '^')
10473 sv_catpvn(stuff, s, eol-s);
10474 #ifndef PERL_STRICT_CR
10475 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10476 char *end = SvPVX(stuff) + SvCUR(stuff);
10479 SvCUR_set(stuff, SvCUR(stuff) - 1);
10490 if (PL_madskills) {
10492 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
10494 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
10497 PL_bufptr = PL_bufend;
10498 CopLINE_inc(PL_curcop);
10499 got_some = lex_next_chunk(0);
10500 CopLINE_dec(PL_curcop);
10503 tokenstart = PL_bufptr;
10511 if (SvCUR(stuff)) {
10514 PL_lex_state = LEX_NORMAL;
10515 start_force(PL_curforce);
10516 NEXTVAL_NEXTTOKE.ival = 0;
10520 PL_lex_state = LEX_FORMLINE;
10522 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10524 else if (PL_encoding)
10525 sv_recode_to_utf8(stuff, PL_encoding);
10527 start_force(PL_curforce);
10528 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10530 start_force(PL_curforce);
10531 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
10535 SvREFCNT_dec(stuff);
10537 PL_lex_formbrack = 0;
10541 if (PL_madskills) {
10543 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
10545 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
10546 PL_thiswhite = savewhite;
10553 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10556 const I32 oldsavestack_ix = PL_savestack_ix;
10557 CV* const outsidecv = PL_compcv;
10560 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10562 SAVEI32(PL_subline);
10563 save_item(PL_subname);
10564 SAVESPTR(PL_compcv);
10566 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10567 CvFLAGS(PL_compcv) |= flags;
10569 PL_subline = CopLINE(PL_curcop);
10570 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10571 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10572 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10574 return oldsavestack_ix;
10578 #pragma segment Perl_yylex
10581 S_yywarn(pTHX_ const char *const s)
10585 PERL_ARGS_ASSERT_YYWARN;
10587 PL_in_eval |= EVAL_WARNONLY;
10589 PL_in_eval &= ~EVAL_WARNONLY;
10594 Perl_yyerror(pTHX_ const char *const s)
10597 const char *where = NULL;
10598 const char *context = NULL;
10601 int yychar = PL_parser->yychar;
10603 PERL_ARGS_ASSERT_YYERROR;
10605 if (!yychar || (yychar == ';' && !PL_rsfp))
10607 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10608 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10609 PL_oldbufptr != PL_bufptr) {
10612 The code below is removed for NetWare because it abends/crashes on NetWare
10613 when the script has error such as not having the closing quotes like:
10614 if ($var eq "value)
10615 Checking of white spaces is anyway done in NetWare code.
10618 while (isSPACE(*PL_oldoldbufptr))
10621 context = PL_oldoldbufptr;
10622 contlen = PL_bufptr - PL_oldoldbufptr;
10624 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10625 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10628 The code below is removed for NetWare because it abends/crashes on NetWare
10629 when the script has error such as not having the closing quotes like:
10630 if ($var eq "value)
10631 Checking of white spaces is anyway done in NetWare code.
10634 while (isSPACE(*PL_oldbufptr))
10637 context = PL_oldbufptr;
10638 contlen = PL_bufptr - PL_oldbufptr;
10640 else if (yychar > 255)
10641 where = "next token ???";
10642 else if (yychar == -2) { /* YYEMPTY */
10643 if (PL_lex_state == LEX_NORMAL ||
10644 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10645 where = "at end of line";
10646 else if (PL_lex_inpat)
10647 where = "within pattern";
10649 where = "within string";
10652 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
10654 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10655 else if (isPRINT_LC(yychar)) {
10656 const char string = yychar;
10657 sv_catpvn(where_sv, &string, 1);
10660 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10661 where = SvPVX_const(where_sv);
10663 msg = sv_2mortal(newSVpv(s, 0));
10664 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10665 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10667 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10669 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10670 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10671 Perl_sv_catpvf(aTHX_ msg,
10672 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10673 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10676 if (PL_in_eval & EVAL_WARNONLY) {
10677 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10681 if (PL_error_count >= 10) {
10682 if (PL_in_eval && SvCUR(ERRSV))
10683 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10684 SVfARG(ERRSV), OutCopFILE(PL_curcop));
10686 Perl_croak(aTHX_ "%s has too many errors.\n",
10687 OutCopFILE(PL_curcop));
10690 PL_in_my_stash = NULL;
10694 #pragma segment Main
10698 S_swallow_bom(pTHX_ U8 *s)
10701 const STRLEN slen = SvCUR(PL_linestr);
10703 PERL_ARGS_ASSERT_SWALLOW_BOM;
10707 if (s[1] == 0xFE) {
10708 /* UTF-16 little-endian? (or UTF-32LE?) */
10709 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10710 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10711 #ifndef PERL_NO_UTF16_FILTER
10712 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10714 if (PL_bufend > (char*)s) {
10715 s = add_utf16_textfilter(s, TRUE);
10718 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10723 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10724 #ifndef PERL_NO_UTF16_FILTER
10725 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10727 if (PL_bufend > (char *)s) {
10728 s = add_utf16_textfilter(s, FALSE);
10731 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10736 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10737 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10738 s += 3; /* UTF-8 */
10744 if (s[2] == 0xFE && s[3] == 0xFF) {
10745 /* UTF-32 big-endian */
10746 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10749 else if (s[2] == 0 && s[3] != 0) {
10752 * are a good indicator of UTF-16BE. */
10753 #ifndef PERL_NO_UTF16_FILTER
10754 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10755 s = add_utf16_textfilter(s, FALSE);
10757 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10763 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
10764 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10765 s += 4; /* UTF-8 */
10771 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10774 * are a good indicator of UTF-16LE. */
10775 #ifndef PERL_NO_UTF16_FILTER
10776 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10777 s = add_utf16_textfilter(s, TRUE);
10779 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10787 #ifndef PERL_NO_UTF16_FILTER
10789 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10792 SV *const filter = FILTER_DATA(idx);
10793 /* We re-use this each time round, throwing the contents away before we
10795 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10796 SV *const utf8_buffer = filter;
10797 IV status = IoPAGE(filter);
10798 const bool reverse = cBOOL(IoLINES(filter));
10801 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10803 /* As we're automatically added, at the lowest level, and hence only called
10804 from this file, we can be sure that we're not called in block mode. Hence
10805 don't bother writing code to deal with block mode. */
10807 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10810 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10812 DEBUG_P(PerlIO_printf(Perl_debug_log,
10813 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10814 FPTR2DPTR(void *, S_utf16_textfilter),
10815 reverse ? 'l' : 'b', idx, maxlen, status,
10816 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10823 /* First, look in our buffer of existing UTF-8 data: */
10824 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10828 } else if (status == 0) {
10830 IoPAGE(filter) = 0;
10831 nl = SvEND(utf8_buffer);
10834 STRLEN got = nl - SvPVX(utf8_buffer);
10835 /* Did we have anything to append? */
10837 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10838 /* Everything else in this code works just fine if SVp_POK isn't
10839 set. This, however, needs it, and we need it to work, else
10840 we loop infinitely because the buffer is never consumed. */
10841 sv_chop(utf8_buffer, nl);
10845 /* OK, not a complete line there, so need to read some more UTF-16.
10846 Read an extra octect if the buffer currently has an odd number. */
10850 if (SvCUR(utf16_buffer) >= 2) {
10851 /* Location of the high octet of the last complete code point.
10852 Gosh, UTF-16 is a pain. All the benefits of variable length,
10853 *coupled* with all the benefits of partial reads and
10855 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10856 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10858 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10862 /* We have the first half of a surrogate. Read more. */
10863 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10866 status = FILTER_READ(idx + 1, utf16_buffer,
10867 160 + (SvCUR(utf16_buffer) & 1));
10868 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10869 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10872 IoPAGE(filter) = status;
10877 chars = SvCUR(utf16_buffer) >> 1;
10878 have = SvCUR(utf8_buffer);
10879 SvGROW(utf8_buffer, have + chars * 3 + 1);
10882 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10883 (U8*)SvPVX_const(utf8_buffer) + have,
10884 chars * 2, &newlen);
10886 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10887 (U8*)SvPVX_const(utf8_buffer) + have,
10888 chars * 2, &newlen);
10890 SvCUR_set(utf8_buffer, have + newlen);
10893 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10894 it's private to us, and utf16_to_utf8{,reversed} take a
10895 (pointer,length) pair, rather than a NUL-terminated string. */
10896 if(SvCUR(utf16_buffer) & 1) {
10897 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10898 SvCUR_set(utf16_buffer, 1);
10900 SvCUR_set(utf16_buffer, 0);
10903 DEBUG_P(PerlIO_printf(Perl_debug_log,
10904 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10906 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10907 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10912 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10914 SV *filter = filter_add(S_utf16_textfilter, NULL);
10916 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10918 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10919 sv_setpvs(filter, "");
10920 IoLINES(filter) = reversed;
10921 IoPAGE(filter) = 1; /* Not EOF */
10923 /* Sadly, we have to return a valid pointer, come what may, so we have to
10924 ignore any error return from this. */
10925 SvCUR_set(PL_linestr, 0);
10926 if (FILTER_READ(0, PL_linestr, 0)) {
10927 SvUTF8_on(PL_linestr);
10929 SvUTF8_on(PL_linestr);
10931 PL_bufend = SvEND(PL_linestr);
10932 return (U8*)SvPVX(PL_linestr);
10937 Returns a pointer to the next character after the parsed
10938 vstring, as well as updating the passed in sv.
10940 Function must be called like
10943 s = scan_vstring(s,e,sv);
10945 where s and e are the start and end of the string.
10946 The sv should already be large enough to store the vstring
10947 passed in, for performance reasons.
10952 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
10955 const char *pos = s;
10956 const char *start = s;
10958 PERL_ARGS_ASSERT_SCAN_VSTRING;
10960 if (*pos == 'v') pos++; /* get past 'v' */
10961 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10963 if ( *pos != '.') {
10964 /* this may not be a v-string if followed by => */
10965 const char *next = pos;
10966 while (next < e && isSPACE(*next))
10968 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
10969 /* return string not v-string */
10970 sv_setpvn(sv,(char *)s,pos-s);
10971 return (char *)pos;
10975 if (!isALPHA(*pos)) {
10976 U8 tmpbuf[UTF8_MAXBYTES+1];
10979 s++; /* get past 'v' */
10984 /* this is atoi() that tolerates underscores */
10987 const char *end = pos;
10989 while (--end >= s) {
10991 const UV orev = rev;
10992 rev += (*end - '0') * mult;
10995 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10996 "Integer overflow in decimal number");
11000 if (rev > 0x7FFFFFFF)
11001 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11003 /* Append native character for the rev point */
11004 tmpend = uvchr_to_utf8(tmpbuf, rev);
11005 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11006 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11008 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11014 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11018 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11025 Perl_keyword_plugin_standard(pTHX_
11026 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11028 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11029 PERL_UNUSED_CONTEXT;
11030 PERL_UNUSED_ARG(keyword_ptr);
11031 PERL_UNUSED_ARG(keyword_len);
11032 PERL_UNUSED_ARG(op_ptr);
11033 return KEYWORD_PLUGIN_DECLINE;
11036 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11038 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11040 SAVEI32(PL_lex_brackets);
11041 if (PL_lex_brackets > 100)
11042 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11043 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11044 SAVEI32(PL_lex_allbrackets);
11045 PL_lex_allbrackets = 0;
11046 SAVEI8(PL_lex_fakeeof);
11047 PL_lex_fakeeof = (U8)fakeeof;
11048 if(yyparse(gramtype) && !PL_parser->error_count)
11049 qerror(Perl_mess(aTHX_ "Parse error"));
11052 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11054 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11058 SAVEVPTR(PL_eval_root);
11059 PL_eval_root = NULL;
11060 parse_recdescent(gramtype, fakeeof);
11066 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11068 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11071 if (flags & ~PARSE_OPTIONAL)
11072 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11073 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11074 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11075 if (!PL_parser->error_count)
11076 qerror(Perl_mess(aTHX_ "Parse error"));
11077 exprop = newOP(OP_NULL, 0);
11083 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11085 Parse a Perl arithmetic expression. This may contain operators of precedence
11086 down to the bit shift operators. The expression must be followed (and thus
11087 terminated) either by a comparison or lower-precedence operator or by
11088 something that would normally terminate an expression such as semicolon.
11089 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11090 otherwise it is mandatory. It is up to the caller to ensure that the
11091 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11092 the source of the code to be parsed and the lexical context for the
11095 The op tree representing the expression is returned. If an optional
11096 expression is absent, a null pointer is returned, otherwise the pointer
11099 If an error occurs in parsing or compilation, in most cases a valid op
11100 tree is returned anyway. The error is reflected in the parser state,
11101 normally resulting in a single exception at the top level of parsing
11102 which covers all the compilation errors that occurred. Some compilation
11103 errors, however, will throw an exception immediately.
11109 Perl_parse_arithexpr(pTHX_ U32 flags)
11111 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11115 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11117 Parse a Perl term expression. This may contain operators of precedence
11118 down to the assignment operators. The expression must be followed (and thus
11119 terminated) either by a comma or lower-precedence operator or by
11120 something that would normally terminate an expression such as semicolon.
11121 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11122 otherwise it is mandatory. It is up to the caller to ensure that the
11123 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11124 the source of the code to be parsed and the lexical context for the
11127 The op tree representing the expression is returned. If an optional
11128 expression is absent, a null pointer is returned, otherwise the pointer
11131 If an error occurs in parsing or compilation, in most cases a valid op
11132 tree is returned anyway. The error is reflected in the parser state,
11133 normally resulting in a single exception at the top level of parsing
11134 which covers all the compilation errors that occurred. Some compilation
11135 errors, however, will throw an exception immediately.
11141 Perl_parse_termexpr(pTHX_ U32 flags)
11143 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11147 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11149 Parse a Perl list expression. This may contain operators of precedence
11150 down to the comma operator. The expression must be followed (and thus
11151 terminated) either by a low-precedence logic operator such as C<or> or by
11152 something that would normally terminate an expression such as semicolon.
11153 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11154 otherwise it is mandatory. It is up to the caller to ensure that the
11155 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11156 the source of the code to be parsed and the lexical context for the
11159 The op tree representing the expression is returned. If an optional
11160 expression is absent, a null pointer is returned, otherwise the pointer
11163 If an error occurs in parsing or compilation, in most cases a valid op
11164 tree is returned anyway. The error is reflected in the parser state,
11165 normally resulting in a single exception at the top level of parsing
11166 which covers all the compilation errors that occurred. Some compilation
11167 errors, however, will throw an exception immediately.
11173 Perl_parse_listexpr(pTHX_ U32 flags)
11175 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11179 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11181 Parse a single complete Perl expression. This allows the full
11182 expression grammar, including the lowest-precedence operators such
11183 as C<or>. The expression must be followed (and thus terminated) by a
11184 token that an expression would normally be terminated by: end-of-file,
11185 closing bracketing punctuation, semicolon, or one of the keywords that
11186 signals a postfix expression-statement modifier. If I<flags> includes
11187 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11188 mandatory. It is up to the caller to ensure that the dynamic parser
11189 state (L</PL_parser> et al) is correctly set to reflect the source of
11190 the code to be parsed and the lexical context for the expression.
11192 The op tree representing the expression is returned. If an optional
11193 expression is absent, a null pointer is returned, otherwise the pointer
11196 If an error occurs in parsing or compilation, in most cases a valid op
11197 tree is returned anyway. The error is reflected in the parser state,
11198 normally resulting in a single exception at the top level of parsing
11199 which covers all the compilation errors that occurred. Some compilation
11200 errors, however, will throw an exception immediately.
11206 Perl_parse_fullexpr(pTHX_ U32 flags)
11208 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11212 =for apidoc Amx|OP *|parse_block|U32 flags
11214 Parse a single complete Perl code block. This consists of an opening
11215 brace, a sequence of statements, and a closing brace. The block
11216 constitutes a lexical scope, so C<my> variables and various compile-time
11217 effects can be contained within it. It is up to the caller to ensure
11218 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11219 reflect the source of the code to be parsed and the lexical context for
11222 The op tree representing the code block is returned. This is always a
11223 real op, never a null pointer. It will normally be a C<lineseq> list,
11224 including C<nextstate> or equivalent ops. No ops to construct any kind
11225 of runtime scope are included by virtue of it being a block.
11227 If an error occurs in parsing or compilation, in most cases a valid op
11228 tree (most likely null) is returned anyway. The error is reflected in
11229 the parser state, normally resulting in a single exception at the top
11230 level of parsing which covers all the compilation errors that occurred.
11231 Some compilation errors, however, will throw an exception immediately.
11233 The I<flags> parameter is reserved for future use, and must always
11240 Perl_parse_block(pTHX_ U32 flags)
11243 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11244 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11248 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11250 Parse a single unadorned Perl statement. This may be a normal imperative
11251 statement or a declaration that has compile-time effect. It does not
11252 include any label or other affixture. It is up to the caller to ensure
11253 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11254 reflect the source of the code to be parsed and the lexical context for
11257 The op tree representing the statement is returned. This may be a
11258 null pointer if the statement is null, for example if it was actually
11259 a subroutine definition (which has compile-time side effects). If not
11260 null, it will be ops directly implementing the statement, suitable to
11261 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11262 equivalent op (except for those embedded in a scope contained entirely
11263 within the statement).
11265 If an error occurs in parsing or compilation, in most cases a valid op
11266 tree (most likely null) is returned anyway. The error is reflected in
11267 the parser state, normally resulting in a single exception at the top
11268 level of parsing which covers all the compilation errors that occurred.
11269 Some compilation errors, however, will throw an exception immediately.
11271 The I<flags> parameter is reserved for future use, and must always
11278 Perl_parse_barestmt(pTHX_ U32 flags)
11281 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11282 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11286 =for apidoc Amx|SV *|parse_label|U32 flags
11288 Parse a single label, possibly optional, of the type that may prefix a
11289 Perl statement. It is up to the caller to ensure that the dynamic parser
11290 state (L</PL_parser> et al) is correctly set to reflect the source of
11291 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11292 label is optional, otherwise it is mandatory.
11294 The name of the label is returned in the form of a fresh scalar. If an
11295 optional label is absent, a null pointer is returned.
11297 If an error occurs in parsing, which can only occur if the label is
11298 mandatory, a valid label is returned anyway. The error is reflected in
11299 the parser state, normally resulting in a single exception at the top
11300 level of parsing which covers all the compilation errors that occurred.
11306 Perl_parse_label(pTHX_ U32 flags)
11308 if (flags & ~PARSE_OPTIONAL)
11309 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11310 if (PL_lex_state == LEX_KNOWNEXT) {
11311 PL_parser->yychar = yylex();
11312 if (PL_parser->yychar == LABEL) {
11313 char *lpv = pl_yylval.pval;
11314 STRLEN llen = strlen(lpv);
11316 PL_parser->yychar = YYEMPTY;
11317 lsv = newSV_type(SVt_PV);
11318 SvPV_set(lsv, lpv);
11319 SvCUR_set(lsv, llen);
11320 SvLEN_set(lsv, llen+1);
11330 STRLEN wlen, bufptr_pos;
11334 if (!isIDFIRST_A(c))
11338 } while(isWORDCHAR_A(c));
11340 if (word_takes_any_delimeter(s, wlen))
11342 bufptr_pos = s - SvPVX(PL_linestr);
11344 lex_read_space(LEX_KEEP_PREVIOUS);
11346 s = SvPVX(PL_linestr) + bufptr_pos;
11347 if (t[0] == ':' && t[1] != ':') {
11348 PL_oldoldbufptr = PL_oldbufptr;
11351 return newSVpvn(s, wlen);
11355 if (flags & PARSE_OPTIONAL) {
11358 qerror(Perl_mess(aTHX_ "Parse error"));
11359 return newSVpvs("x");
11366 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11368 Parse a single complete Perl statement. This may be a normal imperative
11369 statement or a declaration that has compile-time effect, and may include
11370 optional labels. It is up to the caller to ensure that the dynamic
11371 parser state (L</PL_parser> et al) is correctly set to reflect the source
11372 of the code to be parsed and the lexical context for the statement.
11374 The op tree representing the statement is returned. This may be a
11375 null pointer if the statement is null, for example if it was actually
11376 a subroutine definition (which has compile-time side effects). If not
11377 null, it will be the result of a L</newSTATEOP> call, normally including
11378 a C<nextstate> or equivalent op.
11380 If an error occurs in parsing or compilation, in most cases a valid op
11381 tree (most likely null) is returned anyway. The error is reflected in
11382 the parser state, normally resulting in a single exception at the top
11383 level of parsing which covers all the compilation errors that occurred.
11384 Some compilation errors, however, will throw an exception immediately.
11386 The I<flags> parameter is reserved for future use, and must always
11393 Perl_parse_fullstmt(pTHX_ U32 flags)
11396 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11397 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11401 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11403 Parse a sequence of zero or more Perl statements. These may be normal
11404 imperative statements, including optional labels, or declarations
11405 that have compile-time effect, or any mixture thereof. The statement
11406 sequence ends when a closing brace or end-of-file is encountered in a
11407 place where a new statement could have validly started. It is up to
11408 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11409 is correctly set to reflect the source of the code to be parsed and the
11410 lexical context for the statements.
11412 The op tree representing the statement sequence is returned. This may
11413 be a null pointer if the statements were all null, for example if there
11414 were no statements or if there were only subroutine definitions (which
11415 have compile-time side effects). If not null, it will be a C<lineseq>
11416 list, normally including C<nextstate> or equivalent ops.
11418 If an error occurs in parsing or compilation, in most cases a valid op
11419 tree is returned anyway. The error is reflected in the parser state,
11420 normally resulting in a single exception at the top level of parsing
11421 which covers all the compilation errors that occurred. Some compilation
11422 errors, however, will throw an exception immediately.
11424 The I<flags> parameter is reserved for future use, and must always
11431 Perl_parse_stmtseq(pTHX_ U32 flags)
11436 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11437 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11438 c = lex_peek_unichar(0);
11439 if (c != -1 && c != /*{*/'}')
11440 qerror(Perl_mess(aTHX_ "Parse error"));
11445 Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist)
11447 PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
11448 deprecate("qw(...) as parentheses");
11449 force_next((4<<24)|')');
11450 if (qwlist->op_type == OP_STUB) {
11454 start_force(PL_curforce);
11455 NEXTVAL_NEXTTOKE.opval = qwlist;
11458 force_next((2<<24)|'(');
11463 * c-indentation-style: bsd
11464 * c-basic-offset: 4
11465 * indent-tabs-mode: t
11468 * ex: set ts=8 sts=4 sw=4 noet: