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 = SvPVX_const(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, 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, 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(start,SvPVX(PL_linestr) + soff - start));
3805 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
3807 return *s == '(' ? FUNCMETH : METHOD;
3813 /* Encoded script support. filter_add() effectively inserts a
3814 * 'pre-processing' function into the current source input stream.
3815 * Note that the filter function only applies to the current source file
3816 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3818 * The datasv parameter (which may be NULL) can be used to pass
3819 * private data to this instance of the filter. The filter function
3820 * can recover the SV using the FILTER_DATA macro and use it to
3821 * store private buffers and state information.
3823 * The supplied datasv parameter is upgraded to a PVIO type
3824 * and the IoDIRP/IoANY field is used to store the function pointer,
3825 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3826 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3827 * private use must be set using malloc'd pointers.
3831 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3840 if (!PL_rsfp_filters)
3841 PL_rsfp_filters = newAV();
3844 SvUPGRADE(datasv, SVt_PVIO);
3845 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3846 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3847 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3848 FPTR2DPTR(void *, IoANY(datasv)),
3849 SvPV_nolen(datasv)));
3850 av_unshift(PL_rsfp_filters, 1);
3851 av_store(PL_rsfp_filters, 0, datasv) ;
3856 /* Delete most recently added instance of this filter function. */
3858 Perl_filter_del(pTHX_ filter_t funcp)
3863 PERL_ARGS_ASSERT_FILTER_DEL;
3866 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3867 FPTR2DPTR(void*, funcp)));
3869 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3871 /* if filter is on top of stack (usual case) just pop it off */
3872 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3873 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3874 sv_free(av_pop(PL_rsfp_filters));
3878 /* we need to search for the correct entry and clear it */
3879 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3883 /* Invoke the idxth filter function for the current rsfp. */
3884 /* maxlen 0 = read one text line */
3886 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
3891 /* This API is bad. It should have been using unsigned int for maxlen.
3892 Not sure if we want to change the API, but if not we should sanity
3893 check the value here. */
3894 const unsigned int correct_length
3903 PERL_ARGS_ASSERT_FILTER_READ;
3905 if (!PL_parser || !PL_rsfp_filters)
3907 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
3908 /* Provide a default input filter to make life easy. */
3909 /* Note that we append to the line. This is handy. */
3910 DEBUG_P(PerlIO_printf(Perl_debug_log,
3911 "filter_read %d: from rsfp\n", idx));
3912 if (correct_length) {
3915 const int old_len = SvCUR(buf_sv);
3917 /* ensure buf_sv is large enough */
3918 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
3919 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
3920 correct_length)) <= 0) {
3921 if (PerlIO_error(PL_rsfp))
3922 return -1; /* error */
3924 return 0 ; /* end of file */
3926 SvCUR_set(buf_sv, old_len + len) ;
3927 SvPVX(buf_sv)[old_len + len] = '\0';
3930 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
3931 if (PerlIO_error(PL_rsfp))
3932 return -1; /* error */
3934 return 0 ; /* end of file */
3937 return SvCUR(buf_sv);
3939 /* Skip this filter slot if filter has been deleted */
3940 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
3941 DEBUG_P(PerlIO_printf(Perl_debug_log,
3942 "filter_read %d: skipped (filter deleted)\n",
3944 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
3946 /* Get function pointer hidden within datasv */
3947 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
3948 DEBUG_P(PerlIO_printf(Perl_debug_log,
3949 "filter_read %d: via function %p (%s)\n",
3950 idx, (void*)datasv, SvPV_nolen_const(datasv)));
3951 /* Call function. The function is expected to */
3952 /* call "FILTER_READ(idx+1, buf_sv)" first. */
3953 /* Return: <0:error, =0:eof, >0:not eof */
3954 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
3958 S_filter_gets(pTHX_ register SV *sv, STRLEN append)
3962 PERL_ARGS_ASSERT_FILTER_GETS;
3964 #ifdef PERL_CR_FILTER
3965 if (!PL_rsfp_filters) {
3966 filter_add(S_cr_textfilter,NULL);
3969 if (PL_rsfp_filters) {
3971 SvCUR_set(sv, 0); /* start with empty line */
3972 if (FILTER_READ(0, sv, 0) > 0)
3973 return ( SvPVX(sv) ) ;
3978 return (sv_gets(sv, PL_rsfp, append));
3982 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
3987 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
3989 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3993 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3994 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3996 return GvHV(gv); /* Foo:: */
3999 /* use constant CLASS => 'MyClass' */
4000 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
4001 if (gv && GvCV(gv)) {
4002 SV * const sv = cv_const_sv(GvCV(gv));
4004 pkgname = SvPV_const(sv, len);
4007 return gv_stashpvn(pkgname, len, 0);
4011 * S_readpipe_override
4012 * Check whether readpipe() is overridden, and generates the appropriate
4013 * optree, provided sublex_start() is called afterwards.
4016 S_readpipe_override(pTHX)
4019 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4020 pl_yylval.ival = OP_BACKTICK;
4022 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4024 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4025 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4026 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4028 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4029 op_append_elem(OP_LIST,
4030 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4031 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4038 * The intent of this yylex wrapper is to minimize the changes to the
4039 * tokener when we aren't interested in collecting madprops. It remains
4040 * to be seen how successful this strategy will be...
4047 char *s = PL_bufptr;
4049 /* make sure PL_thiswhite is initialized */
4053 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
4054 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4055 return S_pending_ident(aTHX);
4057 /* previous token ate up our whitespace? */
4058 if (!PL_lasttoke && PL_nextwhite) {
4059 PL_thiswhite = PL_nextwhite;
4063 /* isolate the token, and figure out where it is without whitespace */
4064 PL_realtokenstart = -1;
4068 assert(PL_curforce < 0);
4070 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4071 if (!PL_thistoken) {
4072 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4073 PL_thistoken = newSVpvs("");
4075 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4076 PL_thistoken = newSVpvn(tstart, s - tstart);
4079 if (PL_thismad) /* install head */
4080 CURMAD('X', PL_thistoken);
4083 /* last whitespace of a sublex? */
4084 if (optype == ')' && PL_endwhite) {
4085 CURMAD('X', PL_endwhite);
4090 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4091 if (!PL_thiswhite && !PL_endwhite && !optype) {
4092 sv_free(PL_thistoken);
4097 /* put off final whitespace till peg */
4098 if (optype == ';' && !PL_rsfp) {
4099 PL_nextwhite = PL_thiswhite;
4102 else if (PL_thisopen) {
4103 CURMAD('q', PL_thisopen);
4105 sv_free(PL_thistoken);
4109 /* Store actual token text as madprop X */
4110 CURMAD('X', PL_thistoken);
4114 /* add preceding whitespace as madprop _ */
4115 CURMAD('_', PL_thiswhite);
4119 /* add quoted material as madprop = */
4120 CURMAD('=', PL_thisstuff);
4124 /* add terminating quote as madprop Q */
4125 CURMAD('Q', PL_thisclose);
4129 /* special processing based on optype */
4133 /* opval doesn't need a TOKEN since it can already store mp */
4143 if (pl_yylval.opval)
4144 append_madprops(PL_thismad, pl_yylval.opval, 0);
4152 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4161 /* remember any fake bracket that lexer is about to discard */
4162 if (PL_lex_brackets == 1 &&
4163 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4166 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4169 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4170 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4173 break; /* don't bother looking for trailing comment */
4182 /* attach a trailing comment to its statement instead of next token */
4186 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4188 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4190 if (*s == '\n' || *s == '#') {
4191 while (s < PL_bufend && *s != '\n')
4195 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4196 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4213 /* Create new token struct. Note: opvals return early above. */
4214 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4221 S_tokenize_use(pTHX_ int is_use, char *s) {
4224 PERL_ARGS_ASSERT_TOKENIZE_USE;
4226 if (PL_expect != XSTATE)
4227 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4228 is_use ? "use" : "no"));
4230 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4231 s = force_version(s, TRUE);
4232 if (*s == ';' || *s == '}'
4233 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4234 start_force(PL_curforce);
4235 NEXTVAL_NEXTTOKE.opval = NULL;
4238 else if (*s == 'v') {
4239 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4240 s = force_version(s, FALSE);
4244 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4245 s = force_version(s, FALSE);
4247 pl_yylval.ival = is_use;
4251 static const char* const exp_name[] =
4252 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4253 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4257 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4259 S_word_takes_any_delimeter(char *p, STRLEN len)
4261 return (len == 1 && strchr("msyq", p[0])) ||
4263 (p[0] == 't' && p[1] == 'r') ||
4264 (p[0] == 'q' && strchr("qwxr", p[1]))));
4270 Works out what to call the token just pulled out of the input
4271 stream. The yacc parser takes care of taking the ops we return and
4272 stitching them into a tree.
4278 if read an identifier
4279 if we're in a my declaration
4280 croak if they tried to say my($foo::bar)
4281 build the ops for a my() declaration
4282 if it's an access to a my() variable
4283 are we in a sort block?
4284 croak if my($a); $a <=> $b
4285 build ops for access to a my() variable
4286 if in a dq string, and they've said @foo and we can't find @foo
4288 build ops for a bareword
4289 if we already built the token before, use it.
4294 #pragma segment Perl_yylex
4300 register char *s = PL_bufptr;
4306 /* orig_keyword, gvp, and gv are initialized here because
4307 * jump to the label just_a_word_zero can bypass their
4308 * initialization later. */
4309 I32 orig_keyword = 0;
4314 SV* tmp = newSVpvs("");
4315 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4316 (IV)CopLINE(PL_curcop),
4317 lex_state_names[PL_lex_state],
4318 exp_name[PL_expect],
4319 pv_display(tmp, s, strlen(s), 0, 60));
4322 /* check if there's an identifier for us to look at */
4323 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4324 return REPORT(S_pending_ident(aTHX));
4326 /* no identifier pending identification */
4328 switch (PL_lex_state) {
4330 case LEX_NORMAL: /* Some compilers will produce faster */
4331 case LEX_INTERPNORMAL: /* code if we comment these out. */
4335 /* when we've already built the next token, just pull it out of the queue */
4339 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4341 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4342 PL_nexttoke[PL_lasttoke].next_mad = 0;
4343 if (PL_thismad && PL_thismad->mad_key == '_') {
4344 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4345 PL_thismad->mad_val = 0;
4346 mad_free(PL_thismad);
4351 PL_lex_state = PL_lex_defer;
4352 PL_expect = PL_lex_expect;
4353 PL_lex_defer = LEX_NORMAL;
4354 if (!PL_nexttoke[PL_lasttoke].next_type)
4359 pl_yylval = PL_nextval[PL_nexttoke];
4361 PL_lex_state = PL_lex_defer;
4362 PL_expect = PL_lex_expect;
4363 PL_lex_defer = LEX_NORMAL;
4369 next_type = PL_nexttoke[PL_lasttoke].next_type;
4371 next_type = PL_nexttype[PL_nexttoke];
4373 if (next_type & (7<<24)) {
4374 if (next_type & (1<<24)) {
4375 if (PL_lex_brackets > 100)
4376 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4377 PL_lex_brackstack[PL_lex_brackets++] =
4378 (char) ((next_type >> 16) & 0xff);
4380 if (next_type & (2<<24))
4381 PL_lex_allbrackets++;
4382 if (next_type & (4<<24))
4383 PL_lex_allbrackets--;
4384 next_type &= 0xffff;
4387 /* FIXME - can these be merged? */
4390 return REPORT(next_type);
4394 /* interpolated case modifiers like \L \U, including \Q and \E.
4395 when we get here, PL_bufptr is at the \
4397 case LEX_INTERPCASEMOD:
4399 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4400 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
4402 /* handle \E or end of string */
4403 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4405 if (PL_lex_casemods) {
4406 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4407 PL_lex_casestack[PL_lex_casemods] = '\0';
4409 if (PL_bufptr != PL_bufend
4410 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
4412 PL_lex_state = LEX_INTERPCONCAT;
4415 PL_thistoken = newSVpvs("\\E");
4418 PL_lex_allbrackets--;
4422 while (PL_bufptr != PL_bufend &&
4423 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4425 PL_thiswhite = newSVpvs("");
4426 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4430 if (PL_bufptr != PL_bufend)
4433 PL_lex_state = LEX_INTERPCONCAT;
4437 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4438 "### Saw case modifier\n"); });
4440 if (s[1] == '\\' && s[2] == 'E') {
4443 PL_thiswhite = newSVpvs("");
4444 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4447 PL_lex_state = LEX_INTERPCONCAT;
4452 if (!PL_madskills) /* when just compiling don't need correct */
4453 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4454 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4455 if ((*s == 'L' || *s == 'U') &&
4456 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
4457 PL_lex_casestack[--PL_lex_casemods] = '\0';
4458 PL_lex_allbrackets--;
4461 if (PL_lex_casemods > 10)
4462 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4463 PL_lex_casestack[PL_lex_casemods++] = *s;
4464 PL_lex_casestack[PL_lex_casemods] = '\0';
4465 PL_lex_state = LEX_INTERPCONCAT;
4466 start_force(PL_curforce);
4467 NEXTVAL_NEXTTOKE.ival = 0;
4468 force_next((2<<24)|'(');
4469 start_force(PL_curforce);
4471 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4473 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4475 NEXTVAL_NEXTTOKE.ival = OP_LC;
4477 NEXTVAL_NEXTTOKE.ival = OP_UC;
4479 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4481 Perl_croak(aTHX_ "panic: yylex");
4483 SV* const tmpsv = newSVpvs("\\ ");
4484 /* replace the space with the character we want to escape
4486 SvPVX(tmpsv)[1] = *s;
4492 if (PL_lex_starts) {
4498 sv_free(PL_thistoken);
4499 PL_thistoken = newSVpvs("");
4502 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4503 if (PL_lex_casemods == 1 && PL_lex_inpat)
4512 case LEX_INTERPPUSH:
4513 return REPORT(sublex_push());
4515 case LEX_INTERPSTART:
4516 if (PL_bufptr == PL_bufend)
4517 return REPORT(sublex_done());
4518 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4519 "### Interpolated variable\n"); });
4521 PL_lex_dojoin = (*PL_bufptr == '@');
4522 PL_lex_state = LEX_INTERPNORMAL;
4523 if (PL_lex_dojoin) {
4524 start_force(PL_curforce);
4525 NEXTVAL_NEXTTOKE.ival = 0;
4527 start_force(PL_curforce);
4528 force_ident("\"", '$');
4529 start_force(PL_curforce);
4530 NEXTVAL_NEXTTOKE.ival = 0;
4532 start_force(PL_curforce);
4533 NEXTVAL_NEXTTOKE.ival = 0;
4534 force_next((2<<24)|'(');
4535 start_force(PL_curforce);
4536 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4539 if (PL_lex_starts++) {
4544 sv_free(PL_thistoken);
4545 PL_thistoken = newSVpvs("");
4548 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4549 if (!PL_lex_casemods && PL_lex_inpat)
4556 case LEX_INTERPENDMAYBE:
4557 if (intuit_more(PL_bufptr)) {
4558 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4564 if (PL_lex_dojoin) {
4565 PL_lex_dojoin = FALSE;
4566 PL_lex_state = LEX_INTERPCONCAT;
4570 sv_free(PL_thistoken);
4571 PL_thistoken = newSVpvs("");
4574 PL_lex_allbrackets--;
4577 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4578 && SvEVALED(PL_lex_repl))
4580 if (PL_bufptr != PL_bufend)
4581 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4585 case LEX_INTERPCONCAT:
4587 if (PL_lex_brackets)
4588 Perl_croak(aTHX_ "panic: INTERPCONCAT");
4590 if (PL_bufptr == PL_bufend)
4591 return REPORT(sublex_done());
4593 if (SvIVX(PL_linestr) == '\'') {
4594 SV *sv = newSVsv(PL_linestr);
4597 else if ( PL_hints & HINT_NEW_RE )
4598 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
4599 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4603 s = scan_const(PL_bufptr);
4605 PL_lex_state = LEX_INTERPCASEMOD;
4607 PL_lex_state = LEX_INTERPSTART;
4610 if (s != PL_bufptr) {
4611 start_force(PL_curforce);
4613 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
4615 NEXTVAL_NEXTTOKE = pl_yylval;
4618 if (PL_lex_starts++) {
4622 sv_free(PL_thistoken);
4623 PL_thistoken = newSVpvs("");
4626 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4627 if (!PL_lex_casemods && PL_lex_inpat)
4640 PL_lex_state = LEX_NORMAL;
4641 s = scan_formline(PL_bufptr);
4642 if (!PL_lex_formbrack)
4648 PL_oldoldbufptr = PL_oldbufptr;
4654 sv_free(PL_thistoken);
4657 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
4661 if (isIDFIRST_lazy_if(s,UTF))
4664 unsigned char c = *s;
4665 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4666 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4667 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4672 Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
4676 goto fake_eof; /* emulate EOF on ^D or ^Z */
4685 if (PL_lex_brackets &&
4686 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4687 yyerror((const char *)
4689 ? "Format not terminated"
4690 : "Missing right curly or square bracket"));
4692 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4693 "### Tokener got EOF\n");
4697 if (s++ < PL_bufend)
4698 goto retry; /* ignore stray nulls */
4701 if (!PL_in_eval && !PL_preambled) {
4702 PL_preambled = TRUE;
4708 /* Generate a string of Perl code to load the debugger.
4709 * If PERL5DB is set, it will return the contents of that,
4710 * otherwise a compile-time require of perl5db.pl. */
4712 const char * const pdb = PerlEnv_getenv("PERL5DB");
4715 sv_setpv(PL_linestr, pdb);
4716 sv_catpvs(PL_linestr,";");
4718 SETERRNO(0,SS_NORMAL);
4719 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4722 sv_setpvs(PL_linestr,"");
4723 if (PL_preambleav) {
4724 SV **svp = AvARRAY(PL_preambleav);
4725 SV **const end = svp + AvFILLp(PL_preambleav);
4727 sv_catsv(PL_linestr, *svp);
4729 sv_catpvs(PL_linestr, ";");
4731 sv_free(MUTABLE_SV(PL_preambleav));
4732 PL_preambleav = NULL;
4735 sv_catpvs(PL_linestr,
4736 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4737 if (PL_minus_n || PL_minus_p) {
4738 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4740 sv_catpvs(PL_linestr,"chomp;");
4743 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4744 || *PL_splitstr == '"')
4745 && strchr(PL_splitstr + 1, *PL_splitstr))
4746 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4748 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4749 bytes can be used as quoting characters. :-) */
4750 const char *splits = PL_splitstr;
4751 sv_catpvs(PL_linestr, "our @F=split(q\0");
4754 if (*splits == '\\')
4755 sv_catpvn(PL_linestr, splits, 1);
4756 sv_catpvn(PL_linestr, splits, 1);
4757 } while (*splits++);
4758 /* This loop will embed the trailing NUL of
4759 PL_linestr as the last thing it does before
4761 sv_catpvs(PL_linestr, ");");
4765 sv_catpvs(PL_linestr,"our @F=split(' ');");
4768 sv_catpvs(PL_linestr, "\n");
4769 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4770 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4771 PL_last_lop = PL_last_uni = NULL;
4772 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4773 update_debugger_info(PL_linestr, NULL, 0);
4778 bof = PL_rsfp ? TRUE : FALSE;
4781 fake_eof = LEX_FAKE_EOF;
4783 PL_bufptr = PL_bufend;
4784 CopLINE_inc(PL_curcop);
4785 if (!lex_next_chunk(fake_eof)) {
4786 CopLINE_dec(PL_curcop);
4788 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4790 CopLINE_dec(PL_curcop);
4793 PL_realtokenstart = -1;
4796 /* If it looks like the start of a BOM or raw UTF-16,
4797 * check if it in fact is. */
4798 if (bof && PL_rsfp &&
4803 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4804 bof = (offset == (Off_t)SvCUR(PL_linestr));
4805 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4806 /* offset may include swallowed CR */
4808 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4811 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4812 s = swallow_bom((U8*)s);
4815 if (PL_parser->in_pod) {
4816 /* Incest with pod. */
4819 sv_catsv(PL_thiswhite, PL_linestr);
4821 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4822 sv_setpvs(PL_linestr, "");
4823 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4824 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4825 PL_last_lop = PL_last_uni = NULL;
4826 PL_parser->in_pod = 0;
4831 } while (PL_parser->in_pod);
4832 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4833 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4834 PL_last_lop = PL_last_uni = NULL;
4835 if (CopLINE(PL_curcop) == 1) {
4836 while (s < PL_bufend && isSPACE(*s))
4838 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4842 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
4846 if (*s == '#' && *(s+1) == '!')
4848 #ifdef ALTERNATE_SHEBANG
4850 static char const as[] = ALTERNATE_SHEBANG;
4851 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4852 d = s + (sizeof(as) - 1);
4854 #endif /* ALTERNATE_SHEBANG */
4863 while (*d && !isSPACE(*d))
4867 #ifdef ARG_ZERO_IS_SCRIPT
4868 if (ipathend > ipath) {
4870 * HP-UX (at least) sets argv[0] to the script name,
4871 * which makes $^X incorrect. And Digital UNIX and Linux,
4872 * at least, set argv[0] to the basename of the Perl
4873 * interpreter. So, having found "#!", we'll set it right.
4875 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4877 assert(SvPOK(x) || SvGMAGICAL(x));
4878 if (sv_eq(x, CopFILESV(PL_curcop))) {
4879 sv_setpvn(x, ipath, ipathend - ipath);
4885 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
4886 const char * const lstart = SvPV_const(x,llen);
4888 bstart += blen - llen;
4889 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4890 sv_setpvn(x, ipath, ipathend - ipath);
4895 TAINT_NOT; /* $^X is always tainted, but that's OK */
4897 #endif /* ARG_ZERO_IS_SCRIPT */
4902 d = instr(s,"perl -");
4904 d = instr(s,"perl");
4906 /* avoid getting into infinite loops when shebang
4907 * line contains "Perl" rather than "perl" */
4909 for (d = ipathend-4; d >= ipath; --d) {
4910 if ((*d == 'p' || *d == 'P')
4911 && !ibcmp(d, "perl", 4))
4921 #ifdef ALTERNATE_SHEBANG
4923 * If the ALTERNATE_SHEBANG on this system starts with a
4924 * character that can be part of a Perl expression, then if
4925 * we see it but not "perl", we're probably looking at the
4926 * start of Perl code, not a request to hand off to some
4927 * other interpreter. Similarly, if "perl" is there, but
4928 * not in the first 'word' of the line, we assume the line
4929 * contains the start of the Perl program.
4931 if (d && *s != '#') {
4932 const char *c = ipath;
4933 while (*c && !strchr("; \t\r\n\f\v#", *c))
4936 d = NULL; /* "perl" not in first word; ignore */
4938 *s = '#'; /* Don't try to parse shebang line */
4940 #endif /* ALTERNATE_SHEBANG */
4945 !instr(s,"indir") &&
4946 instr(PL_origargv[0],"perl"))
4953 while (s < PL_bufend && isSPACE(*s))
4955 if (s < PL_bufend) {
4956 Newx(newargv,PL_origargc+3,char*);
4958 while (s < PL_bufend && !isSPACE(*s))
4961 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4964 newargv = PL_origargv;
4967 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4969 Perl_croak(aTHX_ "Can't exec %s", ipath);
4972 while (*d && !isSPACE(*d))
4974 while (SPACE_OR_TAB(*d))
4978 const bool switches_done = PL_doswitches;
4979 const U32 oldpdb = PL_perldb;
4980 const bool oldn = PL_minus_n;
4981 const bool oldp = PL_minus_p;
4985 bool baduni = FALSE;
4987 const char *d2 = d1 + 1;
4988 if (parse_unicode_opts((const char **)&d2)
4992 if (baduni || *d1 == 'M' || *d1 == 'm') {
4993 const char * const m = d1;
4994 while (*d1 && !isSPACE(*d1))
4996 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4999 d1 = moreswitches(d1);
5001 if (PL_doswitches && !switches_done) {
5002 int argc = PL_origargc;
5003 char **argv = PL_origargv;
5006 } while (argc && argv[0][0] == '-' && argv[0][1]);
5007 init_argv_symbols(argc,argv);
5009 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5010 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5011 /* if we have already added "LINE: while (<>) {",
5012 we must not do it again */
5014 sv_setpvs(PL_linestr, "");
5015 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5016 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5017 PL_last_lop = PL_last_uni = NULL;
5018 PL_preambled = FALSE;
5019 if (PERLDB_LINE || PERLDB_SAVESRC)
5020 (void)gv_fetchfile(PL_origfilename);
5027 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5029 PL_lex_state = LEX_FORMLINE;
5034 #ifdef PERL_STRICT_CR
5035 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5037 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5039 case ' ': case '\t': case '\f': case 013:
5041 PL_realtokenstart = -1;
5043 PL_thiswhite = newSVpvs("");
5044 sv_catpvn(PL_thiswhite, s, 1);
5051 PL_realtokenstart = -1;
5055 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
5056 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
5057 /* handle eval qq[#line 1 "foo"\n ...] */
5058 CopLINE_dec(PL_curcop);
5061 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5063 if (!PL_in_eval || PL_rsfp)
5068 while (d < PL_bufend && *d != '\n')
5072 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5073 Perl_croak(aTHX_ "panic: input overflow");
5076 PL_thiswhite = newSVpvn(s, d - s);
5081 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5083 PL_lex_state = LEX_FORMLINE;
5089 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5090 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5093 TOKEN(PEG); /* make sure any #! line is accessible */
5098 /* if (PL_madskills && PL_lex_formbrack) { */
5100 while (d < PL_bufend && *d != '\n')
5104 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5105 Perl_croak(aTHX_ "panic: input overflow");
5106 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5108 PL_thiswhite = newSVpvs("");
5109 if (CopLINE(PL_curcop) == 1) {
5110 sv_setpvs(PL_thiswhite, "");
5113 sv_catpvn(PL_thiswhite, s, d - s);
5127 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
5135 while (s < PL_bufend && SPACE_OR_TAB(*s))
5138 if (strnEQ(s,"=>",2)) {
5139 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
5140 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5141 OPERATOR('-'); /* unary minus */
5143 PL_last_uni = PL_oldbufptr;
5145 case 'r': ftst = OP_FTEREAD; break;
5146 case 'w': ftst = OP_FTEWRITE; break;
5147 case 'x': ftst = OP_FTEEXEC; break;
5148 case 'o': ftst = OP_FTEOWNED; break;
5149 case 'R': ftst = OP_FTRREAD; break;
5150 case 'W': ftst = OP_FTRWRITE; break;
5151 case 'X': ftst = OP_FTREXEC; break;
5152 case 'O': ftst = OP_FTROWNED; break;
5153 case 'e': ftst = OP_FTIS; break;
5154 case 'z': ftst = OP_FTZERO; break;
5155 case 's': ftst = OP_FTSIZE; break;
5156 case 'f': ftst = OP_FTFILE; break;
5157 case 'd': ftst = OP_FTDIR; break;
5158 case 'l': ftst = OP_FTLINK; break;
5159 case 'p': ftst = OP_FTPIPE; break;
5160 case 'S': ftst = OP_FTSOCK; break;
5161 case 'u': ftst = OP_FTSUID; break;
5162 case 'g': ftst = OP_FTSGID; break;
5163 case 'k': ftst = OP_FTSVTX; break;
5164 case 'b': ftst = OP_FTBLK; break;
5165 case 'c': ftst = OP_FTCHR; break;
5166 case 't': ftst = OP_FTTTY; break;
5167 case 'T': ftst = OP_FTTEXT; break;
5168 case 'B': ftst = OP_FTBINARY; break;
5169 case 'M': case 'A': case 'C':
5170 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5172 case 'M': ftst = OP_FTMTIME; break;
5173 case 'A': ftst = OP_FTATIME; break;
5174 case 'C': ftst = OP_FTCTIME; break;
5182 PL_last_lop_op = (OPCODE)ftst;
5183 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5184 "### Saw file test %c\n", (int)tmp);
5189 /* Assume it was a minus followed by a one-letter named
5190 * subroutine call (or a -bareword), then. */
5191 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5192 "### '-%c' looked like a file test but was not\n",
5199 const char tmp = *s++;
5202 if (PL_expect == XOPERATOR)
5207 else if (*s == '>') {
5210 if (isIDFIRST_lazy_if(s,UTF)) {
5211 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
5219 if (PL_expect == XOPERATOR) {
5220 if (*s == '=' && !PL_lex_allbrackets &&
5221 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5228 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5230 OPERATOR('-'); /* unary minus */
5236 const char tmp = *s++;
5239 if (PL_expect == XOPERATOR)
5244 if (PL_expect == XOPERATOR) {
5245 if (*s == '=' && !PL_lex_allbrackets &&
5246 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5253 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5260 if (PL_expect != XOPERATOR) {
5261 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5262 PL_expect = XOPERATOR;
5263 force_ident(PL_tokenbuf, '*');
5271 if (*s == '=' && !PL_lex_allbrackets &&
5272 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5278 if (*s == '=' && !PL_lex_allbrackets &&
5279 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5286 if (PL_expect == XOPERATOR) {
5287 if (s[1] == '=' && !PL_lex_allbrackets &&
5288 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5293 PL_tokenbuf[0] = '%';
5294 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5295 sizeof PL_tokenbuf - 1, FALSE);
5296 if (!PL_tokenbuf[1]) {
5299 PL_pending_ident = '%';
5303 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5304 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5309 if (PL_lex_brackets > 100)
5310 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5311 PL_lex_brackstack[PL_lex_brackets++] = 0;
5312 PL_lex_allbrackets++;
5314 const char tmp = *s++;
5319 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5321 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5329 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5336 goto just_a_word_zero_gv;
5339 switch (PL_expect) {
5345 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5347 PL_bufptr = s; /* update in case we back off */
5350 "Use of := for an empty attribute list is not allowed");
5357 PL_expect = XTERMBLOCK;
5360 stuffstart = s - SvPVX(PL_linestr) - 1;
5364 while (isIDFIRST_lazy_if(s,UTF)) {
5367 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5368 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5369 if (tmp < 0) tmp = -tmp;
5384 sv = newSVpvn(s, len);
5386 d = scan_str(d,TRUE,TRUE);
5388 /* MUST advance bufptr here to avoid bogus
5389 "at end of line" context messages from yyerror().
5391 PL_bufptr = s + len;
5392 yyerror("Unterminated attribute parameter in attribute list");
5396 return REPORT(0); /* EOF indicator */
5400 sv_catsv(sv, PL_lex_stuff);
5401 attrs = op_append_elem(OP_LIST, attrs,
5402 newSVOP(OP_CONST, 0, sv));
5403 SvREFCNT_dec(PL_lex_stuff);
5404 PL_lex_stuff = NULL;
5407 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5409 if (PL_in_my == KEY_our) {
5410 deprecate(":unique");
5413 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5416 /* NOTE: any CV attrs applied here need to be part of
5417 the CVf_BUILTIN_ATTRS define in cv.h! */
5418 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5420 CvLVALUE_on(PL_compcv);
5422 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5424 deprecate(":locked");
5426 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5428 CvMETHOD_on(PL_compcv);
5430 /* After we've set the flags, it could be argued that
5431 we don't need to do the attributes.pm-based setting
5432 process, and shouldn't bother appending recognized
5433 flags. To experiment with that, uncomment the
5434 following "else". (Note that's already been
5435 uncommented. That keeps the above-applied built-in
5436 attributes from being intercepted (and possibly
5437 rejected) by a package's attribute routines, but is
5438 justified by the performance win for the common case
5439 of applying only built-in attributes.) */
5441 attrs = op_append_elem(OP_LIST, attrs,
5442 newSVOP(OP_CONST, 0,
5446 if (*s == ':' && s[1] != ':')
5449 break; /* require real whitespace or :'s */
5450 /* XXX losing whitespace on sequential attributes here */
5454 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5455 if (*s != ';' && *s != '}' && *s != tmp
5456 && (tmp != '=' || *s != ')')) {
5457 const char q = ((*s == '\'') ? '"' : '\'');
5458 /* If here for an expression, and parsed no attrs, back
5460 if (tmp == '=' && !attrs) {
5464 /* MUST advance bufptr here to avoid bogus "at end of line"
5465 context messages from yyerror().
5468 yyerror( (const char *)
5470 ? Perl_form(aTHX_ "Invalid separator character "
5471 "%c%c%c in attribute list", q, *s, q)
5472 : "Unterminated attribute list" ) );
5480 start_force(PL_curforce);
5481 NEXTVAL_NEXTTOKE.opval = attrs;
5482 CURMAD('_', PL_nextwhite);
5487 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
5488 (s - SvPVX(PL_linestr)) - stuffstart);
5493 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5497 PL_lex_allbrackets--;
5501 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5502 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5506 PL_lex_allbrackets++;
5509 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5515 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5518 PL_lex_allbrackets--;
5524 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5527 if (PL_lex_brackets <= 0)
5528 yyerror("Unmatched right square bracket");
5531 PL_lex_allbrackets--;
5532 if (PL_lex_state == LEX_INTERPNORMAL) {
5533 if (PL_lex_brackets == 0) {
5534 if (*s == '-' && s[1] == '>')
5535 PL_lex_state = LEX_INTERPENDMAYBE;
5536 else if (*s != '[' && *s != '{')
5537 PL_lex_state = LEX_INTERPEND;
5544 if (PL_lex_brackets > 100) {
5545 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5547 switch (PL_expect) {
5549 if (PL_lex_formbrack) {
5553 if (PL_oldoldbufptr == PL_last_lop)
5554 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5556 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5557 PL_lex_allbrackets++;
5558 OPERATOR(HASHBRACK);
5560 while (s < PL_bufend && SPACE_OR_TAB(*s))
5563 PL_tokenbuf[0] = '\0';
5564 if (d < PL_bufend && *d == '-') {
5565 PL_tokenbuf[0] = '-';
5567 while (d < PL_bufend && SPACE_OR_TAB(*d))
5570 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5571 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5573 while (d < PL_bufend && SPACE_OR_TAB(*d))
5576 const char minus = (PL_tokenbuf[0] == '-');
5577 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
5585 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5586 PL_lex_allbrackets++;
5591 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5592 PL_lex_allbrackets++;
5597 if (PL_oldoldbufptr == PL_last_lop)
5598 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5600 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5601 PL_lex_allbrackets++;
5604 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5606 /* This hack is to get the ${} in the message. */
5608 yyerror("syntax error");
5611 OPERATOR(HASHBRACK);
5613 /* This hack serves to disambiguate a pair of curlies
5614 * as being a block or an anon hash. Normally, expectation
5615 * determines that, but in cases where we're not in a
5616 * position to expect anything in particular (like inside
5617 * eval"") we have to resolve the ambiguity. This code
5618 * covers the case where the first term in the curlies is a
5619 * quoted string. Most other cases need to be explicitly
5620 * disambiguated by prepending a "+" before the opening
5621 * curly in order to force resolution as an anon hash.
5623 * XXX should probably propagate the outer expectation
5624 * into eval"" to rely less on this hack, but that could
5625 * potentially break current behavior of eval"".
5629 if (*s == '\'' || *s == '"' || *s == '`') {
5630 /* common case: get past first string, handling escapes */
5631 for (t++; t < PL_bufend && *t != *s;)
5632 if (*t++ == '\\' && (*t == '\\' || *t == *s))
5636 else if (*s == 'q') {
5639 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5642 /* skip q//-like construct */
5644 char open, close, term;
5647 while (t < PL_bufend && isSPACE(*t))
5649 /* check for q => */
5650 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5651 OPERATOR(HASHBRACK);
5655 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5659 for (t++; t < PL_bufend; t++) {
5660 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5662 else if (*t == open)
5666 for (t++; t < PL_bufend; t++) {
5667 if (*t == '\\' && t+1 < PL_bufend)
5669 else if (*t == close && --brackets <= 0)
5671 else if (*t == open)
5678 /* skip plain q word */
5679 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5682 else if (isALNUM_lazy_if(t,UTF)) {
5684 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5687 while (t < PL_bufend && isSPACE(*t))
5689 /* if comma follows first term, call it an anon hash */
5690 /* XXX it could be a comma expression with loop modifiers */
5691 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5692 || (*t == '=' && t[1] == '>')))
5693 OPERATOR(HASHBRACK);
5694 if (PL_expect == XREF)
5697 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5703 pl_yylval.ival = CopLINE(PL_curcop);
5704 if (isSPACE(*s) || *s == '#')
5705 PL_copline = NOLINE; /* invalidate current command line number */
5708 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5712 if (PL_lex_brackets <= 0)
5713 yyerror("Unmatched right curly bracket");
5715 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5716 PL_lex_allbrackets--;
5717 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
5718 PL_lex_formbrack = 0;
5719 if (PL_lex_state == LEX_INTERPNORMAL) {
5720 if (PL_lex_brackets == 0) {
5721 if (PL_expect & XFAKEBRACK) {
5722 PL_expect &= XENUMMASK;
5723 PL_lex_state = LEX_INTERPEND;
5728 PL_thiswhite = newSVpvs("");
5729 sv_catpvs(PL_thiswhite,"}");
5732 return yylex(); /* ignore fake brackets */
5734 if (*s == '-' && s[1] == '>')
5735 PL_lex_state = LEX_INTERPENDMAYBE;
5736 else if (*s != '[' && *s != '{')
5737 PL_lex_state = LEX_INTERPEND;
5740 if (PL_expect & XFAKEBRACK) {
5741 PL_expect &= XENUMMASK;
5743 return yylex(); /* ignore fake brackets */
5745 start_force(PL_curforce);
5747 curmad('X', newSVpvn(s-1,1));
5748 CURMAD('_', PL_thiswhite);
5753 PL_thistoken = newSVpvs("");
5759 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5760 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5767 if (PL_expect == XOPERATOR) {
5768 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5769 && isIDFIRST_lazy_if(s,UTF))
5771 CopLINE_dec(PL_curcop);
5772 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5773 CopLINE_inc(PL_curcop);
5775 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5776 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5783 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5785 PL_expect = XOPERATOR;
5786 force_ident(PL_tokenbuf, '&');
5790 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5796 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5797 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5804 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5805 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5813 const char tmp = *s++;
5815 if (!PL_lex_allbrackets &&
5816 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5823 if (!PL_lex_allbrackets &&
5824 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5832 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5833 && strchr("+-*/%.^&|<",tmp))
5834 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5835 "Reversed %c= operator",(int)tmp);
5837 if (PL_expect == XSTATE && isALPHA(tmp) &&
5838 (s == PL_linestart+1 || s[-2] == '\n') )
5840 if (PL_in_eval && !PL_rsfp) {
5845 if (strnEQ(s,"=cut",4)) {
5861 PL_thiswhite = newSVpvs("");
5862 sv_catpvn(PL_thiswhite, PL_linestart,
5863 PL_bufend - PL_linestart);
5867 PL_parser->in_pod = 1;
5871 if (PL_lex_brackets < PL_lex_formbrack) {
5873 #ifdef PERL_STRICT_CR
5874 while (SPACE_OR_TAB(*t))
5876 while (SPACE_OR_TAB(*t) || *t == '\r')
5879 if (*t == '\n' || *t == '#') {
5885 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5894 const char tmp = *s++;
5896 /* was this !=~ where !~ was meant?
5897 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5899 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5900 const char *t = s+1;
5902 while (t < PL_bufend && isSPACE(*t))
5905 if (*t == '/' || *t == '?' ||
5906 ((*t == 'm' || *t == 's' || *t == 'y')
5907 && !isALNUM(t[1])) ||
5908 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
5909 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5910 "!=~ should be !~");
5912 if (!PL_lex_allbrackets &&
5913 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5925 if (PL_expect != XOPERATOR) {
5926 if (s[1] != '<' && !strchr(s,'>'))
5929 s = scan_heredoc(s);
5931 s = scan_inputsymbol(s);
5932 TERM(sublex_start());
5938 if (*s == '=' && !PL_lex_allbrackets &&
5939 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5943 SHop(OP_LEFT_SHIFT);
5948 if (!PL_lex_allbrackets &&
5949 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5956 if (!PL_lex_allbrackets &&
5957 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5965 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5973 const char tmp = *s++;
5975 if (*s == '=' && !PL_lex_allbrackets &&
5976 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5980 SHop(OP_RIGHT_SHIFT);
5982 else if (tmp == '=') {
5983 if (!PL_lex_allbrackets &&
5984 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5992 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6001 if (PL_expect == XOPERATOR) {
6002 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6003 return deprecate_commaless_var_list();
6007 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6008 PL_tokenbuf[0] = '@';
6009 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6010 sizeof PL_tokenbuf - 1, FALSE);
6011 if (PL_expect == XOPERATOR)
6012 no_op("Array length", s);
6013 if (!PL_tokenbuf[1])
6015 PL_expect = XOPERATOR;
6016 PL_pending_ident = '#';
6020 PL_tokenbuf[0] = '$';
6021 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6022 sizeof PL_tokenbuf - 1, FALSE);
6023 if (PL_expect == XOPERATOR)
6025 if (!PL_tokenbuf[1]) {
6027 yyerror("Final $ should be \\$ or $name");
6033 const char tmp = *s;
6034 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6037 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6038 && intuit_more(s)) {
6040 PL_tokenbuf[0] = '@';
6041 if (ckWARN(WARN_SYNTAX)) {
6044 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
6047 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6048 while (t < PL_bufend && *t != ']')
6050 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6051 "Multidimensional syntax %.*s not supported",
6052 (int)((t - PL_bufptr) + 1), PL_bufptr);
6056 else if (*s == '{') {
6058 PL_tokenbuf[0] = '%';
6059 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6060 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6062 char tmpbuf[sizeof PL_tokenbuf];
6065 } while (isSPACE(*t));
6066 if (isIDFIRST_lazy_if(t,UTF)) {
6068 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6072 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
6073 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6074 "You need to quote \"%s\"",
6081 PL_expect = XOPERATOR;
6082 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6083 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6084 if (!islop || PL_last_lop_op == OP_GREPSTART)
6085 PL_expect = XOPERATOR;
6086 else if (strchr("$@\"'`q", *s))
6087 PL_expect = XTERM; /* e.g. print $fh "foo" */
6088 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6089 PL_expect = XTERM; /* e.g. print $fh &sub */
6090 else if (isIDFIRST_lazy_if(s,UTF)) {
6091 char tmpbuf[sizeof PL_tokenbuf];
6093 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6094 if ((t2 = keyword(tmpbuf, len, 0))) {
6095 /* binary operators exclude handle interpretations */
6107 PL_expect = XTERM; /* e.g. print $fh length() */
6112 PL_expect = XTERM; /* e.g. print $fh subr() */
6115 else if (isDIGIT(*s))
6116 PL_expect = XTERM; /* e.g. print $fh 3 */
6117 else if (*s == '.' && isDIGIT(s[1]))
6118 PL_expect = XTERM; /* e.g. print $fh .3 */
6119 else if ((*s == '?' || *s == '-' || *s == '+')
6120 && !isSPACE(s[1]) && s[1] != '=')
6121 PL_expect = XTERM; /* e.g. print $fh -1 */
6122 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6124 PL_expect = XTERM; /* e.g. print $fh /.../
6125 XXX except DORDOR operator
6127 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6129 PL_expect = XTERM; /* print $fh <<"EOF" */
6132 PL_pending_ident = '$';
6136 if (PL_expect == XOPERATOR)
6138 PL_tokenbuf[0] = '@';
6139 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6140 if (!PL_tokenbuf[1]) {
6143 if (PL_lex_state == LEX_NORMAL)
6145 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6147 PL_tokenbuf[0] = '%';
6149 /* Warn about @ where they meant $. */
6150 if (*s == '[' || *s == '{') {
6151 if (ckWARN(WARN_SYNTAX)) {
6152 const char *t = s + 1;
6153 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6155 if (*t == '}' || *t == ']') {
6157 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6158 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6159 "Scalar value %.*s better written as $%.*s",
6160 (int)(t-PL_bufptr), PL_bufptr,
6161 (int)(t-PL_bufptr-1), PL_bufptr+1);
6166 PL_pending_ident = '@';
6169 case '/': /* may be division, defined-or, or pattern */
6170 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6171 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6172 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6177 case '?': /* may either be conditional or pattern */
6178 if (PL_expect == XOPERATOR) {
6181 if (!PL_lex_allbrackets &&
6182 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6186 PL_lex_allbrackets++;
6192 /* A // operator. */
6193 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6194 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6195 LEX_FAKEEOF_LOGIC)) {
6203 if (*s == '=' && !PL_lex_allbrackets &&
6204 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6213 /* Disable warning on "study /blah/" */
6214 if (PL_oldoldbufptr == PL_last_uni
6215 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6216 || memNE(PL_last_uni, "study", 5)
6217 || isALNUM_lazy_if(PL_last_uni+5,UTF)
6221 deprecate("?PATTERN? without explicit operator");
6222 s = scan_pat(s,OP_MATCH);
6223 TERM(sublex_start());
6227 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6228 #ifdef PERL_STRICT_CR
6231 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6233 && (s == PL_linestart || s[-1] == '\n') )
6235 PL_lex_formbrack = 0;
6239 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6243 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6246 if (!PL_lex_allbrackets &&
6247 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6254 pl_yylval.ival = OPf_SPECIAL;
6260 if (*s == '=' && !PL_lex_allbrackets &&
6261 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6268 case '0': case '1': case '2': case '3': case '4':
6269 case '5': case '6': case '7': case '8': case '9':
6270 s = scan_num(s, &pl_yylval);
6271 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6272 if (PL_expect == XOPERATOR)
6277 s = scan_str(s,!!PL_madskills,FALSE);
6278 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6279 if (PL_expect == XOPERATOR) {
6280 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6281 return deprecate_commaless_var_list();
6288 pl_yylval.ival = OP_CONST;
6289 TERM(sublex_start());
6292 s = scan_str(s,!!PL_madskills,FALSE);
6293 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6294 if (PL_expect == XOPERATOR) {
6295 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6296 return deprecate_commaless_var_list();
6303 pl_yylval.ival = OP_CONST;
6304 /* FIXME. I think that this can be const if char *d is replaced by
6305 more localised variables. */
6306 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6307 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6308 pl_yylval.ival = OP_STRINGIFY;
6312 TERM(sublex_start());
6315 s = scan_str(s,!!PL_madskills,FALSE);
6316 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6317 if (PL_expect == XOPERATOR)
6318 no_op("Backticks",s);
6321 readpipe_override();
6322 TERM(sublex_start());
6326 if (PL_lex_inwhat && isDIGIT(*s))
6327 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6329 if (PL_expect == XOPERATOR)
6330 no_op("Backslash",s);
6334 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6335 char *start = s + 2;
6336 while (isDIGIT(*start) || *start == '_')
6338 if (*start == '.' && isDIGIT(start[1])) {
6339 s = scan_num(s, &pl_yylval);
6342 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6343 else if (!isALPHA(*start) && (PL_expect == XTERM
6344 || PL_expect == XREF || PL_expect == XSTATE
6345 || PL_expect == XTERMORDORDOR)) {
6346 GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
6348 s = scan_num(s, &pl_yylval);
6355 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6398 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6400 /* Some keywords can be followed by any delimiter, including ':' */
6401 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6403 /* x::* is just a word, unless x is "CORE" */
6404 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6408 while (d < PL_bufend && isSPACE(*d))
6409 d++; /* no comments skipped here, or s### is misparsed */
6411 /* Is this a word before a => operator? */
6412 if (*d == '=' && d[1] == '>') {
6415 = (OP*)newSVOP(OP_CONST, 0,
6416 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6417 pl_yylval.opval->op_private = OPpCONST_BARE;
6421 /* Check for plugged-in keyword */
6425 char *saved_bufptr = PL_bufptr;
6427 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6429 if (result == KEYWORD_PLUGIN_DECLINE) {
6430 /* not a plugged-in keyword */
6431 PL_bufptr = saved_bufptr;
6432 } else if (result == KEYWORD_PLUGIN_STMT) {
6433 pl_yylval.opval = o;
6436 return REPORT(PLUGSTMT);
6437 } else if (result == KEYWORD_PLUGIN_EXPR) {
6438 pl_yylval.opval = o;
6440 PL_expect = XOPERATOR;
6441 return REPORT(PLUGEXPR);
6443 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6448 /* Check for built-in keyword */
6449 tmp = keyword(PL_tokenbuf, len, 0);
6451 /* Is this a label? */
6452 if (!anydelim && PL_expect == XSTATE
6453 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6455 pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
6460 if (tmp < 0) { /* second-class keyword? */
6461 GV *ogv = NULL; /* override (winner) */
6462 GV *hgv = NULL; /* hidden (loser) */
6463 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6465 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
6468 if (GvIMPORTED_CV(gv))
6470 else if (! CvMETHOD(cv))
6474 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
6475 (gv = *gvp) && isGV_with_GP(gv) &&
6476 GvCVu(gv) && GvIMPORTED_CV(gv))
6483 tmp = 0; /* overridden by import or by GLOBAL */
6486 && -tmp==KEY_lock /* XXX generalizable kludge */
6489 tmp = 0; /* any sub overrides "weak" keyword */
6491 else { /* no override */
6493 if (tmp == KEY_dump) {
6494 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6495 "dump() better written as CORE::dump()");
6499 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
6500 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6501 "Ambiguous call resolved as CORE::%s(), "
6502 "qualify as such or use &",
6510 default: /* not a keyword */
6511 /* Trade off - by using this evil construction we can pull the
6512 variable gv into the block labelled keylookup. If not, then
6513 we have to give it function scope so that the goto from the
6514 earlier ':' case doesn't bypass the initialisation. */
6516 just_a_word_zero_gv:
6524 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6528 SV *nextPL_nextwhite = 0;
6532 /* Get the rest if it looks like a package qualifier */
6534 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6536 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6539 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
6540 *s == '\'' ? "'" : "::");
6545 if (PL_expect == XOPERATOR) {
6546 if (PL_bufptr == PL_linestart) {
6547 CopLINE_dec(PL_curcop);
6548 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6549 CopLINE_inc(PL_curcop);
6552 no_op("Bareword",s);
6555 /* Look for a subroutine with this name in current package,
6556 unless name is "Foo::", in which case Foo is a bareword
6557 (and a package name). */
6559 if (len > 2 && !PL_madskills &&
6560 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6562 if (ckWARN(WARN_BAREWORD)
6563 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
6564 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6565 "Bareword \"%s\" refers to nonexistent package",
6568 PL_tokenbuf[len] = '\0';
6574 /* Mustn't actually add anything to a symbol table.
6575 But also don't want to "initialise" any placeholder
6576 constants that might already be there into full
6577 blown PVGVs with attached PVCV. */
6578 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6579 GV_NOADD_NOINIT, SVt_PVCV);
6584 /* if we saw a global override before, get the right name */
6586 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6587 len ? len : strlen(PL_tokenbuf));
6589 SV * const tmp_sv = sv;
6590 sv = newSVpvs("CORE::GLOBAL::");
6591 sv_catsv(sv, tmp_sv);
6592 SvREFCNT_dec(tmp_sv);
6596 if (PL_madskills && !PL_thistoken) {
6597 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
6598 PL_thistoken = newSVpvn(start,s - start);
6599 PL_realtokenstart = s - SvPVX(PL_linestr);
6603 /* Presume this is going to be a bareword of some sort. */
6605 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6606 pl_yylval.opval->op_private = OPpCONST_BARE;
6608 /* And if "Foo::", then that's what it certainly is. */
6613 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6614 const_op->op_private = OPpCONST_BARE;
6615 rv2cv_op = newCVREF(0, const_op);
6617 cv = rv2cv_op_cv(rv2cv_op, 0);
6619 /* See if it's the indirect object for a list operator. */
6621 if (PL_oldoldbufptr &&
6622 PL_oldoldbufptr < PL_bufptr &&
6623 (PL_oldoldbufptr == PL_last_lop
6624 || PL_oldoldbufptr == PL_last_uni) &&
6625 /* NO SKIPSPACE BEFORE HERE! */
6626 (PL_expect == XREF ||
6627 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6629 bool immediate_paren = *s == '(';
6631 /* (Now we can afford to cross potential line boundary.) */
6632 s = SKIPSPACE2(s,nextPL_nextwhite);
6634 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
6637 /* Two barewords in a row may indicate method call. */
6639 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6640 (tmp = intuit_method(s, gv, cv))) {
6642 if (tmp == METHOD && !PL_lex_allbrackets &&
6643 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6644 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6648 /* If not a declared subroutine, it's an indirect object. */
6649 /* (But it's an indir obj regardless for sort.) */
6650 /* Also, if "_" follows a filetest operator, it's a bareword */
6653 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6655 (PL_last_lop_op != OP_MAPSTART &&
6656 PL_last_lop_op != OP_GREPSTART))))
6657 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6658 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6661 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6666 PL_expect = XOPERATOR;
6669 s = SKIPSPACE2(s,nextPL_nextwhite);
6670 PL_nextwhite = nextPL_nextwhite;
6675 /* Is this a word before a => operator? */
6676 if (*s == '=' && s[1] == '>' && !pkgname) {
6679 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
6680 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
6681 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
6685 /* If followed by a paren, it's certainly a subroutine. */
6690 while (SPACE_OR_TAB(*d))
6692 if (*d == ')' && (sv = cv_const_sv(cv))) {
6699 PL_nextwhite = PL_thiswhite;
6702 start_force(PL_curforce);
6704 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6705 PL_expect = XOPERATOR;
6708 PL_nextwhite = nextPL_nextwhite;
6709 curmad('X', PL_thistoken);
6710 PL_thistoken = newSVpvs("");
6719 /* If followed by var or block, call it a method (unless sub) */
6721 if ((*s == '$' || *s == '{') && !cv) {
6723 PL_last_lop = PL_oldbufptr;
6724 PL_last_lop_op = OP_METHOD;
6725 if (!PL_lex_allbrackets &&
6726 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6727 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6731 /* If followed by a bareword, see if it looks like indir obj. */
6734 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6735 && (tmp = intuit_method(s, gv, cv))) {
6737 if (tmp == METHOD && !PL_lex_allbrackets &&
6738 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6739 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6743 /* Not a method, so call it a subroutine (if defined) */
6746 if (lastchar == '-')
6747 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6748 "Ambiguous use of -%s resolved as -&%s()",
6749 PL_tokenbuf, PL_tokenbuf);
6750 /* Check for a constant sub */
6751 if ((sv = cv_const_sv(cv))) {
6754 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6755 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6756 pl_yylval.opval->op_private = 0;
6757 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6761 op_free(pl_yylval.opval);
6762 pl_yylval.opval = rv2cv_op;
6763 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6764 PL_last_lop = PL_oldbufptr;
6765 PL_last_lop_op = OP_ENTERSUB;
6766 /* Is there a prototype? */
6774 const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
6777 while (*proto == ';')
6782 *proto == '$' || *proto == '_'
6783 || *proto == '*' || *proto == '+'
6788 *proto == '\\' && proto[1] && proto[2] == '\0'
6792 if (*proto == '\\' && proto[1] == '[') {
6793 const char *p = proto + 2;
6794 while(*p && *p != ']')
6796 if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
6798 if (*proto == '&' && *s == '{') {
6800 sv_setpvs(PL_subname, "__ANON__");
6802 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6803 if (!PL_lex_allbrackets &&
6804 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6805 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6812 PL_nextwhite = PL_thiswhite;
6815 start_force(PL_curforce);
6816 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6819 PL_nextwhite = nextPL_nextwhite;
6820 curmad('X', PL_thistoken);
6821 PL_thistoken = newSVpvs("");
6824 if (!PL_lex_allbrackets &&
6825 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6826 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6831 /* Guess harder when madskills require "best effort". */
6832 if (PL_madskills && (!gv || !GvCVu(gv))) {
6833 int probable_sub = 0;
6834 if (strchr("\"'`$@%0123456789!*+{[<", *s))
6836 else if (isALPHA(*s)) {
6840 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
6841 if (!keyword(tmpbuf, tmplen, 0))
6844 while (d < PL_bufend && isSPACE(*d))
6846 if (*d == '=' && d[1] == '>')
6851 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
6852 op_free(pl_yylval.opval);
6853 pl_yylval.opval = rv2cv_op;
6854 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6855 PL_last_lop = PL_oldbufptr;
6856 PL_last_lop_op = OP_ENTERSUB;
6857 PL_nextwhite = PL_thiswhite;
6859 start_force(PL_curforce);
6860 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6862 PL_nextwhite = nextPL_nextwhite;
6863 curmad('X', PL_thistoken);
6864 PL_thistoken = newSVpvs("");
6866 if (!PL_lex_allbrackets &&
6867 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6868 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6872 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6875 if (!PL_lex_allbrackets &&
6876 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6877 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6882 /* Call it a bare word */
6884 if (PL_hints & HINT_STRICT_SUBS)
6885 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6888 /* after "print" and similar functions (corresponding to
6889 * "F? L" in opcode.pl), whatever wasn't already parsed as
6890 * a filehandle should be subject to "strict subs".
6891 * Likewise for the optional indirect-object argument to system
6892 * or exec, which can't be a bareword */
6893 if ((PL_last_lop_op == OP_PRINT
6894 || PL_last_lop_op == OP_PRTF
6895 || PL_last_lop_op == OP_SAY
6896 || PL_last_lop_op == OP_SYSTEM
6897 || PL_last_lop_op == OP_EXEC)
6898 && (PL_hints & HINT_STRICT_SUBS))
6899 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6900 if (lastchar != '-') {
6901 if (ckWARN(WARN_RESERVED)) {
6905 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
6906 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6914 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
6915 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6916 "Operator or semicolon missing before %c%s",
6917 lastchar, PL_tokenbuf);
6918 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6919 "Ambiguous use of %c resolved as operator %c",
6920 lastchar, lastchar);
6927 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6932 (OP*)newSVOP(OP_CONST, 0,
6933 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6936 case KEY___PACKAGE__:
6938 (OP*)newSVOP(OP_CONST, 0,
6940 ? newSVhek(HvNAME_HEK(PL_curstash))
6947 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6948 const char *pname = "main";
6949 if (PL_tokenbuf[2] == 'D')
6950 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
6951 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
6955 GvIOp(gv) = newIO();
6956 IoIFP(GvIOp(gv)) = PL_rsfp;
6957 #if defined(HAS_FCNTL) && defined(F_SETFD)
6959 const int fd = PerlIO_fileno(PL_rsfp);
6960 fcntl(fd,F_SETFD,fd >= 3);
6963 /* Mark this internal pseudo-handle as clean */
6964 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6965 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6966 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6968 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6969 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6970 /* if the script was opened in binmode, we need to revert
6971 * it to text mode for compatibility; but only iff it has CRs
6972 * XXX this is a questionable hack at best. */
6973 if (PL_bufend-PL_bufptr > 2
6974 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6977 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6978 loc = PerlIO_tell(PL_rsfp);
6979 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6982 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
6984 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
6985 #endif /* NETWARE */
6987 PerlIO_seek(PL_rsfp, loc, 0);
6991 #ifdef PERLIO_LAYERS
6994 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
6995 else if (PL_encoding) {
7002 XPUSHs(PL_encoding);
7004 call_method("name", G_SCALAR);
7008 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7009 Perl_form(aTHX_ ":encoding(%"SVf")",
7018 if (PL_realtokenstart >= 0) {
7019 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7021 PL_endwhite = newSVpvs("");
7022 sv_catsv(PL_endwhite, PL_thiswhite);
7024 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7025 PL_realtokenstart = -1;
7027 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7043 if (PL_expect == XSTATE) {
7050 if (*s == ':' && s[1] == ':') {
7053 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7054 if (!(tmp = keyword(PL_tokenbuf, len, 1)))
7055 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
7058 else if (tmp == KEY_require || tmp == KEY_do)
7059 /* that's a way to remember we saw "CORE::" */
7072 LOP(OP_ACCEPT,XTERM);
7075 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7080 LOP(OP_ATAN2,XTERM);
7086 LOP(OP_BINMODE,XTERM);
7089 LOP(OP_BLESS,XTERM);
7098 /* We have to disambiguate the two senses of
7099 "continue". If the next token is a '{' then
7100 treat it as the start of a continue block;
7101 otherwise treat it as a control operator.
7111 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7121 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7130 if (!PL_cryptseen) {
7131 PL_cryptseen = TRUE;
7135 LOP(OP_CRYPT,XTERM);
7138 LOP(OP_CHMOD,XTERM);
7141 LOP(OP_CHOWN,XTERM);
7144 LOP(OP_CONNECT,XTERM);
7163 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7164 if (orig_keyword == KEY_do) {
7173 PL_hints |= HINT_BLOCK_SCOPE;
7183 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7184 STR_WITH_LEN("NDBM_File::"),
7185 STR_WITH_LEN("DB_File::"),
7186 STR_WITH_LEN("GDBM_File::"),
7187 STR_WITH_LEN("SDBM_File::"),
7188 STR_WITH_LEN("ODBM_File::"),
7190 LOP(OP_DBMOPEN,XTERM);
7196 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7203 pl_yylval.ival = CopLINE(PL_curcop);
7207 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7221 if (*s == '{') { /* block eval */
7222 PL_expect = XTERMBLOCK;
7223 UNIBRACK(OP_ENTERTRY);
7225 else { /* string eval */
7227 UNIBRACK(OP_ENTEREVAL);
7242 case KEY_endhostent:
7248 case KEY_endservent:
7251 case KEY_endprotoent:
7262 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7264 pl_yylval.ival = CopLINE(PL_curcop);
7266 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7269 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7272 if ((PL_bufend - p) >= 3 &&
7273 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7275 else if ((PL_bufend - p) >= 4 &&
7276 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7279 if (isIDFIRST_lazy_if(p,UTF)) {
7280 p = scan_ident(p, PL_bufend,
7281 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7285 Perl_croak(aTHX_ "Missing $ on loop variable");
7287 s = SvPVX(PL_linestr) + soff;
7293 LOP(OP_FORMLINE,XTERM);
7299 LOP(OP_FCNTL,XTERM);
7305 LOP(OP_FLOCK,XTERM);
7308 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7313 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7318 LOP(OP_GREPSTART, XREF);
7321 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7336 case KEY_getpriority:
7337 LOP(OP_GETPRIORITY,XTERM);
7339 case KEY_getprotobyname:
7342 case KEY_getprotobynumber:
7343 LOP(OP_GPBYNUMBER,XTERM);
7345 case KEY_getprotoent:
7357 case KEY_getpeername:
7358 UNI(OP_GETPEERNAME);
7360 case KEY_gethostbyname:
7363 case KEY_gethostbyaddr:
7364 LOP(OP_GHBYADDR,XTERM);
7366 case KEY_gethostent:
7369 case KEY_getnetbyname:
7372 case KEY_getnetbyaddr:
7373 LOP(OP_GNBYADDR,XTERM);
7378 case KEY_getservbyname:
7379 LOP(OP_GSBYNAME,XTERM);
7381 case KEY_getservbyport:
7382 LOP(OP_GSBYPORT,XTERM);
7384 case KEY_getservent:
7387 case KEY_getsockname:
7388 UNI(OP_GETSOCKNAME);
7390 case KEY_getsockopt:
7391 LOP(OP_GSOCKOPT,XTERM);
7406 pl_yylval.ival = CopLINE(PL_curcop);
7416 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7418 pl_yylval.ival = CopLINE(PL_curcop);
7422 LOP(OP_INDEX,XTERM);
7428 LOP(OP_IOCTL,XTERM);
7440 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7457 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7462 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7476 LOP(OP_LISTEN,XTERM);
7485 s = scan_pat(s,OP_MATCH);
7486 TERM(sublex_start());
7489 LOP(OP_MAPSTART, XREF);
7492 LOP(OP_MKDIR,XTERM);
7495 LOP(OP_MSGCTL,XTERM);
7498 LOP(OP_MSGGET,XTERM);
7501 LOP(OP_MSGRCV,XTERM);
7504 LOP(OP_MSGSND,XTERM);
7509 PL_in_my = (U16)tmp;
7511 if (isIDFIRST_lazy_if(s,UTF)) {
7515 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7516 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7518 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7519 if (!PL_in_my_stash) {
7522 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7526 if (PL_madskills) { /* just add type to declarator token */
7527 sv_catsv(PL_thistoken, PL_nextwhite);
7529 sv_catpvn(PL_thistoken, start, s - start);
7537 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7541 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7546 s = tokenize_use(0, s);
7550 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
7553 if (!PL_lex_allbrackets &&
7554 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7555 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7561 if (isIDFIRST_lazy_if(s,UTF)) {
7563 for (d = s; isALNUM_lazy_if(d,UTF);)
7565 for (t=d; isSPACE(*t);)
7567 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7569 && !(t[0] == '=' && t[1] == '>')
7571 int parms_len = (int)(d-s);
7572 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7573 "Precedence problem: open %.*s should be open(%.*s)",
7574 parms_len, s, parms_len, s);
7580 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7582 pl_yylval.ival = OP_OR;
7592 LOP(OP_OPEN_DIR,XTERM);
7595 checkcomma(s,PL_tokenbuf,"filehandle");
7599 checkcomma(s,PL_tokenbuf,"filehandle");
7618 s = force_word(s,WORD,FALSE,TRUE,FALSE);
7620 s = force_strict_version(s);
7621 PL_lex_expect = XBLOCK;
7625 LOP(OP_PIPE_OP,XTERM);
7628 s = scan_str(s,!!PL_madskills,FALSE);
7631 pl_yylval.ival = OP_CONST;
7632 TERM(sublex_start());
7639 s = scan_str(s,!!PL_madskills,FALSE);
7642 PL_expect = XOPERATOR;
7643 if (SvCUR(PL_lex_stuff)) {
7644 int warned_comma = !ckWARN(WARN_QW);
7645 int warned_comment = warned_comma;
7646 d = SvPV_force(PL_lex_stuff, len);
7648 for (; isSPACE(*d) && len; --len, ++d)
7653 if (!warned_comma || !warned_comment) {
7654 for (; !isSPACE(*d) && len; --len, ++d) {
7655 if (!warned_comma && *d == ',') {
7656 Perl_warner(aTHX_ packWARN(WARN_QW),
7657 "Possible attempt to separate words with commas");
7660 else if (!warned_comment && *d == '#') {
7661 Perl_warner(aTHX_ packWARN(WARN_QW),
7662 "Possible attempt to put comments in qw() list");
7668 for (; !isSPACE(*d) && len; --len, ++d)
7671 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7672 words = op_append_elem(OP_LIST, words,
7673 newSVOP(OP_CONST, 0, tokeq(sv)));
7678 words = newNULLLIST();
7680 SvREFCNT_dec(PL_lex_stuff);
7681 PL_lex_stuff = NULL;
7683 PL_expect = XOPERATOR;
7684 pl_yylval.opval = sawparens(words);
7689 s = scan_str(s,!!PL_madskills,FALSE);
7692 pl_yylval.ival = OP_STRINGIFY;
7693 if (SvIVX(PL_lex_stuff) == '\'')
7694 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7695 TERM(sublex_start());
7698 s = scan_pat(s,OP_QR);
7699 TERM(sublex_start());
7702 s = scan_str(s,!!PL_madskills,FALSE);
7705 readpipe_override();
7706 TERM(sublex_start());
7714 s = force_version(s, FALSE);
7716 else if (*s != 'v' || !isDIGIT(s[1])
7717 || (s = force_version(s, TRUE), *s == 'v'))
7719 *PL_tokenbuf = '\0';
7720 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7721 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7722 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
7724 yyerror("<> should be quotes");
7726 if (orig_keyword == KEY_require) {
7734 PL_last_uni = PL_oldbufptr;
7735 PL_last_lop_op = OP_REQUIRE;
7737 return REPORT( (int)REQUIRE );
7743 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7747 LOP(OP_RENAME,XTERM);
7756 LOP(OP_RINDEX,XTERM);
7765 UNIDOR(OP_READLINE);
7768 UNIDOR(OP_BACKTICK);
7777 LOP(OP_REVERSE,XTERM);
7780 UNIDOR(OP_READLINK);
7787 if (pl_yylval.opval)
7788 TERM(sublex_start());
7790 TOKEN(1); /* force error */
7793 checkcomma(s,PL_tokenbuf,"filehandle");
7803 LOP(OP_SELECT,XTERM);
7809 LOP(OP_SEMCTL,XTERM);
7812 LOP(OP_SEMGET,XTERM);
7815 LOP(OP_SEMOP,XTERM);
7821 LOP(OP_SETPGRP,XTERM);
7823 case KEY_setpriority:
7824 LOP(OP_SETPRIORITY,XTERM);
7826 case KEY_sethostent:
7832 case KEY_setservent:
7835 case KEY_setprotoent:
7845 LOP(OP_SEEKDIR,XTERM);
7847 case KEY_setsockopt:
7848 LOP(OP_SSOCKOPT,XTERM);
7854 LOP(OP_SHMCTL,XTERM);
7857 LOP(OP_SHMGET,XTERM);
7860 LOP(OP_SHMREAD,XTERM);
7863 LOP(OP_SHMWRITE,XTERM);
7866 LOP(OP_SHUTDOWN,XTERM);
7875 LOP(OP_SOCKET,XTERM);
7877 case KEY_socketpair:
7878 LOP(OP_SOCKPAIR,XTERM);
7881 checkcomma(s,PL_tokenbuf,"subroutine name");
7883 if (*s == ';' || *s == ')') /* probably a close */
7884 Perl_croak(aTHX_ "sort is now a reserved word");
7886 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7890 LOP(OP_SPLIT,XTERM);
7893 LOP(OP_SPRINTF,XTERM);
7896 LOP(OP_SPLICE,XTERM);
7911 LOP(OP_SUBSTR,XTERM);
7917 char tmpbuf[sizeof PL_tokenbuf];
7918 SSize_t tboffset = 0;
7919 expectation attrful;
7920 bool have_name, have_proto;
7921 const int key = tmp;
7926 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7927 SV *subtoken = newSVpvn(tstart, s - tstart);
7931 s = SKIPSPACE2(s,tmpwhite);
7936 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7937 (*s == ':' && s[1] == ':'))
7940 SV *nametoke = NULL;
7944 attrful = XATTRBLOCK;
7945 /* remember buffer pos'n for later force_word */
7946 tboffset = s - PL_oldbufptr;
7947 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
7950 nametoke = newSVpvn(s, d - s);
7952 if (memchr(tmpbuf, ':', len))
7953 sv_setpvn(PL_subname, tmpbuf, len);
7955 sv_setsv(PL_subname,PL_curstname);
7956 sv_catpvs(PL_subname,"::");
7957 sv_catpvn(PL_subname,tmpbuf,len);
7964 CURMAD('X', nametoke);
7965 CURMAD('_', tmpwhite);
7966 (void) force_word(PL_oldbufptr + tboffset, WORD,
7969 s = SKIPSPACE2(d,tmpwhite);
7976 Perl_croak(aTHX_ "Missing name in \"my sub\"");
7977 PL_expect = XTERMBLOCK;
7978 attrful = XATTRTERM;
7979 sv_setpvs(PL_subname,"?");
7983 if (key == KEY_format) {
7985 PL_lex_formbrack = PL_lex_brackets + 1;
7987 PL_thistoken = subtoken;
7991 (void) force_word(PL_oldbufptr + tboffset, WORD,
7997 /* Look for a prototype */
8000 bool bad_proto = FALSE;
8001 bool in_brackets = FALSE;
8002 char greedy_proto = ' ';
8003 bool proto_after_greedy_proto = FALSE;
8004 bool must_be_last = FALSE;
8005 bool underscore = FALSE;
8006 bool seen_underscore = FALSE;
8007 const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
8009 s = scan_str(s,!!PL_madskills,FALSE);
8011 Perl_croak(aTHX_ "Prototype not terminated");
8012 /* strip spaces and check for bad characters */
8013 d = SvPVX(PL_lex_stuff);
8015 for (p = d; *p; ++p) {
8019 if (warnillegalproto) {
8021 proto_after_greedy_proto = TRUE;
8022 if (!strchr("$@%*;[]&\\_+", *p)) {
8034 else if ( *p == ']' ) {
8035 in_brackets = FALSE;
8037 else if ( (*p == '@' || *p == '%') &&
8038 ( tmp < 2 || d[tmp-2] != '\\' ) &&
8040 must_be_last = TRUE;
8043 else if ( *p == '_' ) {
8044 underscore = seen_underscore = TRUE;
8051 if (proto_after_greedy_proto)
8052 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8053 "Prototype after '%c' for %"SVf" : %s",
8054 greedy_proto, SVfARG(PL_subname), d);
8056 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8057 "Illegal character %sin prototype for %"SVf" : %s",
8058 seen_underscore ? "after '_' " : "",
8059 SVfARG(PL_subname), d);
8060 SvCUR_set(PL_lex_stuff, tmp);
8065 CURMAD('q', PL_thisopen);
8066 CURMAD('_', tmpwhite);
8067 CURMAD('=', PL_thisstuff);
8068 CURMAD('Q', PL_thisclose);
8069 NEXTVAL_NEXTTOKE.opval =
8070 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8071 PL_lex_stuff = NULL;
8074 s = SKIPSPACE2(s,tmpwhite);
8082 if (*s == ':' && s[1] != ':')
8083 PL_expect = attrful;
8084 else if (*s != '{' && key == KEY_sub) {
8086 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8087 else if (*s != ';' && *s != '}')
8088 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8095 curmad('^', newSVpvs(""));
8096 CURMAD('_', tmpwhite);
8100 PL_thistoken = subtoken;
8103 NEXTVAL_NEXTTOKE.opval =
8104 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8105 PL_lex_stuff = NULL;
8111 sv_setpvs(PL_subname, "__ANON__");
8113 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8117 (void) force_word(PL_oldbufptr + tboffset, WORD,
8126 LOP(OP_SYSTEM,XREF);
8129 LOP(OP_SYMLINK,XTERM);
8132 LOP(OP_SYSCALL,XTERM);
8135 LOP(OP_SYSOPEN,XTERM);
8138 LOP(OP_SYSSEEK,XTERM);
8141 LOP(OP_SYSREAD,XTERM);
8144 LOP(OP_SYSWRITE,XTERM);
8148 TERM(sublex_start());
8169 LOP(OP_TRUNCATE,XTERM);
8181 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8183 pl_yylval.ival = CopLINE(PL_curcop);
8187 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8189 pl_yylval.ival = CopLINE(PL_curcop);
8193 LOP(OP_UNLINK,XTERM);
8199 LOP(OP_UNPACK,XTERM);
8202 LOP(OP_UTIME,XTERM);
8208 LOP(OP_UNSHIFT,XTERM);
8211 s = tokenize_use(1, s);
8221 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8223 pl_yylval.ival = CopLINE(PL_curcop);
8227 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8229 pl_yylval.ival = CopLINE(PL_curcop);
8233 PL_hints |= HINT_BLOCK_SCOPE;
8240 LOP(OP_WAITPID,XTERM);
8249 ctl_l[0] = toCTRL('L');
8251 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8254 /* Make sure $^L is defined */
8255 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8260 if (PL_expect == XOPERATOR) {
8261 if (*s == '=' && !PL_lex_allbrackets &&
8262 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8270 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8272 pl_yylval.ival = OP_XOR;
8277 TERM(sublex_start());
8282 #pragma segment Main
8286 S_pending_ident(pTHX)
8291 /* pit holds the identifier we read and pending_ident is reset */
8292 char pit = PL_pending_ident;
8293 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8294 /* All routes through this function want to know if there is a colon. */
8295 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8296 PL_pending_ident = 0;
8298 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
8299 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8300 "### Pending identifier '%s'\n", PL_tokenbuf); });
8302 /* if we're in a my(), we can't allow dynamics here.
8303 $foo'bar has already been turned into $foo::bar, so
8304 just check for colons.
8306 if it's a legal name, the OP is a PADANY.
8309 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8311 yyerror(Perl_form(aTHX_ "No package name allowed for "
8312 "variable %s in \"our\"",
8314 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8318 yyerror(Perl_form(aTHX_ PL_no_myglob,
8319 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
8321 pl_yylval.opval = newOP(OP_PADANY, 0);
8322 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8323 UTF ? SVf_UTF8 : 0);
8329 build the ops for accesses to a my() variable.
8331 Deny my($a) or my($b) in a sort block, *if* $a or $b is
8332 then used in a comparison. This catches most, but not
8333 all cases. For instance, it catches
8334 sort { my($a); $a <=> $b }
8336 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
8337 (although why you'd do that is anyone's guess).
8342 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8343 UTF ? SVf_UTF8 : 0);
8344 if (tmp != NOT_IN_PAD) {
8345 /* might be an "our" variable" */
8346 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8347 /* build ops for a bareword */
8348 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8349 HEK * const stashname = HvNAME_HEK(stash);
8350 SV * const sym = newSVhek(stashname);
8351 sv_catpvs(sym, "::");
8352 sv_catsv(sym, newSVpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1, SVs_TEMP | (UTF ? SVf_UTF8 : 0 )));
8353 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8354 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8357 ? (GV_ADDMULTI | GV_ADDINEVAL)
8360 ((PL_tokenbuf[0] == '$') ? SVt_PV
8361 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8366 /* if it's a sort block and they're naming $a or $b */
8367 if (PL_last_lop_op == OP_SORT &&
8368 PL_tokenbuf[0] == '$' &&
8369 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
8372 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
8373 d < PL_bufend && *d != '\n';
8376 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
8377 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
8383 pl_yylval.opval = newOP(OP_PADANY, 0);
8384 pl_yylval.opval->op_targ = tmp;
8390 Whine if they've said @foo in a doublequoted string,
8391 and @foo isn't a variable we can find in the symbol
8394 if (ckWARN(WARN_AMBIGUOUS) &&
8395 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8396 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8397 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8398 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8399 /* DO NOT warn for @- and @+ */
8400 && !( PL_tokenbuf[2] == '\0' &&
8401 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8404 /* Downgraded from fatal to warning 20000522 mjd */
8405 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8406 "Possible unintended interpolation of %s in string",
8411 /* build ops for a bareword */
8412 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(PL_tokenbuf + 1,
8414 UTF ? SVf_UTF8 : 0 ));
8415 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8416 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8417 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
8418 | ( UTF ? SVf_UTF8 : 0 ),
8419 ((PL_tokenbuf[0] == '$') ? SVt_PV
8420 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8426 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8430 PERL_ARGS_ASSERT_CHECKCOMMA;
8432 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8433 if (ckWARN(WARN_SYNTAX)) {
8436 for (w = s+2; *w && level; w++) {
8444 /* the list of chars below is for end of statements or
8445 * block / parens, boolean operators (&&, ||, //) and branch
8446 * constructs (or, and, if, until, unless, while, err, for).
8447 * Not a very solid hack... */
8448 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8449 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8450 "%s (...) interpreted as function",name);
8453 while (s < PL_bufend && isSPACE(*s))
8457 while (s < PL_bufend && isSPACE(*s))
8459 if (isIDFIRST_lazy_if(s,UTF)) {
8460 const char * const w = s++;
8461 while (isALNUM_lazy_if(s,UTF))
8463 while (s < PL_bufend && isSPACE(*s))
8467 if (keyword(w, s - w, 0))
8470 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
8471 if (gv && GvCVu(gv))
8473 Perl_croak(aTHX_ "No comma allowed after %s", what);
8478 /* Either returns sv, or mortalizes sv and returns a new SV*.
8479 Best used as sv=new_constant(..., sv, ...).
8480 If s, pv are NULL, calls subroutine with one argument,
8481 and type is used with error messages only. */
8484 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8485 SV *sv, SV *pv, const char *type, STRLEN typelen)
8488 HV * const table = GvHV(PL_hintgv); /* ^H */
8492 const char *why1 = "", *why2 = "", *why3 = "";
8494 PERL_ARGS_ASSERT_NEW_CONSTANT;
8496 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8499 why2 = (const char *)
8500 (strEQ(key,"charnames")
8501 ? "(possibly a missing \"use charnames ...\")"
8503 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
8504 (type ? type: "undef"), why2);
8506 /* This is convoluted and evil ("goto considered harmful")
8507 * but I do not understand the intricacies of all the different
8508 * failure modes of %^H in here. The goal here is to make
8509 * the most probable error message user-friendly. --jhi */
8514 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
8515 (type ? type: "undef"), why1, why2, why3);
8517 yyerror(SvPVX_const(msg));
8522 /* charnames doesn't work well if there have been errors found */
8523 if (PL_error_count > 0 && strEQ(key,"charnames"))
8524 return &PL_sv_undef;
8526 cvp = hv_fetch(table, key, keylen, FALSE);
8527 if (!cvp || !SvOK(*cvp)) {
8530 why3 = "} is not defined";
8533 sv_2mortal(sv); /* Parent created it permanently */
8536 pv = newSVpvn_flags(s, len, SVs_TEMP);
8538 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8540 typesv = &PL_sv_undef;
8542 PUSHSTACKi(PERLSI_OVERLOAD);
8554 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8558 /* Check the eval first */
8559 if (!PL_in_eval && SvTRUE(ERRSV)) {
8560 sv_catpvs(ERRSV, "Propagated");
8561 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
8563 res = SvREFCNT_inc_simple(sv);
8567 SvREFCNT_inc_simple_void(res);
8576 why1 = "Call to &{$^H{";
8578 why3 = "}} did not return a defined value";
8586 /* Returns a NUL terminated string, with the length of the string written to
8590 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8593 register char *d = dest;
8594 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8596 PERL_ARGS_ASSERT_SCAN_WORD;
8600 Perl_croak(aTHX_ ident_too_long);
8601 if (isALNUM(*s)) /* UTF handled below */
8603 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
8608 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
8612 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8613 char *t = s + UTF8SKIP(s);
8615 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8619 Perl_croak(aTHX_ ident_too_long);
8620 Copy(s, d, len, char);
8633 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
8636 char *bracket = NULL;
8638 register char *d = dest;
8639 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8641 PERL_ARGS_ASSERT_SCAN_IDENT;
8646 while (isDIGIT(*s)) {
8648 Perl_croak(aTHX_ ident_too_long);
8655 Perl_croak(aTHX_ ident_too_long);
8656 if (isALNUM(*s)) /* UTF handled below */
8658 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
8663 else if (*s == ':' && s[1] == ':') {
8667 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8668 char *t = s + UTF8SKIP(s);
8669 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8671 if (d + (t - s) > e)
8672 Perl_croak(aTHX_ ident_too_long);
8673 Copy(s, d, t - s, char);
8684 if (PL_lex_state != LEX_NORMAL)
8685 PL_lex_state = LEX_INTERPENDMAYBE;
8688 if (*s == '$' && s[1] &&
8689 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
8702 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8707 if (isSPACE(s[-1])) {
8709 const char ch = *s++;
8710 if (!SPACE_OR_TAB(ch)) {
8716 if (isIDFIRST_lazy_if(d,UTF)) {
8720 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
8721 end += UTF8SKIP(end);
8722 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
8723 end += UTF8SKIP(end);
8725 Copy(s, d, end - s, char);
8730 while ((isALNUM(*s) || *s == ':') && d < e)
8733 Perl_croak(aTHX_ ident_too_long);
8736 while (s < send && SPACE_OR_TAB(*s))
8738 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8739 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8740 const char * const brack =
8742 ((*s == '[') ? "[...]" : "{...}");
8743 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8744 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8745 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8746 funny, dest, brack, funny, dest, brack);
8749 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8750 PL_lex_allbrackets++;
8754 /* Handle extended ${^Foo} variables
8755 * 1999-02-27 mjd-perl-patch@plover.com */
8756 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
8760 while (isALNUM(*s) && d < e) {
8764 Perl_croak(aTHX_ ident_too_long);
8769 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8770 PL_lex_state = LEX_INTERPEND;
8773 if (PL_lex_state == LEX_NORMAL) {
8774 if (ckWARN(WARN_AMBIGUOUS) &&
8775 (keyword(dest, d - dest, 0)
8776 || get_cvn_flags(dest, d - dest, 0)))
8780 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8781 "Ambiguous use of %c{%s} resolved to %c%s",
8782 funny, dest, funny, dest);
8787 s = bracket; /* let the parser handle it */
8791 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8792 PL_lex_state = LEX_INTERPEND;
8797 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
8799 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
8800 * the parse starting at 's', based on the subset that are valid in this
8801 * context input to this routine in 'valid_flags'. Advances s. Returns
8802 * TRUE if the input was a valid flag, so the next char may be as well;
8803 * otherwise FALSE. 'charset' should point to a NUL upon first call on the
8804 * current regex. This routine will set it to any charset modifier found.
8805 * The caller shouldn't change it. This way, another charset modifier
8806 * encountered in the parse can be detected as an error, as we have decided
8811 if (! strchr(valid_flags, c)) {
8820 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
8821 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8822 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8823 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8824 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8825 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8826 case LOCALE_PAT_MOD:
8828 /* In 5.14, qr//lt is legal but deprecated; the 't' means they
8829 * can't be regex modifiers.
8830 * In 5.14, s///le is legal and ambiguous. Try to disambiguate as
8831 * much as easily done. s///lei, for example, has to mean regex
8832 * modifiers if it's not an error (as does any word character
8833 * following the 'e'). Otherwise, we resolve to the backwards-
8834 * compatible, but less likely 's/// le ...', i.e. as meaning
8835 * less-than-or-equal. The reason it's not likely is that s//
8836 * returns a number for code in the field (/r returns a string, but
8837 * that wasn't added until the 5.13 series), and so '<=' should be
8838 * used for comparing, not 'le'. */
8839 if (*((*s) + 1) == 't') {
8842 else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) {
8844 /* 'e' is valid only for substitutes, s///e. If it is not
8845 * valid in the current context, then 'm//le' must mean the
8846 * comparison operator, so use the regular deprecation message.
8848 if (! strchr(valid_flags, 'e')) {
8851 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
8852 "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");
8856 goto multiple_charsets;
8858 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8861 case UNICODE_PAT_MOD:
8862 /* In 5.14, qr//unless and qr//until are legal but deprecated; the
8863 * 'n' means they can't be regex modifiers */
8864 if (*((*s) + 1) == 'n') {
8868 goto multiple_charsets;
8870 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8873 case ASCII_RESTRICT_PAT_MOD:
8874 /* In 5.14, qr//and is legal but deprecated; the 'n' means they
8875 * can't be regex modifiers */
8876 if (*((*s) + 1) == 'n') {
8881 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8885 /* Error if previous modifier wasn't an 'a', but if it was, see
8886 * if, and accept, a second occurrence (only) */
8888 || get_regex_charset(*pmfl)
8889 != REGEX_ASCII_RESTRICTED_CHARSET)
8891 goto multiple_charsets;
8893 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8897 case DEPENDS_PAT_MOD:
8899 goto multiple_charsets;
8901 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8910 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
8911 "Having no space between pattern and following word is deprecated");
8915 if (*charset != c) {
8916 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8918 else if (c == 'a') {
8919 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8922 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8925 /* Pretend that it worked, so will continue processing before dieing */
8931 S_scan_pat(pTHX_ char *start, I32 type)
8935 char *s = scan_str(start,!!PL_madskills,FALSE);
8936 const char * const valid_flags =
8937 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8938 char charset = '\0'; /* character set modifier */
8943 PERL_ARGS_ASSERT_SCAN_PAT;
8946 const char * const delimiter = skipspace(start);
8950 ? "Search pattern not terminated or ternary operator parsed as search pattern"
8951 : "Search pattern not terminated" ));
8954 pm = (PMOP*)newPMOP(type, 0);
8955 if (PL_multi_open == '?') {
8956 /* This is the only point in the code that sets PMf_ONCE: */
8957 pm->op_pmflags |= PMf_ONCE;
8959 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8960 allows us to restrict the list needed by reset to just the ??
8962 assert(type != OP_TRANS);
8964 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
8967 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
8970 elements = mg->mg_len / sizeof(PMOP**);
8971 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
8972 ((PMOP**)mg->mg_ptr) [elements++] = pm;
8973 mg->mg_len = elements * sizeof(PMOP**);
8974 PmopSTASH_set(pm,PL_curstash);
8980 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
8982 if (PL_madskills && modstart != s) {
8983 SV* tmptoken = newSVpvn(modstart, s - modstart);
8984 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
8987 /* issue a warning if /c is specified,but /g is not */
8988 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
8990 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8991 "Use of /c modifier is meaningless without /g" );
8994 PL_lex_op = (OP*)pm;
8995 pl_yylval.ival = OP_MATCH;
9000 S_scan_subst(pTHX_ char *start)
9007 char charset = '\0'; /* character set modifier */
9012 PERL_ARGS_ASSERT_SCAN_SUBST;
9014 pl_yylval.ival = OP_NULL;
9016 s = scan_str(start,!!PL_madskills,FALSE);
9019 Perl_croak(aTHX_ "Substitution pattern not terminated");
9021 if (s[-1] == PL_multi_open)
9025 CURMAD('q', PL_thisopen);
9026 CURMAD('_', PL_thiswhite);
9027 CURMAD('E', PL_thisstuff);
9028 CURMAD('Q', PL_thisclose);
9029 PL_realtokenstart = s - SvPVX(PL_linestr);
9033 first_start = PL_multi_start;
9034 s = scan_str(s,!!PL_madskills,FALSE);
9037 SvREFCNT_dec(PL_lex_stuff);
9038 PL_lex_stuff = NULL;
9040 Perl_croak(aTHX_ "Substitution replacement not terminated");
9042 PL_multi_start = first_start; /* so whole substitution is taken together */
9044 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9048 CURMAD('z', PL_thisopen);
9049 CURMAD('R', PL_thisstuff);
9050 CURMAD('Z', PL_thisclose);
9056 if (*s == EXEC_PAT_MOD) {
9060 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9069 curmad('m', newSVpvn(modstart, s - modstart));
9070 append_madprops(PL_thismad, (OP*)pm, 0);
9074 if ((pm->op_pmflags & PMf_CONTINUE)) {
9075 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9079 SV * const repl = newSVpvs("");
9081 PL_sublex_info.super_bufptr = s;
9082 PL_sublex_info.super_bufend = PL_bufend;
9084 pm->op_pmflags |= PMf_EVAL;
9087 sv_catpvs(repl, "eval ");
9089 sv_catpvs(repl, "do ");
9091 sv_catpvs(repl, "{");
9092 sv_catsv(repl, PL_lex_repl);
9093 if (strchr(SvPVX(PL_lex_repl), '#'))
9094 sv_catpvs(repl, "\n");
9095 sv_catpvs(repl, "}");
9097 SvREFCNT_dec(PL_lex_repl);
9101 PL_lex_op = (OP*)pm;
9102 pl_yylval.ival = OP_SUBST;
9107 S_scan_trans(pTHX_ char *start)
9116 bool nondestruct = 0;
9121 PERL_ARGS_ASSERT_SCAN_TRANS;
9123 pl_yylval.ival = OP_NULL;
9125 s = scan_str(start,!!PL_madskills,FALSE);
9127 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9129 if (s[-1] == PL_multi_open)
9133 CURMAD('q', PL_thisopen);
9134 CURMAD('_', PL_thiswhite);
9135 CURMAD('E', PL_thisstuff);
9136 CURMAD('Q', PL_thisclose);
9137 PL_realtokenstart = s - SvPVX(PL_linestr);
9141 s = scan_str(s,!!PL_madskills,FALSE);
9144 SvREFCNT_dec(PL_lex_stuff);
9145 PL_lex_stuff = NULL;
9147 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9150 CURMAD('z', PL_thisopen);
9151 CURMAD('R', PL_thisstuff);
9152 CURMAD('Z', PL_thisclose);
9155 complement = del = squash = 0;
9162 complement = OPpTRANS_COMPLEMENT;
9165 del = OPpTRANS_DELETE;
9168 squash = OPpTRANS_SQUASH;
9180 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
9181 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
9182 o->op_private &= ~OPpTRANS_ALL;
9183 o->op_private |= del|squash|complement|
9184 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9185 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9188 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9193 curmad('m', newSVpvn(modstart, s - modstart));
9194 append_madprops(PL_thismad, o, 0);
9203 S_scan_heredoc(pTHX_ register char *s)
9207 I32 op_type = OP_SCALAR;
9211 const char *found_newline;
9215 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9217 I32 stuffstart = s - SvPVX(PL_linestr);
9220 PL_realtokenstart = -1;
9223 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9227 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9231 while (SPACE_OR_TAB(*peek))
9233 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9236 s = delimcpy(d, e, s, PL_bufend, term, &len);
9246 if (!isALNUM_lazy_if(s,UTF))
9247 deprecate("bare << to mean <<\"\"");
9248 for (; isALNUM_lazy_if(s,UTF); s++) {
9253 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9254 Perl_croak(aTHX_ "Delimiter for here document is too long");
9257 len = d - PL_tokenbuf;
9261 tstart = PL_tokenbuf + !outer;
9262 PL_thisclose = newSVpvn(tstart, len - !outer);
9263 tstart = SvPVX(PL_linestr) + stuffstart;
9264 PL_thisopen = newSVpvn(tstart, s - tstart);
9265 stuffstart = s - SvPVX(PL_linestr);
9268 #ifndef PERL_STRICT_CR
9269 d = strchr(s, '\r');
9271 char * const olds = s;
9273 while (s < PL_bufend) {
9279 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9288 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9295 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
9296 herewas = newSVpvn(s,PL_bufend-s);
9300 herewas = newSVpvn(s-1,found_newline-s+1);
9303 herewas = newSVpvn(s,found_newline-s);
9308 tstart = SvPVX(PL_linestr) + stuffstart;
9310 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9312 PL_thisstuff = newSVpvn(tstart, s - tstart);
9315 s += SvCUR(herewas);
9318 stuffstart = s - SvPVX(PL_linestr);
9324 tmpstr = newSV_type(SVt_PVIV);
9328 SvIV_set(tmpstr, -1);
9330 else if (term == '`') {
9331 op_type = OP_BACKTICK;
9332 SvIV_set(tmpstr, '\\');
9336 PL_multi_start = CopLINE(PL_curcop);
9337 PL_multi_open = PL_multi_close = '<';
9338 term = *PL_tokenbuf;
9339 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9340 char * const bufptr = PL_sublex_info.super_bufptr;
9341 char * const bufend = PL_sublex_info.super_bufend;
9342 char * const olds = s - SvCUR(herewas);
9343 s = strchr(bufptr, '\n');
9347 while (s < bufend &&
9348 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9350 CopLINE_inc(PL_curcop);
9353 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9354 missingterm(PL_tokenbuf);
9356 sv_setpvn(herewas,bufptr,d-bufptr+1);
9357 sv_setpvn(tmpstr,d+1,s-d);
9359 sv_catpvn(herewas,s,bufend-s);
9360 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9367 while (s < PL_bufend &&
9368 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9370 CopLINE_inc(PL_curcop);
9372 if (s >= PL_bufend) {
9373 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9374 missingterm(PL_tokenbuf);
9376 sv_setpvn(tmpstr,d+1,s-d);
9380 sv_catpvn(PL_thisstuff, d + 1, s - d);
9382 PL_thisstuff = newSVpvn(d + 1, s - d);
9383 stuffstart = s - SvPVX(PL_linestr);
9387 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9389 sv_catpvn(herewas,s,PL_bufend-s);
9390 sv_setsv(PL_linestr,herewas);
9391 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9392 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9393 PL_last_lop = PL_last_uni = NULL;
9396 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9397 while (s >= PL_bufend) { /* multiple line string? */
9400 tstart = SvPVX(PL_linestr) + stuffstart;
9402 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9404 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9408 CopLINE_inc(PL_curcop);
9409 if (!outer || !lex_next_chunk(0)) {
9410 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9411 missingterm(PL_tokenbuf);
9413 CopLINE_dec(PL_curcop);
9416 stuffstart = s - SvPVX(PL_linestr);
9418 CopLINE_inc(PL_curcop);
9419 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9420 PL_last_lop = PL_last_uni = NULL;
9421 #ifndef PERL_STRICT_CR
9422 if (PL_bufend - PL_linestart >= 2) {
9423 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9424 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9426 PL_bufend[-2] = '\n';
9428 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9430 else if (PL_bufend[-1] == '\r')
9431 PL_bufend[-1] = '\n';
9433 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9434 PL_bufend[-1] = '\n';
9436 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9437 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9438 *(SvPVX(PL_linestr) + off ) = ' ';
9439 lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1);
9440 sv_catsv(PL_linestr,herewas);
9441 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9442 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9446 sv_catsv(tmpstr,PL_linestr);
9451 PL_multi_end = CopLINE(PL_curcop);
9452 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9453 SvPV_shrink_to_cur(tmpstr);
9455 SvREFCNT_dec(herewas);
9457 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9459 else if (PL_encoding)
9460 sv_recode_to_utf8(tmpstr, PL_encoding);
9462 PL_lex_stuff = tmpstr;
9463 pl_yylval.ival = op_type;
9468 takes: current position in input buffer
9469 returns: new position in input buffer
9470 side-effects: pl_yylval and lex_op are set.
9475 <FH> read from filehandle
9476 <pkg::FH> read from package qualified filehandle
9477 <pkg'FH> read from package qualified filehandle
9478 <$fh> read from filehandle in $fh
9484 S_scan_inputsymbol(pTHX_ char *start)
9487 register char *s = start; /* current position in buffer */
9490 char *d = PL_tokenbuf; /* start of temp holding space */
9491 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9493 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9495 end = strchr(s, '\n');
9498 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9500 /* die if we didn't have space for the contents of the <>,
9501 or if it didn't end, or if we see a newline
9504 if (len >= (I32)sizeof PL_tokenbuf)
9505 Perl_croak(aTHX_ "Excessively long <> operator");
9507 Perl_croak(aTHX_ "Unterminated <> operator");
9512 Remember, only scalar variables are interpreted as filehandles by
9513 this code. Anything more complex (e.g., <$fh{$num}>) will be
9514 treated as a glob() call.
9515 This code makes use of the fact that except for the $ at the front,
9516 a scalar variable and a filehandle look the same.
9518 if (*d == '$' && d[1]) d++;
9520 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9521 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9524 /* If we've tried to read what we allow filehandles to look like, and
9525 there's still text left, then it must be a glob() and not a getline.
9526 Use scan_str to pull out the stuff between the <> and treat it
9527 as nothing more than a string.
9530 if (d - PL_tokenbuf != len) {
9531 pl_yylval.ival = OP_GLOB;
9532 s = scan_str(start,!!PL_madskills,FALSE);
9534 Perl_croak(aTHX_ "Glob not terminated");
9538 bool readline_overriden = FALSE;
9541 /* we're in a filehandle read situation */
9544 /* turn <> into <ARGV> */
9546 Copy("ARGV",d,5,char);
9548 /* Check whether readline() is overriden */
9549 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
9551 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9553 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
9554 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
9555 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9556 readline_overriden = TRUE;
9558 /* if <$fh>, create the ops to turn the variable into a
9562 /* try to find it in the pad for this block, otherwise find
9563 add symbol table ops
9565 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
9566 if (tmp != NOT_IN_PAD) {
9567 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9568 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9569 HEK * const stashname = HvNAME_HEK(stash);
9570 SV * const sym = sv_2mortal(newSVhek(stashname));
9571 sv_catpvs(sym, "::");
9577 OP * const o = newOP(OP_PADSV, 0);
9579 PL_lex_op = readline_overriden
9580 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9581 op_append_elem(OP_LIST, o,
9582 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9583 : (OP*)newUNOP(OP_READLINE, 0, o);
9592 ? (GV_ADDMULTI | GV_ADDINEVAL)
9595 PL_lex_op = readline_overriden
9596 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9597 op_append_elem(OP_LIST,
9598 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9599 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9600 : (OP*)newUNOP(OP_READLINE, 0,
9601 newUNOP(OP_RV2SV, 0,
9602 newGVOP(OP_GV, 0, gv)));
9604 if (!readline_overriden)
9605 PL_lex_op->op_flags |= OPf_SPECIAL;
9606 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9607 pl_yylval.ival = OP_NULL;
9610 /* If it's none of the above, it must be a literal filehandle
9611 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9613 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
9614 PL_lex_op = readline_overriden
9615 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9616 op_append_elem(OP_LIST,
9617 newGVOP(OP_GV, 0, gv),
9618 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9619 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9620 pl_yylval.ival = OP_NULL;
9629 takes: start position in buffer
9630 keep_quoted preserve \ on the embedded delimiter(s)
9631 keep_delims preserve the delimiters around the string
9632 returns: position to continue reading from buffer
9633 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9634 updates the read buffer.
9636 This subroutine pulls a string out of the input. It is called for:
9637 q single quotes q(literal text)
9638 ' single quotes 'literal text'
9639 qq double quotes qq(interpolate $here please)
9640 " double quotes "interpolate $here please"
9641 qx backticks qx(/bin/ls -l)
9642 ` backticks `/bin/ls -l`
9643 qw quote words @EXPORT_OK = qw( func() $spam )
9644 m// regexp match m/this/
9645 s/// regexp substitute s/this/that/
9646 tr/// string transliterate tr/this/that/
9647 y/// string transliterate y/this/that/
9648 ($*@) sub prototypes sub foo ($)
9649 (stuff) sub attr parameters sub foo : attr(stuff)
9650 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9652 In most of these cases (all but <>, patterns and transliterate)
9653 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9654 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9655 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9658 It skips whitespace before the string starts, and treats the first
9659 character as the delimiter. If the delimiter is one of ([{< then
9660 the corresponding "close" character )]}> is used as the closing
9661 delimiter. It allows quoting of delimiters, and if the string has
9662 balanced delimiters ([{<>}]) it allows nesting.
9664 On success, the SV with the resulting string is put into lex_stuff or,
9665 if that is already non-NULL, into lex_repl. The second case occurs only
9666 when parsing the RHS of the special constructs s/// and tr/// (y///).
9667 For convenience, the terminating delimiter character is stuffed into
9672 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9675 SV *sv; /* scalar value: string */
9676 const char *tmps; /* temp string, used for delimiter matching */
9677 register char *s = start; /* current position in the buffer */
9678 register char term; /* terminating character */
9679 register char *to; /* current position in the sv's data */
9680 I32 brackets = 1; /* bracket nesting level */
9681 bool has_utf8 = FALSE; /* is there any utf8 content? */
9682 I32 termcode; /* terminating char. code */
9683 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9684 STRLEN termlen; /* length of terminating string */
9685 int last_off = 0; /* last position for nesting bracket */
9691 PERL_ARGS_ASSERT_SCAN_STR;
9693 /* skip space before the delimiter */
9699 if (PL_realtokenstart >= 0) {
9700 stuffstart = PL_realtokenstart;
9701 PL_realtokenstart = -1;
9704 stuffstart = start - SvPVX(PL_linestr);
9706 /* mark where we are, in case we need to report errors */
9709 /* after skipping whitespace, the next character is the terminator */
9712 termcode = termstr[0] = term;
9716 termcode = utf8_to_uvchr((U8*)s, &termlen);
9717 Copy(s, termstr, termlen, U8);
9718 if (!UTF8_IS_INVARIANT(term))
9722 /* mark where we are */
9723 PL_multi_start = CopLINE(PL_curcop);
9724 PL_multi_open = term;
9726 /* find corresponding closing delimiter */
9727 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9728 termcode = termstr[0] = term = tmps[5];
9730 PL_multi_close = term;
9732 /* create a new SV to hold the contents. 79 is the SV's initial length.
9733 What a random number. */
9734 sv = newSV_type(SVt_PVIV);
9736 SvIV_set(sv, termcode);
9737 (void)SvPOK_only(sv); /* validate pointer */
9739 /* move past delimiter and try to read a complete string */
9741 sv_catpvn(sv, s, termlen);
9744 tstart = SvPVX(PL_linestr) + stuffstart;
9745 if (!PL_thisopen && !keep_delims) {
9746 PL_thisopen = newSVpvn(tstart, s - tstart);
9747 stuffstart = s - SvPVX(PL_linestr);
9751 if (PL_encoding && !UTF) {
9755 int offset = s - SvPVX_const(PL_linestr);
9756 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9757 &offset, (char*)termstr, termlen);
9758 const char * const ns = SvPVX_const(PL_linestr) + offset;
9759 char * const svlast = SvEND(sv) - 1;
9761 for (; s < ns; s++) {
9762 if (*s == '\n' && !PL_rsfp)
9763 CopLINE_inc(PL_curcop);
9766 goto read_more_line;
9768 /* handle quoted delimiters */
9769 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9771 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9773 if ((svlast-1 - t) % 2) {
9777 SvCUR_set(sv, SvCUR(sv) - 1);
9782 if (PL_multi_open == PL_multi_close) {
9788 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9789 /* At here, all closes are "was quoted" one,
9790 so we don't check PL_multi_close. */
9792 if (!keep_quoted && *(t+1) == PL_multi_open)
9797 else if (*t == PL_multi_open)
9805 SvCUR_set(sv, w - SvPVX_const(sv));
9807 last_off = w - SvPVX(sv);
9808 if (--brackets <= 0)
9814 SvCUR_set(sv, SvCUR(sv) - 1);
9820 /* extend sv if need be */
9821 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9822 /* set 'to' to the next character in the sv's string */
9823 to = SvPVX(sv)+SvCUR(sv);
9825 /* if open delimiter is the close delimiter read unbridle */
9826 if (PL_multi_open == PL_multi_close) {
9827 for (; s < PL_bufend; s++,to++) {
9828 /* embedded newlines increment the current line number */
9829 if (*s == '\n' && !PL_rsfp)
9830 CopLINE_inc(PL_curcop);
9831 /* handle quoted delimiters */
9832 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9833 if (!keep_quoted && s[1] == term)
9835 /* any other quotes are simply copied straight through */
9839 /* terminate when run out of buffer (the for() condition), or
9840 have found the terminator */
9841 else if (*s == term) {
9844 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9847 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9853 /* if the terminator isn't the same as the start character (e.g.,
9854 matched brackets), we have to allow more in the quoting, and
9855 be prepared for nested brackets.
9858 /* read until we run out of string, or we find the terminator */
9859 for (; s < PL_bufend; s++,to++) {
9860 /* embedded newlines increment the line count */
9861 if (*s == '\n' && !PL_rsfp)
9862 CopLINE_inc(PL_curcop);
9863 /* backslashes can escape the open or closing characters */
9864 if (*s == '\\' && s+1 < PL_bufend) {
9866 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9871 /* allow nested opens and closes */
9872 else if (*s == PL_multi_close && --brackets <= 0)
9874 else if (*s == PL_multi_open)
9876 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9881 /* terminate the copied string and update the sv's end-of-string */
9883 SvCUR_set(sv, to - SvPVX_const(sv));
9886 * this next chunk reads more into the buffer if we're not done yet
9890 break; /* handle case where we are done yet :-) */
9892 #ifndef PERL_STRICT_CR
9893 if (to - SvPVX_const(sv) >= 2) {
9894 if ((to[-2] == '\r' && to[-1] == '\n') ||
9895 (to[-2] == '\n' && to[-1] == '\r'))
9899 SvCUR_set(sv, to - SvPVX_const(sv));
9901 else if (to[-1] == '\r')
9904 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9909 /* if we're out of file, or a read fails, bail and reset the current
9910 line marker so we can report where the unterminated string began
9914 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9916 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9918 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9921 CopLINE_inc(PL_curcop);
9922 PL_bufptr = PL_bufend;
9923 if (!lex_next_chunk(0)) {
9925 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9934 /* at this point, we have successfully read the delimited string */
9936 if (!PL_encoding || UTF) {
9939 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9940 const int len = s - tstart;
9942 sv_catpvn(PL_thisstuff, tstart, len);
9944 PL_thisstuff = newSVpvn(tstart, len);
9945 if (!PL_thisclose && !keep_delims)
9946 PL_thisclose = newSVpvn(s,termlen);
9951 sv_catpvn(sv, s, termlen);
9957 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9958 const int len = s - tstart - termlen;
9960 sv_catpvn(PL_thisstuff, tstart, len);
9962 PL_thisstuff = newSVpvn(tstart, len);
9963 if (!PL_thisclose && !keep_delims)
9964 PL_thisclose = newSVpvn(s - termlen,termlen);
9968 if (has_utf8 || PL_encoding)
9971 PL_multi_end = CopLINE(PL_curcop);
9973 /* if we allocated too much space, give some back */
9974 if (SvCUR(sv) + 5 < SvLEN(sv)) {
9975 SvLEN_set(sv, SvCUR(sv) + 1);
9976 SvPV_renew(sv, SvLEN(sv));
9979 /* decide whether this is the first or second quoted string we've read
9992 takes: pointer to position in buffer
9993 returns: pointer to new position in buffer
9994 side-effects: builds ops for the constant in pl_yylval.op
9996 Read a number in any of the formats that Perl accepts:
9998 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
9999 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10002 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10004 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10007 If it reads a number without a decimal point or an exponent, it will
10008 try converting the number to an integer and see if it can do so
10009 without loss of precision.
10013 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10016 register const char *s = start; /* current position in buffer */
10017 register char *d; /* destination in temp buffer */
10018 register char *e; /* end of temp buffer */
10019 NV nv; /* number read, as a double */
10020 SV *sv = NULL; /* place to put the converted number */
10021 bool floatit; /* boolean: int or float? */
10022 const char *lastub = NULL; /* position of last underbar */
10023 static char const number_too_long[] = "Number too long";
10025 PERL_ARGS_ASSERT_SCAN_NUM;
10027 /* We use the first character to decide what type of number this is */
10031 Perl_croak(aTHX_ "panic: scan_num");
10033 /* if it starts with a 0, it could be an octal number, a decimal in
10034 0.13 disguise, or a hexadecimal number, or a binary number. */
10038 u holds the "number so far"
10039 shift the power of 2 of the base
10040 (hex == 4, octal == 3, binary == 1)
10041 overflowed was the number more than we can hold?
10043 Shift is used when we add a digit. It also serves as an "are
10044 we in octal/hex/binary?" indicator to disallow hex characters
10045 when in octal mode.
10050 bool overflowed = FALSE;
10051 bool just_zero = TRUE; /* just plain 0 or binary number? */
10052 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10053 static const char* const bases[5] =
10054 { "", "binary", "", "octal", "hexadecimal" };
10055 static const char* const Bases[5] =
10056 { "", "Binary", "", "Octal", "Hexadecimal" };
10057 static const char* const maxima[5] =
10059 "0b11111111111111111111111111111111",
10063 const char *base, *Base, *max;
10065 /* check for hex */
10066 if (s[1] == 'x' || s[1] == 'X') {
10070 } else if (s[1] == 'b' || s[1] == 'B') {
10075 /* check for a decimal in disguise */
10076 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10078 /* so it must be octal */
10085 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10086 "Misplaced _ in number");
10090 base = bases[shift];
10091 Base = Bases[shift];
10092 max = maxima[shift];
10094 /* read the rest of the number */
10096 /* x is used in the overflow test,
10097 b is the digit we're adding on. */
10102 /* if we don't mention it, we're done */
10106 /* _ are ignored -- but warned about if consecutive */
10108 if (lastub && s == lastub + 1)
10109 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10110 "Misplaced _ in number");
10114 /* 8 and 9 are not octal */
10115 case '8': case '9':
10117 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10121 case '2': case '3': case '4':
10122 case '5': case '6': case '7':
10124 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10127 case '0': case '1':
10128 b = *s++ & 15; /* ASCII digit -> value of digit */
10132 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10133 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10134 /* make sure they said 0x */
10137 b = (*s++ & 7) + 9;
10139 /* Prepare to put the digit we have onto the end
10140 of the number so far. We check for overflows.
10146 x = u << shift; /* make room for the digit */
10148 if ((x >> shift) != u
10149 && !(PL_hints & HINT_NEW_BINARY)) {
10152 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10153 "Integer overflow in %s number",
10156 u = x | b; /* add the digit to the end */
10159 n *= nvshift[shift];
10160 /* If an NV has not enough bits in its
10161 * mantissa to represent an UV this summing of
10162 * small low-order numbers is a waste of time
10163 * (because the NV cannot preserve the
10164 * low-order bits anyway): we could just
10165 * remember when did we overflow and in the
10166 * end just multiply n by the right
10174 /* if we get here, we had success: make a scalar value from
10179 /* final misplaced underbar check */
10180 if (s[-1] == '_') {
10181 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10185 if (n > 4294967295.0)
10186 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10187 "%s number > %s non-portable",
10193 if (u > 0xffffffff)
10194 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10195 "%s number > %s non-portable",
10200 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10201 sv = new_constant(start, s - start, "integer",
10202 sv, NULL, NULL, 0);
10203 else if (PL_hints & HINT_NEW_BINARY)
10204 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10209 handle decimal numbers.
10210 we're also sent here when we read a 0 as the first digit
10212 case '1': case '2': case '3': case '4': case '5':
10213 case '6': case '7': case '8': case '9': case '.':
10216 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10219 /* read next group of digits and _ and copy into d */
10220 while (isDIGIT(*s) || *s == '_') {
10221 /* skip underscores, checking for misplaced ones
10225 if (lastub && s == lastub + 1)
10226 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10227 "Misplaced _ in number");
10231 /* check for end of fixed-length buffer */
10233 Perl_croak(aTHX_ number_too_long);
10234 /* if we're ok, copy the character */
10239 /* final misplaced underbar check */
10240 if (lastub && s == lastub + 1) {
10241 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10244 /* read a decimal portion if there is one. avoid
10245 3..5 being interpreted as the number 3. followed
10248 if (*s == '.' && s[1] != '.') {
10253 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10254 "Misplaced _ in number");
10258 /* copy, ignoring underbars, until we run out of digits.
10260 for (; isDIGIT(*s) || *s == '_'; s++) {
10261 /* fixed length buffer check */
10263 Perl_croak(aTHX_ number_too_long);
10265 if (lastub && s == lastub + 1)
10266 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10267 "Misplaced _ in number");
10273 /* fractional part ending in underbar? */
10274 if (s[-1] == '_') {
10275 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10276 "Misplaced _ in number");
10278 if (*s == '.' && isDIGIT(s[1])) {
10279 /* oops, it's really a v-string, but without the "v" */
10285 /* read exponent part, if present */
10286 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10290 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10291 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10293 /* stray preinitial _ */
10295 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10296 "Misplaced _ in number");
10300 /* allow positive or negative exponent */
10301 if (*s == '+' || *s == '-')
10304 /* stray initial _ */
10306 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10307 "Misplaced _ in number");
10311 /* read digits of exponent */
10312 while (isDIGIT(*s) || *s == '_') {
10315 Perl_croak(aTHX_ number_too_long);
10319 if (((lastub && s == lastub + 1) ||
10320 (!isDIGIT(s[1]) && s[1] != '_')))
10321 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10322 "Misplaced _ in number");
10330 We try to do an integer conversion first if no characters
10331 indicating "float" have been found.
10336 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10338 if (flags == IS_NUMBER_IN_UV) {
10340 sv = newSViv(uv); /* Prefer IVs over UVs. */
10343 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10344 if (uv <= (UV) IV_MIN)
10345 sv = newSViv(-(IV)uv);
10352 /* terminate the string */
10354 nv = Atof(PL_tokenbuf);
10359 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10360 const char *const key = floatit ? "float" : "integer";
10361 const STRLEN keylen = floatit ? 5 : 7;
10362 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10363 key, keylen, sv, NULL, NULL, 0);
10367 /* if it starts with a v, it could be a v-string */
10370 sv = newSV(5); /* preallocate storage space */
10371 s = scan_vstring(s, PL_bufend, sv);
10375 /* make the op for the constant and return */
10378 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10380 lvalp->opval = NULL;
10386 S_scan_formline(pTHX_ register char *s)
10389 register char *eol;
10391 SV * const stuff = newSVpvs("");
10392 bool needargs = FALSE;
10393 bool eofmt = FALSE;
10395 char *tokenstart = s;
10396 SV* savewhite = NULL;
10398 if (PL_madskills) {
10399 savewhite = PL_thiswhite;
10404 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10406 while (!needargs) {
10409 #ifdef PERL_STRICT_CR
10410 while (SPACE_OR_TAB(*t))
10413 while (SPACE_OR_TAB(*t) || *t == '\r')
10416 if (*t == '\n' || t == PL_bufend) {
10421 if (PL_in_eval && !PL_rsfp) {
10422 eol = (char *) memchr(s,'\n',PL_bufend-s);
10427 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10429 for (t = s; t < eol; t++) {
10430 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10432 goto enough; /* ~~ must be first line in formline */
10434 if (*t == '@' || *t == '^')
10438 sv_catpvn(stuff, s, eol-s);
10439 #ifndef PERL_STRICT_CR
10440 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10441 char *end = SvPVX(stuff) + SvCUR(stuff);
10444 SvCUR_set(stuff, SvCUR(stuff) - 1);
10455 if (PL_madskills) {
10457 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
10459 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
10462 PL_bufptr = PL_bufend;
10463 CopLINE_inc(PL_curcop);
10464 got_some = lex_next_chunk(0);
10465 CopLINE_dec(PL_curcop);
10468 tokenstart = PL_bufptr;
10476 if (SvCUR(stuff)) {
10479 PL_lex_state = LEX_NORMAL;
10480 start_force(PL_curforce);
10481 NEXTVAL_NEXTTOKE.ival = 0;
10485 PL_lex_state = LEX_FORMLINE;
10487 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10489 else if (PL_encoding)
10490 sv_recode_to_utf8(stuff, PL_encoding);
10492 start_force(PL_curforce);
10493 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10495 start_force(PL_curforce);
10496 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
10500 SvREFCNT_dec(stuff);
10502 PL_lex_formbrack = 0;
10506 if (PL_madskills) {
10508 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
10510 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
10511 PL_thiswhite = savewhite;
10518 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10521 const I32 oldsavestack_ix = PL_savestack_ix;
10522 CV* const outsidecv = PL_compcv;
10525 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10527 SAVEI32(PL_subline);
10528 save_item(PL_subname);
10529 SAVESPTR(PL_compcv);
10531 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10532 CvFLAGS(PL_compcv) |= flags;
10534 PL_subline = CopLINE(PL_curcop);
10535 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10536 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10537 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10539 return oldsavestack_ix;
10543 #pragma segment Perl_yylex
10546 S_yywarn(pTHX_ const char *const s)
10550 PERL_ARGS_ASSERT_YYWARN;
10552 PL_in_eval |= EVAL_WARNONLY;
10554 PL_in_eval &= ~EVAL_WARNONLY;
10559 Perl_yyerror(pTHX_ const char *const s)
10562 const char *where = NULL;
10563 const char *context = NULL;
10566 int yychar = PL_parser->yychar;
10568 PERL_ARGS_ASSERT_YYERROR;
10570 if (!yychar || (yychar == ';' && !PL_rsfp))
10572 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10573 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10574 PL_oldbufptr != PL_bufptr) {
10577 The code below is removed for NetWare because it abends/crashes on NetWare
10578 when the script has error such as not having the closing quotes like:
10579 if ($var eq "value)
10580 Checking of white spaces is anyway done in NetWare code.
10583 while (isSPACE(*PL_oldoldbufptr))
10586 context = PL_oldoldbufptr;
10587 contlen = PL_bufptr - PL_oldoldbufptr;
10589 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10590 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10593 The code below is removed for NetWare because it abends/crashes on NetWare
10594 when the script has error such as not having the closing quotes like:
10595 if ($var eq "value)
10596 Checking of white spaces is anyway done in NetWare code.
10599 while (isSPACE(*PL_oldbufptr))
10602 context = PL_oldbufptr;
10603 contlen = PL_bufptr - PL_oldbufptr;
10605 else if (yychar > 255)
10606 where = "next token ???";
10607 else if (yychar == -2) { /* YYEMPTY */
10608 if (PL_lex_state == LEX_NORMAL ||
10609 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10610 where = "at end of line";
10611 else if (PL_lex_inpat)
10612 where = "within pattern";
10614 where = "within string";
10617 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
10619 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10620 else if (isPRINT_LC(yychar)) {
10621 const char string = yychar;
10622 sv_catpvn(where_sv, &string, 1);
10625 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10626 where = SvPVX_const(where_sv);
10628 msg = sv_2mortal(newSVpv(s, 0));
10629 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10630 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10632 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10634 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10635 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10636 Perl_sv_catpvf(aTHX_ msg,
10637 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10638 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10641 if (PL_in_eval & EVAL_WARNONLY) {
10642 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10646 if (PL_error_count >= 10) {
10647 if (PL_in_eval && SvCUR(ERRSV))
10648 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10649 SVfARG(ERRSV), OutCopFILE(PL_curcop));
10651 Perl_croak(aTHX_ "%s has too many errors.\n",
10652 OutCopFILE(PL_curcop));
10655 PL_in_my_stash = NULL;
10659 #pragma segment Main
10663 S_swallow_bom(pTHX_ U8 *s)
10666 const STRLEN slen = SvCUR(PL_linestr);
10668 PERL_ARGS_ASSERT_SWALLOW_BOM;
10672 if (s[1] == 0xFE) {
10673 /* UTF-16 little-endian? (or UTF-32LE?) */
10674 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10675 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10676 #ifndef PERL_NO_UTF16_FILTER
10677 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10679 if (PL_bufend > (char*)s) {
10680 s = add_utf16_textfilter(s, TRUE);
10683 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10688 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10689 #ifndef PERL_NO_UTF16_FILTER
10690 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10692 if (PL_bufend > (char *)s) {
10693 s = add_utf16_textfilter(s, FALSE);
10696 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10701 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10702 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10703 s += 3; /* UTF-8 */
10709 if (s[2] == 0xFE && s[3] == 0xFF) {
10710 /* UTF-32 big-endian */
10711 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10714 else if (s[2] == 0 && s[3] != 0) {
10717 * are a good indicator of UTF-16BE. */
10718 #ifndef PERL_NO_UTF16_FILTER
10719 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10720 s = add_utf16_textfilter(s, FALSE);
10722 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10728 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
10729 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10730 s += 4; /* UTF-8 */
10736 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10739 * are a good indicator of UTF-16LE. */
10740 #ifndef PERL_NO_UTF16_FILTER
10741 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10742 s = add_utf16_textfilter(s, TRUE);
10744 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10752 #ifndef PERL_NO_UTF16_FILTER
10754 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10757 SV *const filter = FILTER_DATA(idx);
10758 /* We re-use this each time round, throwing the contents away before we
10760 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10761 SV *const utf8_buffer = filter;
10762 IV status = IoPAGE(filter);
10763 const bool reverse = cBOOL(IoLINES(filter));
10766 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10768 /* As we're automatically added, at the lowest level, and hence only called
10769 from this file, we can be sure that we're not called in block mode. Hence
10770 don't bother writing code to deal with block mode. */
10772 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10775 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10777 DEBUG_P(PerlIO_printf(Perl_debug_log,
10778 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10779 FPTR2DPTR(void *, S_utf16_textfilter),
10780 reverse ? 'l' : 'b', idx, maxlen, status,
10781 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10788 /* First, look in our buffer of existing UTF-8 data: */
10789 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10793 } else if (status == 0) {
10795 IoPAGE(filter) = 0;
10796 nl = SvEND(utf8_buffer);
10799 STRLEN got = nl - SvPVX(utf8_buffer);
10800 /* Did we have anything to append? */
10802 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10803 /* Everything else in this code works just fine if SVp_POK isn't
10804 set. This, however, needs it, and we need it to work, else
10805 we loop infinitely because the buffer is never consumed. */
10806 sv_chop(utf8_buffer, nl);
10810 /* OK, not a complete line there, so need to read some more UTF-16.
10811 Read an extra octect if the buffer currently has an odd number. */
10815 if (SvCUR(utf16_buffer) >= 2) {
10816 /* Location of the high octet of the last complete code point.
10817 Gosh, UTF-16 is a pain. All the benefits of variable length,
10818 *coupled* with all the benefits of partial reads and
10820 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10821 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10823 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10827 /* We have the first half of a surrogate. Read more. */
10828 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10831 status = FILTER_READ(idx + 1, utf16_buffer,
10832 160 + (SvCUR(utf16_buffer) & 1));
10833 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10834 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10837 IoPAGE(filter) = status;
10842 chars = SvCUR(utf16_buffer) >> 1;
10843 have = SvCUR(utf8_buffer);
10844 SvGROW(utf8_buffer, have + chars * 3 + 1);
10847 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10848 (U8*)SvPVX_const(utf8_buffer) + have,
10849 chars * 2, &newlen);
10851 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10852 (U8*)SvPVX_const(utf8_buffer) + have,
10853 chars * 2, &newlen);
10855 SvCUR_set(utf8_buffer, have + newlen);
10858 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10859 it's private to us, and utf16_to_utf8{,reversed} take a
10860 (pointer,length) pair, rather than a NUL-terminated string. */
10861 if(SvCUR(utf16_buffer) & 1) {
10862 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10863 SvCUR_set(utf16_buffer, 1);
10865 SvCUR_set(utf16_buffer, 0);
10868 DEBUG_P(PerlIO_printf(Perl_debug_log,
10869 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10871 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10872 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10877 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10879 SV *filter = filter_add(S_utf16_textfilter, NULL);
10881 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10883 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10884 sv_setpvs(filter, "");
10885 IoLINES(filter) = reversed;
10886 IoPAGE(filter) = 1; /* Not EOF */
10888 /* Sadly, we have to return a valid pointer, come what may, so we have to
10889 ignore any error return from this. */
10890 SvCUR_set(PL_linestr, 0);
10891 if (FILTER_READ(0, PL_linestr, 0)) {
10892 SvUTF8_on(PL_linestr);
10894 SvUTF8_on(PL_linestr);
10896 PL_bufend = SvEND(PL_linestr);
10897 return (U8*)SvPVX(PL_linestr);
10902 Returns a pointer to the next character after the parsed
10903 vstring, as well as updating the passed in sv.
10905 Function must be called like
10908 s = scan_vstring(s,e,sv);
10910 where s and e are the start and end of the string.
10911 The sv should already be large enough to store the vstring
10912 passed in, for performance reasons.
10917 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
10920 const char *pos = s;
10921 const char *start = s;
10923 PERL_ARGS_ASSERT_SCAN_VSTRING;
10925 if (*pos == 'v') pos++; /* get past 'v' */
10926 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10928 if ( *pos != '.') {
10929 /* this may not be a v-string if followed by => */
10930 const char *next = pos;
10931 while (next < e && isSPACE(*next))
10933 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
10934 /* return string not v-string */
10935 sv_setpvn(sv,(char *)s,pos-s);
10936 return (char *)pos;
10940 if (!isALPHA(*pos)) {
10941 U8 tmpbuf[UTF8_MAXBYTES+1];
10944 s++; /* get past 'v' */
10949 /* this is atoi() that tolerates underscores */
10952 const char *end = pos;
10954 while (--end >= s) {
10956 const UV orev = rev;
10957 rev += (*end - '0') * mult;
10960 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10961 "Integer overflow in decimal number");
10965 if (rev > 0x7FFFFFFF)
10966 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
10968 /* Append native character for the rev point */
10969 tmpend = uvchr_to_utf8(tmpbuf, rev);
10970 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
10971 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
10973 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
10979 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10983 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
10990 Perl_keyword_plugin_standard(pTHX_
10991 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
10993 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
10994 PERL_UNUSED_CONTEXT;
10995 PERL_UNUSED_ARG(keyword_ptr);
10996 PERL_UNUSED_ARG(keyword_len);
10997 PERL_UNUSED_ARG(op_ptr);
10998 return KEYWORD_PLUGIN_DECLINE;
11001 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11003 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11005 SAVEI32(PL_lex_brackets);
11006 if (PL_lex_brackets > 100)
11007 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11008 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11009 SAVEI32(PL_lex_allbrackets);
11010 PL_lex_allbrackets = 0;
11011 SAVEI8(PL_lex_fakeeof);
11012 PL_lex_fakeeof = (U8)fakeeof;
11013 if(yyparse(gramtype) && !PL_parser->error_count)
11014 qerror(Perl_mess(aTHX_ "Parse error"));
11017 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11019 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11023 SAVEVPTR(PL_eval_root);
11024 PL_eval_root = NULL;
11025 parse_recdescent(gramtype, fakeeof);
11031 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11033 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11036 if (flags & ~PARSE_OPTIONAL)
11037 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11038 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11039 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11040 if (!PL_parser->error_count)
11041 qerror(Perl_mess(aTHX_ "Parse error"));
11042 exprop = newOP(OP_NULL, 0);
11048 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11050 Parse a Perl arithmetic expression. This may contain operators of precedence
11051 down to the bit shift operators. The expression must be followed (and thus
11052 terminated) either by a comparison or lower-precedence operator or by
11053 something that would normally terminate an expression such as semicolon.
11054 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11055 otherwise it is mandatory. It is up to the caller to ensure that the
11056 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11057 the source of the code to be parsed and the lexical context for the
11060 The op tree representing the expression is returned. If an optional
11061 expression is absent, a null pointer is returned, otherwise the pointer
11064 If an error occurs in parsing or compilation, in most cases a valid op
11065 tree is returned anyway. The error is reflected in the parser state,
11066 normally resulting in a single exception at the top level of parsing
11067 which covers all the compilation errors that occurred. Some compilation
11068 errors, however, will throw an exception immediately.
11074 Perl_parse_arithexpr(pTHX_ U32 flags)
11076 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11080 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11082 Parse a Perl term expression. This may contain operators of precedence
11083 down to the assignment operators. The expression must be followed (and thus
11084 terminated) either by a comma or lower-precedence operator or by
11085 something that would normally terminate an expression such as semicolon.
11086 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11087 otherwise it is mandatory. It is up to the caller to ensure that the
11088 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11089 the source of the code to be parsed and the lexical context for the
11092 The op tree representing the expression is returned. If an optional
11093 expression is absent, a null pointer is returned, otherwise the pointer
11096 If an error occurs in parsing or compilation, in most cases a valid op
11097 tree is returned anyway. The error is reflected in the parser state,
11098 normally resulting in a single exception at the top level of parsing
11099 which covers all the compilation errors that occurred. Some compilation
11100 errors, however, will throw an exception immediately.
11106 Perl_parse_termexpr(pTHX_ U32 flags)
11108 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11112 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11114 Parse a Perl list expression. This may contain operators of precedence
11115 down to the comma operator. The expression must be followed (and thus
11116 terminated) either by a low-precedence logic operator such as C<or> or by
11117 something that would normally terminate an expression such as semicolon.
11118 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11119 otherwise it is mandatory. It is up to the caller to ensure that the
11120 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11121 the source of the code to be parsed and the lexical context for the
11124 The op tree representing the expression is returned. If an optional
11125 expression is absent, a null pointer is returned, otherwise the pointer
11128 If an error occurs in parsing or compilation, in most cases a valid op
11129 tree is returned anyway. The error is reflected in the parser state,
11130 normally resulting in a single exception at the top level of parsing
11131 which covers all the compilation errors that occurred. Some compilation
11132 errors, however, will throw an exception immediately.
11138 Perl_parse_listexpr(pTHX_ U32 flags)
11140 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11144 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11146 Parse a single complete Perl expression. This allows the full
11147 expression grammar, including the lowest-precedence operators such
11148 as C<or>. The expression must be followed (and thus terminated) by a
11149 token that an expression would normally be terminated by: end-of-file,
11150 closing bracketing punctuation, semicolon, or one of the keywords that
11151 signals a postfix expression-statement modifier. If I<flags> includes
11152 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11153 mandatory. It is up to the caller to ensure that the dynamic parser
11154 state (L</PL_parser> et al) is correctly set to reflect the source of
11155 the code to be parsed and the lexical context for the expression.
11157 The op tree representing the expression is returned. If an optional
11158 expression is absent, a null pointer is returned, otherwise the pointer
11161 If an error occurs in parsing or compilation, in most cases a valid op
11162 tree is returned anyway. The error is reflected in the parser state,
11163 normally resulting in a single exception at the top level of parsing
11164 which covers all the compilation errors that occurred. Some compilation
11165 errors, however, will throw an exception immediately.
11171 Perl_parse_fullexpr(pTHX_ U32 flags)
11173 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11177 =for apidoc Amx|OP *|parse_block|U32 flags
11179 Parse a single complete Perl code block. This consists of an opening
11180 brace, a sequence of statements, and a closing brace. The block
11181 constitutes a lexical scope, so C<my> variables and various compile-time
11182 effects can be contained within it. It is up to the caller to ensure
11183 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11184 reflect the source of the code to be parsed and the lexical context for
11187 The op tree representing the code block is returned. This is always a
11188 real op, never a null pointer. It will normally be a C<lineseq> list,
11189 including C<nextstate> or equivalent ops. No ops to construct any kind
11190 of runtime scope are included by virtue of it being a block.
11192 If an error occurs in parsing or compilation, in most cases a valid op
11193 tree (most likely null) is returned anyway. The error is reflected in
11194 the parser state, normally resulting in a single exception at the top
11195 level of parsing which covers all the compilation errors that occurred.
11196 Some compilation errors, however, will throw an exception immediately.
11198 The I<flags> parameter is reserved for future use, and must always
11205 Perl_parse_block(pTHX_ U32 flags)
11208 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11209 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11213 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11215 Parse a single unadorned Perl statement. This may be a normal imperative
11216 statement or a declaration that has compile-time effect. It does not
11217 include any label or other affixture. 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 statement is returned. This may be a
11223 null pointer if the statement is null, for example if it was actually
11224 a subroutine definition (which has compile-time side effects). If not
11225 null, it will be ops directly implementing the statement, suitable to
11226 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11227 equivalent op (except for those embedded in a scope contained entirely
11228 within the statement).
11230 If an error occurs in parsing or compilation, in most cases a valid op
11231 tree (most likely null) is returned anyway. The error is reflected in
11232 the parser state, normally resulting in a single exception at the top
11233 level of parsing which covers all the compilation errors that occurred.
11234 Some compilation errors, however, will throw an exception immediately.
11236 The I<flags> parameter is reserved for future use, and must always
11243 Perl_parse_barestmt(pTHX_ U32 flags)
11246 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11247 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11251 =for apidoc Amx|SV *|parse_label|U32 flags
11253 Parse a single label, possibly optional, of the type that may prefix a
11254 Perl statement. It is up to the caller to ensure that the dynamic parser
11255 state (L</PL_parser> et al) is correctly set to reflect the source of
11256 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11257 label is optional, otherwise it is mandatory.
11259 The name of the label is returned in the form of a fresh scalar. If an
11260 optional label is absent, a null pointer is returned.
11262 If an error occurs in parsing, which can only occur if the label is
11263 mandatory, a valid label is returned anyway. The error is reflected in
11264 the parser state, normally resulting in a single exception at the top
11265 level of parsing which covers all the compilation errors that occurred.
11271 Perl_parse_label(pTHX_ U32 flags)
11273 if (flags & ~PARSE_OPTIONAL)
11274 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11275 if (PL_lex_state == LEX_KNOWNEXT) {
11276 PL_parser->yychar = yylex();
11277 if (PL_parser->yychar == LABEL) {
11278 char *lpv = pl_yylval.pval;
11279 STRLEN llen = strlen(lpv);
11281 PL_parser->yychar = YYEMPTY;
11282 lsv = newSV_type(SVt_PV);
11283 SvPV_set(lsv, lpv);
11284 SvCUR_set(lsv, llen);
11285 SvLEN_set(lsv, llen+1);
11295 STRLEN wlen, bufptr_pos;
11299 if (!isIDFIRST_A(c))
11303 } while(isWORDCHAR_A(c));
11305 if (word_takes_any_delimeter(s, wlen))
11307 bufptr_pos = s - SvPVX(PL_linestr);
11309 lex_read_space(LEX_KEEP_PREVIOUS);
11311 s = SvPVX(PL_linestr) + bufptr_pos;
11312 if (t[0] == ':' && t[1] != ':') {
11313 PL_oldoldbufptr = PL_oldbufptr;
11316 return newSVpvn(s, wlen);
11320 if (flags & PARSE_OPTIONAL) {
11323 qerror(Perl_mess(aTHX_ "Parse error"));
11324 return newSVpvs("x");
11331 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11333 Parse a single complete Perl statement. This may be a normal imperative
11334 statement or a declaration that has compile-time effect, and may include
11335 optional labels. It is up to the caller to ensure that the dynamic
11336 parser state (L</PL_parser> et al) is correctly set to reflect the source
11337 of the code to be parsed and the lexical context for the statement.
11339 The op tree representing the statement is returned. This may be a
11340 null pointer if the statement is null, for example if it was actually
11341 a subroutine definition (which has compile-time side effects). If not
11342 null, it will be the result of a L</newSTATEOP> call, normally including
11343 a C<nextstate> or equivalent op.
11345 If an error occurs in parsing or compilation, in most cases a valid op
11346 tree (most likely null) is returned anyway. The error is reflected in
11347 the parser state, normally resulting in a single exception at the top
11348 level of parsing which covers all the compilation errors that occurred.
11349 Some compilation errors, however, will throw an exception immediately.
11351 The I<flags> parameter is reserved for future use, and must always
11358 Perl_parse_fullstmt(pTHX_ U32 flags)
11361 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11362 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11366 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11368 Parse a sequence of zero or more Perl statements. These may be normal
11369 imperative statements, including optional labels, or declarations
11370 that have compile-time effect, or any mixture thereof. The statement
11371 sequence ends when a closing brace or end-of-file is encountered in a
11372 place where a new statement could have validly started. It is up to
11373 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11374 is correctly set to reflect the source of the code to be parsed and the
11375 lexical context for the statements.
11377 The op tree representing the statement sequence is returned. This may
11378 be a null pointer if the statements were all null, for example if there
11379 were no statements or if there were only subroutine definitions (which
11380 have compile-time side effects). If not null, it will be a C<lineseq>
11381 list, normally including C<nextstate> or equivalent ops.
11383 If an error occurs in parsing or compilation, in most cases a valid op
11384 tree is returned anyway. The error is reflected in the parser state,
11385 normally resulting in a single exception at the top level of parsing
11386 which covers all the compilation errors that occurred. Some compilation
11387 errors, however, will throw an exception immediately.
11389 The I<flags> parameter is reserved for future use, and must always
11396 Perl_parse_stmtseq(pTHX_ U32 flags)
11401 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11402 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11403 c = lex_peek_unichar(0);
11404 if (c != -1 && c != /*{*/'}')
11405 qerror(Perl_mess(aTHX_ "Parse error"));
11410 Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist)
11412 PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
11413 deprecate("qw(...) as parentheses");
11414 force_next((4<<24)|')');
11415 if (qwlist->op_type == OP_STUB) {
11419 start_force(PL_curforce);
11420 NEXTVAL_NEXTTOKE.opval = qwlist;
11423 force_next((2<<24)|'(');
11428 * c-indentation-style: bsd
11429 * c-basic-offset: 4
11430 * indent-tabs-mode: t
11433 * ex: set ts=8 sts=4 sw=4 noet: