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(s, len));
2097 start_force(PL_curforce);
2098 NEXTVAL_NEXTTOKE.opval = o;
2101 o->op_private = OPpCONST_ENTERED;
2102 /* XXX see note in pp_entereval() for why we forgo typo
2103 warnings if the symbol must be introduced in an eval.
2105 gv_fetchpvn_flags(s, len,
2106 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2108 kind == '$' ? SVt_PV :
2109 kind == '@' ? SVt_PVAV :
2110 kind == '%' ? SVt_PVHV :
2118 Perl_str_to_version(pTHX_ SV *sv)
2123 const char *start = SvPV_const(sv,len);
2124 const char * const end = start + len;
2125 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2127 PERL_ARGS_ASSERT_STR_TO_VERSION;
2129 while (start < end) {
2133 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2138 retval += ((NV)n)/nshift;
2147 * Forces the next token to be a version number.
2148 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2149 * and if "guessing" is TRUE, then no new token is created (and the caller
2150 * must use an alternative parsing method).
2154 S_force_version(pTHX_ char *s, int guessing)
2160 I32 startoff = s - SvPVX(PL_linestr);
2163 PERL_ARGS_ASSERT_FORCE_VERSION;
2171 while (isDIGIT(*d) || *d == '_' || *d == '.')
2175 start_force(PL_curforce);
2176 curmad('X', newSVpvn(s,d-s));
2179 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2181 #ifdef USE_LOCALE_NUMERIC
2182 char *loc = setlocale(LC_NUMERIC, "C");
2184 s = scan_num(s, &pl_yylval);
2185 #ifdef USE_LOCALE_NUMERIC
2186 setlocale(LC_NUMERIC, loc);
2188 version = pl_yylval.opval;
2189 ver = cSVOPx(version)->op_sv;
2190 if (SvPOK(ver) && !SvNIOK(ver)) {
2191 SvUPGRADE(ver, SVt_PVNV);
2192 SvNV_set(ver, str_to_version(ver));
2193 SvNOK_on(ver); /* hint that it is a version */
2196 else if (guessing) {
2199 sv_free(PL_nextwhite); /* let next token collect whitespace */
2201 s = SvPVX(PL_linestr) + startoff;
2209 if (PL_madskills && !version) {
2210 sv_free(PL_nextwhite); /* let next token collect whitespace */
2212 s = SvPVX(PL_linestr) + startoff;
2215 /* NOTE: The parser sees the package name and the VERSION swapped */
2216 start_force(PL_curforce);
2217 NEXTVAL_NEXTTOKE.opval = version;
2224 * S_force_strict_version
2225 * Forces the next token to be a version number using strict syntax rules.
2229 S_force_strict_version(pTHX_ char *s)
2234 I32 startoff = s - SvPVX(PL_linestr);
2236 const char *errstr = NULL;
2238 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2240 while (isSPACE(*s)) /* leading whitespace */
2243 if (is_STRICT_VERSION(s,&errstr)) {
2245 s = (char *)scan_version(s, ver, 0);
2246 version = newSVOP(OP_CONST, 0, ver);
2248 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2249 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2253 yyerror(errstr); /* version required */
2258 if (PL_madskills && !version) {
2259 sv_free(PL_nextwhite); /* let next token collect whitespace */
2261 s = SvPVX(PL_linestr) + startoff;
2264 /* NOTE: The parser sees the package name and the VERSION swapped */
2265 start_force(PL_curforce);
2266 NEXTVAL_NEXTTOKE.opval = version;
2274 * Tokenize a quoted string passed in as an SV. It finds the next
2275 * chunk, up to end of string or a backslash. It may make a new
2276 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2281 S_tokeq(pTHX_ SV *sv)
2285 register char *send;
2290 PERL_ARGS_ASSERT_TOKEQ;
2295 s = SvPV_force(sv, len);
2296 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2299 /* This is relying on the SV being "well formed" with a trailing '\0' */
2300 while (s < send && !(*s == '\\' && s[1] == '\\'))
2305 if ( PL_hints & HINT_NEW_STRING ) {
2306 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2310 if (s + 1 < send && (s[1] == '\\'))
2311 s++; /* all that, just for this */
2316 SvCUR_set(sv, d - SvPVX_const(sv));
2318 if ( PL_hints & HINT_NEW_STRING )
2319 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2324 * Now come three functions related to double-quote context,
2325 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2326 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2327 * interact with PL_lex_state, and create fake ( ... ) argument lists
2328 * to handle functions and concatenation.
2329 * They assume that whoever calls them will be setting up a fake
2330 * join call, because each subthing puts a ',' after it. This lets
2333 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
2335 * (I'm not sure whether the spurious commas at the end of lcfirst's
2336 * arguments and join's arguments are created or not).
2341 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2343 * Pattern matching will set PL_lex_op to the pattern-matching op to
2344 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2346 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2348 * Everything else becomes a FUNC.
2350 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2351 * had an OP_CONST or OP_READLINE). This just sets us up for a
2352 * call to S_sublex_push().
2356 S_sublex_start(pTHX)
2359 register const I32 op_type = pl_yylval.ival;
2361 if (op_type == OP_NULL) {
2362 pl_yylval.opval = PL_lex_op;
2366 if (op_type == OP_CONST || op_type == OP_READLINE) {
2367 SV *sv = tokeq(PL_lex_stuff);
2369 if (SvTYPE(sv) == SVt_PVIV) {
2370 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2372 const char * const p = SvPV_const(sv, len);
2373 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2377 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2378 PL_lex_stuff = NULL;
2379 /* Allow <FH> // "foo" */
2380 if (op_type == OP_READLINE)
2381 PL_expect = XTERMORDORDOR;
2384 else if (op_type == OP_BACKTICK && PL_lex_op) {
2385 /* readpipe() vas overriden */
2386 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2387 pl_yylval.opval = PL_lex_op;
2389 PL_lex_stuff = NULL;
2393 PL_sublex_info.super_state = PL_lex_state;
2394 PL_sublex_info.sub_inwhat = (U16)op_type;
2395 PL_sublex_info.sub_op = PL_lex_op;
2396 PL_lex_state = LEX_INTERPPUSH;
2400 pl_yylval.opval = PL_lex_op;
2410 * Create a new scope to save the lexing state. The scope will be
2411 * ended in S_sublex_done. Returns a '(', starting the function arguments
2412 * to the uc, lc, etc. found before.
2413 * Sets PL_lex_state to LEX_INTERPCONCAT.
2422 PL_lex_state = PL_sublex_info.super_state;
2423 SAVEBOOL(PL_lex_dojoin);
2424 SAVEI32(PL_lex_brackets);
2425 SAVEI32(PL_lex_allbrackets);
2426 SAVEI8(PL_lex_fakeeof);
2427 SAVEI32(PL_lex_casemods);
2428 SAVEI32(PL_lex_starts);
2429 SAVEI8(PL_lex_state);
2430 SAVEVPTR(PL_lex_inpat);
2431 SAVEI16(PL_lex_inwhat);
2432 SAVECOPLINE(PL_curcop);
2433 SAVEPPTR(PL_bufptr);
2434 SAVEPPTR(PL_bufend);
2435 SAVEPPTR(PL_oldbufptr);
2436 SAVEPPTR(PL_oldoldbufptr);
2437 SAVEPPTR(PL_last_lop);
2438 SAVEPPTR(PL_last_uni);
2439 SAVEPPTR(PL_linestart);
2440 SAVESPTR(PL_linestr);
2441 SAVEGENERICPV(PL_lex_brackstack);
2442 SAVEGENERICPV(PL_lex_casestack);
2444 PL_linestr = PL_lex_stuff;
2445 PL_lex_stuff = NULL;
2447 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2448 = SvPVX(PL_linestr);
2449 PL_bufend += SvCUR(PL_linestr);
2450 PL_last_lop = PL_last_uni = NULL;
2451 SAVEFREESV(PL_linestr);
2453 PL_lex_dojoin = FALSE;
2454 PL_lex_brackets = 0;
2455 PL_lex_allbrackets = 0;
2456 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2457 Newx(PL_lex_brackstack, 120, char);
2458 Newx(PL_lex_casestack, 12, char);
2459 PL_lex_casemods = 0;
2460 *PL_lex_casestack = '\0';
2462 PL_lex_state = LEX_INTERPCONCAT;
2463 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2465 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2466 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2467 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2468 PL_lex_inpat = PL_sublex_info.sub_op;
2470 PL_lex_inpat = NULL;
2477 * Restores lexer state after a S_sublex_push.
2484 if (!PL_lex_starts++) {
2485 SV * const sv = newSVpvs("");
2486 if (SvUTF8(PL_linestr))
2488 PL_expect = XOPERATOR;
2489 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2493 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2494 PL_lex_state = LEX_INTERPCASEMOD;
2498 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2499 assert(PL_lex_inwhat != OP_TRANSR);
2500 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2501 PL_linestr = PL_lex_repl;
2503 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2504 PL_bufend += SvCUR(PL_linestr);
2505 PL_last_lop = PL_last_uni = NULL;
2506 SAVEFREESV(PL_linestr);
2507 PL_lex_dojoin = FALSE;
2508 PL_lex_brackets = 0;
2509 PL_lex_allbrackets = 0;
2510 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2511 PL_lex_casemods = 0;
2512 *PL_lex_casestack = '\0';
2514 if (SvEVALED(PL_lex_repl)) {
2515 PL_lex_state = LEX_INTERPNORMAL;
2517 /* we don't clear PL_lex_repl here, so that we can check later
2518 whether this is an evalled subst; that means we rely on the
2519 logic to ensure sublex_done() is called again only via the
2520 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2523 PL_lex_state = LEX_INTERPCONCAT;
2533 PL_endwhite = newSVpvs("");
2534 sv_catsv(PL_endwhite, PL_thiswhite);
2538 sv_setpvs(PL_thistoken,"");
2540 PL_realtokenstart = -1;
2544 PL_bufend = SvPVX(PL_linestr);
2545 PL_bufend += SvCUR(PL_linestr);
2546 PL_expect = XOPERATOR;
2547 PL_sublex_info.sub_inwhat = 0;
2555 Extracts a pattern, double-quoted string, or transliteration. This
2558 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2559 processing a pattern (PL_lex_inpat is true), a transliteration
2560 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2562 Returns a pointer to the character scanned up to. If this is
2563 advanced from the start pointer supplied (i.e. if anything was
2564 successfully parsed), will leave an OP for the substring scanned
2565 in pl_yylval. Caller must intuit reason for not parsing further
2566 by looking at the next characters herself.
2570 constants: \N{NAME} only
2571 case and quoting: \U \Q \E
2572 stops on @ and $, but not for $ as tail anchor
2574 In transliterations:
2575 characters are VERY literal, except for - not at the start or end
2576 of the string, which indicates a range. If the range is in bytes,
2577 scan_const expands the range to the full set of intermediate
2578 characters. If the range is in utf8, the hyphen is replaced with
2579 a certain range mark which will be handled by pmtrans() in op.c.
2581 In double-quoted strings:
2583 double-quoted style: \r and \n
2584 constants: \x31, etc.
2585 deprecated backrefs: \1 (in substitution replacements)
2586 case and quoting: \U \Q \E
2589 scan_const does *not* construct ops to handle interpolated strings.
2590 It stops processing as soon as it finds an embedded $ or @ variable
2591 and leaves it to the caller to work out what's going on.
2593 embedded arrays (whether in pattern or not) could be:
2594 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2596 $ in double-quoted strings must be the symbol of an embedded scalar.
2598 $ in pattern could be $foo or could be tail anchor. Assumption:
2599 it's a tail anchor if $ is the last thing in the string, or if it's
2600 followed by one of "()| \r\n\t"
2602 \1 (backreferences) are turned into $1
2604 The structure of the code is
2605 while (there's a character to process) {
2606 handle transliteration ranges
2607 skip regexp comments /(?#comment)/ and codes /(?{code})/
2608 skip #-initiated comments in //x patterns
2609 check for embedded arrays
2610 check for embedded scalars
2612 deprecate \1 in substitution replacements
2613 handle string-changing backslashes \l \U \Q \E, etc.
2614 switch (what was escaped) {
2615 handle \- in a transliteration (becomes a literal -)
2616 if a pattern and not \N{, go treat as regular character
2617 handle \132 (octal characters)
2618 handle \x15 and \x{1234} (hex characters)
2619 handle \N{name} (named characters, also \N{3,5} in a pattern)
2620 handle \cV (control characters)
2621 handle printf-style backslashes (\f, \r, \n, etc)
2624 } (end if backslash)
2625 handle regular character
2626 } (end while character to read)
2631 S_scan_const(pTHX_ char *start)
2634 register char *send = PL_bufend; /* end of the constant */
2635 SV *sv = newSV(send - start); /* sv for the constant. See
2636 note below on sizing. */
2637 register char *s = start; /* start of the constant */
2638 register char *d = SvPVX(sv); /* destination for copies */
2639 bool dorange = FALSE; /* are we in a translit range? */
2640 bool didrange = FALSE; /* did we just finish a range? */
2641 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2642 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2643 to be UTF8? But, this can
2644 show as true when the source
2645 isn't utf8, as for example
2646 when it is entirely composed
2649 /* Note on sizing: The scanned constant is placed into sv, which is
2650 * initialized by newSV() assuming one byte of output for every byte of
2651 * input. This routine expects newSV() to allocate an extra byte for a
2652 * trailing NUL, which this routine will append if it gets to the end of
2653 * the input. There may be more bytes of input than output (eg., \N{LATIN
2654 * CAPITAL LETTER A}), or more output than input if the constant ends up
2655 * recoded to utf8, but each time a construct is found that might increase
2656 * the needed size, SvGROW() is called. Its size parameter each time is
2657 * based on the best guess estimate at the time, namely the length used so
2658 * far, plus the length the current construct will occupy, plus room for
2659 * the trailing NUL, plus one byte for every input byte still unscanned */
2663 UV literal_endpoint = 0;
2664 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2667 PERL_ARGS_ASSERT_SCAN_CONST;
2669 assert(PL_lex_inwhat != OP_TRANSR);
2670 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2671 /* If we are doing a trans and we know we want UTF8 set expectation */
2672 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2673 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2677 while (s < send || dorange) {
2679 /* get transliterations out of the way (they're most literal) */
2680 if (PL_lex_inwhat == OP_TRANS) {
2681 /* expand a range A-Z to the full set of characters. AIE! */
2683 I32 i; /* current expanded character */
2684 I32 min; /* first character in range */
2685 I32 max; /* last character in range */
2696 char * const c = (char*)utf8_hop((U8*)d, -1);
2700 *c = (char)UTF_TO_NATIVE(0xff);
2701 /* mark the range as done, and continue */
2707 i = d - SvPVX_const(sv); /* remember current offset */
2710 SvLEN(sv) + (has_utf8 ?
2711 (512 - UTF_CONTINUATION_MARK +
2714 /* How many two-byte within 0..255: 128 in UTF-8,
2715 * 96 in UTF-8-mod. */
2717 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2719 d = SvPVX(sv) + i; /* refresh d after realloc */
2723 for (j = 0; j <= 1; j++) {
2724 char * const c = (char*)utf8_hop((U8*)d, -1);
2725 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2731 max = (U8)0xff; /* only to \xff */
2732 uvmax = uv; /* \x{100} to uvmax */
2734 d = c; /* eat endpoint chars */
2739 d -= 2; /* eat the first char and the - */
2740 min = (U8)*d; /* first char in range */
2741 max = (U8)d[1]; /* last char in range */
2748 "Invalid range \"%c-%c\" in transliteration operator",
2749 (char)min, (char)max);
2753 if (literal_endpoint == 2 &&
2754 ((isLOWER(min) && isLOWER(max)) ||
2755 (isUPPER(min) && isUPPER(max)))) {
2757 for (i = min; i <= max; i++)
2759 *d++ = NATIVE_TO_NEED(has_utf8,i);
2761 for (i = min; i <= max; i++)
2763 *d++ = NATIVE_TO_NEED(has_utf8,i);
2768 for (i = min; i <= max; i++)
2771 const U8 ch = (U8)NATIVE_TO_UTF(i);
2772 if (UNI_IS_INVARIANT(ch))
2775 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2776 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2785 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2787 *d++ = (char)UTF_TO_NATIVE(0xff);
2789 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2793 /* mark the range as done, and continue */
2797 literal_endpoint = 0;
2802 /* range begins (ignore - as first or last char) */
2803 else if (*s == '-' && s+1 < send && s != start) {
2805 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2812 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2822 literal_endpoint = 0;
2823 native_range = TRUE;
2828 /* if we get here, we're not doing a transliteration */
2830 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2831 except for the last char, which will be done separately. */
2832 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2834 while (s+1 < send && *s != ')')
2835 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2837 else if (s[2] == '{' /* This should match regcomp.c */
2838 || (s[2] == '?' && s[3] == '{'))
2841 char *regparse = s + (s[2] == '{' ? 3 : 4);
2844 while (count && (c = *regparse)) {
2845 if (c == '\\' && regparse[1])
2853 if (*regparse != ')')
2854 regparse--; /* Leave one char for continuation. */
2855 while (s < regparse)
2856 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2860 /* likewise skip #-initiated comments in //x patterns */
2861 else if (*s == '#' && PL_lex_inpat &&
2862 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
2863 while (s+1 < send && *s != '\n')
2864 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2867 /* check for embedded arrays
2868 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2870 else if (*s == '@' && s[1]) {
2871 if (isALNUM_lazy_if(s+1,UTF))
2873 if (strchr(":'{$", s[1]))
2875 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2876 break; /* in regexp, neither @+ nor @- are interpolated */
2879 /* check for embedded scalars. only stop if we're sure it's a
2882 else if (*s == '$') {
2883 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2885 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2887 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2888 "Possible unintended interpolation of $\\ in regex");
2890 break; /* in regexp, $ might be tail anchor */
2894 /* End of else if chain - OP_TRANS rejoin rest */
2897 if (*s == '\\' && s+1 < send) {
2898 char* e; /* Can be used for ending '}', etc. */
2902 /* warn on \1 - \9 in substitution replacements, but note that \11
2903 * is an octal; and \19 is \1 followed by '9' */
2904 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2905 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2907 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2912 /* string-change backslash escapes */
2913 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2917 /* In a pattern, process \N, but skip any other backslash escapes.
2918 * This is because we don't want to translate an escape sequence
2919 * into a meta symbol and have the regex compiler use the meta
2920 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
2921 * in spite of this, we do have to process \N here while the proper
2922 * charnames handler is in scope. See bugs #56444 and #62056.
2923 * There is a complication because \N in a pattern may also stand
2924 * for 'match a non-nl', and not mean a charname, in which case its
2925 * processing should be deferred to the regex compiler. To be a
2926 * charname it must be followed immediately by a '{', and not look
2927 * like \N followed by a curly quantifier, i.e., not something like
2928 * \N{3,}. regcurly returns a boolean indicating if it is a legal
2930 else if (PL_lex_inpat
2933 || regcurly(s + 1)))
2935 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2936 goto default_action;
2941 /* quoted - in transliterations */
2943 if (PL_lex_inwhat == OP_TRANS) {
2950 if ((isALPHA(*s) || isDIGIT(*s)))
2951 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2952 "Unrecognized escape \\%c passed through",
2954 /* default action is to copy the quoted character */
2955 goto default_action;
2958 /* eg. \132 indicates the octal constant 0132 */
2959 case '0': case '1': case '2': case '3':
2960 case '4': case '5': case '6': case '7':
2964 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2967 goto NUM_ESCAPE_INSERT;
2969 /* eg. \o{24} indicates the octal constant \024 */
2975 bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
2981 goto NUM_ESCAPE_INSERT;
2984 /* eg. \x24 indicates the hex constant 0x24 */
2988 char* const e = strchr(s, '}');
2989 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2990 PERL_SCAN_DISALLOW_PREFIX;
2995 yyerror("Missing right brace on \\x{}");
2999 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
3005 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3006 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
3012 /* Insert oct or hex escaped character. There will always be
3013 * enough room in sv since such escapes will be longer than any
3014 * UTF-8 sequence they can end up as, except if they force us
3015 * to recode the rest of the string into utf8 */
3017 /* Here uv is the ordinal of the next character being added in
3018 * unicode (converted from native). */
3019 if (!UNI_IS_INVARIANT(uv)) {
3020 if (!has_utf8 && uv > 255) {
3021 /* Might need to recode whatever we have accumulated so
3022 * far if it contains any chars variant in utf8 or
3025 SvCUR_set(sv, d - SvPVX_const(sv));
3028 /* See Note on sizing above. */
3029 sv_utf8_upgrade_flags_grow(sv,
3030 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3031 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3032 d = SvPVX(sv) + SvCUR(sv);
3037 d = (char*)uvuni_to_utf8((U8*)d, uv);
3038 if (PL_lex_inwhat == OP_TRANS &&
3039 PL_sublex_info.sub_op) {
3040 PL_sublex_info.sub_op->op_private |=
3041 (PL_lex_repl ? OPpTRANS_FROM_UTF
3045 if (uv > 255 && !dorange)
3046 native_range = FALSE;
3059 /* In a non-pattern \N must be a named character, like \N{LATIN
3060 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3061 * mean to match a non-newline. For non-patterns, named
3062 * characters are converted to their string equivalents. In
3063 * patterns, named characters are not converted to their
3064 * ultimate forms for the same reasons that other escapes
3065 * aren't. Instead, they are converted to the \N{U+...} form
3066 * to get the value from the charnames that is in effect right
3067 * now, while preserving the fact that it was a named character
3068 * so that the regex compiler knows this */
3070 /* This section of code doesn't generally use the
3071 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3072 * a close examination of this macro and determined it is a
3073 * no-op except on utfebcdic variant characters. Every
3074 * character generated by this that would normally need to be
3075 * enclosed by this macro is invariant, so the macro is not
3076 * needed, and would complicate use of copy(). XXX There are
3077 * other parts of this file where the macro is used
3078 * inconsistently, but are saved by it being a no-op */
3080 /* The structure of this section of code (besides checking for
3081 * errors and upgrading to utf8) is:
3082 * Further disambiguate between the two meanings of \N, and if
3083 * not a charname, go process it elsewhere
3084 * If of form \N{U+...}, pass it through if a pattern;
3085 * otherwise convert to utf8
3086 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3087 * pattern; otherwise convert to utf8 */
3089 /* Here, s points to the 'N'; the test below is guaranteed to
3090 * succeed if we are being called on a pattern as we already
3091 * know from a test above that the next character is a '{'.
3092 * On a non-pattern \N must mean 'named sequence, which
3093 * requires braces */
3096 yyerror("Missing braces on \\N{}");
3101 /* If there is no matching '}', it is an error. */
3102 if (! (e = strchr(s, '}'))) {
3103 if (! PL_lex_inpat) {
3104 yyerror("Missing right brace on \\N{}");
3106 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3111 /* Here it looks like a named character */
3115 /* XXX This block is temporary code. \N{} implies that the
3116 * pattern is to have Unicode semantics, and therefore
3117 * currently has to be encoded in utf8. By putting it in
3118 * utf8 now, we save a whole pass in the regular expression
3119 * compiler. Once that code is changed so Unicode
3120 * semantics doesn't necessarily have to be in utf8, this
3121 * block should be removed. However, the code that parses
3122 * the output of this would have to be changed to not
3123 * necessarily expect utf8 */
3125 SvCUR_set(sv, d - SvPVX_const(sv));
3128 /* See Note on sizing above. */
3129 sv_utf8_upgrade_flags_grow(sv,
3130 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3131 /* 5 = '\N{' + cur char + NUL */
3132 (STRLEN)(send - s) + 5);
3133 d = SvPVX(sv) + SvCUR(sv);
3138 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3139 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3140 | PERL_SCAN_DISALLOW_PREFIX;
3143 /* For \N{U+...}, the '...' is a unicode value even on
3144 * EBCDIC machines */
3145 s += 2; /* Skip to next char after the 'U+' */
3147 uv = grok_hex(s, &len, &flags, NULL);
3148 if (len == 0 || len != (STRLEN)(e - s)) {
3149 yyerror("Invalid hexadecimal number in \\N{U+...}");
3156 /* On non-EBCDIC platforms, pass through to the regex
3157 * compiler unchanged. The reason we evaluated the
3158 * number above is to make sure there wasn't a syntax
3159 * error. But on EBCDIC we convert to native so
3160 * downstream code can continue to assume it's native
3162 s -= 5; /* Include the '\N{U+' */
3164 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3167 (unsigned int) UNI_TO_NATIVE(uv));
3169 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3173 else { /* Not a pattern: convert the hex to string */
3175 /* If destination is not in utf8, unconditionally
3176 * recode it to be so. This is because \N{} implies
3177 * Unicode semantics, and scalars have to be in utf8
3178 * to guarantee those semantics */
3180 SvCUR_set(sv, d - SvPVX_const(sv));
3183 /* See Note on sizing above. */
3184 sv_utf8_upgrade_flags_grow(
3186 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3187 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3188 d = SvPVX(sv) + SvCUR(sv);
3192 /* Add the string to the output */
3193 if (UNI_IS_INVARIANT(uv)) {
3196 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3199 else { /* Here is \N{NAME} but not \N{U+...}. */
3201 SV *res; /* result from charnames */
3202 const char *str; /* the string in 'res' */
3203 STRLEN len; /* its length */
3205 /* Get the value for NAME */
3206 res = newSVpvn(s, e - s);
3207 res = new_constant( NULL, 0, "charnames",
3208 /* includes all of: \N{...} */
3209 res, NULL, s - 3, e - s + 4 );
3211 /* Most likely res will be in utf8 already since the
3212 * standard charnames uses pack U, but a custom translator
3213 * can leave it otherwise, so make sure. XXX This can be
3214 * revisited to not have charnames use utf8 for characters
3215 * that don't need it when regexes don't have to be in utf8
3216 * for Unicode semantics. If doing so, remember EBCDIC */
3217 sv_utf8_upgrade(res);
3218 str = SvPV_const(res, len);
3220 /* Don't accept malformed input */
3221 if (! is_utf8_string((U8 *) str, len)) {
3222 yyerror("Malformed UTF-8 returned by \\N");
3224 else if (PL_lex_inpat) {
3226 if (! len) { /* The name resolved to an empty string */
3227 Copy("\\N{}", d, 4, char);
3231 /* In order to not lose information for the regex
3232 * compiler, pass the result in the specially made
3233 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3234 * the code points in hex of each character
3235 * returned by charnames */
3237 const char *str_end = str + len;
3238 STRLEN char_length; /* cur char's byte length */
3239 STRLEN output_length; /* and the number of bytes
3240 after this is translated
3242 const STRLEN off = d - SvPVX_const(sv);
3244 /* 2 hex per byte; 2 chars for '\N'; 2 chars for
3245 * max('U+', '.'); and 1 for NUL */
3246 char hex_string[2 * UTF8_MAXBYTES + 5];
3248 /* Get the first character of the result. */
3249 U32 uv = utf8n_to_uvuni((U8 *) str,
3254 /* The call to is_utf8_string() above hopefully
3255 * guarantees that there won't be an error. But
3256 * it's easy here to make sure. The function just
3257 * above warns and returns 0 if invalid utf8, but
3258 * it can also return 0 if the input is validly a
3259 * NUL. Disambiguate */
3260 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3261 uv = UNICODE_REPLACEMENT;
3264 /* Convert first code point to hex, including the
3265 * boiler plate before it. For all these, we
3266 * convert to native format so that downstream code
3267 * can continue to assume the input is native */
3269 my_snprintf(hex_string, sizeof(hex_string),
3271 (unsigned int) UNI_TO_NATIVE(uv));
3273 /* Make sure there is enough space to hold it */
3274 d = off + SvGROW(sv, off
3276 + (STRLEN)(send - e)
3277 + 2); /* '}' + NUL */
3279 Copy(hex_string, d, output_length, char);
3282 /* For each subsequent character, append dot and
3283 * its ordinal in hex */
3284 while ((str += char_length) < str_end) {
3285 const STRLEN off = d - SvPVX_const(sv);
3286 U32 uv = utf8n_to_uvuni((U8 *) str,
3290 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3291 uv = UNICODE_REPLACEMENT;
3295 my_snprintf(hex_string, sizeof(hex_string),
3297 (unsigned int) UNI_TO_NATIVE(uv));
3299 d = off + SvGROW(sv, off
3301 + (STRLEN)(send - e)
3302 + 2); /* '}' + NUL */
3303 Copy(hex_string, d, output_length, char);
3307 *d++ = '}'; /* Done. Add the trailing brace */
3310 else { /* Here, not in a pattern. Convert the name to a
3313 /* If destination is not in utf8, unconditionally
3314 * recode it to be so. This is because \N{} implies
3315 * Unicode semantics, and scalars have to be in utf8
3316 * to guarantee those semantics */
3318 SvCUR_set(sv, d - SvPVX_const(sv));
3321 /* See Note on sizing above. */
3322 sv_utf8_upgrade_flags_grow(sv,
3323 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3324 len + (STRLEN)(send - s) + 1);
3325 d = SvPVX(sv) + SvCUR(sv);
3327 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3329 /* See Note on sizing above. (NOTE: SvCUR() is not
3330 * set correctly here). */
3331 const STRLEN off = d - SvPVX_const(sv);
3332 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3334 Copy(str, d, len, char);
3339 /* Deprecate non-approved name syntax */
3340 if (ckWARN_d(WARN_DEPRECATED)) {
3341 bool problematic = FALSE;
3344 /* For non-ut8 input, look to see that the first
3345 * character is an alpha, then loop through the rest
3346 * checking that each is a continuation */
3348 if (! isALPHAU(*i)) problematic = TRUE;
3349 else for (i = s + 1; i < e; i++) {
3350 if (isCHARNAME_CONT(*i)) continue;
3356 /* Similarly for utf8. For invariants can check
3357 * directly. We accept anything above the latin1
3358 * range because it is immaterial to Perl if it is
3359 * correct or not, and is expensive to check. But
3360 * it is fairly easy in the latin1 range to convert
3361 * the variants into a single character and check
3363 if (UTF8_IS_INVARIANT(*i)) {
3364 if (! isALPHAU(*i)) problematic = TRUE;
3365 } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
3366 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
3372 if (! problematic) for (i = s + UTF8SKIP(s);
3376 if (UTF8_IS_INVARIANT(*i)) {
3377 if (isCHARNAME_CONT(*i)) continue;
3378 } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
3380 } else if (isCHARNAME_CONT(
3382 TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
3391 /* The e-i passed to the final %.*s makes sure that
3392 * should the trailing NUL be missing that this
3393 * print won't run off the end of the string */
3394 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3395 "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
3396 (int)(i - s + 1), s, (int)(e - i), i + 1);
3399 } /* End \N{NAME} */
3402 native_range = FALSE; /* \N{} is defined to be Unicode */
3404 s = e + 1; /* Point to just after the '}' */
3407 /* \c is a control character */
3411 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3414 yyerror("Missing control char name in \\c");
3418 /* printf-style backslashes, formfeeds, newlines, etc */
3420 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3423 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3426 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3429 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3432 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3435 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3438 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3444 } /* end if (backslash) */
3451 /* If we started with encoded form, or already know we want it,
3452 then encode the next character */
3453 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3457 /* One might think that it is wasted effort in the case of the
3458 * source being utf8 (this_utf8 == TRUE) to take the next character
3459 * in the source, convert it to an unsigned value, and then convert
3460 * it back again. But the source has not been validated here. The
3461 * routine that does the conversion checks for errors like
3464 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3465 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3467 SvCUR_set(sv, d - SvPVX_const(sv));
3470 /* See Note on sizing above. */
3471 sv_utf8_upgrade_flags_grow(sv,
3472 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3473 need + (STRLEN)(send - s) + 1);
3474 d = SvPVX(sv) + SvCUR(sv);
3476 } else if (need > len) {
3477 /* encoded value larger than old, may need extra space (NOTE:
3478 * SvCUR() is not set correctly here). See Note on sizing
3480 const STRLEN off = d - SvPVX_const(sv);
3481 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3485 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3487 if (uv > 255 && !dorange)
3488 native_range = FALSE;
3492 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3494 } /* while loop to process each character */
3496 /* terminate the string and set up the sv */
3498 SvCUR_set(sv, d - SvPVX_const(sv));
3499 if (SvCUR(sv) >= SvLEN(sv))
3500 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
3503 if (PL_encoding && !has_utf8) {
3504 sv_recode_to_utf8(sv, PL_encoding);
3510 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3511 PL_sublex_info.sub_op->op_private |=
3512 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3516 /* shrink the sv if we allocated more than we used */
3517 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3518 SvPV_shrink_to_cur(sv);
3521 /* return the substring (via pl_yylval) only if we parsed anything */
3522 if (s > PL_bufptr) {
3523 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
3524 const char *const key = PL_lex_inpat ? "qr" : "q";
3525 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3529 if (PL_lex_inwhat == OP_TRANS) {
3532 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3540 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3543 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3550 * Returns TRUE if there's more to the expression (e.g., a subscript),
3553 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3555 * ->[ and ->{ return TRUE
3556 * { and [ outside a pattern are always subscripts, so return TRUE
3557 * if we're outside a pattern and it's not { or [, then return FALSE
3558 * if we're in a pattern and the first char is a {
3559 * {4,5} (any digits around the comma) returns FALSE
3560 * if we're in a pattern and the first char is a [
3562 * [SOMETHING] has a funky algorithm to decide whether it's a
3563 * character class or not. It has to deal with things like
3564 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3565 * anything else returns TRUE
3568 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3571 S_intuit_more(pTHX_ register char *s)
3575 PERL_ARGS_ASSERT_INTUIT_MORE;
3577 if (PL_lex_brackets)
3579 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3581 if (*s != '{' && *s != '[')
3586 /* In a pattern, so maybe we have {n,m}. */
3594 /* On the other hand, maybe we have a character class */
3597 if (*s == ']' || *s == '^')
3600 /* this is terrifying, and it works */
3601 int weight = 2; /* let's weigh the evidence */
3603 unsigned char un_char = 255, last_un_char;
3604 const char * const send = strchr(s,']');
3605 char tmpbuf[sizeof PL_tokenbuf * 4];
3607 if (!send) /* has to be an expression */
3610 Zero(seen,256,char);
3613 else if (isDIGIT(*s)) {
3615 if (isDIGIT(s[1]) && s[2] == ']')
3621 for (; s < send; s++) {
3622 last_un_char = un_char;
3623 un_char = (unsigned char)*s;
3628 weight -= seen[un_char] * 10;
3629 if (isALNUM_lazy_if(s+1,UTF)) {
3631 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3632 len = (int)strlen(tmpbuf);
3633 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
3638 else if (*s == '$' && s[1] &&
3639 strchr("[#!%*<>()-=",s[1])) {
3640 if (/*{*/ strchr("])} =",s[2]))
3649 if (strchr("wds]",s[1]))
3651 else if (seen[(U8)'\''] || seen[(U8)'"'])
3653 else if (strchr("rnftbxcav",s[1]))
3655 else if (isDIGIT(s[1])) {
3657 while (s[1] && isDIGIT(s[1]))
3667 if (strchr("aA01! ",last_un_char))
3669 if (strchr("zZ79~",s[1]))
3671 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3672 weight -= 5; /* cope with negative subscript */
3675 if (!isALNUM(last_un_char)
3676 && !(last_un_char == '$' || last_un_char == '@'
3677 || last_un_char == '&')
3678 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3683 if (keyword(tmpbuf, d - tmpbuf, 0))
3686 if (un_char == last_un_char + 1)
3688 weight -= seen[un_char];
3693 if (weight >= 0) /* probably a character class */
3703 * Does all the checking to disambiguate
3705 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3706 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3708 * First argument is the stuff after the first token, e.g. "bar".
3710 * Not a method if bar is a filehandle.
3711 * Not a method if foo is a subroutine prototyped to take a filehandle.
3712 * Not a method if it's really "Foo $bar"
3713 * Method if it's "foo $bar"
3714 * Not a method if it's really "print foo $bar"
3715 * Method if it's really "foo package::" (interpreted as package->foo)
3716 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3717 * Not a method if bar is a filehandle or package, but is quoted with
3722 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3725 char *s = start + (*start == '$');
3726 char tmpbuf[sizeof PL_tokenbuf];
3733 PERL_ARGS_ASSERT_INTUIT_METHOD;
3736 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3740 const char *proto = SvPVX_const(cv);
3751 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3752 /* start is the beginning of the possible filehandle/object,
3753 * and s is the end of it
3754 * tmpbuf is a copy of it
3757 if (*start == '$') {
3758 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3759 isUPPER(*PL_tokenbuf))
3762 len = start - SvPVX(PL_linestr);
3766 start = SvPVX(PL_linestr) + len;
3770 return *s == '(' ? FUNCMETH : METHOD;
3772 if (!keyword(tmpbuf, len, 0)) {
3773 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3777 soff = s - SvPVX(PL_linestr);
3781 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
3782 if (indirgv && GvCVu(indirgv))
3784 /* filehandle or package name makes it a method */
3785 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
3787 soff = s - SvPVX(PL_linestr);
3790 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3791 return 0; /* no assumptions -- "=>" quotes bareword */
3793 start_force(PL_curforce);
3794 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3795 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3796 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3798 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
3803 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
3805 return *s == '(' ? FUNCMETH : METHOD;
3811 /* Encoded script support. filter_add() effectively inserts a
3812 * 'pre-processing' function into the current source input stream.
3813 * Note that the filter function only applies to the current source file
3814 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3816 * The datasv parameter (which may be NULL) can be used to pass
3817 * private data to this instance of the filter. The filter function
3818 * can recover the SV using the FILTER_DATA macro and use it to
3819 * store private buffers and state information.
3821 * The supplied datasv parameter is upgraded to a PVIO type
3822 * and the IoDIRP/IoANY field is used to store the function pointer,
3823 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3824 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3825 * private use must be set using malloc'd pointers.
3829 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3838 if (!PL_rsfp_filters)
3839 PL_rsfp_filters = newAV();
3842 SvUPGRADE(datasv, SVt_PVIO);
3843 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3844 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3845 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3846 FPTR2DPTR(void *, IoANY(datasv)),
3847 SvPV_nolen(datasv)));
3848 av_unshift(PL_rsfp_filters, 1);
3849 av_store(PL_rsfp_filters, 0, datasv) ;
3854 /* Delete most recently added instance of this filter function. */
3856 Perl_filter_del(pTHX_ filter_t funcp)
3861 PERL_ARGS_ASSERT_FILTER_DEL;
3864 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3865 FPTR2DPTR(void*, funcp)));
3867 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3869 /* if filter is on top of stack (usual case) just pop it off */
3870 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3871 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3872 sv_free(av_pop(PL_rsfp_filters));
3876 /* we need to search for the correct entry and clear it */
3877 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3881 /* Invoke the idxth filter function for the current rsfp. */
3882 /* maxlen 0 = read one text line */
3884 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
3889 /* This API is bad. It should have been using unsigned int for maxlen.
3890 Not sure if we want to change the API, but if not we should sanity
3891 check the value here. */
3892 const unsigned int correct_length
3901 PERL_ARGS_ASSERT_FILTER_READ;
3903 if (!PL_parser || !PL_rsfp_filters)
3905 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
3906 /* Provide a default input filter to make life easy. */
3907 /* Note that we append to the line. This is handy. */
3908 DEBUG_P(PerlIO_printf(Perl_debug_log,
3909 "filter_read %d: from rsfp\n", idx));
3910 if (correct_length) {
3913 const int old_len = SvCUR(buf_sv);
3915 /* ensure buf_sv is large enough */
3916 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
3917 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
3918 correct_length)) <= 0) {
3919 if (PerlIO_error(PL_rsfp))
3920 return -1; /* error */
3922 return 0 ; /* end of file */
3924 SvCUR_set(buf_sv, old_len + len) ;
3925 SvPVX(buf_sv)[old_len + len] = '\0';
3928 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
3929 if (PerlIO_error(PL_rsfp))
3930 return -1; /* error */
3932 return 0 ; /* end of file */
3935 return SvCUR(buf_sv);
3937 /* Skip this filter slot if filter has been deleted */
3938 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
3939 DEBUG_P(PerlIO_printf(Perl_debug_log,
3940 "filter_read %d: skipped (filter deleted)\n",
3942 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
3944 /* Get function pointer hidden within datasv */
3945 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
3946 DEBUG_P(PerlIO_printf(Perl_debug_log,
3947 "filter_read %d: via function %p (%s)\n",
3948 idx, (void*)datasv, SvPV_nolen_const(datasv)));
3949 /* Call function. The function is expected to */
3950 /* call "FILTER_READ(idx+1, buf_sv)" first. */
3951 /* Return: <0:error, =0:eof, >0:not eof */
3952 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
3956 S_filter_gets(pTHX_ register SV *sv, STRLEN append)
3960 PERL_ARGS_ASSERT_FILTER_GETS;
3962 #ifdef PERL_CR_FILTER
3963 if (!PL_rsfp_filters) {
3964 filter_add(S_cr_textfilter,NULL);
3967 if (PL_rsfp_filters) {
3969 SvCUR_set(sv, 0); /* start with empty line */
3970 if (FILTER_READ(0, sv, 0) > 0)
3971 return ( SvPVX(sv) ) ;
3976 return (sv_gets(sv, PL_rsfp, append));
3980 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
3985 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
3987 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3991 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3992 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3994 return GvHV(gv); /* Foo:: */
3997 /* use constant CLASS => 'MyClass' */
3998 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3999 if (gv && GvCV(gv)) {
4000 SV * const sv = cv_const_sv(GvCV(gv));
4002 pkgname = SvPV_const(sv, len);
4005 return gv_stashpvn(pkgname, len, 0);
4009 * S_readpipe_override
4010 * Check whether readpipe() is overridden, and generates the appropriate
4011 * optree, provided sublex_start() is called afterwards.
4014 S_readpipe_override(pTHX)
4017 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4018 pl_yylval.ival = OP_BACKTICK;
4020 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4022 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4023 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4024 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4026 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4027 op_append_elem(OP_LIST,
4028 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4029 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4036 * The intent of this yylex wrapper is to minimize the changes to the
4037 * tokener when we aren't interested in collecting madprops. It remains
4038 * to be seen how successful this strategy will be...
4045 char *s = PL_bufptr;
4047 /* make sure PL_thiswhite is initialized */
4051 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
4052 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4053 return S_pending_ident(aTHX);
4055 /* previous token ate up our whitespace? */
4056 if (!PL_lasttoke && PL_nextwhite) {
4057 PL_thiswhite = PL_nextwhite;
4061 /* isolate the token, and figure out where it is without whitespace */
4062 PL_realtokenstart = -1;
4066 assert(PL_curforce < 0);
4068 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4069 if (!PL_thistoken) {
4070 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4071 PL_thistoken = newSVpvs("");
4073 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4074 PL_thistoken = newSVpvn(tstart, s - tstart);
4077 if (PL_thismad) /* install head */
4078 CURMAD('X', PL_thistoken);
4081 /* last whitespace of a sublex? */
4082 if (optype == ')' && PL_endwhite) {
4083 CURMAD('X', PL_endwhite);
4088 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4089 if (!PL_thiswhite && !PL_endwhite && !optype) {
4090 sv_free(PL_thistoken);
4095 /* put off final whitespace till peg */
4096 if (optype == ';' && !PL_rsfp) {
4097 PL_nextwhite = PL_thiswhite;
4100 else if (PL_thisopen) {
4101 CURMAD('q', PL_thisopen);
4103 sv_free(PL_thistoken);
4107 /* Store actual token text as madprop X */
4108 CURMAD('X', PL_thistoken);
4112 /* add preceding whitespace as madprop _ */
4113 CURMAD('_', PL_thiswhite);
4117 /* add quoted material as madprop = */
4118 CURMAD('=', PL_thisstuff);
4122 /* add terminating quote as madprop Q */
4123 CURMAD('Q', PL_thisclose);
4127 /* special processing based on optype */
4131 /* opval doesn't need a TOKEN since it can already store mp */
4141 if (pl_yylval.opval)
4142 append_madprops(PL_thismad, pl_yylval.opval, 0);
4150 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4159 /* remember any fake bracket that lexer is about to discard */
4160 if (PL_lex_brackets == 1 &&
4161 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4164 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4167 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4168 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4171 break; /* don't bother looking for trailing comment */
4180 /* attach a trailing comment to its statement instead of next token */
4184 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4186 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4188 if (*s == '\n' || *s == '#') {
4189 while (s < PL_bufend && *s != '\n')
4193 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4194 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4211 /* Create new token struct. Note: opvals return early above. */
4212 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4219 S_tokenize_use(pTHX_ int is_use, char *s) {
4222 PERL_ARGS_ASSERT_TOKENIZE_USE;
4224 if (PL_expect != XSTATE)
4225 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4226 is_use ? "use" : "no"));
4228 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4229 s = force_version(s, TRUE);
4230 if (*s == ';' || *s == '}'
4231 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4232 start_force(PL_curforce);
4233 NEXTVAL_NEXTTOKE.opval = NULL;
4236 else if (*s == 'v') {
4237 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4238 s = force_version(s, FALSE);
4242 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4243 s = force_version(s, FALSE);
4245 pl_yylval.ival = is_use;
4249 static const char* const exp_name[] =
4250 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4251 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4255 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4257 S_word_takes_any_delimeter(char *p, STRLEN len)
4259 return (len == 1 && strchr("msyq", p[0])) ||
4261 (p[0] == 't' && p[1] == 'r') ||
4262 (p[0] == 'q' && strchr("qwxr", p[1]))));
4268 Works out what to call the token just pulled out of the input
4269 stream. The yacc parser takes care of taking the ops we return and
4270 stitching them into a tree.
4276 if read an identifier
4277 if we're in a my declaration
4278 croak if they tried to say my($foo::bar)
4279 build the ops for a my() declaration
4280 if it's an access to a my() variable
4281 are we in a sort block?
4282 croak if my($a); $a <=> $b
4283 build ops for access to a my() variable
4284 if in a dq string, and they've said @foo and we can't find @foo
4286 build ops for a bareword
4287 if we already built the token before, use it.
4292 #pragma segment Perl_yylex
4298 register char *s = PL_bufptr;
4304 /* orig_keyword, gvp, and gv are initialized here because
4305 * jump to the label just_a_word_zero can bypass their
4306 * initialization later. */
4307 I32 orig_keyword = 0;
4312 SV* tmp = newSVpvs("");
4313 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4314 (IV)CopLINE(PL_curcop),
4315 lex_state_names[PL_lex_state],
4316 exp_name[PL_expect],
4317 pv_display(tmp, s, strlen(s), 0, 60));
4320 /* check if there's an identifier for us to look at */
4321 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4322 return REPORT(S_pending_ident(aTHX));
4324 /* no identifier pending identification */
4326 switch (PL_lex_state) {
4328 case LEX_NORMAL: /* Some compilers will produce faster */
4329 case LEX_INTERPNORMAL: /* code if we comment these out. */
4333 /* when we've already built the next token, just pull it out of the queue */
4337 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4339 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4340 PL_nexttoke[PL_lasttoke].next_mad = 0;
4341 if (PL_thismad && PL_thismad->mad_key == '_') {
4342 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4343 PL_thismad->mad_val = 0;
4344 mad_free(PL_thismad);
4349 PL_lex_state = PL_lex_defer;
4350 PL_expect = PL_lex_expect;
4351 PL_lex_defer = LEX_NORMAL;
4352 if (!PL_nexttoke[PL_lasttoke].next_type)
4357 pl_yylval = PL_nextval[PL_nexttoke];
4359 PL_lex_state = PL_lex_defer;
4360 PL_expect = PL_lex_expect;
4361 PL_lex_defer = LEX_NORMAL;
4367 next_type = PL_nexttoke[PL_lasttoke].next_type;
4369 next_type = PL_nexttype[PL_nexttoke];
4371 if (next_type & (7<<24)) {
4372 if (next_type & (1<<24)) {
4373 if (PL_lex_brackets > 100)
4374 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4375 PL_lex_brackstack[PL_lex_brackets++] =
4376 (char) ((next_type >> 16) & 0xff);
4378 if (next_type & (2<<24))
4379 PL_lex_allbrackets++;
4380 if (next_type & (4<<24))
4381 PL_lex_allbrackets--;
4382 next_type &= 0xffff;
4385 /* FIXME - can these be merged? */
4388 return REPORT(next_type);
4392 /* interpolated case modifiers like \L \U, including \Q and \E.
4393 when we get here, PL_bufptr is at the \
4395 case LEX_INTERPCASEMOD:
4397 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4398 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
4400 /* handle \E or end of string */
4401 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4403 if (PL_lex_casemods) {
4404 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4405 PL_lex_casestack[PL_lex_casemods] = '\0';
4407 if (PL_bufptr != PL_bufend
4408 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
4410 PL_lex_state = LEX_INTERPCONCAT;
4413 PL_thistoken = newSVpvs("\\E");
4416 PL_lex_allbrackets--;
4420 while (PL_bufptr != PL_bufend &&
4421 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4423 PL_thiswhite = newSVpvs("");
4424 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4428 if (PL_bufptr != PL_bufend)
4431 PL_lex_state = LEX_INTERPCONCAT;
4435 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4436 "### Saw case modifier\n"); });
4438 if (s[1] == '\\' && s[2] == 'E') {
4441 PL_thiswhite = newSVpvs("");
4442 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4445 PL_lex_state = LEX_INTERPCONCAT;
4450 if (!PL_madskills) /* when just compiling don't need correct */
4451 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4452 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4453 if ((*s == 'L' || *s == 'U') &&
4454 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
4455 PL_lex_casestack[--PL_lex_casemods] = '\0';
4456 PL_lex_allbrackets--;
4459 if (PL_lex_casemods > 10)
4460 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4461 PL_lex_casestack[PL_lex_casemods++] = *s;
4462 PL_lex_casestack[PL_lex_casemods] = '\0';
4463 PL_lex_state = LEX_INTERPCONCAT;
4464 start_force(PL_curforce);
4465 NEXTVAL_NEXTTOKE.ival = 0;
4466 force_next((2<<24)|'(');
4467 start_force(PL_curforce);
4469 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4471 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4473 NEXTVAL_NEXTTOKE.ival = OP_LC;
4475 NEXTVAL_NEXTTOKE.ival = OP_UC;
4477 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4479 Perl_croak(aTHX_ "panic: yylex");
4481 SV* const tmpsv = newSVpvs("\\ ");
4482 /* replace the space with the character we want to escape
4484 SvPVX(tmpsv)[1] = *s;
4490 if (PL_lex_starts) {
4496 sv_free(PL_thistoken);
4497 PL_thistoken = newSVpvs("");
4500 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4501 if (PL_lex_casemods == 1 && PL_lex_inpat)
4510 case LEX_INTERPPUSH:
4511 return REPORT(sublex_push());
4513 case LEX_INTERPSTART:
4514 if (PL_bufptr == PL_bufend)
4515 return REPORT(sublex_done());
4516 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4517 "### Interpolated variable\n"); });
4519 PL_lex_dojoin = (*PL_bufptr == '@');
4520 PL_lex_state = LEX_INTERPNORMAL;
4521 if (PL_lex_dojoin) {
4522 start_force(PL_curforce);
4523 NEXTVAL_NEXTTOKE.ival = 0;
4525 start_force(PL_curforce);
4526 force_ident("\"", '$');
4527 start_force(PL_curforce);
4528 NEXTVAL_NEXTTOKE.ival = 0;
4530 start_force(PL_curforce);
4531 NEXTVAL_NEXTTOKE.ival = 0;
4532 force_next((2<<24)|'(');
4533 start_force(PL_curforce);
4534 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4537 if (PL_lex_starts++) {
4542 sv_free(PL_thistoken);
4543 PL_thistoken = newSVpvs("");
4546 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4547 if (!PL_lex_casemods && PL_lex_inpat)
4554 case LEX_INTERPENDMAYBE:
4555 if (intuit_more(PL_bufptr)) {
4556 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4562 if (PL_lex_dojoin) {
4563 PL_lex_dojoin = FALSE;
4564 PL_lex_state = LEX_INTERPCONCAT;
4568 sv_free(PL_thistoken);
4569 PL_thistoken = newSVpvs("");
4572 PL_lex_allbrackets--;
4575 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4576 && SvEVALED(PL_lex_repl))
4578 if (PL_bufptr != PL_bufend)
4579 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4583 case LEX_INTERPCONCAT:
4585 if (PL_lex_brackets)
4586 Perl_croak(aTHX_ "panic: INTERPCONCAT");
4588 if (PL_bufptr == PL_bufend)
4589 return REPORT(sublex_done());
4591 if (SvIVX(PL_linestr) == '\'') {
4592 SV *sv = newSVsv(PL_linestr);
4595 else if ( PL_hints & HINT_NEW_RE )
4596 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
4597 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4601 s = scan_const(PL_bufptr);
4603 PL_lex_state = LEX_INTERPCASEMOD;
4605 PL_lex_state = LEX_INTERPSTART;
4608 if (s != PL_bufptr) {
4609 start_force(PL_curforce);
4611 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
4613 NEXTVAL_NEXTTOKE = pl_yylval;
4616 if (PL_lex_starts++) {
4620 sv_free(PL_thistoken);
4621 PL_thistoken = newSVpvs("");
4624 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4625 if (!PL_lex_casemods && PL_lex_inpat)
4638 PL_lex_state = LEX_NORMAL;
4639 s = scan_formline(PL_bufptr);
4640 if (!PL_lex_formbrack)
4646 PL_oldoldbufptr = PL_oldbufptr;
4652 sv_free(PL_thistoken);
4655 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
4659 if (isIDFIRST_lazy_if(s,UTF))
4662 unsigned char c = *s;
4663 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4664 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4665 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4670 Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
4674 goto fake_eof; /* emulate EOF on ^D or ^Z */
4683 if (PL_lex_brackets &&
4684 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4685 yyerror((const char *)
4687 ? "Format not terminated"
4688 : "Missing right curly or square bracket"));
4690 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4691 "### Tokener got EOF\n");
4695 if (s++ < PL_bufend)
4696 goto retry; /* ignore stray nulls */
4699 if (!PL_in_eval && !PL_preambled) {
4700 PL_preambled = TRUE;
4706 /* Generate a string of Perl code to load the debugger.
4707 * If PERL5DB is set, it will return the contents of that,
4708 * otherwise a compile-time require of perl5db.pl. */
4710 const char * const pdb = PerlEnv_getenv("PERL5DB");
4713 sv_setpv(PL_linestr, pdb);
4714 sv_catpvs(PL_linestr,";");
4716 SETERRNO(0,SS_NORMAL);
4717 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4720 sv_setpvs(PL_linestr,"");
4721 if (PL_preambleav) {
4722 SV **svp = AvARRAY(PL_preambleav);
4723 SV **const end = svp + AvFILLp(PL_preambleav);
4725 sv_catsv(PL_linestr, *svp);
4727 sv_catpvs(PL_linestr, ";");
4729 sv_free(MUTABLE_SV(PL_preambleav));
4730 PL_preambleav = NULL;
4733 sv_catpvs(PL_linestr,
4734 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4735 if (PL_minus_n || PL_minus_p) {
4736 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4738 sv_catpvs(PL_linestr,"chomp;");
4741 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4742 || *PL_splitstr == '"')
4743 && strchr(PL_splitstr + 1, *PL_splitstr))
4744 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4746 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4747 bytes can be used as quoting characters. :-) */
4748 const char *splits = PL_splitstr;
4749 sv_catpvs(PL_linestr, "our @F=split(q\0");
4752 if (*splits == '\\')
4753 sv_catpvn(PL_linestr, splits, 1);
4754 sv_catpvn(PL_linestr, splits, 1);
4755 } while (*splits++);
4756 /* This loop will embed the trailing NUL of
4757 PL_linestr as the last thing it does before
4759 sv_catpvs(PL_linestr, ");");
4763 sv_catpvs(PL_linestr,"our @F=split(' ');");
4766 sv_catpvs(PL_linestr, "\n");
4767 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4768 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4769 PL_last_lop = PL_last_uni = NULL;
4770 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4771 update_debugger_info(PL_linestr, NULL, 0);
4776 bof = PL_rsfp ? TRUE : FALSE;
4779 fake_eof = LEX_FAKE_EOF;
4781 PL_bufptr = PL_bufend;
4782 CopLINE_inc(PL_curcop);
4783 if (!lex_next_chunk(fake_eof)) {
4784 CopLINE_dec(PL_curcop);
4786 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4788 CopLINE_dec(PL_curcop);
4791 PL_realtokenstart = -1;
4794 /* If it looks like the start of a BOM or raw UTF-16,
4795 * check if it in fact is. */
4796 if (bof && PL_rsfp &&
4801 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4802 bof = (offset == (Off_t)SvCUR(PL_linestr));
4803 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4804 /* offset may include swallowed CR */
4806 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4809 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4810 s = swallow_bom((U8*)s);
4813 if (PL_parser->in_pod) {
4814 /* Incest with pod. */
4817 sv_catsv(PL_thiswhite, PL_linestr);
4819 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4820 sv_setpvs(PL_linestr, "");
4821 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4822 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4823 PL_last_lop = PL_last_uni = NULL;
4824 PL_parser->in_pod = 0;
4829 } while (PL_parser->in_pod);
4830 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4831 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4832 PL_last_lop = PL_last_uni = NULL;
4833 if (CopLINE(PL_curcop) == 1) {
4834 while (s < PL_bufend && isSPACE(*s))
4836 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4840 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
4844 if (*s == '#' && *(s+1) == '!')
4846 #ifdef ALTERNATE_SHEBANG
4848 static char const as[] = ALTERNATE_SHEBANG;
4849 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4850 d = s + (sizeof(as) - 1);
4852 #endif /* ALTERNATE_SHEBANG */
4861 while (*d && !isSPACE(*d))
4865 #ifdef ARG_ZERO_IS_SCRIPT
4866 if (ipathend > ipath) {
4868 * HP-UX (at least) sets argv[0] to the script name,
4869 * which makes $^X incorrect. And Digital UNIX and Linux,
4870 * at least, set argv[0] to the basename of the Perl
4871 * interpreter. So, having found "#!", we'll set it right.
4873 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4875 assert(SvPOK(x) || SvGMAGICAL(x));
4876 if (sv_eq(x, CopFILESV(PL_curcop))) {
4877 sv_setpvn(x, ipath, ipathend - ipath);
4883 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
4884 const char * const lstart = SvPV_const(x,llen);
4886 bstart += blen - llen;
4887 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4888 sv_setpvn(x, ipath, ipathend - ipath);
4893 TAINT_NOT; /* $^X is always tainted, but that's OK */
4895 #endif /* ARG_ZERO_IS_SCRIPT */
4900 d = instr(s,"perl -");
4902 d = instr(s,"perl");
4904 /* avoid getting into infinite loops when shebang
4905 * line contains "Perl" rather than "perl" */
4907 for (d = ipathend-4; d >= ipath; --d) {
4908 if ((*d == 'p' || *d == 'P')
4909 && !ibcmp(d, "perl", 4))
4919 #ifdef ALTERNATE_SHEBANG
4921 * If the ALTERNATE_SHEBANG on this system starts with a
4922 * character that can be part of a Perl expression, then if
4923 * we see it but not "perl", we're probably looking at the
4924 * start of Perl code, not a request to hand off to some
4925 * other interpreter. Similarly, if "perl" is there, but
4926 * not in the first 'word' of the line, we assume the line
4927 * contains the start of the Perl program.
4929 if (d && *s != '#') {
4930 const char *c = ipath;
4931 while (*c && !strchr("; \t\r\n\f\v#", *c))
4934 d = NULL; /* "perl" not in first word; ignore */
4936 *s = '#'; /* Don't try to parse shebang line */
4938 #endif /* ALTERNATE_SHEBANG */
4943 !instr(s,"indir") &&
4944 instr(PL_origargv[0],"perl"))
4951 while (s < PL_bufend && isSPACE(*s))
4953 if (s < PL_bufend) {
4954 Newx(newargv,PL_origargc+3,char*);
4956 while (s < PL_bufend && !isSPACE(*s))
4959 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
4962 newargv = PL_origargv;
4965 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
4967 Perl_croak(aTHX_ "Can't exec %s", ipath);
4970 while (*d && !isSPACE(*d))
4972 while (SPACE_OR_TAB(*d))
4976 const bool switches_done = PL_doswitches;
4977 const U32 oldpdb = PL_perldb;
4978 const bool oldn = PL_minus_n;
4979 const bool oldp = PL_minus_p;
4983 bool baduni = FALSE;
4985 const char *d2 = d1 + 1;
4986 if (parse_unicode_opts((const char **)&d2)
4990 if (baduni || *d1 == 'M' || *d1 == 'm') {
4991 const char * const m = d1;
4992 while (*d1 && !isSPACE(*d1))
4994 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4997 d1 = moreswitches(d1);
4999 if (PL_doswitches && !switches_done) {
5000 int argc = PL_origargc;
5001 char **argv = PL_origargv;
5004 } while (argc && argv[0][0] == '-' && argv[0][1]);
5005 init_argv_symbols(argc,argv);
5007 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5008 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5009 /* if we have already added "LINE: while (<>) {",
5010 we must not do it again */
5012 sv_setpvs(PL_linestr, "");
5013 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5014 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5015 PL_last_lop = PL_last_uni = NULL;
5016 PL_preambled = FALSE;
5017 if (PERLDB_LINE || PERLDB_SAVESRC)
5018 (void)gv_fetchfile(PL_origfilename);
5025 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5027 PL_lex_state = LEX_FORMLINE;
5032 #ifdef PERL_STRICT_CR
5033 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5035 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5037 case ' ': case '\t': case '\f': case 013:
5039 PL_realtokenstart = -1;
5041 PL_thiswhite = newSVpvs("");
5042 sv_catpvn(PL_thiswhite, s, 1);
5049 PL_realtokenstart = -1;
5053 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
5054 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
5055 /* handle eval qq[#line 1 "foo"\n ...] */
5056 CopLINE_dec(PL_curcop);
5059 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5061 if (!PL_in_eval || PL_rsfp)
5066 while (d < PL_bufend && *d != '\n')
5070 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5071 Perl_croak(aTHX_ "panic: input overflow");
5074 PL_thiswhite = newSVpvn(s, d - s);
5079 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5081 PL_lex_state = LEX_FORMLINE;
5087 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5088 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5091 TOKEN(PEG); /* make sure any #! line is accessible */
5096 /* if (PL_madskills && PL_lex_formbrack) { */
5098 while (d < PL_bufend && *d != '\n')
5102 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5103 Perl_croak(aTHX_ "panic: input overflow");
5104 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5106 PL_thiswhite = newSVpvs("");
5107 if (CopLINE(PL_curcop) == 1) {
5108 sv_setpvs(PL_thiswhite, "");
5111 sv_catpvn(PL_thiswhite, s, d - s);
5125 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
5133 while (s < PL_bufend && SPACE_OR_TAB(*s))
5136 if (strnEQ(s,"=>",2)) {
5137 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
5138 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5139 OPERATOR('-'); /* unary minus */
5141 PL_last_uni = PL_oldbufptr;
5143 case 'r': ftst = OP_FTEREAD; break;
5144 case 'w': ftst = OP_FTEWRITE; break;
5145 case 'x': ftst = OP_FTEEXEC; break;
5146 case 'o': ftst = OP_FTEOWNED; break;
5147 case 'R': ftst = OP_FTRREAD; break;
5148 case 'W': ftst = OP_FTRWRITE; break;
5149 case 'X': ftst = OP_FTREXEC; break;
5150 case 'O': ftst = OP_FTROWNED; break;
5151 case 'e': ftst = OP_FTIS; break;
5152 case 'z': ftst = OP_FTZERO; break;
5153 case 's': ftst = OP_FTSIZE; break;
5154 case 'f': ftst = OP_FTFILE; break;
5155 case 'd': ftst = OP_FTDIR; break;
5156 case 'l': ftst = OP_FTLINK; break;
5157 case 'p': ftst = OP_FTPIPE; break;
5158 case 'S': ftst = OP_FTSOCK; break;
5159 case 'u': ftst = OP_FTSUID; break;
5160 case 'g': ftst = OP_FTSGID; break;
5161 case 'k': ftst = OP_FTSVTX; break;
5162 case 'b': ftst = OP_FTBLK; break;
5163 case 'c': ftst = OP_FTCHR; break;
5164 case 't': ftst = OP_FTTTY; break;
5165 case 'T': ftst = OP_FTTEXT; break;
5166 case 'B': ftst = OP_FTBINARY; break;
5167 case 'M': case 'A': case 'C':
5168 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5170 case 'M': ftst = OP_FTMTIME; break;
5171 case 'A': ftst = OP_FTATIME; break;
5172 case 'C': ftst = OP_FTCTIME; break;
5180 PL_last_lop_op = (OPCODE)ftst;
5181 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5182 "### Saw file test %c\n", (int)tmp);
5187 /* Assume it was a minus followed by a one-letter named
5188 * subroutine call (or a -bareword), then. */
5189 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5190 "### '-%c' looked like a file test but was not\n",
5197 const char tmp = *s++;
5200 if (PL_expect == XOPERATOR)
5205 else if (*s == '>') {
5208 if (isIDFIRST_lazy_if(s,UTF)) {
5209 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
5217 if (PL_expect == XOPERATOR) {
5218 if (*s == '=' && !PL_lex_allbrackets &&
5219 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5226 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5228 OPERATOR('-'); /* unary minus */
5234 const char tmp = *s++;
5237 if (PL_expect == XOPERATOR)
5242 if (PL_expect == XOPERATOR) {
5243 if (*s == '=' && !PL_lex_allbrackets &&
5244 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5251 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5258 if (PL_expect != XOPERATOR) {
5259 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5260 PL_expect = XOPERATOR;
5261 force_ident(PL_tokenbuf, '*');
5269 if (*s == '=' && !PL_lex_allbrackets &&
5270 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5276 if (*s == '=' && !PL_lex_allbrackets &&
5277 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5284 if (PL_expect == XOPERATOR) {
5285 if (s[1] == '=' && !PL_lex_allbrackets &&
5286 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5291 PL_tokenbuf[0] = '%';
5292 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5293 sizeof PL_tokenbuf - 1, FALSE);
5294 if (!PL_tokenbuf[1]) {
5297 PL_pending_ident = '%';
5301 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5302 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5307 if (PL_lex_brackets > 100)
5308 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5309 PL_lex_brackstack[PL_lex_brackets++] = 0;
5310 PL_lex_allbrackets++;
5312 const char tmp = *s++;
5317 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5319 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5327 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5334 goto just_a_word_zero_gv;
5337 switch (PL_expect) {
5343 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5345 PL_bufptr = s; /* update in case we back off */
5348 "Use of := for an empty attribute list is not allowed");
5355 PL_expect = XTERMBLOCK;
5358 stuffstart = s - SvPVX(PL_linestr) - 1;
5362 while (isIDFIRST_lazy_if(s,UTF)) {
5365 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5366 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5367 if (tmp < 0) tmp = -tmp;
5382 sv = newSVpvn(s, len);
5384 d = scan_str(d,TRUE,TRUE);
5386 /* MUST advance bufptr here to avoid bogus
5387 "at end of line" context messages from yyerror().
5389 PL_bufptr = s + len;
5390 yyerror("Unterminated attribute parameter in attribute list");
5394 return REPORT(0); /* EOF indicator */
5398 sv_catsv(sv, PL_lex_stuff);
5399 attrs = op_append_elem(OP_LIST, attrs,
5400 newSVOP(OP_CONST, 0, sv));
5401 SvREFCNT_dec(PL_lex_stuff);
5402 PL_lex_stuff = NULL;
5405 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5407 if (PL_in_my == KEY_our) {
5408 deprecate(":unique");
5411 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5414 /* NOTE: any CV attrs applied here need to be part of
5415 the CVf_BUILTIN_ATTRS define in cv.h! */
5416 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5418 CvLVALUE_on(PL_compcv);
5420 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5422 deprecate(":locked");
5424 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5426 CvMETHOD_on(PL_compcv);
5428 /* After we've set the flags, it could be argued that
5429 we don't need to do the attributes.pm-based setting
5430 process, and shouldn't bother appending recognized
5431 flags. To experiment with that, uncomment the
5432 following "else". (Note that's already been
5433 uncommented. That keeps the above-applied built-in
5434 attributes from being intercepted (and possibly
5435 rejected) by a package's attribute routines, but is
5436 justified by the performance win for the common case
5437 of applying only built-in attributes.) */
5439 attrs = op_append_elem(OP_LIST, attrs,
5440 newSVOP(OP_CONST, 0,
5444 if (*s == ':' && s[1] != ':')
5447 break; /* require real whitespace or :'s */
5448 /* XXX losing whitespace on sequential attributes here */
5452 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5453 if (*s != ';' && *s != '}' && *s != tmp
5454 && (tmp != '=' || *s != ')')) {
5455 const char q = ((*s == '\'') ? '"' : '\'');
5456 /* If here for an expression, and parsed no attrs, back
5458 if (tmp == '=' && !attrs) {
5462 /* MUST advance bufptr here to avoid bogus "at end of line"
5463 context messages from yyerror().
5466 yyerror( (const char *)
5468 ? Perl_form(aTHX_ "Invalid separator character "
5469 "%c%c%c in attribute list", q, *s, q)
5470 : "Unterminated attribute list" ) );
5478 start_force(PL_curforce);
5479 NEXTVAL_NEXTTOKE.opval = attrs;
5480 CURMAD('_', PL_nextwhite);
5485 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
5486 (s - SvPVX(PL_linestr)) - stuffstart);
5491 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5495 PL_lex_allbrackets--;
5499 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5500 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5504 PL_lex_allbrackets++;
5507 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5513 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5516 PL_lex_allbrackets--;
5522 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5525 if (PL_lex_brackets <= 0)
5526 yyerror("Unmatched right square bracket");
5529 PL_lex_allbrackets--;
5530 if (PL_lex_state == LEX_INTERPNORMAL) {
5531 if (PL_lex_brackets == 0) {
5532 if (*s == '-' && s[1] == '>')
5533 PL_lex_state = LEX_INTERPENDMAYBE;
5534 else if (*s != '[' && *s != '{')
5535 PL_lex_state = LEX_INTERPEND;
5542 if (PL_lex_brackets > 100) {
5543 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5545 switch (PL_expect) {
5547 if (PL_lex_formbrack) {
5551 if (PL_oldoldbufptr == PL_last_lop)
5552 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5554 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5555 PL_lex_allbrackets++;
5556 OPERATOR(HASHBRACK);
5558 while (s < PL_bufend && SPACE_OR_TAB(*s))
5561 PL_tokenbuf[0] = '\0';
5562 if (d < PL_bufend && *d == '-') {
5563 PL_tokenbuf[0] = '-';
5565 while (d < PL_bufend && SPACE_OR_TAB(*d))
5568 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5569 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5571 while (d < PL_bufend && SPACE_OR_TAB(*d))
5574 const char minus = (PL_tokenbuf[0] == '-');
5575 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
5583 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5584 PL_lex_allbrackets++;
5589 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5590 PL_lex_allbrackets++;
5595 if (PL_oldoldbufptr == PL_last_lop)
5596 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5598 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5599 PL_lex_allbrackets++;
5602 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5604 /* This hack is to get the ${} in the message. */
5606 yyerror("syntax error");
5609 OPERATOR(HASHBRACK);
5611 /* This hack serves to disambiguate a pair of curlies
5612 * as being a block or an anon hash. Normally, expectation
5613 * determines that, but in cases where we're not in a
5614 * position to expect anything in particular (like inside
5615 * eval"") we have to resolve the ambiguity. This code
5616 * covers the case where the first term in the curlies is a
5617 * quoted string. Most other cases need to be explicitly
5618 * disambiguated by prepending a "+" before the opening
5619 * curly in order to force resolution as an anon hash.
5621 * XXX should probably propagate the outer expectation
5622 * into eval"" to rely less on this hack, but that could
5623 * potentially break current behavior of eval"".
5627 if (*s == '\'' || *s == '"' || *s == '`') {
5628 /* common case: get past first string, handling escapes */
5629 for (t++; t < PL_bufend && *t != *s;)
5630 if (*t++ == '\\' && (*t == '\\' || *t == *s))
5634 else if (*s == 'q') {
5637 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5640 /* skip q//-like construct */
5642 char open, close, term;
5645 while (t < PL_bufend && isSPACE(*t))
5647 /* check for q => */
5648 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5649 OPERATOR(HASHBRACK);
5653 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5657 for (t++; t < PL_bufend; t++) {
5658 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5660 else if (*t == open)
5664 for (t++; t < PL_bufend; t++) {
5665 if (*t == '\\' && t+1 < PL_bufend)
5667 else if (*t == close && --brackets <= 0)
5669 else if (*t == open)
5676 /* skip plain q word */
5677 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5680 else if (isALNUM_lazy_if(t,UTF)) {
5682 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5685 while (t < PL_bufend && isSPACE(*t))
5687 /* if comma follows first term, call it an anon hash */
5688 /* XXX it could be a comma expression with loop modifiers */
5689 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5690 || (*t == '=' && t[1] == '>')))
5691 OPERATOR(HASHBRACK);
5692 if (PL_expect == XREF)
5695 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5701 pl_yylval.ival = CopLINE(PL_curcop);
5702 if (isSPACE(*s) || *s == '#')
5703 PL_copline = NOLINE; /* invalidate current command line number */
5706 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5710 if (PL_lex_brackets <= 0)
5711 yyerror("Unmatched right curly bracket");
5713 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5714 PL_lex_allbrackets--;
5715 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
5716 PL_lex_formbrack = 0;
5717 if (PL_lex_state == LEX_INTERPNORMAL) {
5718 if (PL_lex_brackets == 0) {
5719 if (PL_expect & XFAKEBRACK) {
5720 PL_expect &= XENUMMASK;
5721 PL_lex_state = LEX_INTERPEND;
5726 PL_thiswhite = newSVpvs("");
5727 sv_catpvs(PL_thiswhite,"}");
5730 return yylex(); /* ignore fake brackets */
5732 if (*s == '-' && s[1] == '>')
5733 PL_lex_state = LEX_INTERPENDMAYBE;
5734 else if (*s != '[' && *s != '{')
5735 PL_lex_state = LEX_INTERPEND;
5738 if (PL_expect & XFAKEBRACK) {
5739 PL_expect &= XENUMMASK;
5741 return yylex(); /* ignore fake brackets */
5743 start_force(PL_curforce);
5745 curmad('X', newSVpvn(s-1,1));
5746 CURMAD('_', PL_thiswhite);
5751 PL_thistoken = newSVpvs("");
5757 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5758 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5765 if (PL_expect == XOPERATOR) {
5766 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5767 && isIDFIRST_lazy_if(s,UTF))
5769 CopLINE_dec(PL_curcop);
5770 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5771 CopLINE_inc(PL_curcop);
5773 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5774 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5781 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5783 PL_expect = XOPERATOR;
5784 force_ident(PL_tokenbuf, '&');
5788 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5794 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5795 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5802 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5803 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5811 const char tmp = *s++;
5813 if (!PL_lex_allbrackets &&
5814 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5821 if (!PL_lex_allbrackets &&
5822 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5830 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5831 && strchr("+-*/%.^&|<",tmp))
5832 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5833 "Reversed %c= operator",(int)tmp);
5835 if (PL_expect == XSTATE && isALPHA(tmp) &&
5836 (s == PL_linestart+1 || s[-2] == '\n') )
5838 if (PL_in_eval && !PL_rsfp) {
5843 if (strnEQ(s,"=cut",4)) {
5859 PL_thiswhite = newSVpvs("");
5860 sv_catpvn(PL_thiswhite, PL_linestart,
5861 PL_bufend - PL_linestart);
5865 PL_parser->in_pod = 1;
5869 if (PL_lex_brackets < PL_lex_formbrack) {
5871 #ifdef PERL_STRICT_CR
5872 while (SPACE_OR_TAB(*t))
5874 while (SPACE_OR_TAB(*t) || *t == '\r')
5877 if (*t == '\n' || *t == '#') {
5883 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5892 const char tmp = *s++;
5894 /* was this !=~ where !~ was meant?
5895 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5897 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5898 const char *t = s+1;
5900 while (t < PL_bufend && isSPACE(*t))
5903 if (*t == '/' || *t == '?' ||
5904 ((*t == 'm' || *t == 's' || *t == 'y')
5905 && !isALNUM(t[1])) ||
5906 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
5907 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5908 "!=~ should be !~");
5910 if (!PL_lex_allbrackets &&
5911 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5923 if (PL_expect != XOPERATOR) {
5924 if (s[1] != '<' && !strchr(s,'>'))
5927 s = scan_heredoc(s);
5929 s = scan_inputsymbol(s);
5930 TERM(sublex_start());
5936 if (*s == '=' && !PL_lex_allbrackets &&
5937 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5941 SHop(OP_LEFT_SHIFT);
5946 if (!PL_lex_allbrackets &&
5947 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5954 if (!PL_lex_allbrackets &&
5955 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5963 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5971 const char tmp = *s++;
5973 if (*s == '=' && !PL_lex_allbrackets &&
5974 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5978 SHop(OP_RIGHT_SHIFT);
5980 else if (tmp == '=') {
5981 if (!PL_lex_allbrackets &&
5982 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5990 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5999 if (PL_expect == XOPERATOR) {
6000 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6001 return deprecate_commaless_var_list();
6005 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6006 PL_tokenbuf[0] = '@';
6007 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6008 sizeof PL_tokenbuf - 1, FALSE);
6009 if (PL_expect == XOPERATOR)
6010 no_op("Array length", s);
6011 if (!PL_tokenbuf[1])
6013 PL_expect = XOPERATOR;
6014 PL_pending_ident = '#';
6018 PL_tokenbuf[0] = '$';
6019 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6020 sizeof PL_tokenbuf - 1, FALSE);
6021 if (PL_expect == XOPERATOR)
6023 if (!PL_tokenbuf[1]) {
6025 yyerror("Final $ should be \\$ or $name");
6031 const char tmp = *s;
6032 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6035 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6036 && intuit_more(s)) {
6038 PL_tokenbuf[0] = '@';
6039 if (ckWARN(WARN_SYNTAX)) {
6042 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
6045 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6046 while (t < PL_bufend && *t != ']')
6048 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6049 "Multidimensional syntax %.*s not supported",
6050 (int)((t - PL_bufptr) + 1), PL_bufptr);
6054 else if (*s == '{') {
6056 PL_tokenbuf[0] = '%';
6057 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6058 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6060 char tmpbuf[sizeof PL_tokenbuf];
6063 } while (isSPACE(*t));
6064 if (isIDFIRST_lazy_if(t,UTF)) {
6066 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6070 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
6071 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6072 "You need to quote \"%s\"",
6079 PL_expect = XOPERATOR;
6080 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6081 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6082 if (!islop || PL_last_lop_op == OP_GREPSTART)
6083 PL_expect = XOPERATOR;
6084 else if (strchr("$@\"'`q", *s))
6085 PL_expect = XTERM; /* e.g. print $fh "foo" */
6086 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6087 PL_expect = XTERM; /* e.g. print $fh &sub */
6088 else if (isIDFIRST_lazy_if(s,UTF)) {
6089 char tmpbuf[sizeof PL_tokenbuf];
6091 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6092 if ((t2 = keyword(tmpbuf, len, 0))) {
6093 /* binary operators exclude handle interpretations */
6105 PL_expect = XTERM; /* e.g. print $fh length() */
6110 PL_expect = XTERM; /* e.g. print $fh subr() */
6113 else if (isDIGIT(*s))
6114 PL_expect = XTERM; /* e.g. print $fh 3 */
6115 else if (*s == '.' && isDIGIT(s[1]))
6116 PL_expect = XTERM; /* e.g. print $fh .3 */
6117 else if ((*s == '?' || *s == '-' || *s == '+')
6118 && !isSPACE(s[1]) && s[1] != '=')
6119 PL_expect = XTERM; /* e.g. print $fh -1 */
6120 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6122 PL_expect = XTERM; /* e.g. print $fh /.../
6123 XXX except DORDOR operator
6125 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6127 PL_expect = XTERM; /* print $fh <<"EOF" */
6130 PL_pending_ident = '$';
6134 if (PL_expect == XOPERATOR)
6136 PL_tokenbuf[0] = '@';
6137 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6138 if (!PL_tokenbuf[1]) {
6141 if (PL_lex_state == LEX_NORMAL)
6143 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6145 PL_tokenbuf[0] = '%';
6147 /* Warn about @ where they meant $. */
6148 if (*s == '[' || *s == '{') {
6149 if (ckWARN(WARN_SYNTAX)) {
6150 const char *t = s + 1;
6151 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6153 if (*t == '}' || *t == ']') {
6155 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6156 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6157 "Scalar value %.*s better written as $%.*s",
6158 (int)(t-PL_bufptr), PL_bufptr,
6159 (int)(t-PL_bufptr-1), PL_bufptr+1);
6164 PL_pending_ident = '@';
6167 case '/': /* may be division, defined-or, or pattern */
6168 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6169 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6170 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6175 case '?': /* may either be conditional or pattern */
6176 if (PL_expect == XOPERATOR) {
6179 if (!PL_lex_allbrackets &&
6180 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6184 PL_lex_allbrackets++;
6190 /* A // operator. */
6191 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6192 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6193 LEX_FAKEEOF_LOGIC)) {
6201 if (*s == '=' && !PL_lex_allbrackets &&
6202 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6211 /* Disable warning on "study /blah/" */
6212 if (PL_oldoldbufptr == PL_last_uni
6213 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6214 || memNE(PL_last_uni, "study", 5)
6215 || isALNUM_lazy_if(PL_last_uni+5,UTF)
6219 deprecate("?PATTERN? without explicit operator");
6220 s = scan_pat(s,OP_MATCH);
6221 TERM(sublex_start());
6225 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6226 #ifdef PERL_STRICT_CR
6229 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6231 && (s == PL_linestart || s[-1] == '\n') )
6233 PL_lex_formbrack = 0;
6237 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6241 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6244 if (!PL_lex_allbrackets &&
6245 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6252 pl_yylval.ival = OPf_SPECIAL;
6258 if (*s == '=' && !PL_lex_allbrackets &&
6259 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6266 case '0': case '1': case '2': case '3': case '4':
6267 case '5': case '6': case '7': case '8': case '9':
6268 s = scan_num(s, &pl_yylval);
6269 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6270 if (PL_expect == XOPERATOR)
6275 s = scan_str(s,!!PL_madskills,FALSE);
6276 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6277 if (PL_expect == XOPERATOR) {
6278 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6279 return deprecate_commaless_var_list();
6286 pl_yylval.ival = OP_CONST;
6287 TERM(sublex_start());
6290 s = scan_str(s,!!PL_madskills,FALSE);
6291 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6292 if (PL_expect == XOPERATOR) {
6293 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6294 return deprecate_commaless_var_list();
6301 pl_yylval.ival = OP_CONST;
6302 /* FIXME. I think that this can be const if char *d is replaced by
6303 more localised variables. */
6304 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6305 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6306 pl_yylval.ival = OP_STRINGIFY;
6310 TERM(sublex_start());
6313 s = scan_str(s,!!PL_madskills,FALSE);
6314 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6315 if (PL_expect == XOPERATOR)
6316 no_op("Backticks",s);
6319 readpipe_override();
6320 TERM(sublex_start());
6324 if (PL_lex_inwhat && isDIGIT(*s))
6325 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6327 if (PL_expect == XOPERATOR)
6328 no_op("Backslash",s);
6332 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6333 char *start = s + 2;
6334 while (isDIGIT(*start) || *start == '_')
6336 if (*start == '.' && isDIGIT(start[1])) {
6337 s = scan_num(s, &pl_yylval);
6340 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6341 else if (!isALPHA(*start) && (PL_expect == XTERM
6342 || PL_expect == XREF || PL_expect == XSTATE
6343 || PL_expect == XTERMORDORDOR)) {
6344 GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
6346 s = scan_num(s, &pl_yylval);
6353 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6396 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6398 /* Some keywords can be followed by any delimiter, including ':' */
6399 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6401 /* x::* is just a word, unless x is "CORE" */
6402 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6406 while (d < PL_bufend && isSPACE(*d))
6407 d++; /* no comments skipped here, or s### is misparsed */
6409 /* Is this a word before a => operator? */
6410 if (*d == '=' && d[1] == '>') {
6413 = (OP*)newSVOP(OP_CONST, 0,
6414 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6415 pl_yylval.opval->op_private = OPpCONST_BARE;
6419 /* Check for plugged-in keyword */
6423 char *saved_bufptr = PL_bufptr;
6425 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6427 if (result == KEYWORD_PLUGIN_DECLINE) {
6428 /* not a plugged-in keyword */
6429 PL_bufptr = saved_bufptr;
6430 } else if (result == KEYWORD_PLUGIN_STMT) {
6431 pl_yylval.opval = o;
6434 return REPORT(PLUGSTMT);
6435 } else if (result == KEYWORD_PLUGIN_EXPR) {
6436 pl_yylval.opval = o;
6438 PL_expect = XOPERATOR;
6439 return REPORT(PLUGEXPR);
6441 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6446 /* Check for built-in keyword */
6447 tmp = keyword(PL_tokenbuf, len, 0);
6449 /* Is this a label? */
6450 if (!anydelim && PL_expect == XSTATE
6451 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6453 pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
6458 if (tmp < 0) { /* second-class keyword? */
6459 GV *ogv = NULL; /* override (winner) */
6460 GV *hgv = NULL; /* hidden (loser) */
6461 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6463 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
6466 if (GvIMPORTED_CV(gv))
6468 else if (! CvMETHOD(cv))
6472 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
6473 (gv = *gvp) && isGV_with_GP(gv) &&
6474 GvCVu(gv) && GvIMPORTED_CV(gv))
6481 tmp = 0; /* overridden by import or by GLOBAL */
6484 && -tmp==KEY_lock /* XXX generalizable kludge */
6487 tmp = 0; /* any sub overrides "weak" keyword */
6489 else { /* no override */
6491 if (tmp == KEY_dump) {
6492 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6493 "dump() better written as CORE::dump()");
6497 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
6498 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6499 "Ambiguous call resolved as CORE::%s(), "
6500 "qualify as such or use &",
6508 default: /* not a keyword */
6509 /* Trade off - by using this evil construction we can pull the
6510 variable gv into the block labelled keylookup. If not, then
6511 we have to give it function scope so that the goto from the
6512 earlier ':' case doesn't bypass the initialisation. */
6514 just_a_word_zero_gv:
6522 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6526 SV *nextPL_nextwhite = 0;
6530 /* Get the rest if it looks like a package qualifier */
6532 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6534 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6537 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
6538 *s == '\'' ? "'" : "::");
6543 if (PL_expect == XOPERATOR) {
6544 if (PL_bufptr == PL_linestart) {
6545 CopLINE_dec(PL_curcop);
6546 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6547 CopLINE_inc(PL_curcop);
6550 no_op("Bareword",s);
6553 /* Look for a subroutine with this name in current package,
6554 unless name is "Foo::", in which case Foo is a bareword
6555 (and a package name). */
6557 if (len > 2 && !PL_madskills &&
6558 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6560 if (ckWARN(WARN_BAREWORD)
6561 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
6562 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6563 "Bareword \"%s\" refers to nonexistent package",
6566 PL_tokenbuf[len] = '\0';
6572 /* Mustn't actually add anything to a symbol table.
6573 But also don't want to "initialise" any placeholder
6574 constants that might already be there into full
6575 blown PVGVs with attached PVCV. */
6576 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6577 GV_NOADD_NOINIT, SVt_PVCV);
6582 /* if we saw a global override before, get the right name */
6584 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6585 len ? len : strlen(PL_tokenbuf));
6587 SV * const tmp_sv = sv;
6588 sv = newSVpvs("CORE::GLOBAL::");
6589 sv_catsv(sv, tmp_sv);
6590 SvREFCNT_dec(tmp_sv);
6594 if (PL_madskills && !PL_thistoken) {
6595 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
6596 PL_thistoken = newSVpvn(start,s - start);
6597 PL_realtokenstart = s - SvPVX(PL_linestr);
6601 /* Presume this is going to be a bareword of some sort. */
6603 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6604 pl_yylval.opval->op_private = OPpCONST_BARE;
6606 /* And if "Foo::", then that's what it certainly is. */
6611 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6612 const_op->op_private = OPpCONST_BARE;
6613 rv2cv_op = newCVREF(0, const_op);
6615 cv = rv2cv_op_cv(rv2cv_op, 0);
6617 /* See if it's the indirect object for a list operator. */
6619 if (PL_oldoldbufptr &&
6620 PL_oldoldbufptr < PL_bufptr &&
6621 (PL_oldoldbufptr == PL_last_lop
6622 || PL_oldoldbufptr == PL_last_uni) &&
6623 /* NO SKIPSPACE BEFORE HERE! */
6624 (PL_expect == XREF ||
6625 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6627 bool immediate_paren = *s == '(';
6629 /* (Now we can afford to cross potential line boundary.) */
6630 s = SKIPSPACE2(s,nextPL_nextwhite);
6632 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
6635 /* Two barewords in a row may indicate method call. */
6637 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6638 (tmp = intuit_method(s, gv, cv))) {
6640 if (tmp == METHOD && !PL_lex_allbrackets &&
6641 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6642 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6646 /* If not a declared subroutine, it's an indirect object. */
6647 /* (But it's an indir obj regardless for sort.) */
6648 /* Also, if "_" follows a filetest operator, it's a bareword */
6651 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6653 (PL_last_lop_op != OP_MAPSTART &&
6654 PL_last_lop_op != OP_GREPSTART))))
6655 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6656 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6659 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6664 PL_expect = XOPERATOR;
6667 s = SKIPSPACE2(s,nextPL_nextwhite);
6668 PL_nextwhite = nextPL_nextwhite;
6673 /* Is this a word before a => operator? */
6674 if (*s == '=' && s[1] == '>' && !pkgname) {
6677 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
6678 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
6679 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
6683 /* If followed by a paren, it's certainly a subroutine. */
6688 while (SPACE_OR_TAB(*d))
6690 if (*d == ')' && (sv = cv_const_sv(cv))) {
6697 PL_nextwhite = PL_thiswhite;
6700 start_force(PL_curforce);
6702 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6703 PL_expect = XOPERATOR;
6706 PL_nextwhite = nextPL_nextwhite;
6707 curmad('X', PL_thistoken);
6708 PL_thistoken = newSVpvs("");
6717 /* If followed by var or block, call it a method (unless sub) */
6719 if ((*s == '$' || *s == '{') && !cv) {
6721 PL_last_lop = PL_oldbufptr;
6722 PL_last_lop_op = OP_METHOD;
6723 if (!PL_lex_allbrackets &&
6724 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6725 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6729 /* If followed by a bareword, see if it looks like indir obj. */
6732 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6733 && (tmp = intuit_method(s, gv, cv))) {
6735 if (tmp == METHOD && !PL_lex_allbrackets &&
6736 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6737 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6741 /* Not a method, so call it a subroutine (if defined) */
6744 if (lastchar == '-')
6745 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6746 "Ambiguous use of -%s resolved as -&%s()",
6747 PL_tokenbuf, PL_tokenbuf);
6748 /* Check for a constant sub */
6749 if ((sv = cv_const_sv(cv))) {
6752 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6753 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6754 pl_yylval.opval->op_private = 0;
6755 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6759 op_free(pl_yylval.opval);
6760 pl_yylval.opval = rv2cv_op;
6761 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6762 PL_last_lop = PL_oldbufptr;
6763 PL_last_lop_op = OP_ENTERSUB;
6764 /* Is there a prototype? */
6772 const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
6775 while (*proto == ';')
6780 *proto == '$' || *proto == '_'
6781 || *proto == '*' || *proto == '+'
6786 *proto == '\\' && proto[1] && proto[2] == '\0'
6790 if (*proto == '\\' && proto[1] == '[') {
6791 const char *p = proto + 2;
6792 while(*p && *p != ']')
6794 if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
6796 if (*proto == '&' && *s == '{') {
6798 sv_setpvs(PL_subname, "__ANON__");
6800 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6801 if (!PL_lex_allbrackets &&
6802 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6803 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6810 PL_nextwhite = PL_thiswhite;
6813 start_force(PL_curforce);
6814 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6817 PL_nextwhite = nextPL_nextwhite;
6818 curmad('X', PL_thistoken);
6819 PL_thistoken = newSVpvs("");
6822 if (!PL_lex_allbrackets &&
6823 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6824 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6829 /* Guess harder when madskills require "best effort". */
6830 if (PL_madskills && (!gv || !GvCVu(gv))) {
6831 int probable_sub = 0;
6832 if (strchr("\"'`$@%0123456789!*+{[<", *s))
6834 else if (isALPHA(*s)) {
6838 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
6839 if (!keyword(tmpbuf, tmplen, 0))
6842 while (d < PL_bufend && isSPACE(*d))
6844 if (*d == '=' && d[1] == '>')
6849 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
6850 op_free(pl_yylval.opval);
6851 pl_yylval.opval = rv2cv_op;
6852 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6853 PL_last_lop = PL_oldbufptr;
6854 PL_last_lop_op = OP_ENTERSUB;
6855 PL_nextwhite = PL_thiswhite;
6857 start_force(PL_curforce);
6858 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6860 PL_nextwhite = nextPL_nextwhite;
6861 curmad('X', PL_thistoken);
6862 PL_thistoken = newSVpvs("");
6864 if (!PL_lex_allbrackets &&
6865 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6866 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6870 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6873 if (!PL_lex_allbrackets &&
6874 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6875 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6880 /* Call it a bare word */
6882 if (PL_hints & HINT_STRICT_SUBS)
6883 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6886 /* after "print" and similar functions (corresponding to
6887 * "F? L" in opcode.pl), whatever wasn't already parsed as
6888 * a filehandle should be subject to "strict subs".
6889 * Likewise for the optional indirect-object argument to system
6890 * or exec, which can't be a bareword */
6891 if ((PL_last_lop_op == OP_PRINT
6892 || PL_last_lop_op == OP_PRTF
6893 || PL_last_lop_op == OP_SAY
6894 || PL_last_lop_op == OP_SYSTEM
6895 || PL_last_lop_op == OP_EXEC)
6896 && (PL_hints & HINT_STRICT_SUBS))
6897 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6898 if (lastchar != '-') {
6899 if (ckWARN(WARN_RESERVED)) {
6903 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
6904 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6912 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
6913 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6914 "Operator or semicolon missing before %c%s",
6915 lastchar, PL_tokenbuf);
6916 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6917 "Ambiguous use of %c resolved as operator %c",
6918 lastchar, lastchar);
6925 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
6930 (OP*)newSVOP(OP_CONST, 0,
6931 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
6934 case KEY___PACKAGE__:
6936 (OP*)newSVOP(OP_CONST, 0,
6938 ? newSVhek(HvNAME_HEK(PL_curstash))
6945 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
6946 const char *pname = "main";
6947 if (PL_tokenbuf[2] == 'D')
6948 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
6949 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
6953 GvIOp(gv) = newIO();
6954 IoIFP(GvIOp(gv)) = PL_rsfp;
6955 #if defined(HAS_FCNTL) && defined(F_SETFD)
6957 const int fd = PerlIO_fileno(PL_rsfp);
6958 fcntl(fd,F_SETFD,fd >= 3);
6961 /* Mark this internal pseudo-handle as clean */
6962 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
6963 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
6964 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
6966 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
6967 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
6968 /* if the script was opened in binmode, we need to revert
6969 * it to text mode for compatibility; but only iff it has CRs
6970 * XXX this is a questionable hack at best. */
6971 if (PL_bufend-PL_bufptr > 2
6972 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
6975 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
6976 loc = PerlIO_tell(PL_rsfp);
6977 (void)PerlIO_seek(PL_rsfp, 0L, 0);
6980 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
6982 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
6983 #endif /* NETWARE */
6985 PerlIO_seek(PL_rsfp, loc, 0);
6989 #ifdef PERLIO_LAYERS
6992 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
6993 else if (PL_encoding) {
7000 XPUSHs(PL_encoding);
7002 call_method("name", G_SCALAR);
7006 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7007 Perl_form(aTHX_ ":encoding(%"SVf")",
7016 if (PL_realtokenstart >= 0) {
7017 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7019 PL_endwhite = newSVpvs("");
7020 sv_catsv(PL_endwhite, PL_thiswhite);
7022 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7023 PL_realtokenstart = -1;
7025 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7041 if (PL_expect == XSTATE) {
7048 if (*s == ':' && s[1] == ':') {
7051 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7052 if (!(tmp = keyword(PL_tokenbuf, len, 1)))
7053 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
7056 else if (tmp == KEY_require || tmp == KEY_do)
7057 /* that's a way to remember we saw "CORE::" */
7070 LOP(OP_ACCEPT,XTERM);
7073 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7078 LOP(OP_ATAN2,XTERM);
7084 LOP(OP_BINMODE,XTERM);
7087 LOP(OP_BLESS,XTERM);
7096 /* We have to disambiguate the two senses of
7097 "continue". If the next token is a '{' then
7098 treat it as the start of a continue block;
7099 otherwise treat it as a control operator.
7109 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7119 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7128 if (!PL_cryptseen) {
7129 PL_cryptseen = TRUE;
7133 LOP(OP_CRYPT,XTERM);
7136 LOP(OP_CHMOD,XTERM);
7139 LOP(OP_CHOWN,XTERM);
7142 LOP(OP_CONNECT,XTERM);
7161 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7162 if (orig_keyword == KEY_do) {
7171 PL_hints |= HINT_BLOCK_SCOPE;
7181 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7182 STR_WITH_LEN("NDBM_File::"),
7183 STR_WITH_LEN("DB_File::"),
7184 STR_WITH_LEN("GDBM_File::"),
7185 STR_WITH_LEN("SDBM_File::"),
7186 STR_WITH_LEN("ODBM_File::"),
7188 LOP(OP_DBMOPEN,XTERM);
7194 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7201 pl_yylval.ival = CopLINE(PL_curcop);
7205 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7219 if (*s == '{') { /* block eval */
7220 PL_expect = XTERMBLOCK;
7221 UNIBRACK(OP_ENTERTRY);
7223 else { /* string eval */
7225 UNIBRACK(OP_ENTEREVAL);
7240 case KEY_endhostent:
7246 case KEY_endservent:
7249 case KEY_endprotoent:
7260 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7262 pl_yylval.ival = CopLINE(PL_curcop);
7264 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7267 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7270 if ((PL_bufend - p) >= 3 &&
7271 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7273 else if ((PL_bufend - p) >= 4 &&
7274 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7277 if (isIDFIRST_lazy_if(p,UTF)) {
7278 p = scan_ident(p, PL_bufend,
7279 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7283 Perl_croak(aTHX_ "Missing $ on loop variable");
7285 s = SvPVX(PL_linestr) + soff;
7291 LOP(OP_FORMLINE,XTERM);
7297 LOP(OP_FCNTL,XTERM);
7303 LOP(OP_FLOCK,XTERM);
7306 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7311 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7316 LOP(OP_GREPSTART, XREF);
7319 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7334 case KEY_getpriority:
7335 LOP(OP_GETPRIORITY,XTERM);
7337 case KEY_getprotobyname:
7340 case KEY_getprotobynumber:
7341 LOP(OP_GPBYNUMBER,XTERM);
7343 case KEY_getprotoent:
7355 case KEY_getpeername:
7356 UNI(OP_GETPEERNAME);
7358 case KEY_gethostbyname:
7361 case KEY_gethostbyaddr:
7362 LOP(OP_GHBYADDR,XTERM);
7364 case KEY_gethostent:
7367 case KEY_getnetbyname:
7370 case KEY_getnetbyaddr:
7371 LOP(OP_GNBYADDR,XTERM);
7376 case KEY_getservbyname:
7377 LOP(OP_GSBYNAME,XTERM);
7379 case KEY_getservbyport:
7380 LOP(OP_GSBYPORT,XTERM);
7382 case KEY_getservent:
7385 case KEY_getsockname:
7386 UNI(OP_GETSOCKNAME);
7388 case KEY_getsockopt:
7389 LOP(OP_GSOCKOPT,XTERM);
7404 pl_yylval.ival = CopLINE(PL_curcop);
7414 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7416 pl_yylval.ival = CopLINE(PL_curcop);
7420 LOP(OP_INDEX,XTERM);
7426 LOP(OP_IOCTL,XTERM);
7438 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7455 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7460 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7474 LOP(OP_LISTEN,XTERM);
7483 s = scan_pat(s,OP_MATCH);
7484 TERM(sublex_start());
7487 LOP(OP_MAPSTART, XREF);
7490 LOP(OP_MKDIR,XTERM);
7493 LOP(OP_MSGCTL,XTERM);
7496 LOP(OP_MSGGET,XTERM);
7499 LOP(OP_MSGRCV,XTERM);
7502 LOP(OP_MSGSND,XTERM);
7507 PL_in_my = (U16)tmp;
7509 if (isIDFIRST_lazy_if(s,UTF)) {
7513 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7514 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7516 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7517 if (!PL_in_my_stash) {
7520 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7524 if (PL_madskills) { /* just add type to declarator token */
7525 sv_catsv(PL_thistoken, PL_nextwhite);
7527 sv_catpvn(PL_thistoken, start, s - start);
7535 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7539 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7544 s = tokenize_use(0, s);
7548 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
7551 if (!PL_lex_allbrackets &&
7552 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7553 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7559 if (isIDFIRST_lazy_if(s,UTF)) {
7561 for (d = s; isALNUM_lazy_if(d,UTF);)
7563 for (t=d; isSPACE(*t);)
7565 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7567 && !(t[0] == '=' && t[1] == '>')
7569 int parms_len = (int)(d-s);
7570 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7571 "Precedence problem: open %.*s should be open(%.*s)",
7572 parms_len, s, parms_len, s);
7578 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7580 pl_yylval.ival = OP_OR;
7590 LOP(OP_OPEN_DIR,XTERM);
7593 checkcomma(s,PL_tokenbuf,"filehandle");
7597 checkcomma(s,PL_tokenbuf,"filehandle");
7616 s = force_word(s,WORD,FALSE,TRUE,FALSE);
7618 s = force_strict_version(s);
7619 PL_lex_expect = XBLOCK;
7623 LOP(OP_PIPE_OP,XTERM);
7626 s = scan_str(s,!!PL_madskills,FALSE);
7629 pl_yylval.ival = OP_CONST;
7630 TERM(sublex_start());
7637 s = scan_str(s,!!PL_madskills,FALSE);
7640 PL_expect = XOPERATOR;
7641 if (SvCUR(PL_lex_stuff)) {
7642 int warned_comma = !ckWARN(WARN_QW);
7643 int warned_comment = warned_comma;
7644 d = SvPV_force(PL_lex_stuff, len);
7646 for (; isSPACE(*d) && len; --len, ++d)
7651 if (!warned_comma || !warned_comment) {
7652 for (; !isSPACE(*d) && len; --len, ++d) {
7653 if (!warned_comma && *d == ',') {
7654 Perl_warner(aTHX_ packWARN(WARN_QW),
7655 "Possible attempt to separate words with commas");
7658 else if (!warned_comment && *d == '#') {
7659 Perl_warner(aTHX_ packWARN(WARN_QW),
7660 "Possible attempt to put comments in qw() list");
7666 for (; !isSPACE(*d) && len; --len, ++d)
7669 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7670 words = op_append_elem(OP_LIST, words,
7671 newSVOP(OP_CONST, 0, tokeq(sv)));
7676 words = newNULLLIST();
7678 SvREFCNT_dec(PL_lex_stuff);
7679 PL_lex_stuff = NULL;
7681 PL_expect = XOPERATOR;
7682 pl_yylval.opval = sawparens(words);
7687 s = scan_str(s,!!PL_madskills,FALSE);
7690 pl_yylval.ival = OP_STRINGIFY;
7691 if (SvIVX(PL_lex_stuff) == '\'')
7692 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7693 TERM(sublex_start());
7696 s = scan_pat(s,OP_QR);
7697 TERM(sublex_start());
7700 s = scan_str(s,!!PL_madskills,FALSE);
7703 readpipe_override();
7704 TERM(sublex_start());
7712 s = force_version(s, FALSE);
7714 else if (*s != 'v' || !isDIGIT(s[1])
7715 || (s = force_version(s, TRUE), *s == 'v'))
7717 *PL_tokenbuf = '\0';
7718 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7719 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7720 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
7722 yyerror("<> should be quotes");
7724 if (orig_keyword == KEY_require) {
7732 PL_last_uni = PL_oldbufptr;
7733 PL_last_lop_op = OP_REQUIRE;
7735 return REPORT( (int)REQUIRE );
7741 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7745 LOP(OP_RENAME,XTERM);
7754 LOP(OP_RINDEX,XTERM);
7763 UNIDOR(OP_READLINE);
7766 UNIDOR(OP_BACKTICK);
7775 LOP(OP_REVERSE,XTERM);
7778 UNIDOR(OP_READLINK);
7785 if (pl_yylval.opval)
7786 TERM(sublex_start());
7788 TOKEN(1); /* force error */
7791 checkcomma(s,PL_tokenbuf,"filehandle");
7801 LOP(OP_SELECT,XTERM);
7807 LOP(OP_SEMCTL,XTERM);
7810 LOP(OP_SEMGET,XTERM);
7813 LOP(OP_SEMOP,XTERM);
7819 LOP(OP_SETPGRP,XTERM);
7821 case KEY_setpriority:
7822 LOP(OP_SETPRIORITY,XTERM);
7824 case KEY_sethostent:
7830 case KEY_setservent:
7833 case KEY_setprotoent:
7843 LOP(OP_SEEKDIR,XTERM);
7845 case KEY_setsockopt:
7846 LOP(OP_SSOCKOPT,XTERM);
7852 LOP(OP_SHMCTL,XTERM);
7855 LOP(OP_SHMGET,XTERM);
7858 LOP(OP_SHMREAD,XTERM);
7861 LOP(OP_SHMWRITE,XTERM);
7864 LOP(OP_SHUTDOWN,XTERM);
7873 LOP(OP_SOCKET,XTERM);
7875 case KEY_socketpair:
7876 LOP(OP_SOCKPAIR,XTERM);
7879 checkcomma(s,PL_tokenbuf,"subroutine name");
7881 if (*s == ';' || *s == ')') /* probably a close */
7882 Perl_croak(aTHX_ "sort is now a reserved word");
7884 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7888 LOP(OP_SPLIT,XTERM);
7891 LOP(OP_SPRINTF,XTERM);
7894 LOP(OP_SPLICE,XTERM);
7909 LOP(OP_SUBSTR,XTERM);
7915 char tmpbuf[sizeof PL_tokenbuf];
7916 SSize_t tboffset = 0;
7917 expectation attrful;
7918 bool have_name, have_proto;
7919 const int key = tmp;
7924 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7925 SV *subtoken = newSVpvn(tstart, s - tstart);
7929 s = SKIPSPACE2(s,tmpwhite);
7934 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
7935 (*s == ':' && s[1] == ':'))
7938 SV *nametoke = NULL;
7942 attrful = XATTRBLOCK;
7943 /* remember buffer pos'n for later force_word */
7944 tboffset = s - PL_oldbufptr;
7945 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
7948 nametoke = newSVpvn(s, d - s);
7950 if (memchr(tmpbuf, ':', len))
7951 sv_setpvn(PL_subname, tmpbuf, len);
7953 sv_setsv(PL_subname,PL_curstname);
7954 sv_catpvs(PL_subname,"::");
7955 sv_catpvn(PL_subname,tmpbuf,len);
7962 CURMAD('X', nametoke);
7963 CURMAD('_', tmpwhite);
7964 (void) force_word(PL_oldbufptr + tboffset, WORD,
7967 s = SKIPSPACE2(d,tmpwhite);
7974 Perl_croak(aTHX_ "Missing name in \"my sub\"");
7975 PL_expect = XTERMBLOCK;
7976 attrful = XATTRTERM;
7977 sv_setpvs(PL_subname,"?");
7981 if (key == KEY_format) {
7983 PL_lex_formbrack = PL_lex_brackets + 1;
7985 PL_thistoken = subtoken;
7989 (void) force_word(PL_oldbufptr + tboffset, WORD,
7995 /* Look for a prototype */
7998 bool bad_proto = FALSE;
7999 bool in_brackets = FALSE;
8000 char greedy_proto = ' ';
8001 bool proto_after_greedy_proto = FALSE;
8002 bool must_be_last = FALSE;
8003 bool underscore = FALSE;
8004 bool seen_underscore = FALSE;
8005 const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
8007 s = scan_str(s,!!PL_madskills,FALSE);
8009 Perl_croak(aTHX_ "Prototype not terminated");
8010 /* strip spaces and check for bad characters */
8011 d = SvPVX(PL_lex_stuff);
8013 for (p = d; *p; ++p) {
8017 if (warnillegalproto) {
8019 proto_after_greedy_proto = TRUE;
8020 if (!strchr("$@%*;[]&\\_+", *p)) {
8032 else if ( *p == ']' ) {
8033 in_brackets = FALSE;
8035 else if ( (*p == '@' || *p == '%') &&
8036 ( tmp < 2 || d[tmp-2] != '\\' ) &&
8038 must_be_last = TRUE;
8041 else if ( *p == '_' ) {
8042 underscore = seen_underscore = TRUE;
8049 if (proto_after_greedy_proto)
8050 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8051 "Prototype after '%c' for %"SVf" : %s",
8052 greedy_proto, SVfARG(PL_subname), d);
8054 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8055 "Illegal character %sin prototype for %"SVf" : %s",
8056 seen_underscore ? "after '_' " : "",
8057 SVfARG(PL_subname), d);
8058 SvCUR_set(PL_lex_stuff, tmp);
8063 CURMAD('q', PL_thisopen);
8064 CURMAD('_', tmpwhite);
8065 CURMAD('=', PL_thisstuff);
8066 CURMAD('Q', PL_thisclose);
8067 NEXTVAL_NEXTTOKE.opval =
8068 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8069 PL_lex_stuff = NULL;
8072 s = SKIPSPACE2(s,tmpwhite);
8080 if (*s == ':' && s[1] != ':')
8081 PL_expect = attrful;
8082 else if (*s != '{' && key == KEY_sub) {
8084 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8085 else if (*s != ';' && *s != '}')
8086 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8093 curmad('^', newSVpvs(""));
8094 CURMAD('_', tmpwhite);
8098 PL_thistoken = subtoken;
8101 NEXTVAL_NEXTTOKE.opval =
8102 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8103 PL_lex_stuff = NULL;
8109 sv_setpvs(PL_subname, "__ANON__");
8111 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8115 (void) force_word(PL_oldbufptr + tboffset, WORD,
8124 LOP(OP_SYSTEM,XREF);
8127 LOP(OP_SYMLINK,XTERM);
8130 LOP(OP_SYSCALL,XTERM);
8133 LOP(OP_SYSOPEN,XTERM);
8136 LOP(OP_SYSSEEK,XTERM);
8139 LOP(OP_SYSREAD,XTERM);
8142 LOP(OP_SYSWRITE,XTERM);
8146 TERM(sublex_start());
8167 LOP(OP_TRUNCATE,XTERM);
8179 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8181 pl_yylval.ival = CopLINE(PL_curcop);
8185 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8187 pl_yylval.ival = CopLINE(PL_curcop);
8191 LOP(OP_UNLINK,XTERM);
8197 LOP(OP_UNPACK,XTERM);
8200 LOP(OP_UTIME,XTERM);
8206 LOP(OP_UNSHIFT,XTERM);
8209 s = tokenize_use(1, s);
8219 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8221 pl_yylval.ival = CopLINE(PL_curcop);
8225 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8227 pl_yylval.ival = CopLINE(PL_curcop);
8231 PL_hints |= HINT_BLOCK_SCOPE;
8238 LOP(OP_WAITPID,XTERM);
8247 ctl_l[0] = toCTRL('L');
8249 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8252 /* Make sure $^L is defined */
8253 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8258 if (PL_expect == XOPERATOR) {
8259 if (*s == '=' && !PL_lex_allbrackets &&
8260 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8268 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8270 pl_yylval.ival = OP_XOR;
8275 TERM(sublex_start());
8280 #pragma segment Main
8284 S_pending_ident(pTHX)
8289 /* pit holds the identifier we read and pending_ident is reset */
8290 char pit = PL_pending_ident;
8291 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8292 /* All routes through this function want to know if there is a colon. */
8293 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8294 PL_pending_ident = 0;
8296 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
8297 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8298 "### Pending identifier '%s'\n", PL_tokenbuf); });
8300 /* if we're in a my(), we can't allow dynamics here.
8301 $foo'bar has already been turned into $foo::bar, so
8302 just check for colons.
8304 if it's a legal name, the OP is a PADANY.
8307 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8309 yyerror(Perl_form(aTHX_ "No package name allowed for "
8310 "variable %s in \"our\"",
8312 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8316 yyerror(Perl_form(aTHX_ PL_no_myglob,
8317 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
8319 pl_yylval.opval = newOP(OP_PADANY, 0);
8320 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8321 UTF ? SVf_UTF8 : 0);
8327 build the ops for accesses to a my() variable.
8329 Deny my($a) or my($b) in a sort block, *if* $a or $b is
8330 then used in a comparison. This catches most, but not
8331 all cases. For instance, it catches
8332 sort { my($a); $a <=> $b }
8334 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
8335 (although why you'd do that is anyone's guess).
8340 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8341 UTF ? SVf_UTF8 : 0);
8342 if (tmp != NOT_IN_PAD) {
8343 /* might be an "our" variable" */
8344 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8345 /* build ops for a bareword */
8346 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8347 HEK * const stashname = HvNAME_HEK(stash);
8348 SV * const sym = newSVhek(stashname);
8349 sv_catpvs(sym, "::");
8350 sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
8351 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8352 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8355 ? (GV_ADDMULTI | GV_ADDINEVAL)
8358 ((PL_tokenbuf[0] == '$') ? SVt_PV
8359 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8364 /* if it's a sort block and they're naming $a or $b */
8365 if (PL_last_lop_op == OP_SORT &&
8366 PL_tokenbuf[0] == '$' &&
8367 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
8370 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
8371 d < PL_bufend && *d != '\n';
8374 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
8375 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
8381 pl_yylval.opval = newOP(OP_PADANY, 0);
8382 pl_yylval.opval->op_targ = tmp;
8388 Whine if they've said @foo in a doublequoted string,
8389 and @foo isn't a variable we can find in the symbol
8392 if (ckWARN(WARN_AMBIGUOUS) &&
8393 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8394 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
8396 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8397 /* DO NOT warn for @- and @+ */
8398 && !( PL_tokenbuf[2] == '\0' &&
8399 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8402 /* Downgraded from fatal to warning 20000522 mjd */
8403 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8404 "Possible unintended interpolation of %s in string",
8409 /* build ops for a bareword */
8410 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
8412 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8413 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8414 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD,
8415 ((PL_tokenbuf[0] == '$') ? SVt_PV
8416 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8422 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8426 PERL_ARGS_ASSERT_CHECKCOMMA;
8428 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8429 if (ckWARN(WARN_SYNTAX)) {
8432 for (w = s+2; *w && level; w++) {
8440 /* the list of chars below is for end of statements or
8441 * block / parens, boolean operators (&&, ||, //) and branch
8442 * constructs (or, and, if, until, unless, while, err, for).
8443 * Not a very solid hack... */
8444 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8445 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8446 "%s (...) interpreted as function",name);
8449 while (s < PL_bufend && isSPACE(*s))
8453 while (s < PL_bufend && isSPACE(*s))
8455 if (isIDFIRST_lazy_if(s,UTF)) {
8456 const char * const w = s++;
8457 while (isALNUM_lazy_if(s,UTF))
8459 while (s < PL_bufend && isSPACE(*s))
8463 if (keyword(w, s - w, 0))
8466 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
8467 if (gv && GvCVu(gv))
8469 Perl_croak(aTHX_ "No comma allowed after %s", what);
8474 /* Either returns sv, or mortalizes sv and returns a new SV*.
8475 Best used as sv=new_constant(..., sv, ...).
8476 If s, pv are NULL, calls subroutine with one argument,
8477 and type is used with error messages only. */
8480 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8481 SV *sv, SV *pv, const char *type, STRLEN typelen)
8484 HV * const table = GvHV(PL_hintgv); /* ^H */
8488 const char *why1 = "", *why2 = "", *why3 = "";
8490 PERL_ARGS_ASSERT_NEW_CONSTANT;
8492 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8495 why2 = (const char *)
8496 (strEQ(key,"charnames")
8497 ? "(possibly a missing \"use charnames ...\")"
8499 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
8500 (type ? type: "undef"), why2);
8502 /* This is convoluted and evil ("goto considered harmful")
8503 * but I do not understand the intricacies of all the different
8504 * failure modes of %^H in here. The goal here is to make
8505 * the most probable error message user-friendly. --jhi */
8510 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
8511 (type ? type: "undef"), why1, why2, why3);
8513 yyerror(SvPVX_const(msg));
8518 /* charnames doesn't work well if there have been errors found */
8519 if (PL_error_count > 0 && strEQ(key,"charnames"))
8520 return &PL_sv_undef;
8522 cvp = hv_fetch(table, key, keylen, FALSE);
8523 if (!cvp || !SvOK(*cvp)) {
8526 why3 = "} is not defined";
8529 sv_2mortal(sv); /* Parent created it permanently */
8532 pv = newSVpvn_flags(s, len, SVs_TEMP);
8534 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8536 typesv = &PL_sv_undef;
8538 PUSHSTACKi(PERLSI_OVERLOAD);
8550 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8554 /* Check the eval first */
8555 if (!PL_in_eval && SvTRUE(ERRSV)) {
8556 sv_catpvs(ERRSV, "Propagated");
8557 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
8559 res = SvREFCNT_inc_simple(sv);
8563 SvREFCNT_inc_simple_void(res);
8572 why1 = "Call to &{$^H{";
8574 why3 = "}} did not return a defined value";
8582 /* Returns a NUL terminated string, with the length of the string written to
8586 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8589 register char *d = dest;
8590 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8592 PERL_ARGS_ASSERT_SCAN_WORD;
8596 Perl_croak(aTHX_ ident_too_long);
8597 if (isALNUM(*s)) /* UTF handled below */
8599 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
8604 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
8608 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8609 char *t = s + UTF8SKIP(s);
8611 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8615 Perl_croak(aTHX_ ident_too_long);
8616 Copy(s, d, len, char);
8629 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
8632 char *bracket = NULL;
8634 register char *d = dest;
8635 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8637 PERL_ARGS_ASSERT_SCAN_IDENT;
8642 while (isDIGIT(*s)) {
8644 Perl_croak(aTHX_ ident_too_long);
8651 Perl_croak(aTHX_ ident_too_long);
8652 if (isALNUM(*s)) /* UTF handled below */
8654 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
8659 else if (*s == ':' && s[1] == ':') {
8663 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8664 char *t = s + UTF8SKIP(s);
8665 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8667 if (d + (t - s) > e)
8668 Perl_croak(aTHX_ ident_too_long);
8669 Copy(s, d, t - s, char);
8680 if (PL_lex_state != LEX_NORMAL)
8681 PL_lex_state = LEX_INTERPENDMAYBE;
8684 if (*s == '$' && s[1] &&
8685 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
8698 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8703 if (isSPACE(s[-1])) {
8705 const char ch = *s++;
8706 if (!SPACE_OR_TAB(ch)) {
8712 if (isIDFIRST_lazy_if(d,UTF)) {
8716 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
8717 end += UTF8SKIP(end);
8718 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
8719 end += UTF8SKIP(end);
8721 Copy(s, d, end - s, char);
8726 while ((isALNUM(*s) || *s == ':') && d < e)
8729 Perl_croak(aTHX_ ident_too_long);
8732 while (s < send && SPACE_OR_TAB(*s))
8734 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8735 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8736 const char * const brack =
8738 ((*s == '[') ? "[...]" : "{...}");
8739 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8740 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8741 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8742 funny, dest, brack, funny, dest, brack);
8745 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8746 PL_lex_allbrackets++;
8750 /* Handle extended ${^Foo} variables
8751 * 1999-02-27 mjd-perl-patch@plover.com */
8752 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
8756 while (isALNUM(*s) && d < e) {
8760 Perl_croak(aTHX_ ident_too_long);
8765 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8766 PL_lex_state = LEX_INTERPEND;
8769 if (PL_lex_state == LEX_NORMAL) {
8770 if (ckWARN(WARN_AMBIGUOUS) &&
8771 (keyword(dest, d - dest, 0)
8772 || get_cvn_flags(dest, d - dest, 0)))
8776 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8777 "Ambiguous use of %c{%s} resolved to %c%s",
8778 funny, dest, funny, dest);
8783 s = bracket; /* let the parser handle it */
8787 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8788 PL_lex_state = LEX_INTERPEND;
8793 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
8795 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
8796 * the parse starting at 's', based on the subset that are valid in this
8797 * context input to this routine in 'valid_flags'. Advances s. Returns
8798 * TRUE if the input was a valid flag, so the next char may be as well;
8799 * otherwise FALSE. 'charset' should point to a NUL upon first call on the
8800 * current regex. This routine will set it to any charset modifier found.
8801 * The caller shouldn't change it. This way, another charset modifier
8802 * encountered in the parse can be detected as an error, as we have decided
8807 if (! strchr(valid_flags, c)) {
8816 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
8817 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8818 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8819 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8820 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8821 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8822 case LOCALE_PAT_MOD:
8824 /* In 5.14, qr//lt is legal but deprecated; the 't' means they
8825 * can't be regex modifiers.
8826 * In 5.14, s///le is legal and ambiguous. Try to disambiguate as
8827 * much as easily done. s///lei, for example, has to mean regex
8828 * modifiers if it's not an error (as does any word character
8829 * following the 'e'). Otherwise, we resolve to the backwards-
8830 * compatible, but less likely 's/// le ...', i.e. as meaning
8831 * less-than-or-equal. The reason it's not likely is that s//
8832 * returns a number for code in the field (/r returns a string, but
8833 * that wasn't added until the 5.13 series), and so '<=' should be
8834 * used for comparing, not 'le'. */
8835 if (*((*s) + 1) == 't') {
8838 else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) {
8840 /* 'e' is valid only for substitutes, s///e. If it is not
8841 * valid in the current context, then 'm//le' must mean the
8842 * comparison operator, so use the regular deprecation message.
8844 if (! strchr(valid_flags, 'e')) {
8847 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
8848 "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");
8852 goto multiple_charsets;
8854 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8857 case UNICODE_PAT_MOD:
8858 /* In 5.14, qr//unless and qr//until are legal but deprecated; the
8859 * 'n' means they can't be regex modifiers */
8860 if (*((*s) + 1) == 'n') {
8864 goto multiple_charsets;
8866 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8869 case ASCII_RESTRICT_PAT_MOD:
8870 /* In 5.14, qr//and is legal but deprecated; the 'n' means they
8871 * can't be regex modifiers */
8872 if (*((*s) + 1) == 'n') {
8877 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8881 /* Error if previous modifier wasn't an 'a', but if it was, see
8882 * if, and accept, a second occurrence (only) */
8884 || get_regex_charset(*pmfl)
8885 != REGEX_ASCII_RESTRICTED_CHARSET)
8887 goto multiple_charsets;
8889 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
8893 case DEPENDS_PAT_MOD:
8895 goto multiple_charsets;
8897 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
8906 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
8907 "Having no space between pattern and following word is deprecated");
8911 if (*charset != c) {
8912 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
8914 else if (c == 'a') {
8915 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
8918 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
8921 /* Pretend that it worked, so will continue processing before dieing */
8927 S_scan_pat(pTHX_ char *start, I32 type)
8931 char *s = scan_str(start,!!PL_madskills,FALSE);
8932 const char * const valid_flags =
8933 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
8934 char charset = '\0'; /* character set modifier */
8939 PERL_ARGS_ASSERT_SCAN_PAT;
8942 const char * const delimiter = skipspace(start);
8946 ? "Search pattern not terminated or ternary operator parsed as search pattern"
8947 : "Search pattern not terminated" ));
8950 pm = (PMOP*)newPMOP(type, 0);
8951 if (PL_multi_open == '?') {
8952 /* This is the only point in the code that sets PMf_ONCE: */
8953 pm->op_pmflags |= PMf_ONCE;
8955 /* Hence it's safe to do this bit of PMOP book-keeping here, which
8956 allows us to restrict the list needed by reset to just the ??
8958 assert(type != OP_TRANS);
8960 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
8963 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
8966 elements = mg->mg_len / sizeof(PMOP**);
8967 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
8968 ((PMOP**)mg->mg_ptr) [elements++] = pm;
8969 mg->mg_len = elements * sizeof(PMOP**);
8970 PmopSTASH_set(pm,PL_curstash);
8976 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
8978 if (PL_madskills && modstart != s) {
8979 SV* tmptoken = newSVpvn(modstart, s - modstart);
8980 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
8983 /* issue a warning if /c is specified,but /g is not */
8984 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
8986 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
8987 "Use of /c modifier is meaningless without /g" );
8990 PL_lex_op = (OP*)pm;
8991 pl_yylval.ival = OP_MATCH;
8996 S_scan_subst(pTHX_ char *start)
9003 char charset = '\0'; /* character set modifier */
9008 PERL_ARGS_ASSERT_SCAN_SUBST;
9010 pl_yylval.ival = OP_NULL;
9012 s = scan_str(start,!!PL_madskills,FALSE);
9015 Perl_croak(aTHX_ "Substitution pattern not terminated");
9017 if (s[-1] == PL_multi_open)
9021 CURMAD('q', PL_thisopen);
9022 CURMAD('_', PL_thiswhite);
9023 CURMAD('E', PL_thisstuff);
9024 CURMAD('Q', PL_thisclose);
9025 PL_realtokenstart = s - SvPVX(PL_linestr);
9029 first_start = PL_multi_start;
9030 s = scan_str(s,!!PL_madskills,FALSE);
9033 SvREFCNT_dec(PL_lex_stuff);
9034 PL_lex_stuff = NULL;
9036 Perl_croak(aTHX_ "Substitution replacement not terminated");
9038 PL_multi_start = first_start; /* so whole substitution is taken together */
9040 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9044 CURMAD('z', PL_thisopen);
9045 CURMAD('R', PL_thisstuff);
9046 CURMAD('Z', PL_thisclose);
9052 if (*s == EXEC_PAT_MOD) {
9056 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9065 curmad('m', newSVpvn(modstart, s - modstart));
9066 append_madprops(PL_thismad, (OP*)pm, 0);
9070 if ((pm->op_pmflags & PMf_CONTINUE)) {
9071 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9075 SV * const repl = newSVpvs("");
9077 PL_sublex_info.super_bufptr = s;
9078 PL_sublex_info.super_bufend = PL_bufend;
9080 pm->op_pmflags |= PMf_EVAL;
9083 sv_catpvs(repl, "eval ");
9085 sv_catpvs(repl, "do ");
9087 sv_catpvs(repl, "{");
9088 sv_catsv(repl, PL_lex_repl);
9089 if (strchr(SvPVX(PL_lex_repl), '#'))
9090 sv_catpvs(repl, "\n");
9091 sv_catpvs(repl, "}");
9093 SvREFCNT_dec(PL_lex_repl);
9097 PL_lex_op = (OP*)pm;
9098 pl_yylval.ival = OP_SUBST;
9103 S_scan_trans(pTHX_ char *start)
9112 bool nondestruct = 0;
9117 PERL_ARGS_ASSERT_SCAN_TRANS;
9119 pl_yylval.ival = OP_NULL;
9121 s = scan_str(start,!!PL_madskills,FALSE);
9123 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9125 if (s[-1] == PL_multi_open)
9129 CURMAD('q', PL_thisopen);
9130 CURMAD('_', PL_thiswhite);
9131 CURMAD('E', PL_thisstuff);
9132 CURMAD('Q', PL_thisclose);
9133 PL_realtokenstart = s - SvPVX(PL_linestr);
9137 s = scan_str(s,!!PL_madskills,FALSE);
9140 SvREFCNT_dec(PL_lex_stuff);
9141 PL_lex_stuff = NULL;
9143 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9146 CURMAD('z', PL_thisopen);
9147 CURMAD('R', PL_thisstuff);
9148 CURMAD('Z', PL_thisclose);
9151 complement = del = squash = 0;
9158 complement = OPpTRANS_COMPLEMENT;
9161 del = OPpTRANS_DELETE;
9164 squash = OPpTRANS_SQUASH;
9176 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
9177 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
9178 o->op_private &= ~OPpTRANS_ALL;
9179 o->op_private |= del|squash|complement|
9180 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9181 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9184 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9189 curmad('m', newSVpvn(modstart, s - modstart));
9190 append_madprops(PL_thismad, o, 0);
9199 S_scan_heredoc(pTHX_ register char *s)
9203 I32 op_type = OP_SCALAR;
9207 const char *found_newline;
9211 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9213 I32 stuffstart = s - SvPVX(PL_linestr);
9216 PL_realtokenstart = -1;
9219 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9223 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9227 while (SPACE_OR_TAB(*peek))
9229 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9232 s = delimcpy(d, e, s, PL_bufend, term, &len);
9242 if (!isALNUM_lazy_if(s,UTF))
9243 deprecate("bare << to mean <<\"\"");
9244 for (; isALNUM_lazy_if(s,UTF); s++) {
9249 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9250 Perl_croak(aTHX_ "Delimiter for here document is too long");
9253 len = d - PL_tokenbuf;
9257 tstart = PL_tokenbuf + !outer;
9258 PL_thisclose = newSVpvn(tstart, len - !outer);
9259 tstart = SvPVX(PL_linestr) + stuffstart;
9260 PL_thisopen = newSVpvn(tstart, s - tstart);
9261 stuffstart = s - SvPVX(PL_linestr);
9264 #ifndef PERL_STRICT_CR
9265 d = strchr(s, '\r');
9267 char * const olds = s;
9269 while (s < PL_bufend) {
9275 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9284 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9291 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
9292 herewas = newSVpvn(s,PL_bufend-s);
9296 herewas = newSVpvn(s-1,found_newline-s+1);
9299 herewas = newSVpvn(s,found_newline-s);
9304 tstart = SvPVX(PL_linestr) + stuffstart;
9306 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9308 PL_thisstuff = newSVpvn(tstart, s - tstart);
9311 s += SvCUR(herewas);
9314 stuffstart = s - SvPVX(PL_linestr);
9320 tmpstr = newSV_type(SVt_PVIV);
9324 SvIV_set(tmpstr, -1);
9326 else if (term == '`') {
9327 op_type = OP_BACKTICK;
9328 SvIV_set(tmpstr, '\\');
9332 PL_multi_start = CopLINE(PL_curcop);
9333 PL_multi_open = PL_multi_close = '<';
9334 term = *PL_tokenbuf;
9335 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9336 char * const bufptr = PL_sublex_info.super_bufptr;
9337 char * const bufend = PL_sublex_info.super_bufend;
9338 char * const olds = s - SvCUR(herewas);
9339 s = strchr(bufptr, '\n');
9343 while (s < bufend &&
9344 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9346 CopLINE_inc(PL_curcop);
9349 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9350 missingterm(PL_tokenbuf);
9352 sv_setpvn(herewas,bufptr,d-bufptr+1);
9353 sv_setpvn(tmpstr,d+1,s-d);
9355 sv_catpvn(herewas,s,bufend-s);
9356 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9363 while (s < PL_bufend &&
9364 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9366 CopLINE_inc(PL_curcop);
9368 if (s >= PL_bufend) {
9369 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9370 missingterm(PL_tokenbuf);
9372 sv_setpvn(tmpstr,d+1,s-d);
9376 sv_catpvn(PL_thisstuff, d + 1, s - d);
9378 PL_thisstuff = newSVpvn(d + 1, s - d);
9379 stuffstart = s - SvPVX(PL_linestr);
9383 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9385 sv_catpvn(herewas,s,PL_bufend-s);
9386 sv_setsv(PL_linestr,herewas);
9387 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9388 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9389 PL_last_lop = PL_last_uni = NULL;
9392 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9393 while (s >= PL_bufend) { /* multiple line string? */
9396 tstart = SvPVX(PL_linestr) + stuffstart;
9398 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9400 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9404 CopLINE_inc(PL_curcop);
9405 if (!outer || !lex_next_chunk(0)) {
9406 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9407 missingterm(PL_tokenbuf);
9409 CopLINE_dec(PL_curcop);
9412 stuffstart = s - SvPVX(PL_linestr);
9414 CopLINE_inc(PL_curcop);
9415 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9416 PL_last_lop = PL_last_uni = NULL;
9417 #ifndef PERL_STRICT_CR
9418 if (PL_bufend - PL_linestart >= 2) {
9419 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9420 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9422 PL_bufend[-2] = '\n';
9424 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9426 else if (PL_bufend[-1] == '\r')
9427 PL_bufend[-1] = '\n';
9429 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9430 PL_bufend[-1] = '\n';
9432 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9433 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9434 *(SvPVX(PL_linestr) + off ) = ' ';
9435 lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1);
9436 sv_catsv(PL_linestr,herewas);
9437 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9438 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9442 sv_catsv(tmpstr,PL_linestr);
9447 PL_multi_end = CopLINE(PL_curcop);
9448 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9449 SvPV_shrink_to_cur(tmpstr);
9451 SvREFCNT_dec(herewas);
9453 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9455 else if (PL_encoding)
9456 sv_recode_to_utf8(tmpstr, PL_encoding);
9458 PL_lex_stuff = tmpstr;
9459 pl_yylval.ival = op_type;
9464 takes: current position in input buffer
9465 returns: new position in input buffer
9466 side-effects: pl_yylval and lex_op are set.
9471 <FH> read from filehandle
9472 <pkg::FH> read from package qualified filehandle
9473 <pkg'FH> read from package qualified filehandle
9474 <$fh> read from filehandle in $fh
9480 S_scan_inputsymbol(pTHX_ char *start)
9483 register char *s = start; /* current position in buffer */
9486 char *d = PL_tokenbuf; /* start of temp holding space */
9487 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9489 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9491 end = strchr(s, '\n');
9494 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9496 /* die if we didn't have space for the contents of the <>,
9497 or if it didn't end, or if we see a newline
9500 if (len >= (I32)sizeof PL_tokenbuf)
9501 Perl_croak(aTHX_ "Excessively long <> operator");
9503 Perl_croak(aTHX_ "Unterminated <> operator");
9508 Remember, only scalar variables are interpreted as filehandles by
9509 this code. Anything more complex (e.g., <$fh{$num}>) will be
9510 treated as a glob() call.
9511 This code makes use of the fact that except for the $ at the front,
9512 a scalar variable and a filehandle look the same.
9514 if (*d == '$' && d[1]) d++;
9516 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9517 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9520 /* If we've tried to read what we allow filehandles to look like, and
9521 there's still text left, then it must be a glob() and not a getline.
9522 Use scan_str to pull out the stuff between the <> and treat it
9523 as nothing more than a string.
9526 if (d - PL_tokenbuf != len) {
9527 pl_yylval.ival = OP_GLOB;
9528 s = scan_str(start,!!PL_madskills,FALSE);
9530 Perl_croak(aTHX_ "Glob not terminated");
9534 bool readline_overriden = FALSE;
9537 /* we're in a filehandle read situation */
9540 /* turn <> into <ARGV> */
9542 Copy("ARGV",d,5,char);
9544 /* Check whether readline() is overriden */
9545 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
9547 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9549 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
9550 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
9551 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9552 readline_overriden = TRUE;
9554 /* if <$fh>, create the ops to turn the variable into a
9558 /* try to find it in the pad for this block, otherwise find
9559 add symbol table ops
9561 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
9562 if (tmp != NOT_IN_PAD) {
9563 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9564 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9565 HEK * const stashname = HvNAME_HEK(stash);
9566 SV * const sym = sv_2mortal(newSVhek(stashname));
9567 sv_catpvs(sym, "::");
9573 OP * const o = newOP(OP_PADSV, 0);
9575 PL_lex_op = readline_overriden
9576 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9577 op_append_elem(OP_LIST, o,
9578 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9579 : (OP*)newUNOP(OP_READLINE, 0, o);
9588 ? (GV_ADDMULTI | GV_ADDINEVAL)
9591 PL_lex_op = readline_overriden
9592 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9593 op_append_elem(OP_LIST,
9594 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9595 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9596 : (OP*)newUNOP(OP_READLINE, 0,
9597 newUNOP(OP_RV2SV, 0,
9598 newGVOP(OP_GV, 0, gv)));
9600 if (!readline_overriden)
9601 PL_lex_op->op_flags |= OPf_SPECIAL;
9602 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9603 pl_yylval.ival = OP_NULL;
9606 /* If it's none of the above, it must be a literal filehandle
9607 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9609 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
9610 PL_lex_op = readline_overriden
9611 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9612 op_append_elem(OP_LIST,
9613 newGVOP(OP_GV, 0, gv),
9614 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9615 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9616 pl_yylval.ival = OP_NULL;
9625 takes: start position in buffer
9626 keep_quoted preserve \ on the embedded delimiter(s)
9627 keep_delims preserve the delimiters around the string
9628 returns: position to continue reading from buffer
9629 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9630 updates the read buffer.
9632 This subroutine pulls a string out of the input. It is called for:
9633 q single quotes q(literal text)
9634 ' single quotes 'literal text'
9635 qq double quotes qq(interpolate $here please)
9636 " double quotes "interpolate $here please"
9637 qx backticks qx(/bin/ls -l)
9638 ` backticks `/bin/ls -l`
9639 qw quote words @EXPORT_OK = qw( func() $spam )
9640 m// regexp match m/this/
9641 s/// regexp substitute s/this/that/
9642 tr/// string transliterate tr/this/that/
9643 y/// string transliterate y/this/that/
9644 ($*@) sub prototypes sub foo ($)
9645 (stuff) sub attr parameters sub foo : attr(stuff)
9646 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9648 In most of these cases (all but <>, patterns and transliterate)
9649 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9650 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9651 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9654 It skips whitespace before the string starts, and treats the first
9655 character as the delimiter. If the delimiter is one of ([{< then
9656 the corresponding "close" character )]}> is used as the closing
9657 delimiter. It allows quoting of delimiters, and if the string has
9658 balanced delimiters ([{<>}]) it allows nesting.
9660 On success, the SV with the resulting string is put into lex_stuff or,
9661 if that is already non-NULL, into lex_repl. The second case occurs only
9662 when parsing the RHS of the special constructs s/// and tr/// (y///).
9663 For convenience, the terminating delimiter character is stuffed into
9668 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9671 SV *sv; /* scalar value: string */
9672 const char *tmps; /* temp string, used for delimiter matching */
9673 register char *s = start; /* current position in the buffer */
9674 register char term; /* terminating character */
9675 register char *to; /* current position in the sv's data */
9676 I32 brackets = 1; /* bracket nesting level */
9677 bool has_utf8 = FALSE; /* is there any utf8 content? */
9678 I32 termcode; /* terminating char. code */
9679 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9680 STRLEN termlen; /* length of terminating string */
9681 int last_off = 0; /* last position for nesting bracket */
9687 PERL_ARGS_ASSERT_SCAN_STR;
9689 /* skip space before the delimiter */
9695 if (PL_realtokenstart >= 0) {
9696 stuffstart = PL_realtokenstart;
9697 PL_realtokenstart = -1;
9700 stuffstart = start - SvPVX(PL_linestr);
9702 /* mark where we are, in case we need to report errors */
9705 /* after skipping whitespace, the next character is the terminator */
9708 termcode = termstr[0] = term;
9712 termcode = utf8_to_uvchr((U8*)s, &termlen);
9713 Copy(s, termstr, termlen, U8);
9714 if (!UTF8_IS_INVARIANT(term))
9718 /* mark where we are */
9719 PL_multi_start = CopLINE(PL_curcop);
9720 PL_multi_open = term;
9722 /* find corresponding closing delimiter */
9723 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9724 termcode = termstr[0] = term = tmps[5];
9726 PL_multi_close = term;
9728 /* create a new SV to hold the contents. 79 is the SV's initial length.
9729 What a random number. */
9730 sv = newSV_type(SVt_PVIV);
9732 SvIV_set(sv, termcode);
9733 (void)SvPOK_only(sv); /* validate pointer */
9735 /* move past delimiter and try to read a complete string */
9737 sv_catpvn(sv, s, termlen);
9740 tstart = SvPVX(PL_linestr) + stuffstart;
9741 if (!PL_thisopen && !keep_delims) {
9742 PL_thisopen = newSVpvn(tstart, s - tstart);
9743 stuffstart = s - SvPVX(PL_linestr);
9747 if (PL_encoding && !UTF) {
9751 int offset = s - SvPVX_const(PL_linestr);
9752 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9753 &offset, (char*)termstr, termlen);
9754 const char * const ns = SvPVX_const(PL_linestr) + offset;
9755 char * const svlast = SvEND(sv) - 1;
9757 for (; s < ns; s++) {
9758 if (*s == '\n' && !PL_rsfp)
9759 CopLINE_inc(PL_curcop);
9762 goto read_more_line;
9764 /* handle quoted delimiters */
9765 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9767 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9769 if ((svlast-1 - t) % 2) {
9773 SvCUR_set(sv, SvCUR(sv) - 1);
9778 if (PL_multi_open == PL_multi_close) {
9784 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9785 /* At here, all closes are "was quoted" one,
9786 so we don't check PL_multi_close. */
9788 if (!keep_quoted && *(t+1) == PL_multi_open)
9793 else if (*t == PL_multi_open)
9801 SvCUR_set(sv, w - SvPVX_const(sv));
9803 last_off = w - SvPVX(sv);
9804 if (--brackets <= 0)
9810 SvCUR_set(sv, SvCUR(sv) - 1);
9816 /* extend sv if need be */
9817 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9818 /* set 'to' to the next character in the sv's string */
9819 to = SvPVX(sv)+SvCUR(sv);
9821 /* if open delimiter is the close delimiter read unbridle */
9822 if (PL_multi_open == PL_multi_close) {
9823 for (; s < PL_bufend; s++,to++) {
9824 /* embedded newlines increment the current line number */
9825 if (*s == '\n' && !PL_rsfp)
9826 CopLINE_inc(PL_curcop);
9827 /* handle quoted delimiters */
9828 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9829 if (!keep_quoted && s[1] == term)
9831 /* any other quotes are simply copied straight through */
9835 /* terminate when run out of buffer (the for() condition), or
9836 have found the terminator */
9837 else if (*s == term) {
9840 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9843 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9849 /* if the terminator isn't the same as the start character (e.g.,
9850 matched brackets), we have to allow more in the quoting, and
9851 be prepared for nested brackets.
9854 /* read until we run out of string, or we find the terminator */
9855 for (; s < PL_bufend; s++,to++) {
9856 /* embedded newlines increment the line count */
9857 if (*s == '\n' && !PL_rsfp)
9858 CopLINE_inc(PL_curcop);
9859 /* backslashes can escape the open or closing characters */
9860 if (*s == '\\' && s+1 < PL_bufend) {
9862 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9867 /* allow nested opens and closes */
9868 else if (*s == PL_multi_close && --brackets <= 0)
9870 else if (*s == PL_multi_open)
9872 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9877 /* terminate the copied string and update the sv's end-of-string */
9879 SvCUR_set(sv, to - SvPVX_const(sv));
9882 * this next chunk reads more into the buffer if we're not done yet
9886 break; /* handle case where we are done yet :-) */
9888 #ifndef PERL_STRICT_CR
9889 if (to - SvPVX_const(sv) >= 2) {
9890 if ((to[-2] == '\r' && to[-1] == '\n') ||
9891 (to[-2] == '\n' && to[-1] == '\r'))
9895 SvCUR_set(sv, to - SvPVX_const(sv));
9897 else if (to[-1] == '\r')
9900 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
9905 /* if we're out of file, or a read fails, bail and reset the current
9906 line marker so we can report where the unterminated string began
9910 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9912 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9914 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9917 CopLINE_inc(PL_curcop);
9918 PL_bufptr = PL_bufend;
9919 if (!lex_next_chunk(0)) {
9921 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9930 /* at this point, we have successfully read the delimited string */
9932 if (!PL_encoding || UTF) {
9935 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9936 const int len = s - tstart;
9938 sv_catpvn(PL_thisstuff, tstart, len);
9940 PL_thisstuff = newSVpvn(tstart, len);
9941 if (!PL_thisclose && !keep_delims)
9942 PL_thisclose = newSVpvn(s,termlen);
9947 sv_catpvn(sv, s, termlen);
9953 char * const tstart = SvPVX(PL_linestr) + stuffstart;
9954 const int len = s - tstart - termlen;
9956 sv_catpvn(PL_thisstuff, tstart, len);
9958 PL_thisstuff = newSVpvn(tstart, len);
9959 if (!PL_thisclose && !keep_delims)
9960 PL_thisclose = newSVpvn(s - termlen,termlen);
9964 if (has_utf8 || PL_encoding)
9967 PL_multi_end = CopLINE(PL_curcop);
9969 /* if we allocated too much space, give some back */
9970 if (SvCUR(sv) + 5 < SvLEN(sv)) {
9971 SvLEN_set(sv, SvCUR(sv) + 1);
9972 SvPV_renew(sv, SvLEN(sv));
9975 /* decide whether this is the first or second quoted string we've read
9988 takes: pointer to position in buffer
9989 returns: pointer to new position in buffer
9990 side-effects: builds ops for the constant in pl_yylval.op
9992 Read a number in any of the formats that Perl accepts:
9994 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
9995 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
9998 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10000 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10003 If it reads a number without a decimal point or an exponent, it will
10004 try converting the number to an integer and see if it can do so
10005 without loss of precision.
10009 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10012 register const char *s = start; /* current position in buffer */
10013 register char *d; /* destination in temp buffer */
10014 register char *e; /* end of temp buffer */
10015 NV nv; /* number read, as a double */
10016 SV *sv = NULL; /* place to put the converted number */
10017 bool floatit; /* boolean: int or float? */
10018 const char *lastub = NULL; /* position of last underbar */
10019 static char const number_too_long[] = "Number too long";
10021 PERL_ARGS_ASSERT_SCAN_NUM;
10023 /* We use the first character to decide what type of number this is */
10027 Perl_croak(aTHX_ "panic: scan_num");
10029 /* if it starts with a 0, it could be an octal number, a decimal in
10030 0.13 disguise, or a hexadecimal number, or a binary number. */
10034 u holds the "number so far"
10035 shift the power of 2 of the base
10036 (hex == 4, octal == 3, binary == 1)
10037 overflowed was the number more than we can hold?
10039 Shift is used when we add a digit. It also serves as an "are
10040 we in octal/hex/binary?" indicator to disallow hex characters
10041 when in octal mode.
10046 bool overflowed = FALSE;
10047 bool just_zero = TRUE; /* just plain 0 or binary number? */
10048 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10049 static const char* const bases[5] =
10050 { "", "binary", "", "octal", "hexadecimal" };
10051 static const char* const Bases[5] =
10052 { "", "Binary", "", "Octal", "Hexadecimal" };
10053 static const char* const maxima[5] =
10055 "0b11111111111111111111111111111111",
10059 const char *base, *Base, *max;
10061 /* check for hex */
10062 if (s[1] == 'x' || s[1] == 'X') {
10066 } else if (s[1] == 'b' || s[1] == 'B') {
10071 /* check for a decimal in disguise */
10072 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10074 /* so it must be octal */
10081 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10082 "Misplaced _ in number");
10086 base = bases[shift];
10087 Base = Bases[shift];
10088 max = maxima[shift];
10090 /* read the rest of the number */
10092 /* x is used in the overflow test,
10093 b is the digit we're adding on. */
10098 /* if we don't mention it, we're done */
10102 /* _ are ignored -- but warned about if consecutive */
10104 if (lastub && s == lastub + 1)
10105 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10106 "Misplaced _ in number");
10110 /* 8 and 9 are not octal */
10111 case '8': case '9':
10113 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10117 case '2': case '3': case '4':
10118 case '5': case '6': case '7':
10120 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10123 case '0': case '1':
10124 b = *s++ & 15; /* ASCII digit -> value of digit */
10128 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10129 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10130 /* make sure they said 0x */
10133 b = (*s++ & 7) + 9;
10135 /* Prepare to put the digit we have onto the end
10136 of the number so far. We check for overflows.
10142 x = u << shift; /* make room for the digit */
10144 if ((x >> shift) != u
10145 && !(PL_hints & HINT_NEW_BINARY)) {
10148 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10149 "Integer overflow in %s number",
10152 u = x | b; /* add the digit to the end */
10155 n *= nvshift[shift];
10156 /* If an NV has not enough bits in its
10157 * mantissa to represent an UV this summing of
10158 * small low-order numbers is a waste of time
10159 * (because the NV cannot preserve the
10160 * low-order bits anyway): we could just
10161 * remember when did we overflow and in the
10162 * end just multiply n by the right
10170 /* if we get here, we had success: make a scalar value from
10175 /* final misplaced underbar check */
10176 if (s[-1] == '_') {
10177 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10181 if (n > 4294967295.0)
10182 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10183 "%s number > %s non-portable",
10189 if (u > 0xffffffff)
10190 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10191 "%s number > %s non-portable",
10196 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10197 sv = new_constant(start, s - start, "integer",
10198 sv, NULL, NULL, 0);
10199 else if (PL_hints & HINT_NEW_BINARY)
10200 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10205 handle decimal numbers.
10206 we're also sent here when we read a 0 as the first digit
10208 case '1': case '2': case '3': case '4': case '5':
10209 case '6': case '7': case '8': case '9': case '.':
10212 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10215 /* read next group of digits and _ and copy into d */
10216 while (isDIGIT(*s) || *s == '_') {
10217 /* skip underscores, checking for misplaced ones
10221 if (lastub && s == lastub + 1)
10222 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10223 "Misplaced _ in number");
10227 /* check for end of fixed-length buffer */
10229 Perl_croak(aTHX_ number_too_long);
10230 /* if we're ok, copy the character */
10235 /* final misplaced underbar check */
10236 if (lastub && s == lastub + 1) {
10237 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10240 /* read a decimal portion if there is one. avoid
10241 3..5 being interpreted as the number 3. followed
10244 if (*s == '.' && s[1] != '.') {
10249 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10250 "Misplaced _ in number");
10254 /* copy, ignoring underbars, until we run out of digits.
10256 for (; isDIGIT(*s) || *s == '_'; s++) {
10257 /* fixed length buffer check */
10259 Perl_croak(aTHX_ number_too_long);
10261 if (lastub && s == lastub + 1)
10262 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10263 "Misplaced _ in number");
10269 /* fractional part ending in underbar? */
10270 if (s[-1] == '_') {
10271 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10272 "Misplaced _ in number");
10274 if (*s == '.' && isDIGIT(s[1])) {
10275 /* oops, it's really a v-string, but without the "v" */
10281 /* read exponent part, if present */
10282 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10286 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10287 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10289 /* stray preinitial _ */
10291 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10292 "Misplaced _ in number");
10296 /* allow positive or negative exponent */
10297 if (*s == '+' || *s == '-')
10300 /* stray initial _ */
10302 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10303 "Misplaced _ in number");
10307 /* read digits of exponent */
10308 while (isDIGIT(*s) || *s == '_') {
10311 Perl_croak(aTHX_ number_too_long);
10315 if (((lastub && s == lastub + 1) ||
10316 (!isDIGIT(s[1]) && s[1] != '_')))
10317 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10318 "Misplaced _ in number");
10326 We try to do an integer conversion first if no characters
10327 indicating "float" have been found.
10332 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10334 if (flags == IS_NUMBER_IN_UV) {
10336 sv = newSViv(uv); /* Prefer IVs over UVs. */
10339 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10340 if (uv <= (UV) IV_MIN)
10341 sv = newSViv(-(IV)uv);
10348 /* terminate the string */
10350 nv = Atof(PL_tokenbuf);
10355 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10356 const char *const key = floatit ? "float" : "integer";
10357 const STRLEN keylen = floatit ? 5 : 7;
10358 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10359 key, keylen, sv, NULL, NULL, 0);
10363 /* if it starts with a v, it could be a v-string */
10366 sv = newSV(5); /* preallocate storage space */
10367 s = scan_vstring(s, PL_bufend, sv);
10371 /* make the op for the constant and return */
10374 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10376 lvalp->opval = NULL;
10382 S_scan_formline(pTHX_ register char *s)
10385 register char *eol;
10387 SV * const stuff = newSVpvs("");
10388 bool needargs = FALSE;
10389 bool eofmt = FALSE;
10391 char *tokenstart = s;
10392 SV* savewhite = NULL;
10394 if (PL_madskills) {
10395 savewhite = PL_thiswhite;
10400 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10402 while (!needargs) {
10405 #ifdef PERL_STRICT_CR
10406 while (SPACE_OR_TAB(*t))
10409 while (SPACE_OR_TAB(*t) || *t == '\r')
10412 if (*t == '\n' || t == PL_bufend) {
10417 if (PL_in_eval && !PL_rsfp) {
10418 eol = (char *) memchr(s,'\n',PL_bufend-s);
10423 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10425 for (t = s; t < eol; t++) {
10426 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10428 goto enough; /* ~~ must be first line in formline */
10430 if (*t == '@' || *t == '^')
10434 sv_catpvn(stuff, s, eol-s);
10435 #ifndef PERL_STRICT_CR
10436 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10437 char *end = SvPVX(stuff) + SvCUR(stuff);
10440 SvCUR_set(stuff, SvCUR(stuff) - 1);
10451 if (PL_madskills) {
10453 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
10455 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
10458 PL_bufptr = PL_bufend;
10459 CopLINE_inc(PL_curcop);
10460 got_some = lex_next_chunk(0);
10461 CopLINE_dec(PL_curcop);
10464 tokenstart = PL_bufptr;
10472 if (SvCUR(stuff)) {
10475 PL_lex_state = LEX_NORMAL;
10476 start_force(PL_curforce);
10477 NEXTVAL_NEXTTOKE.ival = 0;
10481 PL_lex_state = LEX_FORMLINE;
10483 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10485 else if (PL_encoding)
10486 sv_recode_to_utf8(stuff, PL_encoding);
10488 start_force(PL_curforce);
10489 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10491 start_force(PL_curforce);
10492 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
10496 SvREFCNT_dec(stuff);
10498 PL_lex_formbrack = 0;
10502 if (PL_madskills) {
10504 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
10506 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
10507 PL_thiswhite = savewhite;
10514 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10517 const I32 oldsavestack_ix = PL_savestack_ix;
10518 CV* const outsidecv = PL_compcv;
10521 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10523 SAVEI32(PL_subline);
10524 save_item(PL_subname);
10525 SAVESPTR(PL_compcv);
10527 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10528 CvFLAGS(PL_compcv) |= flags;
10530 PL_subline = CopLINE(PL_curcop);
10531 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10532 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10533 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10535 return oldsavestack_ix;
10539 #pragma segment Perl_yylex
10542 S_yywarn(pTHX_ const char *const s)
10546 PERL_ARGS_ASSERT_YYWARN;
10548 PL_in_eval |= EVAL_WARNONLY;
10550 PL_in_eval &= ~EVAL_WARNONLY;
10555 Perl_yyerror(pTHX_ const char *const s)
10558 const char *where = NULL;
10559 const char *context = NULL;
10562 int yychar = PL_parser->yychar;
10564 PERL_ARGS_ASSERT_YYERROR;
10566 if (!yychar || (yychar == ';' && !PL_rsfp))
10568 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10569 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10570 PL_oldbufptr != PL_bufptr) {
10573 The code below is removed for NetWare because it abends/crashes on NetWare
10574 when the script has error such as not having the closing quotes like:
10575 if ($var eq "value)
10576 Checking of white spaces is anyway done in NetWare code.
10579 while (isSPACE(*PL_oldoldbufptr))
10582 context = PL_oldoldbufptr;
10583 contlen = PL_bufptr - PL_oldoldbufptr;
10585 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10586 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10589 The code below is removed for NetWare because it abends/crashes on NetWare
10590 when the script has error such as not having the closing quotes like:
10591 if ($var eq "value)
10592 Checking of white spaces is anyway done in NetWare code.
10595 while (isSPACE(*PL_oldbufptr))
10598 context = PL_oldbufptr;
10599 contlen = PL_bufptr - PL_oldbufptr;
10601 else if (yychar > 255)
10602 where = "next token ???";
10603 else if (yychar == -2) { /* YYEMPTY */
10604 if (PL_lex_state == LEX_NORMAL ||
10605 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10606 where = "at end of line";
10607 else if (PL_lex_inpat)
10608 where = "within pattern";
10610 where = "within string";
10613 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
10615 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10616 else if (isPRINT_LC(yychar)) {
10617 const char string = yychar;
10618 sv_catpvn(where_sv, &string, 1);
10621 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10622 where = SvPVX_const(where_sv);
10624 msg = sv_2mortal(newSVpv(s, 0));
10625 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10626 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10628 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10630 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10631 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10632 Perl_sv_catpvf(aTHX_ msg,
10633 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10634 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10637 if (PL_in_eval & EVAL_WARNONLY) {
10638 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10642 if (PL_error_count >= 10) {
10643 if (PL_in_eval && SvCUR(ERRSV))
10644 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10645 SVfARG(ERRSV), OutCopFILE(PL_curcop));
10647 Perl_croak(aTHX_ "%s has too many errors.\n",
10648 OutCopFILE(PL_curcop));
10651 PL_in_my_stash = NULL;
10655 #pragma segment Main
10659 S_swallow_bom(pTHX_ U8 *s)
10662 const STRLEN slen = SvCUR(PL_linestr);
10664 PERL_ARGS_ASSERT_SWALLOW_BOM;
10668 if (s[1] == 0xFE) {
10669 /* UTF-16 little-endian? (or UTF-32LE?) */
10670 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10671 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10672 #ifndef PERL_NO_UTF16_FILTER
10673 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10675 if (PL_bufend > (char*)s) {
10676 s = add_utf16_textfilter(s, TRUE);
10679 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10684 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10685 #ifndef PERL_NO_UTF16_FILTER
10686 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10688 if (PL_bufend > (char *)s) {
10689 s = add_utf16_textfilter(s, FALSE);
10692 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10697 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10698 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10699 s += 3; /* UTF-8 */
10705 if (s[2] == 0xFE && s[3] == 0xFF) {
10706 /* UTF-32 big-endian */
10707 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10710 else if (s[2] == 0 && s[3] != 0) {
10713 * are a good indicator of UTF-16BE. */
10714 #ifndef PERL_NO_UTF16_FILTER
10715 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10716 s = add_utf16_textfilter(s, FALSE);
10718 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10724 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
10725 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10726 s += 4; /* UTF-8 */
10732 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10735 * are a good indicator of UTF-16LE. */
10736 #ifndef PERL_NO_UTF16_FILTER
10737 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10738 s = add_utf16_textfilter(s, TRUE);
10740 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10748 #ifndef PERL_NO_UTF16_FILTER
10750 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10753 SV *const filter = FILTER_DATA(idx);
10754 /* We re-use this each time round, throwing the contents away before we
10756 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10757 SV *const utf8_buffer = filter;
10758 IV status = IoPAGE(filter);
10759 const bool reverse = cBOOL(IoLINES(filter));
10762 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10764 /* As we're automatically added, at the lowest level, and hence only called
10765 from this file, we can be sure that we're not called in block mode. Hence
10766 don't bother writing code to deal with block mode. */
10768 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10771 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10773 DEBUG_P(PerlIO_printf(Perl_debug_log,
10774 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10775 FPTR2DPTR(void *, S_utf16_textfilter),
10776 reverse ? 'l' : 'b', idx, maxlen, status,
10777 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10784 /* First, look in our buffer of existing UTF-8 data: */
10785 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10789 } else if (status == 0) {
10791 IoPAGE(filter) = 0;
10792 nl = SvEND(utf8_buffer);
10795 STRLEN got = nl - SvPVX(utf8_buffer);
10796 /* Did we have anything to append? */
10798 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10799 /* Everything else in this code works just fine if SVp_POK isn't
10800 set. This, however, needs it, and we need it to work, else
10801 we loop infinitely because the buffer is never consumed. */
10802 sv_chop(utf8_buffer, nl);
10806 /* OK, not a complete line there, so need to read some more UTF-16.
10807 Read an extra octect if the buffer currently has an odd number. */
10811 if (SvCUR(utf16_buffer) >= 2) {
10812 /* Location of the high octet of the last complete code point.
10813 Gosh, UTF-16 is a pain. All the benefits of variable length,
10814 *coupled* with all the benefits of partial reads and
10816 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10817 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10819 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10823 /* We have the first half of a surrogate. Read more. */
10824 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10827 status = FILTER_READ(idx + 1, utf16_buffer,
10828 160 + (SvCUR(utf16_buffer) & 1));
10829 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10830 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10833 IoPAGE(filter) = status;
10838 chars = SvCUR(utf16_buffer) >> 1;
10839 have = SvCUR(utf8_buffer);
10840 SvGROW(utf8_buffer, have + chars * 3 + 1);
10843 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10844 (U8*)SvPVX_const(utf8_buffer) + have,
10845 chars * 2, &newlen);
10847 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10848 (U8*)SvPVX_const(utf8_buffer) + have,
10849 chars * 2, &newlen);
10851 SvCUR_set(utf8_buffer, have + newlen);
10854 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10855 it's private to us, and utf16_to_utf8{,reversed} take a
10856 (pointer,length) pair, rather than a NUL-terminated string. */
10857 if(SvCUR(utf16_buffer) & 1) {
10858 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10859 SvCUR_set(utf16_buffer, 1);
10861 SvCUR_set(utf16_buffer, 0);
10864 DEBUG_P(PerlIO_printf(Perl_debug_log,
10865 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10867 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10868 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10873 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10875 SV *filter = filter_add(S_utf16_textfilter, NULL);
10877 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10879 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10880 sv_setpvs(filter, "");
10881 IoLINES(filter) = reversed;
10882 IoPAGE(filter) = 1; /* Not EOF */
10884 /* Sadly, we have to return a valid pointer, come what may, so we have to
10885 ignore any error return from this. */
10886 SvCUR_set(PL_linestr, 0);
10887 if (FILTER_READ(0, PL_linestr, 0)) {
10888 SvUTF8_on(PL_linestr);
10890 SvUTF8_on(PL_linestr);
10892 PL_bufend = SvEND(PL_linestr);
10893 return (U8*)SvPVX(PL_linestr);
10898 Returns a pointer to the next character after the parsed
10899 vstring, as well as updating the passed in sv.
10901 Function must be called like
10904 s = scan_vstring(s,e,sv);
10906 where s and e are the start and end of the string.
10907 The sv should already be large enough to store the vstring
10908 passed in, for performance reasons.
10913 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
10916 const char *pos = s;
10917 const char *start = s;
10919 PERL_ARGS_ASSERT_SCAN_VSTRING;
10921 if (*pos == 'v') pos++; /* get past 'v' */
10922 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10924 if ( *pos != '.') {
10925 /* this may not be a v-string if followed by => */
10926 const char *next = pos;
10927 while (next < e && isSPACE(*next))
10929 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
10930 /* return string not v-string */
10931 sv_setpvn(sv,(char *)s,pos-s);
10932 return (char *)pos;
10936 if (!isALPHA(*pos)) {
10937 U8 tmpbuf[UTF8_MAXBYTES+1];
10940 s++; /* get past 'v' */
10945 /* this is atoi() that tolerates underscores */
10948 const char *end = pos;
10950 while (--end >= s) {
10952 const UV orev = rev;
10953 rev += (*end - '0') * mult;
10956 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10957 "Integer overflow in decimal number");
10961 if (rev > 0x7FFFFFFF)
10962 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
10964 /* Append native character for the rev point */
10965 tmpend = uvchr_to_utf8(tmpbuf, rev);
10966 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
10967 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
10969 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
10975 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
10979 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
10986 Perl_keyword_plugin_standard(pTHX_
10987 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
10989 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
10990 PERL_UNUSED_CONTEXT;
10991 PERL_UNUSED_ARG(keyword_ptr);
10992 PERL_UNUSED_ARG(keyword_len);
10993 PERL_UNUSED_ARG(op_ptr);
10994 return KEYWORD_PLUGIN_DECLINE;
10997 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
10999 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11001 SAVEI32(PL_lex_brackets);
11002 if (PL_lex_brackets > 100)
11003 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11004 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11005 SAVEI32(PL_lex_allbrackets);
11006 PL_lex_allbrackets = 0;
11007 SAVEI8(PL_lex_fakeeof);
11008 PL_lex_fakeeof = (U8)fakeeof;
11009 if(yyparse(gramtype) && !PL_parser->error_count)
11010 qerror(Perl_mess(aTHX_ "Parse error"));
11013 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11015 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11019 SAVEVPTR(PL_eval_root);
11020 PL_eval_root = NULL;
11021 parse_recdescent(gramtype, fakeeof);
11027 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11029 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11032 if (flags & ~PARSE_OPTIONAL)
11033 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11034 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11035 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11036 if (!PL_parser->error_count)
11037 qerror(Perl_mess(aTHX_ "Parse error"));
11038 exprop = newOP(OP_NULL, 0);
11044 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11046 Parse a Perl arithmetic expression. This may contain operators of precedence
11047 down to the bit shift operators. The expression must be followed (and thus
11048 terminated) either by a comparison or lower-precedence operator or by
11049 something that would normally terminate an expression such as semicolon.
11050 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11051 otherwise it is mandatory. It is up to the caller to ensure that the
11052 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11053 the source of the code to be parsed and the lexical context for the
11056 The op tree representing the expression is returned. If an optional
11057 expression is absent, a null pointer is returned, otherwise the pointer
11060 If an error occurs in parsing or compilation, in most cases a valid op
11061 tree is returned anyway. The error is reflected in the parser state,
11062 normally resulting in a single exception at the top level of parsing
11063 which covers all the compilation errors that occurred. Some compilation
11064 errors, however, will throw an exception immediately.
11070 Perl_parse_arithexpr(pTHX_ U32 flags)
11072 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11076 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11078 Parse a Perl term expression. This may contain operators of precedence
11079 down to the assignment operators. The expression must be followed (and thus
11080 terminated) either by a comma or lower-precedence operator or by
11081 something that would normally terminate an expression such as semicolon.
11082 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11083 otherwise it is mandatory. It is up to the caller to ensure that the
11084 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11085 the source of the code to be parsed and the lexical context for the
11088 The op tree representing the expression is returned. If an optional
11089 expression is absent, a null pointer is returned, otherwise the pointer
11092 If an error occurs in parsing or compilation, in most cases a valid op
11093 tree is returned anyway. The error is reflected in the parser state,
11094 normally resulting in a single exception at the top level of parsing
11095 which covers all the compilation errors that occurred. Some compilation
11096 errors, however, will throw an exception immediately.
11102 Perl_parse_termexpr(pTHX_ U32 flags)
11104 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11108 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11110 Parse a Perl list expression. This may contain operators of precedence
11111 down to the comma operator. The expression must be followed (and thus
11112 terminated) either by a low-precedence logic operator such as C<or> or by
11113 something that would normally terminate an expression such as semicolon.
11114 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11115 otherwise it is mandatory. It is up to the caller to ensure that the
11116 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11117 the source of the code to be parsed and the lexical context for the
11120 The op tree representing the expression is returned. If an optional
11121 expression is absent, a null pointer is returned, otherwise the pointer
11124 If an error occurs in parsing or compilation, in most cases a valid op
11125 tree is returned anyway. The error is reflected in the parser state,
11126 normally resulting in a single exception at the top level of parsing
11127 which covers all the compilation errors that occurred. Some compilation
11128 errors, however, will throw an exception immediately.
11134 Perl_parse_listexpr(pTHX_ U32 flags)
11136 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11140 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11142 Parse a single complete Perl expression. This allows the full
11143 expression grammar, including the lowest-precedence operators such
11144 as C<or>. The expression must be followed (and thus terminated) by a
11145 token that an expression would normally be terminated by: end-of-file,
11146 closing bracketing punctuation, semicolon, or one of the keywords that
11147 signals a postfix expression-statement modifier. If I<flags> includes
11148 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11149 mandatory. It is up to the caller to ensure that the dynamic parser
11150 state (L</PL_parser> et al) is correctly set to reflect the source of
11151 the code to be parsed and the lexical context for the expression.
11153 The op tree representing the expression is returned. If an optional
11154 expression is absent, a null pointer is returned, otherwise the pointer
11157 If an error occurs in parsing or compilation, in most cases a valid op
11158 tree is returned anyway. The error is reflected in the parser state,
11159 normally resulting in a single exception at the top level of parsing
11160 which covers all the compilation errors that occurred. Some compilation
11161 errors, however, will throw an exception immediately.
11167 Perl_parse_fullexpr(pTHX_ U32 flags)
11169 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11173 =for apidoc Amx|OP *|parse_block|U32 flags
11175 Parse a single complete Perl code block. This consists of an opening
11176 brace, a sequence of statements, and a closing brace. The block
11177 constitutes a lexical scope, so C<my> variables and various compile-time
11178 effects can be contained within it. It is up to the caller to ensure
11179 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11180 reflect the source of the code to be parsed and the lexical context for
11183 The op tree representing the code block is returned. This is always a
11184 real op, never a null pointer. It will normally be a C<lineseq> list,
11185 including C<nextstate> or equivalent ops. No ops to construct any kind
11186 of runtime scope are included by virtue of it being a block.
11188 If an error occurs in parsing or compilation, in most cases a valid op
11189 tree (most likely null) is returned anyway. The error is reflected in
11190 the parser state, normally resulting in a single exception at the top
11191 level of parsing which covers all the compilation errors that occurred.
11192 Some compilation errors, however, will throw an exception immediately.
11194 The I<flags> parameter is reserved for future use, and must always
11201 Perl_parse_block(pTHX_ U32 flags)
11204 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11205 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11209 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11211 Parse a single unadorned Perl statement. This may be a normal imperative
11212 statement or a declaration that has compile-time effect. It does not
11213 include any label or other affixture. It is up to the caller to ensure
11214 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11215 reflect the source of the code to be parsed and the lexical context for
11218 The op tree representing the statement is returned. This may be a
11219 null pointer if the statement is null, for example if it was actually
11220 a subroutine definition (which has compile-time side effects). If not
11221 null, it will be ops directly implementing the statement, suitable to
11222 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11223 equivalent op (except for those embedded in a scope contained entirely
11224 within the statement).
11226 If an error occurs in parsing or compilation, in most cases a valid op
11227 tree (most likely null) is returned anyway. The error is reflected in
11228 the parser state, normally resulting in a single exception at the top
11229 level of parsing which covers all the compilation errors that occurred.
11230 Some compilation errors, however, will throw an exception immediately.
11232 The I<flags> parameter is reserved for future use, and must always
11239 Perl_parse_barestmt(pTHX_ U32 flags)
11242 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11243 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11247 =for apidoc Amx|SV *|parse_label|U32 flags
11249 Parse a single label, possibly optional, of the type that may prefix a
11250 Perl statement. It is up to the caller to ensure that the dynamic parser
11251 state (L</PL_parser> et al) is correctly set to reflect the source of
11252 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11253 label is optional, otherwise it is mandatory.
11255 The name of the label is returned in the form of a fresh scalar. If an
11256 optional label is absent, a null pointer is returned.
11258 If an error occurs in parsing, which can only occur if the label is
11259 mandatory, a valid label is returned anyway. The error is reflected in
11260 the parser state, normally resulting in a single exception at the top
11261 level of parsing which covers all the compilation errors that occurred.
11267 Perl_parse_label(pTHX_ U32 flags)
11269 if (flags & ~PARSE_OPTIONAL)
11270 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11271 if (PL_lex_state == LEX_KNOWNEXT) {
11272 PL_parser->yychar = yylex();
11273 if (PL_parser->yychar == LABEL) {
11274 char *lpv = pl_yylval.pval;
11275 STRLEN llen = strlen(lpv);
11277 PL_parser->yychar = YYEMPTY;
11278 lsv = newSV_type(SVt_PV);
11279 SvPV_set(lsv, lpv);
11280 SvCUR_set(lsv, llen);
11281 SvLEN_set(lsv, llen+1);
11291 STRLEN wlen, bufptr_pos;
11295 if (!isIDFIRST_A(c))
11299 } while(isWORDCHAR_A(c));
11301 if (word_takes_any_delimeter(s, wlen))
11303 bufptr_pos = s - SvPVX(PL_linestr);
11305 lex_read_space(LEX_KEEP_PREVIOUS);
11307 s = SvPVX(PL_linestr) + bufptr_pos;
11308 if (t[0] == ':' && t[1] != ':') {
11309 PL_oldoldbufptr = PL_oldbufptr;
11312 return newSVpvn(s, wlen);
11316 if (flags & PARSE_OPTIONAL) {
11319 qerror(Perl_mess(aTHX_ "Parse error"));
11320 return newSVpvs("x");
11327 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11329 Parse a single complete Perl statement. This may be a normal imperative
11330 statement or a declaration that has compile-time effect, and may include
11331 optional labels. It is up to the caller to ensure that the dynamic
11332 parser state (L</PL_parser> et al) is correctly set to reflect the source
11333 of the code to be parsed and the lexical context for the statement.
11335 The op tree representing the statement is returned. This may be a
11336 null pointer if the statement is null, for example if it was actually
11337 a subroutine definition (which has compile-time side effects). If not
11338 null, it will be the result of a L</newSTATEOP> call, normally including
11339 a C<nextstate> or equivalent op.
11341 If an error occurs in parsing or compilation, in most cases a valid op
11342 tree (most likely null) is returned anyway. The error is reflected in
11343 the parser state, normally resulting in a single exception at the top
11344 level of parsing which covers all the compilation errors that occurred.
11345 Some compilation errors, however, will throw an exception immediately.
11347 The I<flags> parameter is reserved for future use, and must always
11354 Perl_parse_fullstmt(pTHX_ U32 flags)
11357 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11358 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11362 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11364 Parse a sequence of zero or more Perl statements. These may be normal
11365 imperative statements, including optional labels, or declarations
11366 that have compile-time effect, or any mixture thereof. The statement
11367 sequence ends when a closing brace or end-of-file is encountered in a
11368 place where a new statement could have validly started. It is up to
11369 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11370 is correctly set to reflect the source of the code to be parsed and the
11371 lexical context for the statements.
11373 The op tree representing the statement sequence is returned. This may
11374 be a null pointer if the statements were all null, for example if there
11375 were no statements or if there were only subroutine definitions (which
11376 have compile-time side effects). If not null, it will be a C<lineseq>
11377 list, normally including C<nextstate> or equivalent ops.
11379 If an error occurs in parsing or compilation, in most cases a valid op
11380 tree is returned anyway. The error is reflected in the parser state,
11381 normally resulting in a single exception at the top level of parsing
11382 which covers all the compilation errors that occurred. Some compilation
11383 errors, however, will throw an exception immediately.
11385 The I<flags> parameter is reserved for future use, and must always
11392 Perl_parse_stmtseq(pTHX_ U32 flags)
11397 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11398 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11399 c = lex_peek_unichar(0);
11400 if (c != -1 && c != /*{*/'}')
11401 qerror(Perl_mess(aTHX_ "Parse error"));
11406 Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist)
11408 PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
11409 deprecate("qw(...) as parentheses");
11410 force_next((4<<24)|')');
11411 if (qwlist->op_type == OP_STUB) {
11415 start_force(PL_curforce);
11416 NEXTVAL_NEXTTOKE.opval = qwlist;
11419 force_next((2<<24)|'(');
11424 * c-indentation-style: bsd
11425 * c-basic-offset: 4
11426 * indent-tabs-mode: t
11429 * ex: set ts=8 sts=4 sw=4 noet: