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_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (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. Currently it is only
673 used by perl internally, so extensions should always pass zero.
678 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
679 can share filters with the current parser. */
682 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
685 const char *s = NULL;
686 yy_parser *parser, *oparser;
687 if (flags && flags & ~LEX_START_FLAGS)
688 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
690 /* create and initialise a parser */
692 Newxz(parser, 1, yy_parser);
693 parser->old_parser = oparser = PL_parser;
696 parser->stack = NULL;
698 parser->stack_size = 0;
700 /* on scope exit, free this parser and restore any outer one */
702 parser->saved_curcop = PL_curcop;
704 /* initialise lexer state */
707 parser->curforce = -1;
709 parser->nexttoke = 0;
711 parser->error_count = oparser ? oparser->error_count : 0;
712 parser->copline = NOLINE;
713 parser->lex_state = LEX_NORMAL;
714 parser->expect = XSTATE;
716 parser->rsfp_filters =
717 !(flags & LEX_START_SAME_FILTER) || !oparser
719 : MUTABLE_AV(SvREFCNT_inc(
720 oparser->rsfp_filters
721 ? oparser->rsfp_filters
722 : (oparser->rsfp_filters = newAV())
725 Newx(parser->lex_brackstack, 120, char);
726 Newx(parser->lex_casestack, 12, char);
727 *parser->lex_casestack = '\0';
731 s = SvPV_const(line, len);
732 parser->linestr = flags & LEX_START_COPIED
733 ? SvREFCNT_inc_simple_NN(line)
734 : newSVpvn_flags(s, len, SvUTF8(line));
735 if (!len || s[len-1] != ';')
736 sv_catpvs(parser->linestr, "\n;");
738 parser->linestr = newSVpvs("\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;
746 parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES);
748 parser->in_pod = parser->filtered = 0;
752 /* delete a parser object */
755 Perl_parser_free(pTHX_ const yy_parser *parser)
757 PERL_ARGS_ASSERT_PARSER_FREE;
759 PL_curcop = parser->saved_curcop;
760 SvREFCNT_dec(parser->linestr);
762 if (parser->rsfp == PerlIO_stdin())
763 PerlIO_clearerr(parser->rsfp);
764 else if (parser->rsfp && (!parser->old_parser ||
765 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
766 PerlIO_close(parser->rsfp);
767 SvREFCNT_dec(parser->rsfp_filters);
769 Safefree(parser->lex_brackstack);
770 Safefree(parser->lex_casestack);
771 PL_parser = parser->old_parser;
777 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
779 Buffer scalar containing the chunk currently under consideration of the
780 text currently being lexed. This is always a plain string scalar (for
781 which C<SvPOK> is true). It is not intended to be used as a scalar by
782 normal scalar means; instead refer to the buffer directly by the pointer
783 variables described below.
785 The lexer maintains various C<char*> pointers to things in the
786 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
787 reallocated, all of these pointers must be updated. Don't attempt to
788 do this manually, but rather use L</lex_grow_linestr> if you need to
789 reallocate the buffer.
791 The content of the text chunk in the buffer is commonly exactly one
792 complete line of input, up to and including a newline terminator,
793 but there are situations where it is otherwise. The octets of the
794 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
795 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
796 flag on this scalar, which may disagree with it.
798 For direct examination of the buffer, the variable
799 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
800 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
801 of these pointers is usually preferable to examination of the scalar
802 through normal scalar means.
804 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
806 Direct pointer to the end of the chunk of text currently being lexed, the
807 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
808 + SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
809 always located at the end of the buffer, and does not count as part of
810 the buffer's contents.
812 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
814 Points to the current position of lexing inside the lexer buffer.
815 Characters around this point may be freely examined, within
816 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
817 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
818 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
820 Lexing code (whether in the Perl core or not) moves this pointer past
821 the characters that it consumes. It is also expected to perform some
822 bookkeeping whenever a newline character is consumed. This movement
823 can be more conveniently performed by the function L</lex_read_to>,
824 which handles newlines appropriately.
826 Interpretation of the buffer's octets can be abstracted out by
827 using the slightly higher-level functions L</lex_peek_unichar> and
828 L</lex_read_unichar>.
830 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
832 Points to the start of the current line inside the lexer buffer.
833 This is useful for indicating at which column an error occurred, and
834 not much else. This must be updated by any lexing code that consumes
835 a newline; the function L</lex_read_to> handles this detail.
841 =for apidoc Amx|bool|lex_bufutf8
843 Indicates whether the octets in the lexer buffer
844 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
845 of Unicode characters. If not, they should be interpreted as Latin-1
846 characters. This is analogous to the C<SvUTF8> flag for scalars.
848 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
849 contains valid UTF-8. Lexing code must be robust in the face of invalid
852 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
853 is significant, but not the whole story regarding the input character
854 encoding. Normally, when a file is being read, the scalar contains octets
855 and its C<SvUTF8> flag is off, but the octets should be interpreted as
856 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
857 however, the scalar may have the C<SvUTF8> flag on, and in this case its
858 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
859 is in effect. This logic may change in the future; use this function
860 instead of implementing the logic yourself.
866 Perl_lex_bufutf8(pTHX)
872 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
874 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
875 at least I<len> octets (including terminating NUL). Returns a
876 pointer to the reallocated buffer. This is necessary before making
877 any direct modification of the buffer that would increase its length.
878 L</lex_stuff_pvn> provides a more convenient way to insert text into
881 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
882 this function updates all of the lexer's variables that point directly
889 Perl_lex_grow_linestr(pTHX_ STRLEN len)
893 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
894 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
895 linestr = PL_parser->linestr;
896 buf = SvPVX(linestr);
897 if (len <= SvLEN(linestr))
899 bufend_pos = PL_parser->bufend - buf;
900 bufptr_pos = PL_parser->bufptr - buf;
901 oldbufptr_pos = PL_parser->oldbufptr - buf;
902 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
903 linestart_pos = PL_parser->linestart - buf;
904 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
905 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
906 buf = sv_grow(linestr, len);
907 PL_parser->bufend = buf + bufend_pos;
908 PL_parser->bufptr = buf + bufptr_pos;
909 PL_parser->oldbufptr = buf + oldbufptr_pos;
910 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
911 PL_parser->linestart = buf + linestart_pos;
912 if (PL_parser->last_uni)
913 PL_parser->last_uni = buf + last_uni_pos;
914 if (PL_parser->last_lop)
915 PL_parser->last_lop = buf + last_lop_pos;
920 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
922 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
923 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
924 reallocating the buffer if necessary. This means that lexing code that
925 runs later will see the characters as if they had appeared in the input.
926 It is not recommended to do this as part of normal parsing, and most
927 uses of this facility run the risk of the inserted characters being
928 interpreted in an unintended manner.
930 The string to be inserted is represented by I<len> octets starting
931 at I<pv>. These octets are interpreted as either UTF-8 or Latin-1,
932 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
933 The characters are recoded for the lexer buffer, according to how the
934 buffer is currently being interpreted (L</lex_bufutf8>). If a string
935 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
936 function is more convenient.
942 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
946 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
947 if (flags & ~(LEX_STUFF_UTF8))
948 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
950 if (flags & LEX_STUFF_UTF8) {
954 const char *p, *e = pv+len;
955 for (p = pv; p != e; p++)
956 highhalf += !!(((U8)*p) & 0x80);
959 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
960 bufptr = PL_parser->bufptr;
961 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
962 SvCUR_set(PL_parser->linestr,
963 SvCUR(PL_parser->linestr) + len+highhalf);
964 PL_parser->bufend += len+highhalf;
965 for (p = pv; p != e; p++) {
968 *bufptr++ = (char)(0xc0 | (c >> 6));
969 *bufptr++ = (char)(0x80 | (c & 0x3f));
976 if (flags & LEX_STUFF_UTF8) {
978 const char *p, *e = pv+len;
979 for (p = pv; p != e; p++) {
982 Perl_croak(aTHX_ "Lexing code attempted to stuff "
983 "non-Latin-1 character into Latin-1 input");
984 } else if (c >= 0xc2 && p+1 != e &&
985 (((U8)p[1]) & 0xc0) == 0x80) {
988 } else if (c >= 0x80) {
989 /* malformed UTF-8 */
991 SAVESPTR(PL_warnhook);
992 PL_warnhook = PERL_WARNHOOK_FATAL;
993 utf8n_to_uvuni((U8*)p, e-p, NULL, 0);
999 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1000 bufptr = PL_parser->bufptr;
1001 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1002 SvCUR_set(PL_parser->linestr,
1003 SvCUR(PL_parser->linestr) + len-highhalf);
1004 PL_parser->bufend += len-highhalf;
1005 for (p = pv; p != e; p++) {
1008 *bufptr++ = (char)(((c & 0x3) << 6) | (p[1] & 0x3f));
1011 *bufptr++ = (char)c;
1016 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1017 bufptr = PL_parser->bufptr;
1018 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1019 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1020 PL_parser->bufend += len;
1021 Copy(pv, bufptr, len, char);
1027 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1029 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1030 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1031 reallocating the buffer if necessary. This means that lexing code that
1032 runs later will see the characters as if they had appeared in the input.
1033 It is not recommended to do this as part of normal parsing, and most
1034 uses of this facility run the risk of the inserted characters being
1035 interpreted in an unintended manner.
1037 The string to be inserted is represented by octets starting at I<pv>
1038 and continuing to the first nul. These octets are interpreted as either
1039 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1040 in I<flags>. The characters are recoded for the lexer buffer, according
1041 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1042 If it is not convenient to nul-terminate a string to be inserted, the
1043 L</lex_stuff_pvn> function is more appropriate.
1049 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1051 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1052 lex_stuff_pvn(pv, strlen(pv), flags);
1056 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1058 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1059 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1060 reallocating the buffer if necessary. This means that lexing code that
1061 runs later will see the characters as if they had appeared in the input.
1062 It is not recommended to do this as part of normal parsing, and most
1063 uses of this facility run the risk of the inserted characters being
1064 interpreted in an unintended manner.
1066 The string to be inserted is the string value of I<sv>. The characters
1067 are recoded for the lexer buffer, according to how the buffer is currently
1068 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1069 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1070 need to construct a scalar.
1076 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1080 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1082 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1084 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1088 =for apidoc Amx|void|lex_unstuff|char *ptr
1090 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1091 I<ptr>. Text following I<ptr> will be moved, and the buffer shortened.
1092 This hides the discarded text from any lexing code that runs later,
1093 as if the text had never appeared.
1095 This is not the normal way to consume lexed text. For that, use
1102 Perl_lex_unstuff(pTHX_ char *ptr)
1106 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1107 buf = PL_parser->bufptr;
1109 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1112 bufend = PL_parser->bufend;
1114 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1115 unstuff_len = ptr - buf;
1116 Move(ptr, buf, bufend+1-ptr, char);
1117 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1118 PL_parser->bufend = bufend - unstuff_len;
1122 =for apidoc Amx|void|lex_read_to|char *ptr
1124 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1125 to I<ptr>. This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
1126 performing the correct bookkeeping whenever a newline character is passed.
1127 This is the normal way to consume lexed text.
1129 Interpretation of the buffer's octets can be abstracted out by
1130 using the slightly higher-level functions L</lex_peek_unichar> and
1131 L</lex_read_unichar>.
1137 Perl_lex_read_to(pTHX_ char *ptr)
1140 PERL_ARGS_ASSERT_LEX_READ_TO;
1141 s = PL_parser->bufptr;
1142 if (ptr < s || ptr > PL_parser->bufend)
1143 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1144 for (; s != ptr; s++)
1146 CopLINE_inc(PL_curcop);
1147 PL_parser->linestart = s+1;
1149 PL_parser->bufptr = ptr;
1153 =for apidoc Amx|void|lex_discard_to|char *ptr
1155 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1156 up to I<ptr>. The remaining content of the buffer will be moved, and
1157 all pointers into the buffer updated appropriately. I<ptr> must not
1158 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1159 it is not permitted to discard text that has yet to be lexed.
1161 Normally it is not necessarily to do this directly, because it suffices to
1162 use the implicit discarding behaviour of L</lex_next_chunk> and things
1163 based on it. However, if a token stretches across multiple lines,
1164 and the lexing code has kept multiple lines of text in the buffer for
1165 that purpose, then after completion of the token it would be wise to
1166 explicitly discard the now-unneeded earlier lines, to avoid future
1167 multi-line tokens growing the buffer without bound.
1173 Perl_lex_discard_to(pTHX_ char *ptr)
1177 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1178 buf = SvPVX(PL_parser->linestr);
1180 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1183 if (ptr > PL_parser->bufptr)
1184 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1185 discard_len = ptr - buf;
1186 if (PL_parser->oldbufptr < ptr)
1187 PL_parser->oldbufptr = ptr;
1188 if (PL_parser->oldoldbufptr < ptr)
1189 PL_parser->oldoldbufptr = ptr;
1190 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1191 PL_parser->last_uni = NULL;
1192 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1193 PL_parser->last_lop = NULL;
1194 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1195 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1196 PL_parser->bufend -= discard_len;
1197 PL_parser->bufptr -= discard_len;
1198 PL_parser->oldbufptr -= discard_len;
1199 PL_parser->oldoldbufptr -= discard_len;
1200 if (PL_parser->last_uni)
1201 PL_parser->last_uni -= discard_len;
1202 if (PL_parser->last_lop)
1203 PL_parser->last_lop -= discard_len;
1207 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1209 Reads in the next chunk of text to be lexed, appending it to
1210 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1211 looked to the end of the current chunk and wants to know more. It is
1212 usual, but not necessary, for lexing to have consumed the entirety of
1213 the current chunk at this time.
1215 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1216 chunk (i.e., the current chunk has been entirely consumed), normally the
1217 current chunk will be discarded at the same time that the new chunk is
1218 read in. If I<flags> includes C<LEX_KEEP_PREVIOUS>, the current chunk
1219 will not be discarded. If the current chunk has not been entirely
1220 consumed, then it will not be discarded regardless of the flag.
1222 Returns true if some new text was added to the buffer, or false if the
1223 buffer has reached the end of the input text.
1228 #define LEX_FAKE_EOF 0x80000000
1231 Perl_lex_next_chunk(pTHX_ U32 flags)
1235 STRLEN old_bufend_pos, new_bufend_pos;
1236 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1237 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1238 bool got_some_for_debugger = 0;
1240 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF))
1241 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1242 linestr = PL_parser->linestr;
1243 buf = SvPVX(linestr);
1244 if (!(flags & LEX_KEEP_PREVIOUS) &&
1245 PL_parser->bufptr == PL_parser->bufend) {
1246 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1248 if (PL_parser->last_uni != PL_parser->bufend)
1249 PL_parser->last_uni = NULL;
1250 if (PL_parser->last_lop != PL_parser->bufend)
1251 PL_parser->last_lop = NULL;
1252 last_uni_pos = last_lop_pos = 0;
1256 old_bufend_pos = PL_parser->bufend - buf;
1257 bufptr_pos = PL_parser->bufptr - buf;
1258 oldbufptr_pos = PL_parser->oldbufptr - buf;
1259 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1260 linestart_pos = PL_parser->linestart - buf;
1261 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1262 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1264 if (flags & LEX_FAKE_EOF) {
1266 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1268 } else if (filter_gets(linestr, old_bufend_pos)) {
1270 got_some_for_debugger = 1;
1272 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1273 sv_setpvs(linestr, "");
1275 /* End of real input. Close filehandle (unless it was STDIN),
1276 * then add implicit termination.
1278 if ((PerlIO*)PL_parser->rsfp == PerlIO_stdin())
1279 PerlIO_clearerr(PL_parser->rsfp);
1280 else if (PL_parser->rsfp)
1281 (void)PerlIO_close(PL_parser->rsfp);
1282 PL_parser->rsfp = NULL;
1283 PL_parser->in_pod = PL_parser->filtered = 0;
1285 if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1288 if (!PL_in_eval && PL_minus_p) {
1290 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1291 PL_minus_n = PL_minus_p = 0;
1292 } else if (!PL_in_eval && PL_minus_n) {
1293 sv_catpvs(linestr, /*{*/";}");
1296 sv_catpvs(linestr, ";");
1299 buf = SvPVX(linestr);
1300 new_bufend_pos = SvCUR(linestr);
1301 PL_parser->bufend = buf + new_bufend_pos;
1302 PL_parser->bufptr = buf + bufptr_pos;
1303 PL_parser->oldbufptr = buf + oldbufptr_pos;
1304 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1305 PL_parser->linestart = buf + linestart_pos;
1306 if (PL_parser->last_uni)
1307 PL_parser->last_uni = buf + last_uni_pos;
1308 if (PL_parser->last_lop)
1309 PL_parser->last_lop = buf + last_lop_pos;
1310 if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1311 PL_curstash != PL_debstash) {
1312 /* debugger active and we're not compiling the debugger code,
1313 * so store the line into the debugger's array of lines
1315 update_debugger_info(NULL, buf+old_bufend_pos,
1316 new_bufend_pos-old_bufend_pos);
1322 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1324 Looks ahead one (Unicode) character in the text currently being lexed.
1325 Returns the codepoint (unsigned integer value) of the next character,
1326 or -1 if lexing has reached the end of the input text. To consume the
1327 peeked character, use L</lex_read_unichar>.
1329 If the next character is in (or extends into) the next chunk of input
1330 text, the next chunk will be read in. Normally the current chunk will be
1331 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1332 then the current chunk will not be discarded.
1334 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1335 is encountered, an exception is generated.
1341 Perl_lex_peek_unichar(pTHX_ U32 flags)
1345 if (flags & ~(LEX_KEEP_PREVIOUS))
1346 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1347 s = PL_parser->bufptr;
1348 bufend = PL_parser->bufend;
1354 if (!lex_next_chunk(flags))
1356 s = PL_parser->bufptr;
1357 bufend = PL_parser->bufend;
1363 len = PL_utf8skip[head];
1364 while ((STRLEN)(bufend-s) < len) {
1365 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1367 s = PL_parser->bufptr;
1368 bufend = PL_parser->bufend;
1371 unichar = utf8n_to_uvuni((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1372 if (retlen == (STRLEN)-1) {
1373 /* malformed UTF-8 */
1375 SAVESPTR(PL_warnhook);
1376 PL_warnhook = PERL_WARNHOOK_FATAL;
1377 utf8n_to_uvuni((U8*)s, bufend-s, NULL, 0);
1383 if (!lex_next_chunk(flags))
1385 s = PL_parser->bufptr;
1392 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1394 Reads the next (Unicode) character in the text currently being lexed.
1395 Returns the codepoint (unsigned integer value) of the character read,
1396 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1397 if lexing has reached the end of the input text. To non-destructively
1398 examine the next character, use L</lex_peek_unichar> instead.
1400 If the next character is in (or extends into) the next chunk of input
1401 text, the next chunk will be read in. Normally the current chunk will be
1402 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1403 then the current chunk will not be discarded.
1405 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1406 is encountered, an exception is generated.
1412 Perl_lex_read_unichar(pTHX_ U32 flags)
1415 if (flags & ~(LEX_KEEP_PREVIOUS))
1416 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1417 c = lex_peek_unichar(flags);
1420 CopLINE_inc(PL_curcop);
1422 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1424 ++(PL_parser->bufptr);
1430 =for apidoc Amx|void|lex_read_space|U32 flags
1432 Reads optional spaces, in Perl style, in the text currently being
1433 lexed. The spaces may include ordinary whitespace characters and
1434 Perl-style comments. C<#line> directives are processed if encountered.
1435 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1436 at a non-space character (or the end of the input text).
1438 If spaces extend into the next chunk of input text, the next chunk will
1439 be read in. Normally the current chunk will be discarded at the same
1440 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1441 chunk will not be discarded.
1446 #define LEX_NO_NEXT_CHUNK 0x80000000
1449 Perl_lex_read_space(pTHX_ U32 flags)
1452 bool need_incline = 0;
1453 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK))
1454 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1457 sv_free(PL_skipwhite);
1458 PL_skipwhite = NULL;
1461 PL_skipwhite = newSVpvs("");
1462 #endif /* PERL_MAD */
1463 s = PL_parser->bufptr;
1464 bufend = PL_parser->bufend;
1470 } while (!(c == '\n' || (c == 0 && s == bufend)));
1471 } else if (c == '\n') {
1473 PL_parser->linestart = s;
1478 } else if (isSPACE(c)) {
1480 } else if (c == 0 && s == bufend) {
1484 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1485 #endif /* PERL_MAD */
1486 if (flags & LEX_NO_NEXT_CHUNK)
1488 PL_parser->bufptr = s;
1489 CopLINE_inc(PL_curcop);
1490 got_more = lex_next_chunk(flags);
1491 CopLINE_dec(PL_curcop);
1492 s = PL_parser->bufptr;
1493 bufend = PL_parser->bufend;
1496 if (need_incline && PL_parser->rsfp) {
1506 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1507 #endif /* PERL_MAD */
1508 PL_parser->bufptr = s;
1513 * This subroutine has nothing to do with tilting, whether at windmills
1514 * or pinball tables. Its name is short for "increment line". It
1515 * increments the current line number in CopLINE(PL_curcop) and checks
1516 * to see whether the line starts with a comment of the form
1517 * # line 500 "foo.pm"
1518 * If so, it sets the current line number and file to the values in the comment.
1522 S_incline(pTHX_ const char *s)
1530 PERL_ARGS_ASSERT_INCLINE;
1532 CopLINE_inc(PL_curcop);
1535 while (SPACE_OR_TAB(*s))
1537 if (strnEQ(s, "line", 4))
1541 if (SPACE_OR_TAB(*s))
1545 while (SPACE_OR_TAB(*s))
1553 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1555 while (SPACE_OR_TAB(*s))
1557 if (*s == '"' && (t = strchr(s+1, '"'))) {
1563 while (!isSPACE(*t))
1567 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1569 if (*e != '\n' && *e != '\0')
1570 return; /* false alarm */
1572 line_num = atoi(n)-1;
1575 const STRLEN len = t - s;
1576 SV *const temp_sv = CopFILESV(PL_curcop);
1581 cf = SvPVX(temp_sv);
1582 tmplen = SvCUR(temp_sv);
1588 if (!PL_rsfp && !PL_parser->filtered) {
1589 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1590 * to *{"::_<newfilename"} */
1591 /* However, the long form of evals is only turned on by the
1592 debugger - usually they're "(eval %lu)" */
1596 STRLEN tmplen2 = len;
1597 if (tmplen + 2 <= sizeof smallbuf)
1600 Newx(tmpbuf, tmplen + 2, char);
1603 memcpy(tmpbuf + 2, cf, tmplen);
1605 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
1610 if (tmplen2 + 2 <= sizeof smallbuf)
1613 Newx(tmpbuf2, tmplen2 + 2, char);
1615 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
1616 /* Either they malloc'd it, or we malloc'd it,
1617 so no prefix is present in ours. */
1622 memcpy(tmpbuf2 + 2, s, tmplen2);
1625 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1627 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1628 /* adjust ${"::_<newfilename"} to store the new file name */
1629 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1630 /* The line number may differ. If that is the case,
1631 alias the saved lines that are in the array.
1632 Otherwise alias the whole array. */
1633 if (CopLINE(PL_curcop) == line_num) {
1634 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
1635 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
1637 else if (GvAV(*gvp)) {
1638 AV * const av = GvAV(*gvp);
1639 const I32 start = CopLINE(PL_curcop)+1;
1640 I32 items = AvFILLp(av) - start;
1642 AV * const av2 = GvAVn(gv2);
1643 SV **svp = AvARRAY(av) + start;
1644 I32 l = (I32)line_num+1;
1646 av_store(av2, l++, SvREFCNT_inc(*svp++));
1651 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1653 if (tmpbuf != smallbuf) Safefree(tmpbuf);
1655 CopFILE_free(PL_curcop);
1656 CopFILE_setn(PL_curcop, s, len);
1658 CopLINE_set(PL_curcop, line_num);
1662 /* skip space before PL_thistoken */
1665 S_skipspace0(pTHX_ register char *s)
1667 PERL_ARGS_ASSERT_SKIPSPACE0;
1674 PL_thiswhite = newSVpvs("");
1675 sv_catsv(PL_thiswhite, PL_skipwhite);
1676 sv_free(PL_skipwhite);
1679 PL_realtokenstart = s - SvPVX(PL_linestr);
1683 /* skip space after PL_thistoken */
1686 S_skipspace1(pTHX_ register char *s)
1688 const char *start = s;
1689 I32 startoff = start - SvPVX(PL_linestr);
1691 PERL_ARGS_ASSERT_SKIPSPACE1;
1696 start = SvPVX(PL_linestr) + startoff;
1697 if (!PL_thistoken && PL_realtokenstart >= 0) {
1698 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1699 PL_thistoken = newSVpvn(tstart, start - tstart);
1701 PL_realtokenstart = -1;
1704 PL_nextwhite = newSVpvs("");
1705 sv_catsv(PL_nextwhite, PL_skipwhite);
1706 sv_free(PL_skipwhite);
1713 S_skipspace2(pTHX_ register char *s, SV **svp)
1716 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
1717 const I32 startoff = s - SvPVX(PL_linestr);
1719 PERL_ARGS_ASSERT_SKIPSPACE2;
1722 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
1723 if (!PL_madskills || !svp)
1725 start = SvPVX(PL_linestr) + startoff;
1726 if (!PL_thistoken && PL_realtokenstart >= 0) {
1727 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1728 PL_thistoken = newSVpvn(tstart, start - tstart);
1729 PL_realtokenstart = -1;
1733 *svp = newSVpvs("");
1734 sv_setsv(*svp, PL_skipwhite);
1735 sv_free(PL_skipwhite);
1744 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1746 AV *av = CopFILEAVx(PL_curcop);
1748 SV * const sv = newSV_type(SVt_PVMG);
1750 sv_setsv(sv, orig_sv);
1752 sv_setpvn(sv, buf, len);
1755 av_store(av, (I32)CopLINE(PL_curcop), sv);
1761 * Called to gobble the appropriate amount and type of whitespace.
1762 * Skips comments as well.
1766 S_skipspace(pTHX_ register char *s)
1770 #endif /* PERL_MAD */
1771 PERL_ARGS_ASSERT_SKIPSPACE;
1774 sv_free(PL_skipwhite);
1775 PL_skipwhite = NULL;
1777 #endif /* PERL_MAD */
1778 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1779 while (s < PL_bufend && SPACE_OR_TAB(*s))
1782 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1784 lex_read_space(LEX_KEEP_PREVIOUS |
1785 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1786 LEX_NO_NEXT_CHUNK : 0));
1788 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1789 if (PL_linestart > PL_bufptr)
1790 PL_bufptr = PL_linestart;
1795 PL_skipwhite = newSVpvn(start, s-start);
1796 #endif /* PERL_MAD */
1802 * Check the unary operators to ensure there's no ambiguity in how they're
1803 * used. An ambiguous piece of code would be:
1805 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1806 * the +5 is its argument.
1816 if (PL_oldoldbufptr != PL_last_uni)
1818 while (isSPACE(*PL_last_uni))
1821 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1823 if ((t = strchr(s, '(')) && t < PL_bufptr)
1826 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1827 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1828 (int)(s - PL_last_uni), PL_last_uni);
1832 * LOP : macro to build a list operator. Its behaviour has been replaced
1833 * with a subroutine, S_lop() for which LOP is just another name.
1836 #define LOP(f,x) return lop(f,x,s)
1840 * Build a list operator (or something that might be one). The rules:
1841 * - if we have a next token, then it's a list operator [why?]
1842 * - if the next thing is an opening paren, then it's a function
1843 * - else it's a list operator
1847 S_lop(pTHX_ I32 f, int x, char *s)
1851 PERL_ARGS_ASSERT_LOP;
1857 PL_last_lop = PL_oldbufptr;
1858 PL_last_lop_op = (OPCODE)f;
1867 return REPORT(FUNC);
1870 return REPORT(FUNC);
1873 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1874 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1875 return REPORT(LSTOP);
1882 * Sets up for an eventual force_next(). start_force(0) basically does
1883 * an unshift, while start_force(-1) does a push. yylex removes items
1888 S_start_force(pTHX_ int where)
1892 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1893 where = PL_lasttoke;
1894 assert(PL_curforce < 0 || PL_curforce == where);
1895 if (PL_curforce != where) {
1896 for (i = PL_lasttoke; i > where; --i) {
1897 PL_nexttoke[i] = PL_nexttoke[i-1];
1901 if (PL_curforce < 0) /* in case of duplicate start_force() */
1902 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1903 PL_curforce = where;
1906 curmad('^', newSVpvs(""));
1907 CURMAD('_', PL_nextwhite);
1912 S_curmad(pTHX_ char slot, SV *sv)
1918 if (PL_curforce < 0)
1919 where = &PL_thismad;
1921 where = &PL_nexttoke[PL_curforce].next_mad;
1927 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1929 else if (PL_encoding) {
1930 sv_recode_to_utf8(sv, PL_encoding);
1935 /* keep a slot open for the head of the list? */
1936 if (slot != '_' && *where && (*where)->mad_key == '^') {
1937 (*where)->mad_key = slot;
1938 sv_free(MUTABLE_SV(((*where)->mad_val)));
1939 (*where)->mad_val = (void*)sv;
1942 addmad(newMADsv(slot, sv), where, 0);
1945 # define start_force(where) NOOP
1946 # define curmad(slot, sv) NOOP
1951 * When the lexer realizes it knows the next token (for instance,
1952 * it is reordering tokens for the parser) then it can call S_force_next
1953 * to know what token to return the next time the lexer is called. Caller
1954 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1955 * and possibly PL_expect to ensure the lexer handles the token correctly.
1959 S_force_next(pTHX_ I32 type)
1964 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1965 tokereport(type, &NEXTVAL_NEXTTOKE);
1969 if (PL_curforce < 0)
1970 start_force(PL_lasttoke);
1971 PL_nexttoke[PL_curforce].next_type = type;
1972 if (PL_lex_state != LEX_KNOWNEXT)
1973 PL_lex_defer = PL_lex_state;
1974 PL_lex_state = LEX_KNOWNEXT;
1975 PL_lex_expect = PL_expect;
1978 PL_nexttype[PL_nexttoke] = type;
1980 if (PL_lex_state != LEX_KNOWNEXT) {
1981 PL_lex_defer = PL_lex_state;
1982 PL_lex_expect = PL_expect;
1983 PL_lex_state = LEX_KNOWNEXT;
1991 int yyc = PL_parser->yychar;
1992 if (yyc != YYEMPTY) {
1995 NEXTVAL_NEXTTOKE = PL_parser->yylval;
1996 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
1997 PL_lex_allbrackets--;
1999 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2000 } else if (yyc == '('/*)*/) {
2001 PL_lex_allbrackets--;
2006 PL_parser->yychar = YYEMPTY;
2011 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2014 SV * const sv = newSVpvn_utf8(start, len,
2017 && !is_ascii_string((const U8*)start, len)
2018 && is_utf8_string((const U8*)start, len));
2024 * When the lexer knows the next thing is a word (for instance, it has
2025 * just seen -> and it knows that the next char is a word char, then
2026 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2030 * char *start : buffer position (must be within PL_linestr)
2031 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2032 * int check_keyword : if true, Perl checks to make sure the word isn't
2033 * a keyword (do this if the word is a label, e.g. goto FOO)
2034 * int allow_pack : if true, : characters will also be allowed (require,
2035 * use, etc. do this)
2036 * int allow_initial_tick : used by the "sub" lexer only.
2040 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
2046 PERL_ARGS_ASSERT_FORCE_WORD;
2048 start = SKIPSPACE1(start);
2050 if (isIDFIRST_lazy_if(s,UTF) ||
2051 (allow_pack && *s == ':') ||
2052 (allow_initial_tick && *s == '\'') )
2054 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2055 if (check_keyword && keyword(PL_tokenbuf, len, 0))
2057 start_force(PL_curforce);
2059 curmad('X', newSVpvn(start,s-start));
2060 if (token == METHOD) {
2065 PL_expect = XOPERATOR;
2069 curmad('g', newSVpvs( "forced" ));
2070 NEXTVAL_NEXTTOKE.opval
2071 = (OP*)newSVOP(OP_CONST,0,
2072 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2073 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2081 * Called when the lexer wants $foo *foo &foo etc, but the program
2082 * text only contains the "foo" portion. The first argument is a pointer
2083 * to the "foo", and the second argument is the type symbol to prefix.
2084 * Forces the next token to be a "WORD".
2085 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2089 S_force_ident(pTHX_ register const char *s, int kind)
2093 PERL_ARGS_ASSERT_FORCE_IDENT;
2096 const STRLEN len = strlen(s);
2097 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2098 UTF ? SVf_UTF8 : 0));
2099 start_force(PL_curforce);
2100 NEXTVAL_NEXTTOKE.opval = o;
2103 o->op_private = OPpCONST_ENTERED;
2104 /* XXX see note in pp_entereval() for why we forgo typo
2105 warnings if the symbol must be introduced in an eval.
2107 gv_fetchpvn_flags(s, len,
2108 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2109 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2110 kind == '$' ? SVt_PV :
2111 kind == '@' ? SVt_PVAV :
2112 kind == '%' ? SVt_PVHV :
2120 Perl_str_to_version(pTHX_ SV *sv)
2125 const char *start = SvPV_const(sv,len);
2126 const char * const end = start + len;
2127 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2129 PERL_ARGS_ASSERT_STR_TO_VERSION;
2131 while (start < end) {
2135 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2140 retval += ((NV)n)/nshift;
2149 * Forces the next token to be a version number.
2150 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2151 * and if "guessing" is TRUE, then no new token is created (and the caller
2152 * must use an alternative parsing method).
2156 S_force_version(pTHX_ char *s, int guessing)
2162 I32 startoff = s - SvPVX(PL_linestr);
2165 PERL_ARGS_ASSERT_FORCE_VERSION;
2173 while (isDIGIT(*d) || *d == '_' || *d == '.')
2177 start_force(PL_curforce);
2178 curmad('X', newSVpvn(s,d-s));
2181 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2183 #ifdef USE_LOCALE_NUMERIC
2184 char *loc = setlocale(LC_NUMERIC, "C");
2186 s = scan_num(s, &pl_yylval);
2187 #ifdef USE_LOCALE_NUMERIC
2188 setlocale(LC_NUMERIC, loc);
2190 version = pl_yylval.opval;
2191 ver = cSVOPx(version)->op_sv;
2192 if (SvPOK(ver) && !SvNIOK(ver)) {
2193 SvUPGRADE(ver, SVt_PVNV);
2194 SvNV_set(ver, str_to_version(ver));
2195 SvNOK_on(ver); /* hint that it is a version */
2198 else if (guessing) {
2201 sv_free(PL_nextwhite); /* let next token collect whitespace */
2203 s = SvPVX(PL_linestr) + startoff;
2211 if (PL_madskills && !version) {
2212 sv_free(PL_nextwhite); /* let next token collect whitespace */
2214 s = SvPVX(PL_linestr) + startoff;
2217 /* NOTE: The parser sees the package name and the VERSION swapped */
2218 start_force(PL_curforce);
2219 NEXTVAL_NEXTTOKE.opval = version;
2226 * S_force_strict_version
2227 * Forces the next token to be a version number using strict syntax rules.
2231 S_force_strict_version(pTHX_ char *s)
2236 I32 startoff = s - SvPVX(PL_linestr);
2238 const char *errstr = NULL;
2240 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2242 while (isSPACE(*s)) /* leading whitespace */
2245 if (is_STRICT_VERSION(s,&errstr)) {
2247 s = (char *)scan_version(s, ver, 0);
2248 version = newSVOP(OP_CONST, 0, ver);
2250 else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2251 (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2255 yyerror(errstr); /* version required */
2260 if (PL_madskills && !version) {
2261 sv_free(PL_nextwhite); /* let next token collect whitespace */
2263 s = SvPVX(PL_linestr) + startoff;
2266 /* NOTE: The parser sees the package name and the VERSION swapped */
2267 start_force(PL_curforce);
2268 NEXTVAL_NEXTTOKE.opval = version;
2276 * Tokenize a quoted string passed in as an SV. It finds the next
2277 * chunk, up to end of string or a backslash. It may make a new
2278 * SV containing that chunk (if HINT_NEW_STRING is on). It also
2283 S_tokeq(pTHX_ SV *sv)
2287 register char *send;
2292 PERL_ARGS_ASSERT_TOKEQ;
2297 s = SvPV_force(sv, len);
2298 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2301 /* This is relying on the SV being "well formed" with a trailing '\0' */
2302 while (s < send && !(*s == '\\' && s[1] == '\\'))
2307 if ( PL_hints & HINT_NEW_STRING ) {
2308 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2312 if (s + 1 < send && (s[1] == '\\'))
2313 s++; /* all that, just for this */
2318 SvCUR_set(sv, d - SvPVX_const(sv));
2320 if ( PL_hints & HINT_NEW_STRING )
2321 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2326 * Now come three functions related to double-quote context,
2327 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2328 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2329 * interact with PL_lex_state, and create fake ( ... ) argument lists
2330 * to handle functions and concatenation.
2331 * They assume that whoever calls them will be setting up a fake
2332 * join call, because each subthing puts a ',' after it. This lets
2335 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
2337 * (I'm not sure whether the spurious commas at the end of lcfirst's
2338 * arguments and join's arguments are created or not).
2343 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2345 * Pattern matching will set PL_lex_op to the pattern-matching op to
2346 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2348 * OP_CONST and OP_READLINE are easy--just make the new op and return.
2350 * Everything else becomes a FUNC.
2352 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2353 * had an OP_CONST or OP_READLINE). This just sets us up for a
2354 * call to S_sublex_push().
2358 S_sublex_start(pTHX)
2361 register const I32 op_type = pl_yylval.ival;
2363 if (op_type == OP_NULL) {
2364 pl_yylval.opval = PL_lex_op;
2368 if (op_type == OP_CONST || op_type == OP_READLINE) {
2369 SV *sv = tokeq(PL_lex_stuff);
2371 if (SvTYPE(sv) == SVt_PVIV) {
2372 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2374 const char * const p = SvPV_const(sv, len);
2375 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2379 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2380 PL_lex_stuff = NULL;
2381 /* Allow <FH> // "foo" */
2382 if (op_type == OP_READLINE)
2383 PL_expect = XTERMORDORDOR;
2386 else if (op_type == OP_BACKTICK && PL_lex_op) {
2387 /* readpipe() vas overriden */
2388 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2389 pl_yylval.opval = PL_lex_op;
2391 PL_lex_stuff = NULL;
2395 PL_sublex_info.super_state = PL_lex_state;
2396 PL_sublex_info.sub_inwhat = (U16)op_type;
2397 PL_sublex_info.sub_op = PL_lex_op;
2398 PL_lex_state = LEX_INTERPPUSH;
2402 pl_yylval.opval = PL_lex_op;
2412 * Create a new scope to save the lexing state. The scope will be
2413 * ended in S_sublex_done. Returns a '(', starting the function arguments
2414 * to the uc, lc, etc. found before.
2415 * Sets PL_lex_state to LEX_INTERPCONCAT.
2424 PL_lex_state = PL_sublex_info.super_state;
2425 SAVEBOOL(PL_lex_dojoin);
2426 SAVEI32(PL_lex_brackets);
2427 SAVEI32(PL_lex_allbrackets);
2428 SAVEI8(PL_lex_fakeeof);
2429 SAVEI32(PL_lex_casemods);
2430 SAVEI32(PL_lex_starts);
2431 SAVEI8(PL_lex_state);
2432 SAVEVPTR(PL_lex_inpat);
2433 SAVEI16(PL_lex_inwhat);
2434 SAVECOPLINE(PL_curcop);
2435 SAVEPPTR(PL_bufptr);
2436 SAVEPPTR(PL_bufend);
2437 SAVEPPTR(PL_oldbufptr);
2438 SAVEPPTR(PL_oldoldbufptr);
2439 SAVEPPTR(PL_last_lop);
2440 SAVEPPTR(PL_last_uni);
2441 SAVEPPTR(PL_linestart);
2442 SAVESPTR(PL_linestr);
2443 SAVEGENERICPV(PL_lex_brackstack);
2444 SAVEGENERICPV(PL_lex_casestack);
2446 PL_linestr = PL_lex_stuff;
2447 PL_lex_stuff = NULL;
2449 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2450 = SvPVX(PL_linestr);
2451 PL_bufend += SvCUR(PL_linestr);
2452 PL_last_lop = PL_last_uni = NULL;
2453 SAVEFREESV(PL_linestr);
2455 PL_lex_dojoin = FALSE;
2456 PL_lex_brackets = 0;
2457 PL_lex_allbrackets = 0;
2458 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2459 Newx(PL_lex_brackstack, 120, char);
2460 Newx(PL_lex_casestack, 12, char);
2461 PL_lex_casemods = 0;
2462 *PL_lex_casestack = '\0';
2464 PL_lex_state = LEX_INTERPCONCAT;
2465 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2467 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2468 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2469 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2470 PL_lex_inpat = PL_sublex_info.sub_op;
2472 PL_lex_inpat = NULL;
2479 * Restores lexer state after a S_sublex_push.
2486 if (!PL_lex_starts++) {
2487 SV * const sv = newSVpvs("");
2488 if (SvUTF8(PL_linestr))
2490 PL_expect = XOPERATOR;
2491 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2495 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2496 PL_lex_state = LEX_INTERPCASEMOD;
2500 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2501 assert(PL_lex_inwhat != OP_TRANSR);
2502 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2503 PL_linestr = PL_lex_repl;
2505 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2506 PL_bufend += SvCUR(PL_linestr);
2507 PL_last_lop = PL_last_uni = NULL;
2508 SAVEFREESV(PL_linestr);
2509 PL_lex_dojoin = FALSE;
2510 PL_lex_brackets = 0;
2511 PL_lex_allbrackets = 0;
2512 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2513 PL_lex_casemods = 0;
2514 *PL_lex_casestack = '\0';
2516 if (SvEVALED(PL_lex_repl)) {
2517 PL_lex_state = LEX_INTERPNORMAL;
2519 /* we don't clear PL_lex_repl here, so that we can check later
2520 whether this is an evalled subst; that means we rely on the
2521 logic to ensure sublex_done() is called again only via the
2522 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2525 PL_lex_state = LEX_INTERPCONCAT;
2535 PL_endwhite = newSVpvs("");
2536 sv_catsv(PL_endwhite, PL_thiswhite);
2540 sv_setpvs(PL_thistoken,"");
2542 PL_realtokenstart = -1;
2546 PL_bufend = SvPVX(PL_linestr);
2547 PL_bufend += SvCUR(PL_linestr);
2548 PL_expect = XOPERATOR;
2549 PL_sublex_info.sub_inwhat = 0;
2557 Extracts a pattern, double-quoted string, or transliteration. This
2560 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2561 processing a pattern (PL_lex_inpat is true), a transliteration
2562 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2564 Returns a pointer to the character scanned up to. If this is
2565 advanced from the start pointer supplied (i.e. if anything was
2566 successfully parsed), will leave an OP for the substring scanned
2567 in pl_yylval. Caller must intuit reason for not parsing further
2568 by looking at the next characters herself.
2572 constants: \N{NAME} only
2573 case and quoting: \U \Q \E
2574 stops on @ and $, but not for $ as tail anchor
2576 In transliterations:
2577 characters are VERY literal, except for - not at the start or end
2578 of the string, which indicates a range. If the range is in bytes,
2579 scan_const expands the range to the full set of intermediate
2580 characters. If the range is in utf8, the hyphen is replaced with
2581 a certain range mark which will be handled by pmtrans() in op.c.
2583 In double-quoted strings:
2585 double-quoted style: \r and \n
2586 constants: \x31, etc.
2587 deprecated backrefs: \1 (in substitution replacements)
2588 case and quoting: \U \Q \E
2591 scan_const does *not* construct ops to handle interpolated strings.
2592 It stops processing as soon as it finds an embedded $ or @ variable
2593 and leaves it to the caller to work out what's going on.
2595 embedded arrays (whether in pattern or not) could be:
2596 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2598 $ in double-quoted strings must be the symbol of an embedded scalar.
2600 $ in pattern could be $foo or could be tail anchor. Assumption:
2601 it's a tail anchor if $ is the last thing in the string, or if it's
2602 followed by one of "()| \r\n\t"
2604 \1 (backreferences) are turned into $1
2606 The structure of the code is
2607 while (there's a character to process) {
2608 handle transliteration ranges
2609 skip regexp comments /(?#comment)/ and codes /(?{code})/
2610 skip #-initiated comments in //x patterns
2611 check for embedded arrays
2612 check for embedded scalars
2614 deprecate \1 in substitution replacements
2615 handle string-changing backslashes \l \U \Q \E, etc.
2616 switch (what was escaped) {
2617 handle \- in a transliteration (becomes a literal -)
2618 if a pattern and not \N{, go treat as regular character
2619 handle \132 (octal characters)
2620 handle \x15 and \x{1234} (hex characters)
2621 handle \N{name} (named characters, also \N{3,5} in a pattern)
2622 handle \cV (control characters)
2623 handle printf-style backslashes (\f, \r, \n, etc)
2626 } (end if backslash)
2627 handle regular character
2628 } (end while character to read)
2633 S_scan_const(pTHX_ char *start)
2636 register char *send = PL_bufend; /* end of the constant */
2637 SV *sv = newSV(send - start); /* sv for the constant. See
2638 note below on sizing. */
2639 register char *s = start; /* start of the constant */
2640 register char *d = SvPVX(sv); /* destination for copies */
2641 bool dorange = FALSE; /* are we in a translit range? */
2642 bool didrange = FALSE; /* did we just finish a range? */
2643 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2644 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
2645 to be UTF8? But, this can
2646 show as true when the source
2647 isn't utf8, as for example
2648 when it is entirely composed
2651 /* Note on sizing: The scanned constant is placed into sv, which is
2652 * initialized by newSV() assuming one byte of output for every byte of
2653 * input. This routine expects newSV() to allocate an extra byte for a
2654 * trailing NUL, which this routine will append if it gets to the end of
2655 * the input. There may be more bytes of input than output (eg., \N{LATIN
2656 * CAPITAL LETTER A}), or more output than input if the constant ends up
2657 * recoded to utf8, but each time a construct is found that might increase
2658 * the needed size, SvGROW() is called. Its size parameter each time is
2659 * based on the best guess estimate at the time, namely the length used so
2660 * far, plus the length the current construct will occupy, plus room for
2661 * the trailing NUL, plus one byte for every input byte still unscanned */
2665 UV literal_endpoint = 0;
2666 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2669 PERL_ARGS_ASSERT_SCAN_CONST;
2671 assert(PL_lex_inwhat != OP_TRANSR);
2672 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2673 /* If we are doing a trans and we know we want UTF8 set expectation */
2674 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2675 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2679 while (s < send || dorange) {
2681 /* get transliterations out of the way (they're most literal) */
2682 if (PL_lex_inwhat == OP_TRANS) {
2683 /* expand a range A-Z to the full set of characters. AIE! */
2685 I32 i; /* current expanded character */
2686 I32 min; /* first character in range */
2687 I32 max; /* last character in range */
2698 char * const c = (char*)utf8_hop((U8*)d, -1);
2702 *c = (char)UTF_TO_NATIVE(0xff);
2703 /* mark the range as done, and continue */
2709 i = d - SvPVX_const(sv); /* remember current offset */
2712 SvLEN(sv) + (has_utf8 ?
2713 (512 - UTF_CONTINUATION_MARK +
2716 /* How many two-byte within 0..255: 128 in UTF-8,
2717 * 96 in UTF-8-mod. */
2719 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2721 d = SvPVX(sv) + i; /* refresh d after realloc */
2725 for (j = 0; j <= 1; j++) {
2726 char * const c = (char*)utf8_hop((U8*)d, -1);
2727 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2733 max = (U8)0xff; /* only to \xff */
2734 uvmax = uv; /* \x{100} to uvmax */
2736 d = c; /* eat endpoint chars */
2741 d -= 2; /* eat the first char and the - */
2742 min = (U8)*d; /* first char in range */
2743 max = (U8)d[1]; /* last char in range */
2750 "Invalid range \"%c-%c\" in transliteration operator",
2751 (char)min, (char)max);
2755 if (literal_endpoint == 2 &&
2756 ((isLOWER(min) && isLOWER(max)) ||
2757 (isUPPER(min) && isUPPER(max)))) {
2759 for (i = min; i <= max; i++)
2761 *d++ = NATIVE_TO_NEED(has_utf8,i);
2763 for (i = min; i <= max; i++)
2765 *d++ = NATIVE_TO_NEED(has_utf8,i);
2770 for (i = min; i <= max; i++)
2773 const U8 ch = (U8)NATIVE_TO_UTF(i);
2774 if (UNI_IS_INVARIANT(ch))
2777 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2778 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2787 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2789 *d++ = (char)UTF_TO_NATIVE(0xff);
2791 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2795 /* mark the range as done, and continue */
2799 literal_endpoint = 0;
2804 /* range begins (ignore - as first or last char) */
2805 else if (*s == '-' && s+1 < send && s != start) {
2807 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2814 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2824 literal_endpoint = 0;
2825 native_range = TRUE;
2830 /* if we get here, we're not doing a transliteration */
2832 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2833 except for the last char, which will be done separately. */
2834 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2836 while (s+1 < send && *s != ')')
2837 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2839 else if (s[2] == '{' /* This should match regcomp.c */
2840 || (s[2] == '?' && s[3] == '{'))
2843 char *regparse = s + (s[2] == '{' ? 3 : 4);
2846 while (count && (c = *regparse)) {
2847 if (c == '\\' && regparse[1])
2855 if (*regparse != ')')
2856 regparse--; /* Leave one char for continuation. */
2857 while (s < regparse)
2858 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2862 /* likewise skip #-initiated comments in //x patterns */
2863 else if (*s == '#' && PL_lex_inpat &&
2864 ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
2865 while (s+1 < send && *s != '\n')
2866 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2869 /* check for embedded arrays
2870 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2872 else if (*s == '@' && s[1]) {
2873 if (isALNUM_lazy_if(s+1,UTF))
2875 if (strchr(":'{$", s[1]))
2877 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2878 break; /* in regexp, neither @+ nor @- are interpolated */
2881 /* check for embedded scalars. only stop if we're sure it's a
2884 else if (*s == '$') {
2885 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2887 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2889 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2890 "Possible unintended interpolation of $\\ in regex");
2892 break; /* in regexp, $ might be tail anchor */
2896 /* End of else if chain - OP_TRANS rejoin rest */
2899 if (*s == '\\' && s+1 < send) {
2900 char* e; /* Can be used for ending '}', etc. */
2904 /* warn on \1 - \9 in substitution replacements, but note that \11
2905 * is an octal; and \19 is \1 followed by '9' */
2906 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2907 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2909 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2914 /* string-change backslash escapes */
2915 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2919 /* In a pattern, process \N, but skip any other backslash escapes.
2920 * This is because we don't want to translate an escape sequence
2921 * into a meta symbol and have the regex compiler use the meta
2922 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
2923 * in spite of this, we do have to process \N here while the proper
2924 * charnames handler is in scope. See bugs #56444 and #62056.
2925 * There is a complication because \N in a pattern may also stand
2926 * for 'match a non-nl', and not mean a charname, in which case its
2927 * processing should be deferred to the regex compiler. To be a
2928 * charname it must be followed immediately by a '{', and not look
2929 * like \N followed by a curly quantifier, i.e., not something like
2930 * \N{3,}. regcurly returns a boolean indicating if it is a legal
2932 else if (PL_lex_inpat
2935 || regcurly(s + 1)))
2937 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2938 goto default_action;
2943 /* quoted - in transliterations */
2945 if (PL_lex_inwhat == OP_TRANS) {
2952 if ((isALPHA(*s) || isDIGIT(*s)))
2953 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2954 "Unrecognized escape \\%c passed through",
2956 /* default action is to copy the quoted character */
2957 goto default_action;
2960 /* eg. \132 indicates the octal constant 0132 */
2961 case '0': case '1': case '2': case '3':
2962 case '4': case '5': case '6': case '7':
2966 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2969 goto NUM_ESCAPE_INSERT;
2971 /* eg. \o{24} indicates the octal constant \024 */
2977 bool valid = grok_bslash_o(s, &uv, &len, &error, 1);
2983 goto NUM_ESCAPE_INSERT;
2986 /* eg. \x24 indicates the hex constant 0x24 */
2990 char* const e = strchr(s, '}');
2991 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2992 PERL_SCAN_DISALLOW_PREFIX;
2997 yyerror("Missing right brace on \\x{}");
3001 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
3007 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3008 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
3014 /* Insert oct or hex escaped character. There will always be
3015 * enough room in sv since such escapes will be longer than any
3016 * UTF-8 sequence they can end up as, except if they force us
3017 * to recode the rest of the string into utf8 */
3019 /* Here uv is the ordinal of the next character being added in
3020 * unicode (converted from native). */
3021 if (!UNI_IS_INVARIANT(uv)) {
3022 if (!has_utf8 && uv > 255) {
3023 /* Might need to recode whatever we have accumulated so
3024 * far if it contains any chars variant in utf8 or
3027 SvCUR_set(sv, d - SvPVX_const(sv));
3030 /* See Note on sizing above. */
3031 sv_utf8_upgrade_flags_grow(sv,
3032 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3033 UNISKIP(uv) + (STRLEN)(send - s) + 1);
3034 d = SvPVX(sv) + SvCUR(sv);
3039 d = (char*)uvuni_to_utf8((U8*)d, uv);
3040 if (PL_lex_inwhat == OP_TRANS &&
3041 PL_sublex_info.sub_op) {
3042 PL_sublex_info.sub_op->op_private |=
3043 (PL_lex_repl ? OPpTRANS_FROM_UTF
3047 if (uv > 255 && !dorange)
3048 native_range = FALSE;
3061 /* In a non-pattern \N must be a named character, like \N{LATIN
3062 * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3063 * mean to match a non-newline. For non-patterns, named
3064 * characters are converted to their string equivalents. In
3065 * patterns, named characters are not converted to their
3066 * ultimate forms for the same reasons that other escapes
3067 * aren't. Instead, they are converted to the \N{U+...} form
3068 * to get the value from the charnames that is in effect right
3069 * now, while preserving the fact that it was a named character
3070 * so that the regex compiler knows this */
3072 /* This section of code doesn't generally use the
3073 * NATIVE_TO_NEED() macro to transform the input. I (khw) did
3074 * a close examination of this macro and determined it is a
3075 * no-op except on utfebcdic variant characters. Every
3076 * character generated by this that would normally need to be
3077 * enclosed by this macro is invariant, so the macro is not
3078 * needed, and would complicate use of copy(). XXX There are
3079 * other parts of this file where the macro is used
3080 * inconsistently, but are saved by it being a no-op */
3082 /* The structure of this section of code (besides checking for
3083 * errors and upgrading to utf8) is:
3084 * Further disambiguate between the two meanings of \N, and if
3085 * not a charname, go process it elsewhere
3086 * If of form \N{U+...}, pass it through if a pattern;
3087 * otherwise convert to utf8
3088 * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3089 * pattern; otherwise convert to utf8 */
3091 /* Here, s points to the 'N'; the test below is guaranteed to
3092 * succeed if we are being called on a pattern as we already
3093 * know from a test above that the next character is a '{'.
3094 * On a non-pattern \N must mean 'named sequence, which
3095 * requires braces */
3098 yyerror("Missing braces on \\N{}");
3103 /* If there is no matching '}', it is an error. */
3104 if (! (e = strchr(s, '}'))) {
3105 if (! PL_lex_inpat) {
3106 yyerror("Missing right brace on \\N{}");
3108 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3113 /* Here it looks like a named character */
3117 /* XXX This block is temporary code. \N{} implies that the
3118 * pattern is to have Unicode semantics, and therefore
3119 * currently has to be encoded in utf8. By putting it in
3120 * utf8 now, we save a whole pass in the regular expression
3121 * compiler. Once that code is changed so Unicode
3122 * semantics doesn't necessarily have to be in utf8, this
3123 * block should be removed. However, the code that parses
3124 * the output of this would have to be changed to not
3125 * necessarily expect utf8 */
3127 SvCUR_set(sv, d - SvPVX_const(sv));
3130 /* See Note on sizing above. */
3131 sv_utf8_upgrade_flags_grow(sv,
3132 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3133 /* 5 = '\N{' + cur char + NUL */
3134 (STRLEN)(send - s) + 5);
3135 d = SvPVX(sv) + SvCUR(sv);
3140 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3141 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3142 | PERL_SCAN_DISALLOW_PREFIX;
3145 /* For \N{U+...}, the '...' is a unicode value even on
3146 * EBCDIC machines */
3147 s += 2; /* Skip to next char after the 'U+' */
3149 uv = grok_hex(s, &len, &flags, NULL);
3150 if (len == 0 || len != (STRLEN)(e - s)) {
3151 yyerror("Invalid hexadecimal number in \\N{U+...}");
3158 /* On non-EBCDIC platforms, pass through to the regex
3159 * compiler unchanged. The reason we evaluated the
3160 * number above is to make sure there wasn't a syntax
3161 * error. But on EBCDIC we convert to native so
3162 * downstream code can continue to assume it's native
3164 s -= 5; /* Include the '\N{U+' */
3166 d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3169 (unsigned int) UNI_TO_NATIVE(uv));
3171 Copy(s, d, e - s + 1, char); /* 1 = include the } */
3175 else { /* Not a pattern: convert the hex to string */
3177 /* If destination is not in utf8, unconditionally
3178 * recode it to be so. This is because \N{} implies
3179 * Unicode semantics, and scalars have to be in utf8
3180 * to guarantee those semantics */
3182 SvCUR_set(sv, d - SvPVX_const(sv));
3185 /* See Note on sizing above. */
3186 sv_utf8_upgrade_flags_grow(
3188 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3189 UNISKIP(uv) + (STRLEN)(send - e) + 1);
3190 d = SvPVX(sv) + SvCUR(sv);
3194 /* Add the string to the output */
3195 if (UNI_IS_INVARIANT(uv)) {
3198 else d = (char*)uvuni_to_utf8((U8*)d, uv);
3201 else { /* Here is \N{NAME} but not \N{U+...}. */
3203 SV *res; /* result from charnames */
3204 const char *str; /* the string in 'res' */
3205 STRLEN len; /* its length */
3207 /* Get the value for NAME */
3208 res = newSVpvn(s, e - s);
3209 res = new_constant( NULL, 0, "charnames",
3210 /* includes all of: \N{...} */
3211 res, NULL, s - 3, e - s + 4 );
3213 /* Most likely res will be in utf8 already since the
3214 * standard charnames uses pack U, but a custom translator
3215 * can leave it otherwise, so make sure. XXX This can be
3216 * revisited to not have charnames use utf8 for characters
3217 * that don't need it when regexes don't have to be in utf8
3218 * for Unicode semantics. If doing so, remember EBCDIC */
3219 sv_utf8_upgrade(res);
3220 str = SvPV_const(res, len);
3222 /* Don't accept malformed input */
3223 if (! is_utf8_string((U8 *) str, len)) {
3224 yyerror("Malformed UTF-8 returned by \\N");
3226 else if (PL_lex_inpat) {
3228 if (! len) { /* The name resolved to an empty string */
3229 Copy("\\N{}", d, 4, char);
3233 /* In order to not lose information for the regex
3234 * compiler, pass the result in the specially made
3235 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3236 * the code points in hex of each character
3237 * returned by charnames */
3239 const char *str_end = str + len;
3240 STRLEN char_length; /* cur char's byte length */
3241 STRLEN output_length; /* and the number of bytes
3242 after this is translated
3244 const STRLEN off = d - SvPVX_const(sv);
3246 /* 2 hex per byte; 2 chars for '\N'; 2 chars for
3247 * max('U+', '.'); and 1 for NUL */
3248 char hex_string[2 * UTF8_MAXBYTES + 5];
3250 /* Get the first character of the result. */
3251 U32 uv = utf8n_to_uvuni((U8 *) str,
3256 /* The call to is_utf8_string() above hopefully
3257 * guarantees that there won't be an error. But
3258 * it's easy here to make sure. The function just
3259 * above warns and returns 0 if invalid utf8, but
3260 * it can also return 0 if the input is validly a
3261 * NUL. Disambiguate */
3262 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3263 uv = UNICODE_REPLACEMENT;
3266 /* Convert first code point to hex, including the
3267 * boiler plate before it. For all these, we
3268 * convert to native format so that downstream code
3269 * can continue to assume the input is native */
3271 my_snprintf(hex_string, sizeof(hex_string),
3273 (unsigned int) UNI_TO_NATIVE(uv));
3275 /* Make sure there is enough space to hold it */
3276 d = off + SvGROW(sv, off
3278 + (STRLEN)(send - e)
3279 + 2); /* '}' + NUL */
3281 Copy(hex_string, d, output_length, char);
3284 /* For each subsequent character, append dot and
3285 * its ordinal in hex */
3286 while ((str += char_length) < str_end) {
3287 const STRLEN off = d - SvPVX_const(sv);
3288 U32 uv = utf8n_to_uvuni((U8 *) str,
3292 if (uv == 0 && NATIVE_TO_ASCII(*str) != '\0') {
3293 uv = UNICODE_REPLACEMENT;
3297 my_snprintf(hex_string, sizeof(hex_string),
3299 (unsigned int) UNI_TO_NATIVE(uv));
3301 d = off + SvGROW(sv, off
3303 + (STRLEN)(send - e)
3304 + 2); /* '}' + NUL */
3305 Copy(hex_string, d, output_length, char);
3309 *d++ = '}'; /* Done. Add the trailing brace */
3312 else { /* Here, not in a pattern. Convert the name to a
3315 /* If destination is not in utf8, unconditionally
3316 * recode it to be so. This is because \N{} implies
3317 * Unicode semantics, and scalars have to be in utf8
3318 * to guarantee those semantics */
3320 SvCUR_set(sv, d - SvPVX_const(sv));
3323 /* See Note on sizing above. */
3324 sv_utf8_upgrade_flags_grow(sv,
3325 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3326 len + (STRLEN)(send - s) + 1);
3327 d = SvPVX(sv) + SvCUR(sv);
3329 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3331 /* See Note on sizing above. (NOTE: SvCUR() is not
3332 * set correctly here). */
3333 const STRLEN off = d - SvPVX_const(sv);
3334 d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3336 Copy(str, d, len, char);
3341 /* Deprecate non-approved name syntax */
3342 if (ckWARN_d(WARN_DEPRECATED)) {
3343 bool problematic = FALSE;
3346 /* For non-ut8 input, look to see that the first
3347 * character is an alpha, then loop through the rest
3348 * checking that each is a continuation */
3350 if (! isALPHAU(*i)) problematic = TRUE;
3351 else for (i = s + 1; i < e; i++) {
3352 if (isCHARNAME_CONT(*i)) continue;
3358 /* Similarly for utf8. For invariants can check
3359 * directly. We accept anything above the latin1
3360 * range because it is immaterial to Perl if it is
3361 * correct or not, and is expensive to check. But
3362 * it is fairly easy in the latin1 range to convert
3363 * the variants into a single character and check
3365 if (UTF8_IS_INVARIANT(*i)) {
3366 if (! isALPHAU(*i)) problematic = TRUE;
3367 } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) {
3368 if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i,
3374 if (! problematic) for (i = s + UTF8SKIP(s);
3378 if (UTF8_IS_INVARIANT(*i)) {
3379 if (isCHARNAME_CONT(*i)) continue;
3380 } else if (! UTF8_IS_DOWNGRADEABLE_START(*i)) {
3382 } else if (isCHARNAME_CONT(
3384 TWO_BYTE_UTF8_TO_UNI(*i, *(i+1)))))
3393 /* The e-i passed to the final %.*s makes sure that
3394 * should the trailing NUL be missing that this
3395 * print won't run off the end of the string */
3396 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
3397 "Deprecated character in \\N{...}; marked by <-- HERE in \\N{%.*s<-- HERE %.*s",
3398 (int)(i - s + 1), s, (int)(e - i), i + 1);
3401 } /* End \N{NAME} */
3404 native_range = FALSE; /* \N{} is defined to be Unicode */
3406 s = e + 1; /* Point to just after the '}' */
3409 /* \c is a control character */
3413 *d++ = grok_bslash_c(*s++, has_utf8, 1);
3416 yyerror("Missing control char name in \\c");
3420 /* printf-style backslashes, formfeeds, newlines, etc */
3422 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
3425 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
3428 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
3431 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
3434 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
3437 *d++ = ASCII_TO_NEED(has_utf8,'\033');
3440 *d++ = ASCII_TO_NEED(has_utf8,'\007');
3446 } /* end if (backslash) */
3453 /* If we started with encoded form, or already know we want it,
3454 then encode the next character */
3455 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3459 /* One might think that it is wasted effort in the case of the
3460 * source being utf8 (this_utf8 == TRUE) to take the next character
3461 * in the source, convert it to an unsigned value, and then convert
3462 * it back again. But the source has not been validated here. The
3463 * routine that does the conversion checks for errors like
3466 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
3467 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
3469 SvCUR_set(sv, d - SvPVX_const(sv));
3472 /* See Note on sizing above. */
3473 sv_utf8_upgrade_flags_grow(sv,
3474 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3475 need + (STRLEN)(send - s) + 1);
3476 d = SvPVX(sv) + SvCUR(sv);
3478 } else if (need > len) {
3479 /* encoded value larger than old, may need extra space (NOTE:
3480 * SvCUR() is not set correctly here). See Note on sizing
3482 const STRLEN off = d - SvPVX_const(sv);
3483 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3487 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3489 if (uv > 255 && !dorange)
3490 native_range = FALSE;
3494 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
3496 } /* while loop to process each character */
3498 /* terminate the string and set up the sv */
3500 SvCUR_set(sv, d - SvPVX_const(sv));
3501 if (SvCUR(sv) >= SvLEN(sv))
3502 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
3505 if (PL_encoding && !has_utf8) {
3506 sv_recode_to_utf8(sv, PL_encoding);
3512 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3513 PL_sublex_info.sub_op->op_private |=
3514 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3518 /* shrink the sv if we allocated more than we used */
3519 if (SvCUR(sv) + 5 < SvLEN(sv)) {
3520 SvPV_shrink_to_cur(sv);
3523 /* return the substring (via pl_yylval) only if we parsed anything */
3524 if (s > PL_bufptr) {
3525 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
3526 const char *const key = PL_lex_inpat ? "qr" : "q";
3527 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3531 if (PL_lex_inwhat == OP_TRANS) {
3534 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3542 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3545 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3552 * Returns TRUE if there's more to the expression (e.g., a subscript),
3555 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3557 * ->[ and ->{ return TRUE
3558 * { and [ outside a pattern are always subscripts, so return TRUE
3559 * if we're outside a pattern and it's not { or [, then return FALSE
3560 * if we're in a pattern and the first char is a {
3561 * {4,5} (any digits around the comma) returns FALSE
3562 * if we're in a pattern and the first char is a [
3564 * [SOMETHING] has a funky algorithm to decide whether it's a
3565 * character class or not. It has to deal with things like
3566 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3567 * anything else returns TRUE
3570 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3573 S_intuit_more(pTHX_ register char *s)
3577 PERL_ARGS_ASSERT_INTUIT_MORE;
3579 if (PL_lex_brackets)
3581 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3583 if (*s != '{' && *s != '[')
3588 /* In a pattern, so maybe we have {n,m}. */
3596 /* On the other hand, maybe we have a character class */
3599 if (*s == ']' || *s == '^')
3602 /* this is terrifying, and it works */
3603 int weight = 2; /* let's weigh the evidence */
3605 unsigned char un_char = 255, last_un_char;
3606 const char * const send = strchr(s,']');
3607 char tmpbuf[sizeof PL_tokenbuf * 4];
3609 if (!send) /* has to be an expression */
3612 Zero(seen,256,char);
3615 else if (isDIGIT(*s)) {
3617 if (isDIGIT(s[1]) && s[2] == ']')
3623 for (; s < send; s++) {
3624 last_un_char = un_char;
3625 un_char = (unsigned char)*s;
3630 weight -= seen[un_char] * 10;
3631 if (isALNUM_lazy_if(s+1,UTF)) {
3633 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3634 len = (int)strlen(tmpbuf);
3635 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3636 UTF ? SVf_UTF8 : 0, SVt_PV))
3641 else if (*s == '$' && s[1] &&
3642 strchr("[#!%*<>()-=",s[1])) {
3643 if (/*{*/ strchr("])} =",s[2]))
3652 if (strchr("wds]",s[1]))
3654 else if (seen[(U8)'\''] || seen[(U8)'"'])
3656 else if (strchr("rnftbxcav",s[1]))
3658 else if (isDIGIT(s[1])) {
3660 while (s[1] && isDIGIT(s[1]))
3670 if (strchr("aA01! ",last_un_char))
3672 if (strchr("zZ79~",s[1]))
3674 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3675 weight -= 5; /* cope with negative subscript */
3678 if (!isALNUM(last_un_char)
3679 && !(last_un_char == '$' || last_un_char == '@'
3680 || last_un_char == '&')
3681 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3686 if (keyword(tmpbuf, d - tmpbuf, 0))
3689 if (un_char == last_un_char + 1)
3691 weight -= seen[un_char];
3696 if (weight >= 0) /* probably a character class */
3706 * Does all the checking to disambiguate
3708 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
3709 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3711 * First argument is the stuff after the first token, e.g. "bar".
3713 * Not a method if bar is a filehandle.
3714 * Not a method if foo is a subroutine prototyped to take a filehandle.
3715 * Not a method if it's really "Foo $bar"
3716 * Method if it's "foo $bar"
3717 * Not a method if it's really "print foo $bar"
3718 * Method if it's really "foo package::" (interpreted as package->foo)
3719 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3720 * Not a method if bar is a filehandle or package, but is quoted with
3725 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
3728 char *s = start + (*start == '$');
3729 char tmpbuf[sizeof PL_tokenbuf];
3736 PERL_ARGS_ASSERT_INTUIT_METHOD;
3739 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3743 const char *proto = CvPROTO(cv);
3754 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3755 /* start is the beginning of the possible filehandle/object,
3756 * and s is the end of it
3757 * tmpbuf is a copy of it
3760 if (*start == '$') {
3761 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3762 isUPPER(*PL_tokenbuf))
3765 len = start - SvPVX(PL_linestr);
3769 start = SvPVX(PL_linestr) + len;
3773 return *s == '(' ? FUNCMETH : METHOD;
3775 if (!keyword(tmpbuf, len, 0)) {
3776 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3780 soff = s - SvPVX(PL_linestr);
3784 indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3785 if (indirgv && GvCVu(indirgv))
3787 /* filehandle or package name makes it a method */
3788 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3790 soff = s - SvPVX(PL_linestr);
3793 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3794 return 0; /* no assumptions -- "=>" quotes bareword */
3796 start_force(PL_curforce);
3797 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3798 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3799 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3801 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
3802 ( UTF ? SVf_UTF8 : 0 )));
3807 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
3809 return *s == '(' ? FUNCMETH : METHOD;
3815 /* Encoded script support. filter_add() effectively inserts a
3816 * 'pre-processing' function into the current source input stream.
3817 * Note that the filter function only applies to the current source file
3818 * (e.g., it will not affect files 'require'd or 'use'd by this one).
3820 * The datasv parameter (which may be NULL) can be used to pass
3821 * private data to this instance of the filter. The filter function
3822 * can recover the SV using the FILTER_DATA macro and use it to
3823 * store private buffers and state information.
3825 * The supplied datasv parameter is upgraded to a PVIO type
3826 * and the IoDIRP/IoANY field is used to store the function pointer,
3827 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3828 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3829 * private use must be set using malloc'd pointers.
3833 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3842 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3843 Perl_croak(aTHX_ "Source filters apply only to byte streams");
3845 if (!PL_rsfp_filters)
3846 PL_rsfp_filters = newAV();
3849 SvUPGRADE(datasv, SVt_PVIO);
3850 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3851 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3852 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3853 FPTR2DPTR(void *, IoANY(datasv)),
3854 SvPV_nolen(datasv)));
3855 av_unshift(PL_rsfp_filters, 1);
3856 av_store(PL_rsfp_filters, 0, datasv) ;
3858 !PL_parser->filtered
3859 && PL_parser->lex_flags & LEX_EVALBYTES
3860 && PL_bufptr < PL_bufend
3862 const char *s = PL_bufptr;
3863 while (s < PL_bufend) {
3865 SV *linestr = PL_parser->linestr;
3866 char *buf = SvPVX(linestr);
3867 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3868 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3869 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3870 STRLEN const linestart_pos = PL_parser->linestart - buf;
3871 STRLEN const last_uni_pos =
3872 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3873 STRLEN const last_lop_pos =
3874 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3875 av_push(PL_rsfp_filters, linestr);
3876 PL_parser->linestr =
3877 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3878 buf = SvPVX(PL_parser->linestr);
3879 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3880 PL_parser->bufptr = buf + bufptr_pos;
3881 PL_parser->oldbufptr = buf + oldbufptr_pos;
3882 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3883 PL_parser->linestart = buf + linestart_pos;
3884 if (PL_parser->last_uni)
3885 PL_parser->last_uni = buf + last_uni_pos;
3886 if (PL_parser->last_lop)
3887 PL_parser->last_lop = buf + last_lop_pos;
3888 SvLEN(linestr) = SvCUR(linestr);
3889 SvCUR(linestr) = s-SvPVX(linestr);
3890 PL_parser->filtered = 1;
3900 /* Delete most recently added instance of this filter function. */
3902 Perl_filter_del(pTHX_ filter_t funcp)
3907 PERL_ARGS_ASSERT_FILTER_DEL;
3910 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3911 FPTR2DPTR(void*, funcp)));
3913 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3915 /* if filter is on top of stack (usual case) just pop it off */
3916 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3917 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3918 sv_free(av_pop(PL_rsfp_filters));
3922 /* we need to search for the correct entry and clear it */
3923 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3927 /* Invoke the idxth filter function for the current rsfp. */
3928 /* maxlen 0 = read one text line */
3930 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
3935 /* This API is bad. It should have been using unsigned int for maxlen.
3936 Not sure if we want to change the API, but if not we should sanity
3937 check the value here. */
3938 unsigned int correct_length
3947 PERL_ARGS_ASSERT_FILTER_READ;
3949 if (!PL_parser || !PL_rsfp_filters)
3951 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
3952 /* Provide a default input filter to make life easy. */
3953 /* Note that we append to the line. This is handy. */
3954 DEBUG_P(PerlIO_printf(Perl_debug_log,
3955 "filter_read %d: from rsfp\n", idx));
3956 if (correct_length) {
3959 const int old_len = SvCUR(buf_sv);
3961 /* ensure buf_sv is large enough */
3962 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
3963 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
3964 correct_length)) <= 0) {
3965 if (PerlIO_error(PL_rsfp))
3966 return -1; /* error */
3968 return 0 ; /* end of file */
3970 SvCUR_set(buf_sv, old_len + len) ;
3971 SvPVX(buf_sv)[old_len + len] = '\0';
3974 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
3975 if (PerlIO_error(PL_rsfp))
3976 return -1; /* error */
3978 return 0 ; /* end of file */
3981 return SvCUR(buf_sv);
3983 /* Skip this filter slot if filter has been deleted */
3984 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
3985 DEBUG_P(PerlIO_printf(Perl_debug_log,
3986 "filter_read %d: skipped (filter deleted)\n",
3988 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
3990 if (SvTYPE(datasv) != SVt_PVIO) {
3991 if (correct_length) {
3993 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
3994 if (!remainder) return 0; /* eof */
3995 if (correct_length > remainder) correct_length = remainder;
3996 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
3997 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4000 const char *s = SvEND(datasv);
4001 const char *send = SvPVX(datasv) + SvLEN(datasv);
4009 if (s == send) return 0; /* eof */
4010 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4011 SvCUR_set(datasv, s-SvPVX(datasv));
4013 return SvCUR(buf_sv);
4015 /* Get function pointer hidden within datasv */
4016 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4017 DEBUG_P(PerlIO_printf(Perl_debug_log,
4018 "filter_read %d: via function %p (%s)\n",
4019 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4020 /* Call function. The function is expected to */
4021 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4022 /* Return: <0:error, =0:eof, >0:not eof */
4023 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4027 S_filter_gets(pTHX_ register SV *sv, STRLEN append)
4031 PERL_ARGS_ASSERT_FILTER_GETS;
4033 #ifdef PERL_CR_FILTER
4034 if (!PL_rsfp_filters) {
4035 filter_add(S_cr_textfilter,NULL);
4038 if (PL_rsfp_filters) {
4040 SvCUR_set(sv, 0); /* start with empty line */
4041 if (FILTER_READ(0, sv, 0) > 0)
4042 return ( SvPVX(sv) ) ;
4047 return (sv_gets(sv, PL_rsfp, append));
4051 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4056 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4058 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4062 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4063 (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4065 return GvHV(gv); /* Foo:: */
4068 /* use constant CLASS => 'MyClass' */
4069 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4070 if (gv && GvCV(gv)) {
4071 SV * const sv = cv_const_sv(GvCV(gv));
4073 pkgname = SvPV_const(sv, len);
4076 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4080 * S_readpipe_override
4081 * Check whether readpipe() is overridden, and generates the appropriate
4082 * optree, provided sublex_start() is called afterwards.
4085 S_readpipe_override(pTHX)
4088 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4089 pl_yylval.ival = OP_BACKTICK;
4091 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4093 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4094 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4095 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4097 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4098 op_append_elem(OP_LIST,
4099 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4100 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4107 * The intent of this yylex wrapper is to minimize the changes to the
4108 * tokener when we aren't interested in collecting madprops. It remains
4109 * to be seen how successful this strategy will be...
4116 char *s = PL_bufptr;
4118 /* make sure PL_thiswhite is initialized */
4122 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
4123 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4124 return S_pending_ident(aTHX);
4126 /* previous token ate up our whitespace? */
4127 if (!PL_lasttoke && PL_nextwhite) {
4128 PL_thiswhite = PL_nextwhite;
4132 /* isolate the token, and figure out where it is without whitespace */
4133 PL_realtokenstart = -1;
4137 assert(PL_curforce < 0);
4139 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4140 if (!PL_thistoken) {
4141 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4142 PL_thistoken = newSVpvs("");
4144 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4145 PL_thistoken = newSVpvn(tstart, s - tstart);
4148 if (PL_thismad) /* install head */
4149 CURMAD('X', PL_thistoken);
4152 /* last whitespace of a sublex? */
4153 if (optype == ')' && PL_endwhite) {
4154 CURMAD('X', PL_endwhite);
4159 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4160 if (!PL_thiswhite && !PL_endwhite && !optype) {
4161 sv_free(PL_thistoken);
4166 /* put off final whitespace till peg */
4167 if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4168 PL_nextwhite = PL_thiswhite;
4171 else if (PL_thisopen) {
4172 CURMAD('q', PL_thisopen);
4174 sv_free(PL_thistoken);
4178 /* Store actual token text as madprop X */
4179 CURMAD('X', PL_thistoken);
4183 /* add preceding whitespace as madprop _ */
4184 CURMAD('_', PL_thiswhite);
4188 /* add quoted material as madprop = */
4189 CURMAD('=', PL_thisstuff);
4193 /* add terminating quote as madprop Q */
4194 CURMAD('Q', PL_thisclose);
4198 /* special processing based on optype */
4202 /* opval doesn't need a TOKEN since it can already store mp */
4212 if (pl_yylval.opval)
4213 append_madprops(PL_thismad, pl_yylval.opval, 0);
4221 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4230 /* remember any fake bracket that lexer is about to discard */
4231 if (PL_lex_brackets == 1 &&
4232 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4235 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4238 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4239 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4242 break; /* don't bother looking for trailing comment */
4251 /* attach a trailing comment to its statement instead of next token */
4255 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4257 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4259 if (*s == '\n' || *s == '#') {
4260 while (s < PL_bufend && *s != '\n')
4264 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4265 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4282 /* Create new token struct. Note: opvals return early above. */
4283 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4290 S_tokenize_use(pTHX_ int is_use, char *s) {
4293 PERL_ARGS_ASSERT_TOKENIZE_USE;
4295 if (PL_expect != XSTATE)
4296 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4297 is_use ? "use" : "no"));
4299 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4300 s = force_version(s, TRUE);
4301 if (*s == ';' || *s == '}'
4302 || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4303 start_force(PL_curforce);
4304 NEXTVAL_NEXTTOKE.opval = NULL;
4307 else if (*s == 'v') {
4308 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4309 s = force_version(s, FALSE);
4313 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4314 s = force_version(s, FALSE);
4316 pl_yylval.ival = is_use;
4320 static const char* const exp_name[] =
4321 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4322 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4326 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4328 S_word_takes_any_delimeter(char *p, STRLEN len)
4330 return (len == 1 && strchr("msyq", p[0])) ||
4332 (p[0] == 't' && p[1] == 'r') ||
4333 (p[0] == 'q' && strchr("qwxr", p[1]))));
4339 Works out what to call the token just pulled out of the input
4340 stream. The yacc parser takes care of taking the ops we return and
4341 stitching them into a tree.
4347 if read an identifier
4348 if we're in a my declaration
4349 croak if they tried to say my($foo::bar)
4350 build the ops for a my() declaration
4351 if it's an access to a my() variable
4352 are we in a sort block?
4353 croak if my($a); $a <=> $b
4354 build ops for access to a my() variable
4355 if in a dq string, and they've said @foo and we can't find @foo
4357 build ops for a bareword
4358 if we already built the token before, use it.
4363 #pragma segment Perl_yylex
4369 register char *s = PL_bufptr;
4375 /* orig_keyword, gvp, and gv are initialized here because
4376 * jump to the label just_a_word_zero can bypass their
4377 * initialization later. */
4378 I32 orig_keyword = 0;
4383 SV* tmp = newSVpvs("");
4384 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4385 (IV)CopLINE(PL_curcop),
4386 lex_state_names[PL_lex_state],
4387 exp_name[PL_expect],
4388 pv_display(tmp, s, strlen(s), 0, 60));
4391 /* check if there's an identifier for us to look at */
4392 if (PL_lex_state != LEX_KNOWNEXT && PL_pending_ident)
4393 return REPORT(S_pending_ident(aTHX));
4395 /* no identifier pending identification */
4397 switch (PL_lex_state) {
4399 case LEX_NORMAL: /* Some compilers will produce faster */
4400 case LEX_INTERPNORMAL: /* code if we comment these out. */
4404 /* when we've already built the next token, just pull it out of the queue */
4408 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4410 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4411 PL_nexttoke[PL_lasttoke].next_mad = 0;
4412 if (PL_thismad && PL_thismad->mad_key == '_') {
4413 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4414 PL_thismad->mad_val = 0;
4415 mad_free(PL_thismad);
4420 PL_lex_state = PL_lex_defer;
4421 PL_expect = PL_lex_expect;
4422 PL_lex_defer = LEX_NORMAL;
4423 if (!PL_nexttoke[PL_lasttoke].next_type)
4428 pl_yylval = PL_nextval[PL_nexttoke];
4430 PL_lex_state = PL_lex_defer;
4431 PL_expect = PL_lex_expect;
4432 PL_lex_defer = LEX_NORMAL;
4438 next_type = PL_nexttoke[PL_lasttoke].next_type;
4440 next_type = PL_nexttype[PL_nexttoke];
4442 if (next_type & (7<<24)) {
4443 if (next_type & (1<<24)) {
4444 if (PL_lex_brackets > 100)
4445 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4446 PL_lex_brackstack[PL_lex_brackets++] =
4447 (char) ((next_type >> 16) & 0xff);
4449 if (next_type & (2<<24))
4450 PL_lex_allbrackets++;
4451 if (next_type & (4<<24))
4452 PL_lex_allbrackets--;
4453 next_type &= 0xffff;
4456 /* FIXME - can these be merged? */
4459 return REPORT(next_type);
4463 /* interpolated case modifiers like \L \U, including \Q and \E.
4464 when we get here, PL_bufptr is at the \
4466 case LEX_INTERPCASEMOD:
4468 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4469 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
4471 /* handle \E or end of string */
4472 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4474 if (PL_lex_casemods) {
4475 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4476 PL_lex_casestack[PL_lex_casemods] = '\0';
4478 if (PL_bufptr != PL_bufend
4479 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
4481 PL_lex_state = LEX_INTERPCONCAT;
4484 PL_thistoken = newSVpvs("\\E");
4487 PL_lex_allbrackets--;
4491 while (PL_bufptr != PL_bufend &&
4492 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4494 PL_thiswhite = newSVpvs("");
4495 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4499 if (PL_bufptr != PL_bufend)
4502 PL_lex_state = LEX_INTERPCONCAT;
4506 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4507 "### Saw case modifier\n"); });
4509 if (s[1] == '\\' && s[2] == 'E') {
4512 PL_thiswhite = newSVpvs("");
4513 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4516 PL_lex_state = LEX_INTERPCONCAT;
4521 if (!PL_madskills) /* when just compiling don't need correct */
4522 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4523 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4524 if ((*s == 'L' || *s == 'U') &&
4525 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
4526 PL_lex_casestack[--PL_lex_casemods] = '\0';
4527 PL_lex_allbrackets--;
4530 if (PL_lex_casemods > 10)
4531 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4532 PL_lex_casestack[PL_lex_casemods++] = *s;
4533 PL_lex_casestack[PL_lex_casemods] = '\0';
4534 PL_lex_state = LEX_INTERPCONCAT;
4535 start_force(PL_curforce);
4536 NEXTVAL_NEXTTOKE.ival = 0;
4537 force_next((2<<24)|'(');
4538 start_force(PL_curforce);
4540 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4542 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4544 NEXTVAL_NEXTTOKE.ival = OP_LC;
4546 NEXTVAL_NEXTTOKE.ival = OP_UC;
4548 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4550 Perl_croak(aTHX_ "panic: yylex");
4552 SV* const tmpsv = newSVpvs("\\ ");
4553 /* replace the space with the character we want to escape
4555 SvPVX(tmpsv)[1] = *s;
4561 if (PL_lex_starts) {
4567 sv_free(PL_thistoken);
4568 PL_thistoken = newSVpvs("");
4571 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4572 if (PL_lex_casemods == 1 && PL_lex_inpat)
4581 case LEX_INTERPPUSH:
4582 return REPORT(sublex_push());
4584 case LEX_INTERPSTART:
4585 if (PL_bufptr == PL_bufend)
4586 return REPORT(sublex_done());
4587 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4588 "### Interpolated variable\n"); });
4590 PL_lex_dojoin = (*PL_bufptr == '@');
4591 PL_lex_state = LEX_INTERPNORMAL;
4592 if (PL_lex_dojoin) {
4593 start_force(PL_curforce);
4594 NEXTVAL_NEXTTOKE.ival = 0;
4596 start_force(PL_curforce);
4597 force_ident("\"", '$');
4598 start_force(PL_curforce);
4599 NEXTVAL_NEXTTOKE.ival = 0;
4601 start_force(PL_curforce);
4602 NEXTVAL_NEXTTOKE.ival = 0;
4603 force_next((2<<24)|'(');
4604 start_force(PL_curforce);
4605 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4608 if (PL_lex_starts++) {
4613 sv_free(PL_thistoken);
4614 PL_thistoken = newSVpvs("");
4617 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4618 if (!PL_lex_casemods && PL_lex_inpat)
4625 case LEX_INTERPENDMAYBE:
4626 if (intuit_more(PL_bufptr)) {
4627 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
4633 if (PL_lex_dojoin) {
4634 PL_lex_dojoin = FALSE;
4635 PL_lex_state = LEX_INTERPCONCAT;
4639 sv_free(PL_thistoken);
4640 PL_thistoken = newSVpvs("");
4643 PL_lex_allbrackets--;
4646 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
4647 && SvEVALED(PL_lex_repl))
4649 if (PL_bufptr != PL_bufend)
4650 Perl_croak(aTHX_ "Bad evalled substitution pattern");
4654 case LEX_INTERPCONCAT:
4656 if (PL_lex_brackets)
4657 Perl_croak(aTHX_ "panic: INTERPCONCAT");
4659 if (PL_bufptr == PL_bufend)
4660 return REPORT(sublex_done());
4662 if (SvIVX(PL_linestr) == '\'') {
4663 SV *sv = newSVsv(PL_linestr);
4666 else if ( PL_hints & HINT_NEW_RE )
4667 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
4668 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4672 s = scan_const(PL_bufptr);
4674 PL_lex_state = LEX_INTERPCASEMOD;
4676 PL_lex_state = LEX_INTERPSTART;
4679 if (s != PL_bufptr) {
4680 start_force(PL_curforce);
4682 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
4684 NEXTVAL_NEXTTOKE = pl_yylval;
4687 if (PL_lex_starts++) {
4691 sv_free(PL_thistoken);
4692 PL_thistoken = newSVpvs("");
4695 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4696 if (!PL_lex_casemods && PL_lex_inpat)
4709 PL_lex_state = LEX_NORMAL;
4710 s = scan_formline(PL_bufptr);
4711 if (!PL_lex_formbrack)
4717 PL_oldoldbufptr = PL_oldbufptr;
4723 sv_free(PL_thistoken);
4726 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
4730 if (isIDFIRST_lazy_if(s,UTF))
4733 unsigned char c = *s;
4734 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
4735 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
4736 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
4741 Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
4745 goto fake_eof; /* emulate EOF on ^D or ^Z */
4751 if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
4754 if (PL_lex_brackets &&
4755 PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
4756 yyerror((const char *)
4758 ? "Format not terminated"
4759 : "Missing right curly or square bracket"));
4761 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4762 "### Tokener got EOF\n");
4766 if (s++ < PL_bufend)
4767 goto retry; /* ignore stray nulls */
4770 if (!PL_in_eval && !PL_preambled) {
4771 PL_preambled = TRUE;
4777 /* Generate a string of Perl code to load the debugger.
4778 * If PERL5DB is set, it will return the contents of that,
4779 * otherwise a compile-time require of perl5db.pl. */
4781 const char * const pdb = PerlEnv_getenv("PERL5DB");
4784 sv_setpv(PL_linestr, pdb);
4785 sv_catpvs(PL_linestr,";");
4787 SETERRNO(0,SS_NORMAL);
4788 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
4791 sv_setpvs(PL_linestr,"");
4792 if (PL_preambleav) {
4793 SV **svp = AvARRAY(PL_preambleav);
4794 SV **const end = svp + AvFILLp(PL_preambleav);
4796 sv_catsv(PL_linestr, *svp);
4798 sv_catpvs(PL_linestr, ";");
4800 sv_free(MUTABLE_SV(PL_preambleav));
4801 PL_preambleav = NULL;
4804 sv_catpvs(PL_linestr,
4805 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
4806 if (PL_minus_n || PL_minus_p) {
4807 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
4809 sv_catpvs(PL_linestr,"chomp;");
4812 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
4813 || *PL_splitstr == '"')
4814 && strchr(PL_splitstr + 1, *PL_splitstr))
4815 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
4817 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
4818 bytes can be used as quoting characters. :-) */
4819 const char *splits = PL_splitstr;
4820 sv_catpvs(PL_linestr, "our @F=split(q\0");
4823 if (*splits == '\\')
4824 sv_catpvn(PL_linestr, splits, 1);
4825 sv_catpvn(PL_linestr, splits, 1);
4826 } while (*splits++);
4827 /* This loop will embed the trailing NUL of
4828 PL_linestr as the last thing it does before
4830 sv_catpvs(PL_linestr, ");");
4834 sv_catpvs(PL_linestr,"our @F=split(' ');");
4837 sv_catpvs(PL_linestr, "\n");
4838 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4839 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4840 PL_last_lop = PL_last_uni = NULL;
4841 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4842 update_debugger_info(PL_linestr, NULL, 0);
4847 bof = PL_rsfp ? TRUE : FALSE;
4850 fake_eof = LEX_FAKE_EOF;
4852 PL_bufptr = PL_bufend;
4853 CopLINE_inc(PL_curcop);
4854 if (!lex_next_chunk(fake_eof)) {
4855 CopLINE_dec(PL_curcop);
4857 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
4859 CopLINE_dec(PL_curcop);
4862 PL_realtokenstart = -1;
4865 /* If it looks like the start of a BOM or raw UTF-16,
4866 * check if it in fact is. */
4867 if (bof && PL_rsfp &&
4872 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
4873 bof = (offset == (Off_t)SvCUR(PL_linestr));
4874 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
4875 /* offset may include swallowed CR */
4877 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
4880 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4881 s = swallow_bom((U8*)s);
4884 if (PL_parser->in_pod) {
4885 /* Incest with pod. */
4888 sv_catsv(PL_thiswhite, PL_linestr);
4890 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
4891 sv_setpvs(PL_linestr, "");
4892 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4893 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4894 PL_last_lop = PL_last_uni = NULL;
4895 PL_parser->in_pod = 0;
4898 if (PL_rsfp || PL_parser->filtered)
4900 } while (PL_parser->in_pod);
4901 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
4902 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4903 PL_last_lop = PL_last_uni = NULL;
4904 if (CopLINE(PL_curcop) == 1) {
4905 while (s < PL_bufend && isSPACE(*s))
4907 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
4911 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
4915 if (*s == '#' && *(s+1) == '!')
4917 #ifdef ALTERNATE_SHEBANG
4919 static char const as[] = ALTERNATE_SHEBANG;
4920 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
4921 d = s + (sizeof(as) - 1);
4923 #endif /* ALTERNATE_SHEBANG */
4932 while (*d && !isSPACE(*d))
4936 #ifdef ARG_ZERO_IS_SCRIPT
4937 if (ipathend > ipath) {
4939 * HP-UX (at least) sets argv[0] to the script name,
4940 * which makes $^X incorrect. And Digital UNIX and Linux,
4941 * at least, set argv[0] to the basename of the Perl
4942 * interpreter. So, having found "#!", we'll set it right.
4944 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
4946 assert(SvPOK(x) || SvGMAGICAL(x));
4947 if (sv_eq(x, CopFILESV(PL_curcop))) {
4948 sv_setpvn(x, ipath, ipathend - ipath);
4954 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
4955 const char * const lstart = SvPV_const(x,llen);
4957 bstart += blen - llen;
4958 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
4959 sv_setpvn(x, ipath, ipathend - ipath);
4964 TAINT_NOT; /* $^X is always tainted, but that's OK */
4966 #endif /* ARG_ZERO_IS_SCRIPT */
4971 d = instr(s,"perl -");
4973 d = instr(s,"perl");
4975 /* avoid getting into infinite loops when shebang
4976 * line contains "Perl" rather than "perl" */
4978 for (d = ipathend-4; d >= ipath; --d) {
4979 if ((*d == 'p' || *d == 'P')
4980 && !ibcmp(d, "perl", 4))
4990 #ifdef ALTERNATE_SHEBANG
4992 * If the ALTERNATE_SHEBANG on this system starts with a
4993 * character that can be part of a Perl expression, then if
4994 * we see it but not "perl", we're probably looking at the
4995 * start of Perl code, not a request to hand off to some
4996 * other interpreter. Similarly, if "perl" is there, but
4997 * not in the first 'word' of the line, we assume the line
4998 * contains the start of the Perl program.
5000 if (d && *s != '#') {
5001 const char *c = ipath;
5002 while (*c && !strchr("; \t\r\n\f\v#", *c))
5005 d = NULL; /* "perl" not in first word; ignore */
5007 *s = '#'; /* Don't try to parse shebang line */
5009 #endif /* ALTERNATE_SHEBANG */
5014 !instr(s,"indir") &&
5015 instr(PL_origargv[0],"perl"))
5022 while (s < PL_bufend && isSPACE(*s))
5024 if (s < PL_bufend) {
5025 Newx(newargv,PL_origargc+3,char*);
5027 while (s < PL_bufend && !isSPACE(*s))
5030 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5033 newargv = PL_origargv;
5036 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5038 Perl_croak(aTHX_ "Can't exec %s", ipath);
5041 while (*d && !isSPACE(*d))
5043 while (SPACE_OR_TAB(*d))
5047 const bool switches_done = PL_doswitches;
5048 const U32 oldpdb = PL_perldb;
5049 const bool oldn = PL_minus_n;
5050 const bool oldp = PL_minus_p;
5054 bool baduni = FALSE;
5056 const char *d2 = d1 + 1;
5057 if (parse_unicode_opts((const char **)&d2)
5061 if (baduni || *d1 == 'M' || *d1 == 'm') {
5062 const char * const m = d1;
5063 while (*d1 && !isSPACE(*d1))
5065 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5068 d1 = moreswitches(d1);
5070 if (PL_doswitches && !switches_done) {
5071 int argc = PL_origargc;
5072 char **argv = PL_origargv;
5075 } while (argc && argv[0][0] == '-' && argv[0][1]);
5076 init_argv_symbols(argc,argv);
5078 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
5079 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5080 /* if we have already added "LINE: while (<>) {",
5081 we must not do it again */
5083 sv_setpvs(PL_linestr, "");
5084 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5085 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5086 PL_last_lop = PL_last_uni = NULL;
5087 PL_preambled = FALSE;
5088 if (PERLDB_LINE || PERLDB_SAVESRC)
5089 (void)gv_fetchfile(PL_origfilename);
5096 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5098 PL_lex_state = LEX_FORMLINE;
5103 #ifdef PERL_STRICT_CR
5104 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5106 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5108 case ' ': case '\t': case '\f': case 013:
5110 PL_realtokenstart = -1;
5112 PL_thiswhite = newSVpvs("");
5113 sv_catpvn(PL_thiswhite, s, 1);
5120 PL_realtokenstart = -1;
5124 if (PL_lex_state != LEX_NORMAL ||
5125 (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
5126 if (*s == '#' && s == PL_linestart && PL_in_eval
5127 && !PL_rsfp && !PL_parser->filtered) {
5128 /* handle eval qq[#line 1 "foo"\n ...] */
5129 CopLINE_dec(PL_curcop);
5132 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5134 if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
5139 while (d < PL_bufend && *d != '\n')
5143 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5144 Perl_croak(aTHX_ "panic: input overflow");
5147 PL_thiswhite = newSVpvn(s, d - s);
5152 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5154 PL_lex_state = LEX_FORMLINE;
5160 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5161 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5164 TOKEN(PEG); /* make sure any #! line is accessible */
5169 /* if (PL_madskills && PL_lex_formbrack) { */
5171 while (d < PL_bufend && *d != '\n')
5175 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5176 Perl_croak(aTHX_ "panic: input overflow");
5177 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5179 PL_thiswhite = newSVpvs("");
5180 if (CopLINE(PL_curcop) == 1) {
5181 sv_setpvs(PL_thiswhite, "");
5184 sv_catpvn(PL_thiswhite, s, d - s);
5198 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
5206 while (s < PL_bufend && SPACE_OR_TAB(*s))
5209 if (strnEQ(s,"=>",2)) {
5210 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
5211 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5212 OPERATOR('-'); /* unary minus */
5214 PL_last_uni = PL_oldbufptr;
5216 case 'r': ftst = OP_FTEREAD; break;
5217 case 'w': ftst = OP_FTEWRITE; break;
5218 case 'x': ftst = OP_FTEEXEC; break;
5219 case 'o': ftst = OP_FTEOWNED; break;
5220 case 'R': ftst = OP_FTRREAD; break;
5221 case 'W': ftst = OP_FTRWRITE; break;
5222 case 'X': ftst = OP_FTREXEC; break;
5223 case 'O': ftst = OP_FTROWNED; break;
5224 case 'e': ftst = OP_FTIS; break;
5225 case 'z': ftst = OP_FTZERO; break;
5226 case 's': ftst = OP_FTSIZE; break;
5227 case 'f': ftst = OP_FTFILE; break;
5228 case 'd': ftst = OP_FTDIR; break;
5229 case 'l': ftst = OP_FTLINK; break;
5230 case 'p': ftst = OP_FTPIPE; break;
5231 case 'S': ftst = OP_FTSOCK; break;
5232 case 'u': ftst = OP_FTSUID; break;
5233 case 'g': ftst = OP_FTSGID; break;
5234 case 'k': ftst = OP_FTSVTX; break;
5235 case 'b': ftst = OP_FTBLK; break;
5236 case 'c': ftst = OP_FTCHR; break;
5237 case 't': ftst = OP_FTTTY; break;
5238 case 'T': ftst = OP_FTTEXT; break;
5239 case 'B': ftst = OP_FTBINARY; break;
5240 case 'M': case 'A': case 'C':
5241 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5243 case 'M': ftst = OP_FTMTIME; break;
5244 case 'A': ftst = OP_FTATIME; break;
5245 case 'C': ftst = OP_FTCTIME; break;
5253 PL_last_lop_op = (OPCODE)ftst;
5254 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5255 "### Saw file test %c\n", (int)tmp);
5260 /* Assume it was a minus followed by a one-letter named
5261 * subroutine call (or a -bareword), then. */
5262 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5263 "### '-%c' looked like a file test but was not\n",
5270 const char tmp = *s++;
5273 if (PL_expect == XOPERATOR)
5278 else if (*s == '>') {
5281 if (isIDFIRST_lazy_if(s,UTF)) {
5282 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
5290 if (PL_expect == XOPERATOR) {
5291 if (*s == '=' && !PL_lex_allbrackets &&
5292 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5299 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5301 OPERATOR('-'); /* unary minus */
5307 const char tmp = *s++;
5310 if (PL_expect == XOPERATOR)
5315 if (PL_expect == XOPERATOR) {
5316 if (*s == '=' && !PL_lex_allbrackets &&
5317 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5324 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5331 if (PL_expect != XOPERATOR) {
5332 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5333 PL_expect = XOPERATOR;
5334 force_ident(PL_tokenbuf, '*');
5342 if (*s == '=' && !PL_lex_allbrackets &&
5343 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5349 if (*s == '=' && !PL_lex_allbrackets &&
5350 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5357 if (PL_expect == XOPERATOR) {
5358 if (s[1] == '=' && !PL_lex_allbrackets &&
5359 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5364 PL_tokenbuf[0] = '%';
5365 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5366 sizeof PL_tokenbuf - 1, FALSE);
5367 if (!PL_tokenbuf[1]) {
5370 PL_pending_ident = '%';
5374 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5375 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5380 if (PL_lex_brackets > 100)
5381 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5382 PL_lex_brackstack[PL_lex_brackets++] = 0;
5383 PL_lex_allbrackets++;
5385 const char tmp = *s++;
5390 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5392 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5400 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5407 goto just_a_word_zero_gv;
5410 switch (PL_expect) {
5416 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5418 PL_bufptr = s; /* update in case we back off */
5421 "Use of := for an empty attribute list is not allowed");
5428 PL_expect = XTERMBLOCK;
5431 stuffstart = s - SvPVX(PL_linestr) - 1;
5435 while (isIDFIRST_lazy_if(s,UTF)) {
5438 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5439 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5440 if (tmp < 0) tmp = -tmp;
5455 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5457 d = scan_str(d,TRUE,TRUE);
5459 /* MUST advance bufptr here to avoid bogus
5460 "at end of line" context messages from yyerror().
5462 PL_bufptr = s + len;
5463 yyerror("Unterminated attribute parameter in attribute list");
5467 return REPORT(0); /* EOF indicator */
5471 sv_catsv(sv, PL_lex_stuff);
5472 attrs = op_append_elem(OP_LIST, attrs,
5473 newSVOP(OP_CONST, 0, sv));
5474 SvREFCNT_dec(PL_lex_stuff);
5475 PL_lex_stuff = NULL;
5478 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
5480 if (PL_in_my == KEY_our) {
5481 deprecate(":unique");
5484 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5487 /* NOTE: any CV attrs applied here need to be part of
5488 the CVf_BUILTIN_ATTRS define in cv.h! */
5489 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
5491 CvLVALUE_on(PL_compcv);
5493 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
5495 deprecate(":locked");
5497 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
5499 CvMETHOD_on(PL_compcv);
5501 /* After we've set the flags, it could be argued that
5502 we don't need to do the attributes.pm-based setting
5503 process, and shouldn't bother appending recognized
5504 flags. To experiment with that, uncomment the
5505 following "else". (Note that's already been
5506 uncommented. That keeps the above-applied built-in
5507 attributes from being intercepted (and possibly
5508 rejected) by a package's attribute routines, but is
5509 justified by the performance win for the common case
5510 of applying only built-in attributes.) */
5512 attrs = op_append_elem(OP_LIST, attrs,
5513 newSVOP(OP_CONST, 0,
5517 if (*s == ':' && s[1] != ':')
5520 break; /* require real whitespace or :'s */
5521 /* XXX losing whitespace on sequential attributes here */
5525 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5526 if (*s != ';' && *s != '}' && *s != tmp
5527 && (tmp != '=' || *s != ')')) {
5528 const char q = ((*s == '\'') ? '"' : '\'');
5529 /* If here for an expression, and parsed no attrs, back
5531 if (tmp == '=' && !attrs) {
5535 /* MUST advance bufptr here to avoid bogus "at end of line"
5536 context messages from yyerror().
5539 yyerror( (const char *)
5541 ? Perl_form(aTHX_ "Invalid separator character "
5542 "%c%c%c in attribute list", q, *s, q)
5543 : "Unterminated attribute list" ) );
5551 start_force(PL_curforce);
5552 NEXTVAL_NEXTTOKE.opval = attrs;
5553 CURMAD('_', PL_nextwhite);
5558 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
5559 (s - SvPVX(PL_linestr)) - stuffstart);
5564 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
5568 PL_lex_allbrackets--;
5572 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
5573 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
5577 PL_lex_allbrackets++;
5580 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
5586 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
5589 PL_lex_allbrackets--;
5595 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5598 if (PL_lex_brackets <= 0)
5599 yyerror("Unmatched right square bracket");
5602 PL_lex_allbrackets--;
5603 if (PL_lex_state == LEX_INTERPNORMAL) {
5604 if (PL_lex_brackets == 0) {
5605 if (*s == '-' && s[1] == '>')
5606 PL_lex_state = LEX_INTERPENDMAYBE;
5607 else if (*s != '[' && *s != '{')
5608 PL_lex_state = LEX_INTERPEND;
5615 if (PL_lex_brackets > 100) {
5616 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5618 switch (PL_expect) {
5620 if (PL_lex_formbrack) {
5624 if (PL_oldoldbufptr == PL_last_lop)
5625 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5627 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5628 PL_lex_allbrackets++;
5629 OPERATOR(HASHBRACK);
5631 while (s < PL_bufend && SPACE_OR_TAB(*s))
5634 PL_tokenbuf[0] = '\0';
5635 if (d < PL_bufend && *d == '-') {
5636 PL_tokenbuf[0] = '-';
5638 while (d < PL_bufend && SPACE_OR_TAB(*d))
5641 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
5642 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
5644 while (d < PL_bufend && SPACE_OR_TAB(*d))
5647 const char minus = (PL_tokenbuf[0] == '-');
5648 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
5656 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
5657 PL_lex_allbrackets++;
5662 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5663 PL_lex_allbrackets++;
5668 if (PL_oldoldbufptr == PL_last_lop)
5669 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
5671 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5672 PL_lex_allbrackets++;
5675 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
5677 /* This hack is to get the ${} in the message. */
5679 yyerror("syntax error");
5682 OPERATOR(HASHBRACK);
5684 /* This hack serves to disambiguate a pair of curlies
5685 * as being a block or an anon hash. Normally, expectation
5686 * determines that, but in cases where we're not in a
5687 * position to expect anything in particular (like inside
5688 * eval"") we have to resolve the ambiguity. This code
5689 * covers the case where the first term in the curlies is a
5690 * quoted string. Most other cases need to be explicitly
5691 * disambiguated by prepending a "+" before the opening
5692 * curly in order to force resolution as an anon hash.
5694 * XXX should probably propagate the outer expectation
5695 * into eval"" to rely less on this hack, but that could
5696 * potentially break current behavior of eval"".
5700 if (*s == '\'' || *s == '"' || *s == '`') {
5701 /* common case: get past first string, handling escapes */
5702 for (t++; t < PL_bufend && *t != *s;)
5703 if (*t++ == '\\' && (*t == '\\' || *t == *s))
5707 else if (*s == 'q') {
5710 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
5713 /* skip q//-like construct */
5715 char open, close, term;
5718 while (t < PL_bufend && isSPACE(*t))
5720 /* check for q => */
5721 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
5722 OPERATOR(HASHBRACK);
5726 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5730 for (t++; t < PL_bufend; t++) {
5731 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
5733 else if (*t == open)
5737 for (t++; t < PL_bufend; t++) {
5738 if (*t == '\\' && t+1 < PL_bufend)
5740 else if (*t == close && --brackets <= 0)
5742 else if (*t == open)
5749 /* skip plain q word */
5750 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5753 else if (isALNUM_lazy_if(t,UTF)) {
5755 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
5758 while (t < PL_bufend && isSPACE(*t))
5760 /* if comma follows first term, call it an anon hash */
5761 /* XXX it could be a comma expression with loop modifiers */
5762 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
5763 || (*t == '=' && t[1] == '>')))
5764 OPERATOR(HASHBRACK);
5765 if (PL_expect == XREF)
5768 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
5774 pl_yylval.ival = CopLINE(PL_curcop);
5775 if (isSPACE(*s) || *s == '#')
5776 PL_copline = NOLINE; /* invalidate current command line number */
5779 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
5783 if (PL_lex_brackets <= 0)
5784 yyerror("Unmatched right curly bracket");
5786 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
5787 PL_lex_allbrackets--;
5788 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
5789 PL_lex_formbrack = 0;
5790 if (PL_lex_state == LEX_INTERPNORMAL) {
5791 if (PL_lex_brackets == 0) {
5792 if (PL_expect & XFAKEBRACK) {
5793 PL_expect &= XENUMMASK;
5794 PL_lex_state = LEX_INTERPEND;
5799 PL_thiswhite = newSVpvs("");
5800 sv_catpvs(PL_thiswhite,"}");
5803 return yylex(); /* ignore fake brackets */
5805 if (*s == '-' && s[1] == '>')
5806 PL_lex_state = LEX_INTERPENDMAYBE;
5807 else if (*s != '[' && *s != '{')
5808 PL_lex_state = LEX_INTERPEND;
5811 if (PL_expect & XFAKEBRACK) {
5812 PL_expect &= XENUMMASK;
5814 return yylex(); /* ignore fake brackets */
5816 start_force(PL_curforce);
5818 curmad('X', newSVpvn(s-1,1));
5819 CURMAD('_', PL_thiswhite);
5824 PL_thistoken = newSVpvs("");
5830 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5831 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5838 if (PL_expect == XOPERATOR) {
5839 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
5840 && isIDFIRST_lazy_if(s,UTF))
5842 CopLINE_dec(PL_curcop);
5843 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5844 CopLINE_inc(PL_curcop);
5846 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5847 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5854 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5856 PL_expect = XOPERATOR;
5857 force_ident(PL_tokenbuf, '&');
5861 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
5867 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5868 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
5875 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5876 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
5884 const char tmp = *s++;
5886 if (!PL_lex_allbrackets &&
5887 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5894 if (!PL_lex_allbrackets &&
5895 PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
5903 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
5904 && strchr("+-*/%.^&|<",tmp))
5905 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5906 "Reversed %c= operator",(int)tmp);
5908 if (PL_expect == XSTATE && isALPHA(tmp) &&
5909 (s == PL_linestart+1 || s[-2] == '\n') )
5911 if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
5916 if (strnEQ(s,"=cut",4)) {
5932 PL_thiswhite = newSVpvs("");
5933 sv_catpvn(PL_thiswhite, PL_linestart,
5934 PL_bufend - PL_linestart);
5938 PL_parser->in_pod = 1;
5942 if (PL_lex_brackets < PL_lex_formbrack) {
5944 #ifdef PERL_STRICT_CR
5945 while (SPACE_OR_TAB(*t))
5947 while (SPACE_OR_TAB(*t) || *t == '\r')
5950 if (*t == '\n' || *t == '#') {
5956 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5965 const char tmp = *s++;
5967 /* was this !=~ where !~ was meant?
5968 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
5970 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
5971 const char *t = s+1;
5973 while (t < PL_bufend && isSPACE(*t))
5976 if (*t == '/' || *t == '?' ||
5977 ((*t == 'm' || *t == 's' || *t == 'y')
5978 && !isALNUM(t[1])) ||
5979 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
5980 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5981 "!=~ should be !~");
5983 if (!PL_lex_allbrackets &&
5984 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
5996 if (PL_expect != XOPERATOR) {
5997 if (s[1] != '<' && !strchr(s,'>'))
6000 s = scan_heredoc(s);
6002 s = scan_inputsymbol(s);
6003 TERM(sublex_start());
6009 if (*s == '=' && !PL_lex_allbrackets &&
6010 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6014 SHop(OP_LEFT_SHIFT);
6019 if (!PL_lex_allbrackets &&
6020 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6027 if (!PL_lex_allbrackets &&
6028 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6036 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6044 const char tmp = *s++;
6046 if (*s == '=' && !PL_lex_allbrackets &&
6047 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6051 SHop(OP_RIGHT_SHIFT);
6053 else if (tmp == '=') {
6054 if (!PL_lex_allbrackets &&
6055 PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6063 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6072 if (PL_expect == XOPERATOR) {
6073 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6074 return deprecate_commaless_var_list();
6078 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
6079 PL_tokenbuf[0] = '@';
6080 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6081 sizeof PL_tokenbuf - 1, FALSE);
6082 if (PL_expect == XOPERATOR)
6083 no_op("Array length", s);
6084 if (!PL_tokenbuf[1])
6086 PL_expect = XOPERATOR;
6087 PL_pending_ident = '#';
6091 PL_tokenbuf[0] = '$';
6092 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6093 sizeof PL_tokenbuf - 1, FALSE);
6094 if (PL_expect == XOPERATOR)
6096 if (!PL_tokenbuf[1]) {
6098 yyerror("Final $ should be \\$ or $name");
6104 const char tmp = *s;
6105 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6108 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6109 && intuit_more(s)) {
6111 PL_tokenbuf[0] = '@';
6112 if (ckWARN(WARN_SYNTAX)) {
6115 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
6118 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6119 while (t < PL_bufend && *t != ']')
6121 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6122 "Multidimensional syntax %.*s not supported",
6123 (int)((t - PL_bufptr) + 1), PL_bufptr);
6127 else if (*s == '{') {
6129 PL_tokenbuf[0] = '%';
6130 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
6131 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
6133 char tmpbuf[sizeof PL_tokenbuf];
6136 } while (isSPACE(*t));
6137 if (isIDFIRST_lazy_if(t,UTF)) {
6139 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6143 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
6144 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6145 "You need to quote \"%s\"",
6152 PL_expect = XOPERATOR;
6153 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6154 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6155 if (!islop || PL_last_lop_op == OP_GREPSTART)
6156 PL_expect = XOPERATOR;
6157 else if (strchr("$@\"'`q", *s))
6158 PL_expect = XTERM; /* e.g. print $fh "foo" */
6159 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
6160 PL_expect = XTERM; /* e.g. print $fh &sub */
6161 else if (isIDFIRST_lazy_if(s,UTF)) {
6162 char tmpbuf[sizeof PL_tokenbuf];
6164 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6165 if ((t2 = keyword(tmpbuf, len, 0))) {
6166 /* binary operators exclude handle interpretations */
6178 PL_expect = XTERM; /* e.g. print $fh length() */
6183 PL_expect = XTERM; /* e.g. print $fh subr() */
6186 else if (isDIGIT(*s))
6187 PL_expect = XTERM; /* e.g. print $fh 3 */
6188 else if (*s == '.' && isDIGIT(s[1]))
6189 PL_expect = XTERM; /* e.g. print $fh .3 */
6190 else if ((*s == '?' || *s == '-' || *s == '+')
6191 && !isSPACE(s[1]) && s[1] != '=')
6192 PL_expect = XTERM; /* e.g. print $fh -1 */
6193 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6195 PL_expect = XTERM; /* e.g. print $fh /.../
6196 XXX except DORDOR operator
6198 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6200 PL_expect = XTERM; /* print $fh <<"EOF" */
6203 PL_pending_ident = '$';
6207 if (PL_expect == XOPERATOR)
6209 PL_tokenbuf[0] = '@';
6210 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6211 if (!PL_tokenbuf[1]) {
6214 if (PL_lex_state == LEX_NORMAL)
6216 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
6218 PL_tokenbuf[0] = '%';
6220 /* Warn about @ where they meant $. */
6221 if (*s == '[' || *s == '{') {
6222 if (ckWARN(WARN_SYNTAX)) {
6223 const char *t = s + 1;
6224 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
6226 if (*t == '}' || *t == ']') {
6228 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6229 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6230 "Scalar value %.*s better written as $%.*s",
6231 (int)(t-PL_bufptr), PL_bufptr,
6232 (int)(t-PL_bufptr-1), PL_bufptr+1);
6237 PL_pending_ident = '@';
6240 case '/': /* may be division, defined-or, or pattern */
6241 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
6242 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6243 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6248 case '?': /* may either be conditional or pattern */
6249 if (PL_expect == XOPERATOR) {
6252 if (!PL_lex_allbrackets &&
6253 PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6257 PL_lex_allbrackets++;
6263 /* A // operator. */
6264 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6265 (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6266 LEX_FAKEEOF_LOGIC)) {
6274 if (*s == '=' && !PL_lex_allbrackets &&
6275 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6284 /* Disable warning on "study /blah/" */
6285 if (PL_oldoldbufptr == PL_last_uni
6286 && (*PL_last_uni != 's' || s - PL_last_uni < 5
6287 || memNE(PL_last_uni, "study", 5)
6288 || isALNUM_lazy_if(PL_last_uni+5,UTF)
6292 deprecate("?PATTERN? without explicit operator");
6293 s = scan_pat(s,OP_MATCH);
6294 TERM(sublex_start());
6298 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6299 #ifdef PERL_STRICT_CR
6302 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6304 && (s == PL_linestart || s[-1] == '\n') )
6306 PL_lex_formbrack = 0;
6310 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6314 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6317 if (!PL_lex_allbrackets &&
6318 PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6325 pl_yylval.ival = OPf_SPECIAL;
6331 if (*s == '=' && !PL_lex_allbrackets &&
6332 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6339 case '0': case '1': case '2': case '3': case '4':
6340 case '5': case '6': case '7': case '8': case '9':
6341 s = scan_num(s, &pl_yylval);
6342 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6343 if (PL_expect == XOPERATOR)
6348 s = scan_str(s,!!PL_madskills,FALSE);
6349 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6350 if (PL_expect == XOPERATOR) {
6351 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6352 return deprecate_commaless_var_list();
6359 pl_yylval.ival = OP_CONST;
6360 TERM(sublex_start());
6363 s = scan_str(s,!!PL_madskills,FALSE);
6364 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6365 if (PL_expect == XOPERATOR) {
6366 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
6367 return deprecate_commaless_var_list();
6374 pl_yylval.ival = OP_CONST;
6375 /* FIXME. I think that this can be const if char *d is replaced by
6376 more localised variables. */
6377 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6378 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6379 pl_yylval.ival = OP_STRINGIFY;
6383 TERM(sublex_start());
6386 s = scan_str(s,!!PL_madskills,FALSE);
6387 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6388 if (PL_expect == XOPERATOR)
6389 no_op("Backticks",s);
6392 readpipe_override();
6393 TERM(sublex_start());
6397 if (PL_lex_inwhat && isDIGIT(*s))
6398 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6400 if (PL_expect == XOPERATOR)
6401 no_op("Backslash",s);
6405 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
6406 char *start = s + 2;
6407 while (isDIGIT(*start) || *start == '_')
6409 if (*start == '.' && isDIGIT(start[1])) {
6410 s = scan_num(s, &pl_yylval);
6413 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
6414 else if (!isALPHA(*start) && (PL_expect == XTERM
6415 || PL_expect == XREF || PL_expect == XSTATE
6416 || PL_expect == XTERMORDORDOR)) {
6417 GV *const gv = gv_fetchpvn_flags(s, start - s,
6418 UTF ? SVf_UTF8 : 0, SVt_PVCV);
6420 s = scan_num(s, &pl_yylval);
6427 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
6470 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6472 /* Some keywords can be followed by any delimiter, including ':' */
6473 anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6475 /* x::* is just a word, unless x is "CORE" */
6476 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
6480 while (d < PL_bufend && isSPACE(*d))
6481 d++; /* no comments skipped here, or s### is misparsed */
6483 /* Is this a word before a => operator? */
6484 if (*d == '=' && d[1] == '>') {
6487 = (OP*)newSVOP(OP_CONST, 0,
6488 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6489 pl_yylval.opval->op_private = OPpCONST_BARE;
6493 /* Check for plugged-in keyword */
6497 char *saved_bufptr = PL_bufptr;
6499 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6501 if (result == KEYWORD_PLUGIN_DECLINE) {
6502 /* not a plugged-in keyword */
6503 PL_bufptr = saved_bufptr;
6504 } else if (result == KEYWORD_PLUGIN_STMT) {
6505 pl_yylval.opval = o;
6508 return REPORT(PLUGSTMT);
6509 } else if (result == KEYWORD_PLUGIN_EXPR) {
6510 pl_yylval.opval = o;
6512 PL_expect = XOPERATOR;
6513 return REPORT(PLUGEXPR);
6515 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6520 /* Check for built-in keyword */
6521 tmp = keyword(PL_tokenbuf, len, 0);
6523 /* Is this a label? */
6524 if (!anydelim && PL_expect == XSTATE
6525 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
6527 pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
6532 if (tmp < 0) { /* second-class keyword? */
6533 GV *ogv = NULL; /* override (winner) */
6534 GV *hgv = NULL; /* hidden (loser) */
6535 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
6537 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6538 UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
6541 if (GvIMPORTED_CV(gv))
6543 else if (! CvMETHOD(cv))
6547 (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
6548 UTF ? -(I32)len : (I32)len, FALSE)) &&
6549 (gv = *gvp) && isGV_with_GP(gv) &&
6550 GvCVu(gv) && GvIMPORTED_CV(gv))
6557 tmp = 0; /* overridden by import or by GLOBAL */
6560 && -tmp==KEY_lock /* XXX generalizable kludge */
6563 tmp = 0; /* any sub overrides "weak" keyword */
6565 else { /* no override */
6567 if (tmp == KEY_dump) {
6568 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
6569 "dump() better written as CORE::dump()");
6573 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
6574 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6575 "Ambiguous call resolved as CORE::%s(), "
6576 "qualify as such or use &",
6584 default: /* not a keyword */
6585 /* Trade off - by using this evil construction we can pull the
6586 variable gv into the block labelled keylookup. If not, then
6587 we have to give it function scope so that the goto from the
6588 earlier ':' case doesn't bypass the initialisation. */
6590 just_a_word_zero_gv:
6598 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
6602 SV *nextPL_nextwhite = 0;
6606 /* Get the rest if it looks like a package qualifier */
6608 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
6610 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
6613 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
6614 *s == '\'' ? "'" : "::");
6619 if (PL_expect == XOPERATOR) {
6620 if (PL_bufptr == PL_linestart) {
6621 CopLINE_dec(PL_curcop);
6622 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6623 CopLINE_inc(PL_curcop);
6626 no_op("Bareword",s);
6629 /* Look for a subroutine with this name in current package,
6630 unless name is "Foo::", in which case Foo is a bareword
6631 (and a package name). */
6633 if (len > 2 && !PL_madskills &&
6634 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
6636 if (ckWARN(WARN_BAREWORD)
6637 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
6638 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
6639 "Bareword \"%s\" refers to nonexistent package",
6642 PL_tokenbuf[len] = '\0';
6648 /* Mustn't actually add anything to a symbol table.
6649 But also don't want to "initialise" any placeholder
6650 constants that might already be there into full
6651 blown PVGVs with attached PVCV. */
6652 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
6653 GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
6659 /* if we saw a global override before, get the right name */
6661 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
6662 len ? len : strlen(PL_tokenbuf));
6664 SV * const tmp_sv = sv;
6665 sv = newSVpvs("CORE::GLOBAL::");
6666 sv_catsv(sv, tmp_sv);
6667 SvREFCNT_dec(tmp_sv);
6671 if (PL_madskills && !PL_thistoken) {
6672 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
6673 PL_thistoken = newSVpvn(start,s - start);
6674 PL_realtokenstart = s - SvPVX(PL_linestr);
6678 /* Presume this is going to be a bareword of some sort. */
6680 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
6681 pl_yylval.opval->op_private = OPpCONST_BARE;
6683 /* And if "Foo::", then that's what it certainly is. */
6688 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
6689 const_op->op_private = OPpCONST_BARE;
6690 rv2cv_op = newCVREF(0, const_op);
6692 cv = rv2cv_op_cv(rv2cv_op, 0);
6694 /* See if it's the indirect object for a list operator. */
6696 if (PL_oldoldbufptr &&
6697 PL_oldoldbufptr < PL_bufptr &&
6698 (PL_oldoldbufptr == PL_last_lop
6699 || PL_oldoldbufptr == PL_last_uni) &&
6700 /* NO SKIPSPACE BEFORE HERE! */
6701 (PL_expect == XREF ||
6702 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
6704 bool immediate_paren = *s == '(';
6706 /* (Now we can afford to cross potential line boundary.) */
6707 s = SKIPSPACE2(s,nextPL_nextwhite);
6709 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
6712 /* Two barewords in a row may indicate method call. */
6714 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
6715 (tmp = intuit_method(s, gv, cv))) {
6717 if (tmp == METHOD && !PL_lex_allbrackets &&
6718 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6719 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6723 /* If not a declared subroutine, it's an indirect object. */
6724 /* (But it's an indir obj regardless for sort.) */
6725 /* Also, if "_" follows a filetest operator, it's a bareword */
6728 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
6730 (PL_last_lop_op != OP_MAPSTART &&
6731 PL_last_lop_op != OP_GREPSTART))))
6732 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
6733 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
6736 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
6741 PL_expect = XOPERATOR;
6744 s = SKIPSPACE2(s,nextPL_nextwhite);
6745 PL_nextwhite = nextPL_nextwhite;
6750 /* Is this a word before a => operator? */
6751 if (*s == '=' && s[1] == '>' && !pkgname) {
6754 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
6755 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
6756 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
6760 /* If followed by a paren, it's certainly a subroutine. */
6765 while (SPACE_OR_TAB(*d))
6767 if (*d == ')' && (sv = cv_const_sv(cv))) {
6774 PL_nextwhite = PL_thiswhite;
6777 start_force(PL_curforce);
6779 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6780 PL_expect = XOPERATOR;
6783 PL_nextwhite = nextPL_nextwhite;
6784 curmad('X', PL_thistoken);
6785 PL_thistoken = newSVpvs("");
6794 /* If followed by var or block, call it a method (unless sub) */
6796 if ((*s == '$' || *s == '{') && !cv) {
6798 PL_last_lop = PL_oldbufptr;
6799 PL_last_lop_op = OP_METHOD;
6800 if (!PL_lex_allbrackets &&
6801 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6802 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6806 /* If followed by a bareword, see if it looks like indir obj. */
6809 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
6810 && (tmp = intuit_method(s, gv, cv))) {
6812 if (tmp == METHOD && !PL_lex_allbrackets &&
6813 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6814 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6818 /* Not a method, so call it a subroutine (if defined) */
6821 if (lastchar == '-')
6822 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6823 "Ambiguous use of -%s resolved as -&%s()",
6824 PL_tokenbuf, PL_tokenbuf);
6825 /* Check for a constant sub */
6826 if ((sv = cv_const_sv(cv))) {
6829 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
6830 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
6831 pl_yylval.opval->op_private = 0;
6832 pl_yylval.opval->op_flags |= OPf_SPECIAL;
6836 op_free(pl_yylval.opval);
6837 pl_yylval.opval = rv2cv_op;
6838 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6839 PL_last_lop = PL_oldbufptr;
6840 PL_last_lop_op = OP_ENTERSUB;
6841 /* Is there a prototype? */
6848 STRLEN protolen = CvPROTOLEN(cv);
6849 const char *proto = CvPROTO(cv);
6852 while (*proto == ';')
6857 *proto == '$' || *proto == '_'
6858 || *proto == '*' || *proto == '+'
6863 *proto == '\\' && proto[1] && proto[2] == '\0'
6867 if (*proto == '\\' && proto[1] == '[') {
6868 const char *p = proto + 2;
6869 while(*p && *p != ']')
6871 if(*p == ']' && !p[1]) OPERATOR(UNIOPSUB);
6873 if (*proto == '&' && *s == '{') {
6875 sv_setpvs(PL_subname, "__ANON__");
6877 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6878 if (!PL_lex_allbrackets &&
6879 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6880 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6887 PL_nextwhite = PL_thiswhite;
6890 start_force(PL_curforce);
6891 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6894 PL_nextwhite = nextPL_nextwhite;
6895 curmad('X', PL_thistoken);
6896 PL_thistoken = newSVpvs("");
6899 if (!PL_lex_allbrackets &&
6900 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6901 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6906 /* Guess harder when madskills require "best effort". */
6907 if (PL_madskills && (!gv || !GvCVu(gv))) {
6908 int probable_sub = 0;
6909 if (strchr("\"'`$@%0123456789!*+{[<", *s))
6911 else if (isALPHA(*s)) {
6915 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
6916 if (!keyword(tmpbuf, tmplen, 0))
6919 while (d < PL_bufend && isSPACE(*d))
6921 if (*d == '=' && d[1] == '>')
6926 gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
6928 op_free(pl_yylval.opval);
6929 pl_yylval.opval = rv2cv_op;
6930 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
6931 PL_last_lop = PL_oldbufptr;
6932 PL_last_lop_op = OP_ENTERSUB;
6933 PL_nextwhite = PL_thiswhite;
6935 start_force(PL_curforce);
6936 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6938 PL_nextwhite = nextPL_nextwhite;
6939 curmad('X', PL_thistoken);
6940 PL_thistoken = newSVpvs("");
6942 if (!PL_lex_allbrackets &&
6943 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6944 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6948 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
6951 if (!PL_lex_allbrackets &&
6952 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
6953 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
6958 /* Call it a bare word */
6960 if (PL_hints & HINT_STRICT_SUBS)
6961 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6964 /* after "print" and similar functions (corresponding to
6965 * "F? L" in opcode.pl), whatever wasn't already parsed as
6966 * a filehandle should be subject to "strict subs".
6967 * Likewise for the optional indirect-object argument to system
6968 * or exec, which can't be a bareword */
6969 if ((PL_last_lop_op == OP_PRINT
6970 || PL_last_lop_op == OP_PRTF
6971 || PL_last_lop_op == OP_SAY
6972 || PL_last_lop_op == OP_SYSTEM
6973 || PL_last_lop_op == OP_EXEC)
6974 && (PL_hints & HINT_STRICT_SUBS))
6975 pl_yylval.opval->op_private |= OPpCONST_STRICT;
6976 if (lastchar != '-') {
6977 if (ckWARN(WARN_RESERVED)) {
6981 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
6982 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
6990 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
6991 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6992 "Operator or semicolon missing before %c%s",
6993 lastchar, PL_tokenbuf);
6994 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
6995 "Ambiguous use of %c resolved as operator %c",
6996 lastchar, lastchar);
7003 (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7008 (OP*)newSVOP(OP_CONST, 0,
7009 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7012 case KEY___PACKAGE__:
7014 (OP*)newSVOP(OP_CONST, 0,
7016 ? newSVhek(HvNAME_HEK(PL_curstash))
7023 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7024 const char *pname = "main";
7027 if (PL_tokenbuf[2] == 'D')
7030 PL_curstash ? PL_curstash : PL_defstash;
7031 pname = HvNAME_get(stash);
7032 plen = HvNAMELEN (stash);
7033 if(HvNAMEUTF8(stash)) putf8 = SVf_UTF8;
7035 gv = gv_fetchpvn_flags(
7036 Perl_form(aTHX_ "%*s::DATA", (int)plen, pname),
7037 plen+6, GV_ADD|putf8, SVt_PVIO
7041 GvIOp(gv) = newIO();
7042 IoIFP(GvIOp(gv)) = PL_rsfp;
7043 #if defined(HAS_FCNTL) && defined(F_SETFD)
7045 const int fd = PerlIO_fileno(PL_rsfp);
7046 fcntl(fd,F_SETFD,fd >= 3);
7049 /* Mark this internal pseudo-handle as clean */
7050 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7051 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7052 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7054 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7055 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7056 /* if the script was opened in binmode, we need to revert
7057 * it to text mode for compatibility; but only iff it has CRs
7058 * XXX this is a questionable hack at best. */
7059 if (PL_bufend-PL_bufptr > 2
7060 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7063 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7064 loc = PerlIO_tell(PL_rsfp);
7065 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7068 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7070 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7071 #endif /* NETWARE */
7073 PerlIO_seek(PL_rsfp, loc, 0);
7077 #ifdef PERLIO_LAYERS
7080 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7081 else if (PL_encoding) {
7088 XPUSHs(PL_encoding);
7090 call_method("name", G_SCALAR);
7094 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7095 Perl_form(aTHX_ ":encoding(%"SVf")",
7104 if (PL_realtokenstart >= 0) {
7105 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7107 PL_endwhite = newSVpvs("");
7108 sv_catsv(PL_endwhite, PL_thiswhite);
7110 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7111 PL_realtokenstart = -1;
7113 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7129 if (PL_expect == XSTATE) {
7136 if (*s == ':' && s[1] == ':') {
7139 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7140 if (!(tmp = keyword(PL_tokenbuf, len, 1)))
7141 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
7144 else if (tmp == KEY_require || tmp == KEY_do
7146 /* that's a way to remember we saw "CORE::" */
7159 LOP(OP_ACCEPT,XTERM);
7162 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7167 LOP(OP_ATAN2,XTERM);
7173 LOP(OP_BINMODE,XTERM);
7176 LOP(OP_BLESS,XTERM);
7185 /* We have to disambiguate the two senses of
7186 "continue". If the next token is a '{' then
7187 treat it as the start of a continue block;
7188 otherwise treat it as a control operator.
7198 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7208 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7217 if (!PL_cryptseen) {
7218 PL_cryptseen = TRUE;
7222 LOP(OP_CRYPT,XTERM);
7225 LOP(OP_CHMOD,XTERM);
7228 LOP(OP_CHOWN,XTERM);
7231 LOP(OP_CONNECT,XTERM);
7250 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7251 if (orig_keyword == KEY_do) {
7260 PL_hints |= HINT_BLOCK_SCOPE;
7270 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7271 STR_WITH_LEN("NDBM_File::"),
7272 STR_WITH_LEN("DB_File::"),
7273 STR_WITH_LEN("GDBM_File::"),
7274 STR_WITH_LEN("SDBM_File::"),
7275 STR_WITH_LEN("ODBM_File::"),
7277 LOP(OP_DBMOPEN,XTERM);
7283 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7290 pl_yylval.ival = CopLINE(PL_curcop);
7294 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7308 if (*s == '{') { /* block eval */
7309 PL_expect = XTERMBLOCK;
7310 UNIBRACK(OP_ENTERTRY);
7312 else { /* string eval */
7314 UNIBRACK(OP_ENTEREVAL);
7319 UNIBRACK(-OP_ENTEREVAL);
7333 case KEY_endhostent:
7339 case KEY_endservent:
7342 case KEY_endprotoent:
7353 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7355 pl_yylval.ival = CopLINE(PL_curcop);
7357 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
7360 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7363 if ((PL_bufend - p) >= 3 &&
7364 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7366 else if ((PL_bufend - p) >= 4 &&
7367 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7370 if (isIDFIRST_lazy_if(p,UTF)) {
7371 p = scan_ident(p, PL_bufend,
7372 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7376 Perl_croak(aTHX_ "Missing $ on loop variable");
7378 s = SvPVX(PL_linestr) + soff;
7384 LOP(OP_FORMLINE,XTERM);
7390 LOP(OP_FCNTL,XTERM);
7396 LOP(OP_FLOCK,XTERM);
7399 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7404 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7409 LOP(OP_GREPSTART, XREF);
7412 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7427 case KEY_getpriority:
7428 LOP(OP_GETPRIORITY,XTERM);
7430 case KEY_getprotobyname:
7433 case KEY_getprotobynumber:
7434 LOP(OP_GPBYNUMBER,XTERM);
7436 case KEY_getprotoent:
7448 case KEY_getpeername:
7449 UNI(OP_GETPEERNAME);
7451 case KEY_gethostbyname:
7454 case KEY_gethostbyaddr:
7455 LOP(OP_GHBYADDR,XTERM);
7457 case KEY_gethostent:
7460 case KEY_getnetbyname:
7463 case KEY_getnetbyaddr:
7464 LOP(OP_GNBYADDR,XTERM);
7469 case KEY_getservbyname:
7470 LOP(OP_GSBYNAME,XTERM);
7472 case KEY_getservbyport:
7473 LOP(OP_GSBYPORT,XTERM);
7475 case KEY_getservent:
7478 case KEY_getsockname:
7479 UNI(OP_GETSOCKNAME);
7481 case KEY_getsockopt:
7482 LOP(OP_GSOCKOPT,XTERM);
7497 pl_yylval.ival = CopLINE(PL_curcop);
7502 orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
7510 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7512 pl_yylval.ival = CopLINE(PL_curcop);
7516 LOP(OP_INDEX,XTERM);
7522 LOP(OP_IOCTL,XTERM);
7534 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7551 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7556 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7570 LOP(OP_LISTEN,XTERM);
7579 s = scan_pat(s,OP_MATCH);
7580 TERM(sublex_start());
7583 LOP(OP_MAPSTART, XREF);
7586 LOP(OP_MKDIR,XTERM);
7589 LOP(OP_MSGCTL,XTERM);
7592 LOP(OP_MSGGET,XTERM);
7595 LOP(OP_MSGRCV,XTERM);
7598 LOP(OP_MSGSND,XTERM);
7603 PL_in_my = (U16)tmp;
7605 if (isIDFIRST_lazy_if(s,UTF)) {
7609 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
7610 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
7612 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
7613 if (!PL_in_my_stash) {
7616 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
7620 if (PL_madskills) { /* just add type to declarator token */
7621 sv_catsv(PL_thistoken, PL_nextwhite);
7623 sv_catpvn(PL_thistoken, start, s - start);
7631 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7635 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7640 s = tokenize_use(0, s);
7644 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
7647 if (!PL_lex_allbrackets &&
7648 PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7649 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7655 if (isIDFIRST_lazy_if(s,UTF)) {
7657 for (d = s; isALNUM_lazy_if(d,UTF);)
7659 for (t=d; isSPACE(*t);)
7661 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
7663 && !(t[0] == '=' && t[1] == '>')
7665 int parms_len = (int)(d-s);
7666 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
7667 "Precedence problem: open %.*s should be open(%.*s)",
7668 parms_len, s, parms_len, s);
7674 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7676 pl_yylval.ival = OP_OR;
7686 LOP(OP_OPEN_DIR,XTERM);
7689 checkcomma(s,PL_tokenbuf,"filehandle");
7693 checkcomma(s,PL_tokenbuf,"filehandle");
7712 s = force_word(s,WORD,FALSE,TRUE,FALSE);
7714 s = force_strict_version(s);
7715 PL_lex_expect = XBLOCK;
7719 LOP(OP_PIPE_OP,XTERM);
7722 s = scan_str(s,!!PL_madskills,FALSE);
7725 pl_yylval.ival = OP_CONST;
7726 TERM(sublex_start());
7733 s = scan_str(s,!!PL_madskills,FALSE);
7736 PL_expect = XOPERATOR;
7737 if (SvCUR(PL_lex_stuff)) {
7738 int warned_comma = !ckWARN(WARN_QW);
7739 int warned_comment = warned_comma;
7740 d = SvPV_force(PL_lex_stuff, len);
7742 for (; isSPACE(*d) && len; --len, ++d)
7747 if (!warned_comma || !warned_comment) {
7748 for (; !isSPACE(*d) && len; --len, ++d) {
7749 if (!warned_comma && *d == ',') {
7750 Perl_warner(aTHX_ packWARN(WARN_QW),
7751 "Possible attempt to separate words with commas");
7754 else if (!warned_comment && *d == '#') {
7755 Perl_warner(aTHX_ packWARN(WARN_QW),
7756 "Possible attempt to put comments in qw() list");
7762 for (; !isSPACE(*d) && len; --len, ++d)
7765 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
7766 words = op_append_elem(OP_LIST, words,
7767 newSVOP(OP_CONST, 0, tokeq(sv)));
7772 words = newNULLLIST();
7774 SvREFCNT_dec(PL_lex_stuff);
7775 PL_lex_stuff = NULL;
7777 PL_expect = XOPERATOR;
7778 pl_yylval.opval = sawparens(words);
7783 s = scan_str(s,!!PL_madskills,FALSE);
7786 pl_yylval.ival = OP_STRINGIFY;
7787 if (SvIVX(PL_lex_stuff) == '\'')
7788 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
7789 TERM(sublex_start());
7792 s = scan_pat(s,OP_QR);
7793 TERM(sublex_start());
7796 s = scan_str(s,!!PL_madskills,FALSE);
7799 readpipe_override();
7800 TERM(sublex_start());
7808 s = force_version(s, FALSE);
7810 else if (*s != 'v' || !isDIGIT(s[1])
7811 || (s = force_version(s, TRUE), *s == 'v'))
7813 *PL_tokenbuf = '\0';
7814 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7815 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
7816 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
7817 GV_ADD | (UTF ? SVf_UTF8 : 0));
7819 yyerror("<> should be quotes");
7821 if (orig_keyword == KEY_require) {
7829 PL_last_uni = PL_oldbufptr;
7830 PL_last_lop_op = OP_REQUIRE;
7832 return REPORT( (int)REQUIRE );
7838 s = force_word(s,WORD,TRUE,FALSE,FALSE);
7842 LOP(OP_RENAME,XTERM);
7851 LOP(OP_RINDEX,XTERM);
7860 UNIDOR(OP_READLINE);
7863 UNIDOR(OP_BACKTICK);
7872 LOP(OP_REVERSE,XTERM);
7875 UNIDOR(OP_READLINK);
7882 if (pl_yylval.opval)
7883 TERM(sublex_start());
7885 TOKEN(1); /* force error */
7888 checkcomma(s,PL_tokenbuf,"filehandle");
7898 LOP(OP_SELECT,XTERM);
7904 LOP(OP_SEMCTL,XTERM);
7907 LOP(OP_SEMGET,XTERM);
7910 LOP(OP_SEMOP,XTERM);
7916 LOP(OP_SETPGRP,XTERM);
7918 case KEY_setpriority:
7919 LOP(OP_SETPRIORITY,XTERM);
7921 case KEY_sethostent:
7927 case KEY_setservent:
7930 case KEY_setprotoent:
7940 LOP(OP_SEEKDIR,XTERM);
7942 case KEY_setsockopt:
7943 LOP(OP_SSOCKOPT,XTERM);
7949 LOP(OP_SHMCTL,XTERM);
7952 LOP(OP_SHMGET,XTERM);
7955 LOP(OP_SHMREAD,XTERM);
7958 LOP(OP_SHMWRITE,XTERM);
7961 LOP(OP_SHUTDOWN,XTERM);
7970 LOP(OP_SOCKET,XTERM);
7972 case KEY_socketpair:
7973 LOP(OP_SOCKPAIR,XTERM);
7976 checkcomma(s,PL_tokenbuf,"subroutine name");
7978 if (*s == ';' || *s == ')') /* probably a close */
7979 Perl_croak(aTHX_ "sort is now a reserved word");
7981 s = force_word(s,WORD,TRUE,TRUE,FALSE);
7985 LOP(OP_SPLIT,XTERM);
7988 LOP(OP_SPRINTF,XTERM);
7991 LOP(OP_SPLICE,XTERM);
8006 LOP(OP_SUBSTR,XTERM);
8012 char tmpbuf[sizeof PL_tokenbuf];
8013 SSize_t tboffset = 0;
8014 expectation attrful;
8015 bool have_name, have_proto;
8016 const int key = tmp;
8021 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
8022 SV *subtoken = newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr));
8026 s = SKIPSPACE2(s,tmpwhite);
8031 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
8032 (*s == ':' && s[1] == ':'))
8035 SV *nametoke = NULL;
8039 attrful = XATTRBLOCK;
8040 /* remember buffer pos'n for later force_word */
8041 tboffset = s - PL_oldbufptr;
8042 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
8045 nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
8047 if (memchr(tmpbuf, ':', len))
8048 sv_setpvn(PL_subname, tmpbuf, len);
8050 sv_setsv(PL_subname,PL_curstname);
8051 sv_catpvs(PL_subname,"::");
8052 sv_catpvn(PL_subname,tmpbuf,len);
8054 if (SvUTF8(PL_linestr))
8055 SvUTF8_on(PL_subname);
8061 CURMAD('X', nametoke);
8062 CURMAD('_', tmpwhite);
8063 (void) force_word(PL_oldbufptr + tboffset, WORD,
8066 s = SKIPSPACE2(d,tmpwhite);
8073 Perl_croak(aTHX_ "Missing name in \"my sub\"");
8074 PL_expect = XTERMBLOCK;
8075 attrful = XATTRTERM;
8076 sv_setpvs(PL_subname,"?");
8080 if (key == KEY_format) {
8082 PL_lex_formbrack = PL_lex_brackets + 1;
8084 PL_thistoken = subtoken;
8088 (void) force_word(PL_oldbufptr + tboffset, WORD,
8094 /* Look for a prototype */
8097 bool bad_proto = FALSE;
8098 bool in_brackets = FALSE;
8099 char greedy_proto = ' ';
8100 bool proto_after_greedy_proto = FALSE;
8101 bool must_be_last = FALSE;
8102 bool underscore = FALSE;
8103 bool seen_underscore = FALSE;
8104 const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
8107 s = scan_str(s,!!PL_madskills,FALSE);
8109 Perl_croak(aTHX_ "Prototype not terminated");
8110 /* strip spaces and check for bad characters */
8111 d = SvPV(PL_lex_stuff, tmplen);
8113 for (p = d; tmplen; tmplen--, ++p) {
8117 if (warnillegalproto) {
8119 proto_after_greedy_proto = TRUE;
8120 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
8132 else if ( *p == ']' ) {
8133 in_brackets = FALSE;
8135 else if ( (*p == '@' || *p == '%') &&
8136 ( tmp < 2 || d[tmp-2] != '\\' ) &&
8138 must_be_last = TRUE;
8141 else if ( *p == '_' ) {
8142 underscore = seen_underscore = TRUE;
8149 if (proto_after_greedy_proto)
8150 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8151 "Prototype after '%c' for %"SVf" : %s",
8152 greedy_proto, SVfARG(PL_subname), d);
8154 SV *dsv = newSVpvs_flags("", SVs_TEMP);
8155 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
8156 "Illegal character %sin prototype for %"SVf" : %s",
8157 seen_underscore ? "after '_' " : "",
8160 newSVpvn_flags(d, tmp, SVs_TEMP | SvUTF8(PL_lex_stuff)),
8161 tmp, UNI_DISPLAY_ISPRINT));
8163 SvCUR_set(PL_lex_stuff, tmp);
8168 CURMAD('q', PL_thisopen);
8169 CURMAD('_', tmpwhite);
8170 CURMAD('=', PL_thisstuff);
8171 CURMAD('Q', PL_thisclose);
8172 NEXTVAL_NEXTTOKE.opval =
8173 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8174 PL_lex_stuff = NULL;
8177 s = SKIPSPACE2(s,tmpwhite);
8185 if (*s == ':' && s[1] != ':')
8186 PL_expect = attrful;
8187 else if (*s != '{' && key == KEY_sub) {
8189 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8190 else if (*s != ';' && *s != '}')
8191 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8198 curmad('^', newSVpvs(""));
8199 CURMAD('_', tmpwhite);
8203 PL_thistoken = subtoken;
8206 NEXTVAL_NEXTTOKE.opval =
8207 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8208 PL_lex_stuff = NULL;
8214 sv_setpvs(PL_subname, "__ANON__");
8216 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8220 (void) force_word(PL_oldbufptr + tboffset, WORD,
8229 LOP(OP_SYSTEM,XREF);
8232 LOP(OP_SYMLINK,XTERM);
8235 LOP(OP_SYSCALL,XTERM);
8238 LOP(OP_SYSOPEN,XTERM);
8241 LOP(OP_SYSSEEK,XTERM);
8244 LOP(OP_SYSREAD,XTERM);
8247 LOP(OP_SYSWRITE,XTERM);
8251 TERM(sublex_start());
8272 LOP(OP_TRUNCATE,XTERM);
8284 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8286 pl_yylval.ival = CopLINE(PL_curcop);
8290 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8292 pl_yylval.ival = CopLINE(PL_curcop);
8296 LOP(OP_UNLINK,XTERM);
8302 LOP(OP_UNPACK,XTERM);
8305 LOP(OP_UTIME,XTERM);
8311 LOP(OP_UNSHIFT,XTERM);
8314 s = tokenize_use(1, s);
8324 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8326 pl_yylval.ival = CopLINE(PL_curcop);
8330 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8332 pl_yylval.ival = CopLINE(PL_curcop);
8336 PL_hints |= HINT_BLOCK_SCOPE;
8343 LOP(OP_WAITPID,XTERM);
8352 ctl_l[0] = toCTRL('L');
8354 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
8357 /* Make sure $^L is defined */
8358 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
8363 if (PL_expect == XOPERATOR) {
8364 if (*s == '=' && !PL_lex_allbrackets &&
8365 PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8373 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8375 pl_yylval.ival = OP_XOR;
8380 TERM(sublex_start());
8385 #pragma segment Main
8389 S_pending_ident(pTHX)
8394 /* pit holds the identifier we read and pending_ident is reset */
8395 char pit = PL_pending_ident;
8396 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8397 /* All routes through this function want to know if there is a colon. */
8398 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8399 PL_pending_ident = 0;
8401 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
8402 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8403 "### Pending identifier '%s'\n", PL_tokenbuf); });
8405 /* if we're in a my(), we can't allow dynamics here.
8406 $foo'bar has already been turned into $foo::bar, so
8407 just check for colons.
8409 if it's a legal name, the OP is a PADANY.
8412 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8414 yyerror(Perl_form(aTHX_ "No package name allowed for "
8415 "variable %s in \"our\"",
8417 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8421 yyerror(Perl_form(aTHX_ PL_no_myglob,
8422 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
8424 pl_yylval.opval = newOP(OP_PADANY, 0);
8425 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
8426 UTF ? SVf_UTF8 : 0);
8432 build the ops for accesses to a my() variable.
8434 Deny my($a) or my($b) in a sort block, *if* $a or $b is
8435 then used in a comparison. This catches most, but not
8436 all cases. For instance, it catches
8437 sort { my($a); $a <=> $b }
8439 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
8440 (although why you'd do that is anyone's guess).
8445 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
8446 UTF ? SVf_UTF8 : 0);
8447 if (tmp != NOT_IN_PAD) {
8448 /* might be an "our" variable" */
8449 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
8450 /* build ops for a bareword */
8451 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
8452 HEK * const stashname = HvNAME_HEK(stash);
8453 SV * const sym = newSVhek(stashname);
8454 sv_catpvs(sym, "::");
8455 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
8456 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
8457 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8460 ? (GV_ADDMULTI | GV_ADDINEVAL)
8463 ((PL_tokenbuf[0] == '$') ? SVt_PV
8464 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8469 /* if it's a sort block and they're naming $a or $b */
8470 if (PL_last_lop_op == OP_SORT &&
8471 PL_tokenbuf[0] == '$' &&
8472 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
8475 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
8476 d < PL_bufend && *d != '\n';
8479 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
8480 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
8486 pl_yylval.opval = newOP(OP_PADANY, 0);
8487 pl_yylval.opval->op_targ = tmp;
8493 Whine if they've said @foo in a doublequoted string,
8494 and @foo isn't a variable we can find in the symbol
8497 if (ckWARN(WARN_AMBIGUOUS) &&
8498 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
8499 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
8500 ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
8501 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
8502 /* DO NOT warn for @- and @+ */
8503 && !( PL_tokenbuf[2] == '\0' &&
8504 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
8507 /* Downgraded from fatal to warning 20000522 mjd */
8508 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8509 "Possible unintended interpolation of %s in string",
8514 /* build ops for a bareword */
8515 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(PL_tokenbuf + 1,
8517 UTF ? SVf_UTF8 : 0 ));
8518 pl_yylval.opval->op_private = OPpCONST_ENTERED;
8519 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
8520 (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
8521 | ( UTF ? SVf_UTF8 : 0 ),
8522 ((PL_tokenbuf[0] == '$') ? SVt_PV
8523 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
8529 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
8533 PERL_ARGS_ASSERT_CHECKCOMMA;
8535 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8536 if (ckWARN(WARN_SYNTAX)) {
8539 for (w = s+2; *w && level; w++) {
8547 /* the list of chars below is for end of statements or
8548 * block / parens, boolean operators (&&, ||, //) and branch
8549 * constructs (or, and, if, until, unless, while, err, for).
8550 * Not a very solid hack... */
8551 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
8552 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8553 "%s (...) interpreted as function",name);
8556 while (s < PL_bufend && isSPACE(*s))
8560 while (s < PL_bufend && isSPACE(*s))
8562 if (isIDFIRST_lazy_if(s,UTF)) {
8563 const char * const w = s++;
8564 while (isALNUM_lazy_if(s,UTF))
8566 while (s < PL_bufend && isSPACE(*s))
8570 if (keyword(w, s - w, 0))
8573 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
8574 if (gv && GvCVu(gv))
8576 Perl_croak(aTHX_ "No comma allowed after %s", what);
8581 /* Either returns sv, or mortalizes sv and returns a new SV*.
8582 Best used as sv=new_constant(..., sv, ...).
8583 If s, pv are NULL, calls subroutine with one argument,
8584 and type is used with error messages only. */
8587 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
8588 SV *sv, SV *pv, const char *type, STRLEN typelen)
8591 HV * const table = GvHV(PL_hintgv); /* ^H */
8595 const char *why1 = "", *why2 = "", *why3 = "";
8597 PERL_ARGS_ASSERT_NEW_CONSTANT;
8599 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8602 why2 = (const char *)
8603 (strEQ(key,"charnames")
8604 ? "(possibly a missing \"use charnames ...\")"
8606 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
8607 (type ? type: "undef"), why2);
8609 /* This is convoluted and evil ("goto considered harmful")
8610 * but I do not understand the intricacies of all the different
8611 * failure modes of %^H in here. The goal here is to make
8612 * the most probable error message user-friendly. --jhi */
8617 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
8618 (type ? type: "undef"), why1, why2, why3);
8620 yyerror(SvPVX_const(msg));
8625 /* charnames doesn't work well if there have been errors found */
8626 if (PL_error_count > 0 && strEQ(key,"charnames"))
8627 return &PL_sv_undef;
8629 cvp = hv_fetch(table, key, keylen, FALSE);
8630 if (!cvp || !SvOK(*cvp)) {
8633 why3 = "} is not defined";
8636 sv_2mortal(sv); /* Parent created it permanently */
8639 pv = newSVpvn_flags(s, len, SVs_TEMP);
8641 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
8643 typesv = &PL_sv_undef;
8645 PUSHSTACKi(PERLSI_OVERLOAD);
8657 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
8661 /* Check the eval first */
8662 if (!PL_in_eval && SvTRUE(ERRSV)) {
8663 sv_catpvs(ERRSV, "Propagated");
8664 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
8666 res = SvREFCNT_inc_simple(sv);
8670 SvREFCNT_inc_simple_void(res);
8679 why1 = "Call to &{$^H{";
8681 why3 = "}} did not return a defined value";
8689 /* Returns a NUL terminated string, with the length of the string written to
8693 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
8696 register char *d = dest;
8697 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8699 PERL_ARGS_ASSERT_SCAN_WORD;
8703 Perl_croak(aTHX_ ident_too_long);
8704 if (isALNUM(*s)) /* UTF handled below */
8706 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
8711 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
8715 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8716 char *t = s + UTF8SKIP(s);
8718 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8722 Perl_croak(aTHX_ ident_too_long);
8723 Copy(s, d, len, char);
8736 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
8739 char *bracket = NULL;
8741 register char *d = dest;
8742 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
8744 PERL_ARGS_ASSERT_SCAN_IDENT;
8749 while (isDIGIT(*s)) {
8751 Perl_croak(aTHX_ ident_too_long);
8758 Perl_croak(aTHX_ ident_too_long);
8759 if (isALNUM(*s)) /* UTF handled below */
8761 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
8766 else if (*s == ':' && s[1] == ':') {
8770 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
8771 char *t = s + UTF8SKIP(s);
8772 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
8774 if (d + (t - s) > e)
8775 Perl_croak(aTHX_ ident_too_long);
8776 Copy(s, d, t - s, char);
8787 if (PL_lex_state != LEX_NORMAL)
8788 PL_lex_state = LEX_INTERPENDMAYBE;
8791 if (*s == '$' && s[1] &&
8792 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
8804 const STRLEN skip = UTF8SKIP(s);
8807 for ( i = 0; i < skip; i++ )
8815 if (*d == '^' && *s && isCONTROLVAR(*s)) {
8820 if (isSPACE(s[-1])) {
8822 const char ch = *s++;
8823 if (!SPACE_OR_TAB(ch)) {
8829 if (isIDFIRST_lazy_if(d,UTF)) {
8833 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
8834 end += UTF8SKIP(end);
8835 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
8836 end += UTF8SKIP(end);
8838 Copy(s, d, end - s, char);
8843 while ((isALNUM(*s) || *s == ':') && d < e)
8846 Perl_croak(aTHX_ ident_too_long);
8849 while (s < send && SPACE_OR_TAB(*s))
8851 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
8852 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
8853 const char * const brack =
8855 ((*s == '[') ? "[...]" : "{...}");
8856 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
8857 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8858 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
8859 funny, dest, brack, funny, dest, brack);
8862 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
8863 PL_lex_allbrackets++;
8867 /* Handle extended ${^Foo} variables
8868 * 1999-02-27 mjd-perl-patch@plover.com */
8869 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
8873 while (isALNUM(*s) && d < e) {
8877 Perl_croak(aTHX_ ident_too_long);
8882 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
8883 PL_lex_state = LEX_INTERPEND;
8886 if (PL_lex_state == LEX_NORMAL) {
8887 if (ckWARN(WARN_AMBIGUOUS) &&
8888 (keyword(dest, d - dest, 0)
8889 || get_cvn_flags(dest, d - dest, 0)))
8893 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
8894 "Ambiguous use of %c{%s} resolved to %c%s",
8895 funny, dest, funny, dest);
8900 s = bracket; /* let the parser handle it */
8904 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
8905 PL_lex_state = LEX_INTERPEND;
8910 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
8912 /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
8913 * the parse starting at 's', based on the subset that are valid in this
8914 * context input to this routine in 'valid_flags'. Advances s. Returns
8915 * TRUE if the input was a valid flag, so the next char may be as well;
8916 * otherwise FALSE. 'charset' should point to a NUL upon first call on the
8917 * current regex. This routine will set it to any charset modifier found.
8918 * The caller shouldn't change it. This way, another charset modifier
8919 * encountered in the parse can be detected as an error, as we have decided
8924 if (! strchr(valid_flags, c)) {
8933 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
8934 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
8935 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
8936 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
8937 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
8938 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
8939 case LOCALE_PAT_MOD:
8941 /* In 5.14, qr//lt is legal but deprecated; the 't' means they
8942 * can't be regex modifiers.
8943 * In 5.14, s///le is legal and ambiguous. Try to disambiguate as
8944 * much as easily done. s///lei, for example, has to mean regex
8945 * modifiers if it's not an error (as does any word character
8946 * following the 'e'). Otherwise, we resolve to the backwards-
8947 * compatible, but less likely 's/// le ...', i.e. as meaning
8948 * less-than-or-equal. The reason it's not likely is that s//
8949 * returns a number for code in the field (/r returns a string, but
8950 * that wasn't added until the 5.13 series), and so '<=' should be
8951 * used for comparing, not 'le'. */
8952 if (*((*s) + 1) == 't') {
8955 else if (*((*s) + 1) == 'e' && ! isALNUM(*((*s) + 2))) {
8957 /* 'e' is valid only for substitutes, s///e. If it is not
8958 * valid in the current context, then 'm//le' must mean the
8959 * comparison operator, so use the regular deprecation message.
8961 if (! strchr(valid_flags, 'e')) {
8964 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
8965 "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");
8969 goto multiple_charsets;
8971 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
8974 case UNICODE_PAT_MOD:
8975 /* In 5.14, qr//unless and qr//until are legal but deprecated; the
8976 * 'n' means they can't be regex modifiers */
8977 if (*((*s) + 1) == 'n') {
8981 goto multiple_charsets;
8983 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
8986 case ASCII_RESTRICT_PAT_MOD:
8987 /* In 5.14, qr//and is legal but deprecated; the 'n' means they
8988 * can't be regex modifiers */
8989 if (*((*s) + 1) == 'n') {
8994 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
8998 /* Error if previous modifier wasn't an 'a', but if it was, see
8999 * if, and accept, a second occurrence (only) */
9001 || get_regex_charset(*pmfl)
9002 != REGEX_ASCII_RESTRICTED_CHARSET)
9004 goto multiple_charsets;
9006 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9010 case DEPENDS_PAT_MOD:
9012 goto multiple_charsets;
9014 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9023 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX),
9024 "Having no space between pattern and following word is deprecated");
9028 if (*charset != c) {
9029 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9031 else if (c == 'a') {
9032 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9035 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9038 /* Pretend that it worked, so will continue processing before dieing */
9044 S_scan_pat(pTHX_ char *start, I32 type)
9048 char *s = scan_str(start,!!PL_madskills,FALSE);
9049 const char * const valid_flags =
9050 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9051 char charset = '\0'; /* character set modifier */
9056 PERL_ARGS_ASSERT_SCAN_PAT;
9059 const char * const delimiter = skipspace(start);
9063 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9064 : "Search pattern not terminated" ));
9067 pm = (PMOP*)newPMOP(type, 0);
9068 if (PL_multi_open == '?') {
9069 /* This is the only point in the code that sets PMf_ONCE: */
9070 pm->op_pmflags |= PMf_ONCE;
9072 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9073 allows us to restrict the list needed by reset to just the ??
9075 assert(type != OP_TRANS);
9077 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9080 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9083 elements = mg->mg_len / sizeof(PMOP**);
9084 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9085 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9086 mg->mg_len = elements * sizeof(PMOP**);
9087 PmopSTASH_set(pm,PL_curstash);
9093 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
9095 if (PL_madskills && modstart != s) {
9096 SV* tmptoken = newSVpvn(modstart, s - modstart);
9097 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9100 /* issue a warning if /c is specified,but /g is not */
9101 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9103 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9104 "Use of /c modifier is meaningless without /g" );
9107 PL_lex_op = (OP*)pm;
9108 pl_yylval.ival = OP_MATCH;
9113 S_scan_subst(pTHX_ char *start)
9120 char charset = '\0'; /* character set modifier */
9125 PERL_ARGS_ASSERT_SCAN_SUBST;
9127 pl_yylval.ival = OP_NULL;
9129 s = scan_str(start,!!PL_madskills,FALSE);
9132 Perl_croak(aTHX_ "Substitution pattern not terminated");
9134 if (s[-1] == PL_multi_open)
9138 CURMAD('q', PL_thisopen);
9139 CURMAD('_', PL_thiswhite);
9140 CURMAD('E', PL_thisstuff);
9141 CURMAD('Q', PL_thisclose);
9142 PL_realtokenstart = s - SvPVX(PL_linestr);
9146 first_start = PL_multi_start;
9147 s = scan_str(s,!!PL_madskills,FALSE);
9150 SvREFCNT_dec(PL_lex_stuff);
9151 PL_lex_stuff = NULL;
9153 Perl_croak(aTHX_ "Substitution replacement not terminated");
9155 PL_multi_start = first_start; /* so whole substitution is taken together */
9157 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9161 CURMAD('z', PL_thisopen);
9162 CURMAD('R', PL_thisstuff);
9163 CURMAD('Z', PL_thisclose);
9169 if (*s == EXEC_PAT_MOD) {
9173 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9182 curmad('m', newSVpvn(modstart, s - modstart));
9183 append_madprops(PL_thismad, (OP*)pm, 0);
9187 if ((pm->op_pmflags & PMf_CONTINUE)) {
9188 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9192 SV * const repl = newSVpvs("");
9194 PL_sublex_info.super_bufptr = s;
9195 PL_sublex_info.super_bufend = PL_bufend;
9197 pm->op_pmflags |= PMf_EVAL;
9200 sv_catpvs(repl, "eval ");
9202 sv_catpvs(repl, "do ");
9204 sv_catpvs(repl, "{");
9205 sv_catsv(repl, PL_lex_repl);
9206 if (strchr(SvPVX(PL_lex_repl), '#'))
9207 sv_catpvs(repl, "\n");
9208 sv_catpvs(repl, "}");
9210 SvREFCNT_dec(PL_lex_repl);
9214 PL_lex_op = (OP*)pm;
9215 pl_yylval.ival = OP_SUBST;
9220 S_scan_trans(pTHX_ char *start)
9229 bool nondestruct = 0;
9234 PERL_ARGS_ASSERT_SCAN_TRANS;
9236 pl_yylval.ival = OP_NULL;
9238 s = scan_str(start,!!PL_madskills,FALSE);
9240 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9242 if (s[-1] == PL_multi_open)
9246 CURMAD('q', PL_thisopen);
9247 CURMAD('_', PL_thiswhite);
9248 CURMAD('E', PL_thisstuff);
9249 CURMAD('Q', PL_thisclose);
9250 PL_realtokenstart = s - SvPVX(PL_linestr);
9254 s = scan_str(s,!!PL_madskills,FALSE);
9257 SvREFCNT_dec(PL_lex_stuff);
9258 PL_lex_stuff = NULL;
9260 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9263 CURMAD('z', PL_thisopen);
9264 CURMAD('R', PL_thisstuff);
9265 CURMAD('Z', PL_thisclose);
9268 complement = del = squash = 0;
9275 complement = OPpTRANS_COMPLEMENT;
9278 del = OPpTRANS_DELETE;
9281 squash = OPpTRANS_SQUASH;
9293 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
9294 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
9295 o->op_private &= ~OPpTRANS_ALL;
9296 o->op_private |= del|squash|complement|
9297 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9298 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9301 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9306 curmad('m', newSVpvn(modstart, s - modstart));
9307 append_madprops(PL_thismad, o, 0);
9316 S_scan_heredoc(pTHX_ register char *s)
9320 I32 op_type = OP_SCALAR;
9324 const char *found_newline;
9328 const int outer = (PL_rsfp || PL_parser->filtered)
9329 && !(PL_lex_inwhat == OP_SCALAR);
9331 I32 stuffstart = s - SvPVX(PL_linestr);
9334 PL_realtokenstart = -1;
9337 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9341 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9345 while (SPACE_OR_TAB(*peek))
9347 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9350 s = delimcpy(d, e, s, PL_bufend, term, &len);
9360 if (!isALNUM_lazy_if(s,UTF))
9361 deprecate("bare << to mean <<\"\"");
9362 for (; isALNUM_lazy_if(s,UTF); s++) {
9367 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9368 Perl_croak(aTHX_ "Delimiter for here document is too long");
9371 len = d - PL_tokenbuf;
9375 tstart = PL_tokenbuf + !outer;
9376 PL_thisclose = newSVpvn(tstart, len - !outer);
9377 tstart = SvPVX(PL_linestr) + stuffstart;
9378 PL_thisopen = newSVpvn(tstart, s - tstart);
9379 stuffstart = s - SvPVX(PL_linestr);
9382 #ifndef PERL_STRICT_CR
9383 d = strchr(s, '\r');
9385 char * const olds = s;
9387 while (s < PL_bufend) {
9393 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9402 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9409 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
9410 herewas = newSVpvn(s,PL_bufend-s);
9414 herewas = newSVpvn(s-1,found_newline-s+1);
9417 herewas = newSVpvn(s,found_newline-s);
9422 tstart = SvPVX(PL_linestr) + stuffstart;
9424 sv_catpvn(PL_thisstuff, tstart, s - tstart);
9426 PL_thisstuff = newSVpvn(tstart, s - tstart);
9429 s += SvCUR(herewas);
9432 stuffstart = s - SvPVX(PL_linestr);
9438 tmpstr = newSV_type(SVt_PVIV);
9442 SvIV_set(tmpstr, -1);
9444 else if (term == '`') {
9445 op_type = OP_BACKTICK;
9446 SvIV_set(tmpstr, '\\');
9450 PL_multi_start = CopLINE(PL_curcop);
9451 PL_multi_open = PL_multi_close = '<';
9452 term = *PL_tokenbuf;
9453 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp
9454 && !PL_parser->filtered) {
9455 char * const bufptr = PL_sublex_info.super_bufptr;
9456 char * const bufend = PL_sublex_info.super_bufend;
9457 char * const olds = s - SvCUR(herewas);
9458 s = strchr(bufptr, '\n');
9462 while (s < bufend &&
9463 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9465 CopLINE_inc(PL_curcop);
9468 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9469 missingterm(PL_tokenbuf);
9471 sv_setpvn(herewas,bufptr,d-bufptr+1);
9472 sv_setpvn(tmpstr,d+1,s-d);
9474 sv_catpvn(herewas,s,bufend-s);
9475 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9482 while (s < PL_bufend &&
9483 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9485 CopLINE_inc(PL_curcop);
9487 if (s >= PL_bufend) {
9488 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9489 missingterm(PL_tokenbuf);
9491 sv_setpvn(tmpstr,d+1,s-d);
9495 sv_catpvn(PL_thisstuff, d + 1, s - d);
9497 PL_thisstuff = newSVpvn(d + 1, s - d);
9498 stuffstart = s - SvPVX(PL_linestr);
9502 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9504 sv_catpvn(herewas,s,PL_bufend-s);
9505 sv_setsv(PL_linestr,herewas);
9506 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9507 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9508 PL_last_lop = PL_last_uni = NULL;
9511 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
9512 while (s >= PL_bufend) { /* multiple line string? */
9515 tstart = SvPVX(PL_linestr) + stuffstart;
9517 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
9519 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
9523 CopLINE_inc(PL_curcop);
9524 if (!outer || !lex_next_chunk(0)) {
9525 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9526 missingterm(PL_tokenbuf);
9528 CopLINE_dec(PL_curcop);
9531 stuffstart = s - SvPVX(PL_linestr);
9533 CopLINE_inc(PL_curcop);
9534 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9535 PL_last_lop = PL_last_uni = NULL;
9536 #ifndef PERL_STRICT_CR
9537 if (PL_bufend - PL_linestart >= 2) {
9538 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9539 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9541 PL_bufend[-2] = '\n';
9543 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9545 else if (PL_bufend[-1] == '\r')
9546 PL_bufend[-1] = '\n';
9548 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9549 PL_bufend[-1] = '\n';
9551 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9552 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9553 *(SvPVX(PL_linestr) + off ) = ' ';
9554 lex_grow_linestr(SvCUR(PL_linestr) + SvCUR(herewas) + 1);
9555 sv_catsv(PL_linestr,herewas);
9556 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9557 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9561 sv_catsv(tmpstr,PL_linestr);
9566 PL_multi_end = CopLINE(PL_curcop);
9567 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9568 SvPV_shrink_to_cur(tmpstr);
9570 SvREFCNT_dec(herewas);
9572 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9574 else if (PL_encoding)
9575 sv_recode_to_utf8(tmpstr, PL_encoding);
9577 PL_lex_stuff = tmpstr;
9578 pl_yylval.ival = op_type;
9583 takes: current position in input buffer
9584 returns: new position in input buffer
9585 side-effects: pl_yylval and lex_op are set.
9590 <FH> read from filehandle
9591 <pkg::FH> read from package qualified filehandle
9592 <pkg'FH> read from package qualified filehandle
9593 <$fh> read from filehandle in $fh
9599 S_scan_inputsymbol(pTHX_ char *start)
9602 register char *s = start; /* current position in buffer */
9605 char *d = PL_tokenbuf; /* start of temp holding space */
9606 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9608 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
9610 end = strchr(s, '\n');
9613 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9615 /* die if we didn't have space for the contents of the <>,
9616 or if it didn't end, or if we see a newline
9619 if (len >= (I32)sizeof PL_tokenbuf)
9620 Perl_croak(aTHX_ "Excessively long <> operator");
9622 Perl_croak(aTHX_ "Unterminated <> operator");
9627 Remember, only scalar variables are interpreted as filehandles by
9628 this code. Anything more complex (e.g., <$fh{$num}>) will be
9629 treated as a glob() call.
9630 This code makes use of the fact that except for the $ at the front,
9631 a scalar variable and a filehandle look the same.
9633 if (*d == '$' && d[1]) d++;
9635 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9636 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9637 d += UTF ? UTF8SKIP(d) : 1;
9639 /* If we've tried to read what we allow filehandles to look like, and
9640 there's still text left, then it must be a glob() and not a getline.
9641 Use scan_str to pull out the stuff between the <> and treat it
9642 as nothing more than a string.
9645 if (d - PL_tokenbuf != len) {
9646 pl_yylval.ival = OP_GLOB;
9647 s = scan_str(start,!!PL_madskills,FALSE);
9649 Perl_croak(aTHX_ "Glob not terminated");
9653 bool readline_overriden = FALSE;
9656 /* we're in a filehandle read situation */
9659 /* turn <> into <ARGV> */
9661 Copy("ARGV",d,5,char);
9663 /* Check whether readline() is overriden */
9664 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
9666 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9668 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
9669 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
9670 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9671 readline_overriden = TRUE;
9673 /* if <$fh>, create the ops to turn the variable into a
9677 /* try to find it in the pad for this block, otherwise find
9678 add symbol table ops
9680 const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
9681 if (tmp != NOT_IN_PAD) {
9682 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9683 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9684 HEK * const stashname = HvNAME_HEK(stash);
9685 SV * const sym = sv_2mortal(newSVhek(stashname));
9686 sv_catpvs(sym, "::");
9692 OP * const o = newOP(OP_PADSV, 0);
9694 PL_lex_op = readline_overriden
9695 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9696 op_append_elem(OP_LIST, o,
9697 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9698 : (OP*)newUNOP(OP_READLINE, 0, o);
9707 ? (GV_ADDMULTI | GV_ADDINEVAL)
9708 : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
9710 PL_lex_op = readline_overriden
9711 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9712 op_append_elem(OP_LIST,
9713 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9714 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9715 : (OP*)newUNOP(OP_READLINE, 0,
9716 newUNOP(OP_RV2SV, 0,
9717 newGVOP(OP_GV, 0, gv)));
9719 if (!readline_overriden)
9720 PL_lex_op->op_flags |= OPf_SPECIAL;
9721 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
9722 pl_yylval.ival = OP_NULL;
9725 /* If it's none of the above, it must be a literal filehandle
9726 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9728 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
9729 PL_lex_op = readline_overriden
9730 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9731 op_append_elem(OP_LIST,
9732 newGVOP(OP_GV, 0, gv),
9733 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9734 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9735 pl_yylval.ival = OP_NULL;
9744 takes: start position in buffer
9745 keep_quoted preserve \ on the embedded delimiter(s)
9746 keep_delims preserve the delimiters around the string
9747 returns: position to continue reading from buffer
9748 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9749 updates the read buffer.
9751 This subroutine pulls a string out of the input. It is called for:
9752 q single quotes q(literal text)
9753 ' single quotes 'literal text'
9754 qq double quotes qq(interpolate $here please)
9755 " double quotes "interpolate $here please"
9756 qx backticks qx(/bin/ls -l)
9757 ` backticks `/bin/ls -l`
9758 qw quote words @EXPORT_OK = qw( func() $spam )
9759 m// regexp match m/this/
9760 s/// regexp substitute s/this/that/
9761 tr/// string transliterate tr/this/that/
9762 y/// string transliterate y/this/that/
9763 ($*@) sub prototypes sub foo ($)
9764 (stuff) sub attr parameters sub foo : attr(stuff)
9765 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9767 In most of these cases (all but <>, patterns and transliterate)
9768 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9769 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9770 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9773 It skips whitespace before the string starts, and treats the first
9774 character as the delimiter. If the delimiter is one of ([{< then
9775 the corresponding "close" character )]}> is used as the closing
9776 delimiter. It allows quoting of delimiters, and if the string has
9777 balanced delimiters ([{<>}]) it allows nesting.
9779 On success, the SV with the resulting string is put into lex_stuff or,
9780 if that is already non-NULL, into lex_repl. The second case occurs only
9781 when parsing the RHS of the special constructs s/// and tr/// (y///).
9782 For convenience, the terminating delimiter character is stuffed into
9787 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9790 SV *sv; /* scalar value: string */
9791 const char *tmps; /* temp string, used for delimiter matching */
9792 register char *s = start; /* current position in the buffer */
9793 register char term; /* terminating character */
9794 register char *to; /* current position in the sv's data */
9795 I32 brackets = 1; /* bracket nesting level */
9796 bool has_utf8 = FALSE; /* is there any utf8 content? */
9797 I32 termcode; /* terminating char. code */
9798 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9799 STRLEN termlen; /* length of terminating string */
9800 int last_off = 0; /* last position for nesting bracket */
9806 PERL_ARGS_ASSERT_SCAN_STR;
9808 /* skip space before the delimiter */
9814 if (PL_realtokenstart >= 0) {
9815 stuffstart = PL_realtokenstart;
9816 PL_realtokenstart = -1;
9819 stuffstart = start - SvPVX(PL_linestr);
9821 /* mark where we are, in case we need to report errors */
9824 /* after skipping whitespace, the next character is the terminator */
9827 termcode = termstr[0] = term;
9831 termcode = utf8_to_uvchr((U8*)s, &termlen);
9832 Copy(s, termstr, termlen, U8);
9833 if (!UTF8_IS_INVARIANT(term))
9837 /* mark where we are */
9838 PL_multi_start = CopLINE(PL_curcop);
9839 PL_multi_open = term;
9841 /* find corresponding closing delimiter */
9842 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9843 termcode = termstr[0] = term = tmps[5];
9845 PL_multi_close = term;
9847 /* create a new SV to hold the contents. 79 is the SV's initial length.
9848 What a random number. */
9849 sv = newSV_type(SVt_PVIV);
9851 SvIV_set(sv, termcode);
9852 (void)SvPOK_only(sv); /* validate pointer */
9854 /* move past delimiter and try to read a complete string */
9856 sv_catpvn(sv, s, termlen);
9859 tstart = SvPVX(PL_linestr) + stuffstart;
9860 if (!PL_thisopen && !keep_delims) {
9861 PL_thisopen = newSVpvn(tstart, s - tstart);
9862 stuffstart = s - SvPVX(PL_linestr);
9866 if (PL_encoding && !UTF) {
9870 int offset = s - SvPVX_const(PL_linestr);
9871 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9872 &offset, (char*)termstr, termlen);
9873 const char * const ns = SvPVX_const(PL_linestr) + offset;
9874 char * const svlast = SvEND(sv) - 1;
9876 for (; s < ns; s++) {
9877 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9878 CopLINE_inc(PL_curcop);
9881 goto read_more_line;
9883 /* handle quoted delimiters */
9884 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9886 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9888 if ((svlast-1 - t) % 2) {
9892 SvCUR_set(sv, SvCUR(sv) - 1);
9897 if (PL_multi_open == PL_multi_close) {
9903 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
9904 /* At here, all closes are "was quoted" one,
9905 so we don't check PL_multi_close. */
9907 if (!keep_quoted && *(t+1) == PL_multi_open)
9912 else if (*t == PL_multi_open)
9920 SvCUR_set(sv, w - SvPVX_const(sv));
9922 last_off = w - SvPVX(sv);
9923 if (--brackets <= 0)
9929 SvCUR_set(sv, SvCUR(sv) - 1);
9935 /* extend sv if need be */
9936 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9937 /* set 'to' to the next character in the sv's string */
9938 to = SvPVX(sv)+SvCUR(sv);
9940 /* if open delimiter is the close delimiter read unbridle */
9941 if (PL_multi_open == PL_multi_close) {
9942 for (; s < PL_bufend; s++,to++) {
9943 /* embedded newlines increment the current line number */
9944 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9945 CopLINE_inc(PL_curcop);
9946 /* handle quoted delimiters */
9947 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9948 if (!keep_quoted && s[1] == term)
9950 /* any other quotes are simply copied straight through */
9954 /* terminate when run out of buffer (the for() condition), or
9955 have found the terminator */
9956 else if (*s == term) {
9959 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9962 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9968 /* if the terminator isn't the same as the start character (e.g.,
9969 matched brackets), we have to allow more in the quoting, and
9970 be prepared for nested brackets.
9973 /* read until we run out of string, or we find the terminator */
9974 for (; s < PL_bufend; s++,to++) {
9975 /* embedded newlines increment the line count */
9976 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
9977 CopLINE_inc(PL_curcop);
9978 /* backslashes can escape the open or closing characters */
9979 if (*s == '\\' && s+1 < PL_bufend) {
9981 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
9986 /* allow nested opens and closes */
9987 else if (*s == PL_multi_close && --brackets <= 0)
9989 else if (*s == PL_multi_open)
9991 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9996 /* terminate the copied string and update the sv's end-of-string */
9998 SvCUR_set(sv, to - SvPVX_const(sv));
10001 * this next chunk reads more into the buffer if we're not done yet
10005 break; /* handle case where we are done yet :-) */
10007 #ifndef PERL_STRICT_CR
10008 if (to - SvPVX_const(sv) >= 2) {
10009 if ((to[-2] == '\r' && to[-1] == '\n') ||
10010 (to[-2] == '\n' && to[-1] == '\r'))
10014 SvCUR_set(sv, to - SvPVX_const(sv));
10016 else if (to[-1] == '\r')
10019 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10024 /* if we're out of file, or a read fails, bail and reset the current
10025 line marker so we can report where the unterminated string began
10028 if (PL_madskills) {
10029 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10031 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10033 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10036 CopLINE_inc(PL_curcop);
10037 PL_bufptr = PL_bufend;
10038 if (!lex_next_chunk(0)) {
10040 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10049 /* at this point, we have successfully read the delimited string */
10051 if (!PL_encoding || UTF) {
10053 if (PL_madskills) {
10054 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10055 const int len = s - tstart;
10057 sv_catpvn(PL_thisstuff, tstart, len);
10059 PL_thisstuff = newSVpvn(tstart, len);
10060 if (!PL_thisclose && !keep_delims)
10061 PL_thisclose = newSVpvn(s,termlen);
10066 sv_catpvn(sv, s, termlen);
10071 if (PL_madskills) {
10072 char * const tstart = SvPVX(PL_linestr) + stuffstart;
10073 const int len = s - tstart - termlen;
10075 sv_catpvn(PL_thisstuff, tstart, len);
10077 PL_thisstuff = newSVpvn(tstart, len);
10078 if (!PL_thisclose && !keep_delims)
10079 PL_thisclose = newSVpvn(s - termlen,termlen);
10083 if (has_utf8 || PL_encoding)
10086 PL_multi_end = CopLINE(PL_curcop);
10088 /* if we allocated too much space, give some back */
10089 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10090 SvLEN_set(sv, SvCUR(sv) + 1);
10091 SvPV_renew(sv, SvLEN(sv));
10094 /* decide whether this is the first or second quoted string we've read
10107 takes: pointer to position in buffer
10108 returns: pointer to new position in buffer
10109 side-effects: builds ops for the constant in pl_yylval.op
10111 Read a number in any of the formats that Perl accepts:
10113 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10114 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10117 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10119 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10122 If it reads a number without a decimal point or an exponent, it will
10123 try converting the number to an integer and see if it can do so
10124 without loss of precision.
10128 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10131 register const char *s = start; /* current position in buffer */
10132 register char *d; /* destination in temp buffer */
10133 register char *e; /* end of temp buffer */
10134 NV nv; /* number read, as a double */
10135 SV *sv = NULL; /* place to put the converted number */
10136 bool floatit; /* boolean: int or float? */
10137 const char *lastub = NULL; /* position of last underbar */
10138 static char const number_too_long[] = "Number too long";
10140 PERL_ARGS_ASSERT_SCAN_NUM;
10142 /* We use the first character to decide what type of number this is */
10146 Perl_croak(aTHX_ "panic: scan_num");
10148 /* if it starts with a 0, it could be an octal number, a decimal in
10149 0.13 disguise, or a hexadecimal number, or a binary number. */
10153 u holds the "number so far"
10154 shift the power of 2 of the base
10155 (hex == 4, octal == 3, binary == 1)
10156 overflowed was the number more than we can hold?
10158 Shift is used when we add a digit. It also serves as an "are
10159 we in octal/hex/binary?" indicator to disallow hex characters
10160 when in octal mode.
10165 bool overflowed = FALSE;
10166 bool just_zero = TRUE; /* just plain 0 or binary number? */
10167 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10168 static const char* const bases[5] =
10169 { "", "binary", "", "octal", "hexadecimal" };
10170 static const char* const Bases[5] =
10171 { "", "Binary", "", "Octal", "Hexadecimal" };
10172 static const char* const maxima[5] =
10174 "0b11111111111111111111111111111111",
10178 const char *base, *Base, *max;
10180 /* check for hex */
10181 if (s[1] == 'x' || s[1] == 'X') {
10185 } else if (s[1] == 'b' || s[1] == 'B') {
10190 /* check for a decimal in disguise */
10191 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10193 /* so it must be octal */
10200 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10201 "Misplaced _ in number");
10205 base = bases[shift];
10206 Base = Bases[shift];
10207 max = maxima[shift];
10209 /* read the rest of the number */
10211 /* x is used in the overflow test,
10212 b is the digit we're adding on. */
10217 /* if we don't mention it, we're done */
10221 /* _ are ignored -- but warned about if consecutive */
10223 if (lastub && s == lastub + 1)
10224 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10225 "Misplaced _ in number");
10229 /* 8 and 9 are not octal */
10230 case '8': case '9':
10232 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10236 case '2': case '3': case '4':
10237 case '5': case '6': case '7':
10239 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10242 case '0': case '1':
10243 b = *s++ & 15; /* ASCII digit -> value of digit */
10247 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10248 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10249 /* make sure they said 0x */
10252 b = (*s++ & 7) + 9;
10254 /* Prepare to put the digit we have onto the end
10255 of the number so far. We check for overflows.
10261 x = u << shift; /* make room for the digit */
10263 if ((x >> shift) != u
10264 && !(PL_hints & HINT_NEW_BINARY)) {
10267 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
10268 "Integer overflow in %s number",
10271 u = x | b; /* add the digit to the end */
10274 n *= nvshift[shift];
10275 /* If an NV has not enough bits in its
10276 * mantissa to represent an UV this summing of
10277 * small low-order numbers is a waste of time
10278 * (because the NV cannot preserve the
10279 * low-order bits anyway): we could just
10280 * remember when did we overflow and in the
10281 * end just multiply n by the right
10289 /* if we get here, we had success: make a scalar value from
10294 /* final misplaced underbar check */
10295 if (s[-1] == '_') {
10296 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10300 if (n > 4294967295.0)
10301 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10302 "%s number > %s non-portable",
10308 if (u > 0xffffffff)
10309 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
10310 "%s number > %s non-portable",
10315 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10316 sv = new_constant(start, s - start, "integer",
10317 sv, NULL, NULL, 0);
10318 else if (PL_hints & HINT_NEW_BINARY)
10319 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
10324 handle decimal numbers.
10325 we're also sent here when we read a 0 as the first digit
10327 case '1': case '2': case '3': case '4': case '5':
10328 case '6': case '7': case '8': case '9': case '.':
10331 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10334 /* read next group of digits and _ and copy into d */
10335 while (isDIGIT(*s) || *s == '_') {
10336 /* skip underscores, checking for misplaced ones
10340 if (lastub && s == lastub + 1)
10341 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10342 "Misplaced _ in number");
10346 /* check for end of fixed-length buffer */
10348 Perl_croak(aTHX_ number_too_long);
10349 /* if we're ok, copy the character */
10354 /* final misplaced underbar check */
10355 if (lastub && s == lastub + 1) {
10356 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10359 /* read a decimal portion if there is one. avoid
10360 3..5 being interpreted as the number 3. followed
10363 if (*s == '.' && s[1] != '.') {
10368 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10369 "Misplaced _ in number");
10373 /* copy, ignoring underbars, until we run out of digits.
10375 for (; isDIGIT(*s) || *s == '_'; s++) {
10376 /* fixed length buffer check */
10378 Perl_croak(aTHX_ number_too_long);
10380 if (lastub && s == lastub + 1)
10381 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10382 "Misplaced _ in number");
10388 /* fractional part ending in underbar? */
10389 if (s[-1] == '_') {
10390 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10391 "Misplaced _ in number");
10393 if (*s == '.' && isDIGIT(s[1])) {
10394 /* oops, it's really a v-string, but without the "v" */
10400 /* read exponent part, if present */
10401 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10405 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10406 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10408 /* stray preinitial _ */
10410 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10411 "Misplaced _ in number");
10415 /* allow positive or negative exponent */
10416 if (*s == '+' || *s == '-')
10419 /* stray initial _ */
10421 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10422 "Misplaced _ in number");
10426 /* read digits of exponent */
10427 while (isDIGIT(*s) || *s == '_') {
10430 Perl_croak(aTHX_ number_too_long);
10434 if (((lastub && s == lastub + 1) ||
10435 (!isDIGIT(s[1]) && s[1] != '_')))
10436 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10437 "Misplaced _ in number");
10445 We try to do an integer conversion first if no characters
10446 indicating "float" have been found.
10451 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10453 if (flags == IS_NUMBER_IN_UV) {
10455 sv = newSViv(uv); /* Prefer IVs over UVs. */
10458 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10459 if (uv <= (UV) IV_MIN)
10460 sv = newSViv(-(IV)uv);
10467 /* terminate the string */
10469 nv = Atof(PL_tokenbuf);
10474 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
10475 const char *const key = floatit ? "float" : "integer";
10476 const STRLEN keylen = floatit ? 5 : 7;
10477 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
10478 key, keylen, sv, NULL, NULL, 0);
10482 /* if it starts with a v, it could be a v-string */
10485 sv = newSV(5); /* preallocate storage space */
10486 s = scan_vstring(s, PL_bufend, sv);
10490 /* make the op for the constant and return */
10493 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10495 lvalp->opval = NULL;
10501 S_scan_formline(pTHX_ register char *s)
10504 register char *eol;
10506 SV * const stuff = newSVpvs("");
10507 bool needargs = FALSE;
10508 bool eofmt = FALSE;
10510 char *tokenstart = s;
10511 SV* savewhite = NULL;
10513 if (PL_madskills) {
10514 savewhite = PL_thiswhite;
10519 PERL_ARGS_ASSERT_SCAN_FORMLINE;
10521 while (!needargs) {
10524 #ifdef PERL_STRICT_CR
10525 while (SPACE_OR_TAB(*t))
10528 while (SPACE_OR_TAB(*t) || *t == '\r')
10531 if (*t == '\n' || t == PL_bufend) {
10536 if (PL_in_eval && !PL_rsfp && !PL_parser->filtered) {
10537 eol = (char *) memchr(s,'\n',PL_bufend-s);
10542 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10544 for (t = s; t < eol; t++) {
10545 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10547 goto enough; /* ~~ must be first line in formline */
10549 if (*t == '@' || *t == '^')
10553 sv_catpvn(stuff, s, eol-s);
10554 #ifndef PERL_STRICT_CR
10555 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10556 char *end = SvPVX(stuff) + SvCUR(stuff);
10559 SvCUR_set(stuff, SvCUR(stuff) - 1);
10567 if (PL_rsfp || PL_parser->filtered) {
10570 if (PL_madskills) {
10572 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
10574 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
10577 PL_bufptr = PL_bufend;
10578 CopLINE_inc(PL_curcop);
10579 got_some = lex_next_chunk(0);
10580 CopLINE_dec(PL_curcop);
10583 tokenstart = PL_bufptr;
10591 if (SvCUR(stuff)) {
10594 PL_lex_state = LEX_NORMAL;
10595 start_force(PL_curforce);
10596 NEXTVAL_NEXTTOKE.ival = 0;
10600 PL_lex_state = LEX_FORMLINE;
10602 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10604 else if (PL_encoding)
10605 sv_recode_to_utf8(stuff, PL_encoding);
10607 start_force(PL_curforce);
10608 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10610 start_force(PL_curforce);
10611 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
10615 SvREFCNT_dec(stuff);
10617 PL_lex_formbrack = 0;
10621 if (PL_madskills) {
10623 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
10625 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
10626 PL_thiswhite = savewhite;
10633 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10636 const I32 oldsavestack_ix = PL_savestack_ix;
10637 CV* const outsidecv = PL_compcv;
10640 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10642 SAVEI32(PL_subline);
10643 save_item(PL_subname);
10644 SAVESPTR(PL_compcv);
10646 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
10647 CvFLAGS(PL_compcv) |= flags;
10649 PL_subline = CopLINE(PL_curcop);
10650 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10651 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
10652 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10654 return oldsavestack_ix;
10658 #pragma segment Perl_yylex
10661 S_yywarn(pTHX_ const char *const s)
10665 PERL_ARGS_ASSERT_YYWARN;
10667 PL_in_eval |= EVAL_WARNONLY;
10669 PL_in_eval &= ~EVAL_WARNONLY;
10674 Perl_yyerror(pTHX_ const char *const s)
10677 const char *where = NULL;
10678 const char *context = NULL;
10681 int yychar = PL_parser->yychar;
10683 PERL_ARGS_ASSERT_YYERROR;
10685 if (!yychar || (yychar == ';' && !PL_rsfp))
10687 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10688 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10689 PL_oldbufptr != PL_bufptr) {
10692 The code below is removed for NetWare because it abends/crashes on NetWare
10693 when the script has error such as not having the closing quotes like:
10694 if ($var eq "value)
10695 Checking of white spaces is anyway done in NetWare code.
10698 while (isSPACE(*PL_oldoldbufptr))
10701 context = PL_oldoldbufptr;
10702 contlen = PL_bufptr - PL_oldoldbufptr;
10704 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10705 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10708 The code below is removed for NetWare because it abends/crashes on NetWare
10709 when the script has error such as not having the closing quotes like:
10710 if ($var eq "value)
10711 Checking of white spaces is anyway done in NetWare code.
10714 while (isSPACE(*PL_oldbufptr))
10717 context = PL_oldbufptr;
10718 contlen = PL_bufptr - PL_oldbufptr;
10720 else if (yychar > 255)
10721 where = "next token ???";
10722 else if (yychar == -2) { /* YYEMPTY */
10723 if (PL_lex_state == LEX_NORMAL ||
10724 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10725 where = "at end of line";
10726 else if (PL_lex_inpat)
10727 where = "within pattern";
10729 where = "within string";
10732 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
10734 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10735 else if (isPRINT_LC(yychar)) {
10736 const char string = yychar;
10737 sv_catpvn(where_sv, &string, 1);
10740 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10741 where = SvPVX_const(where_sv);
10743 msg = sv_2mortal(newSVpv(s, 0));
10744 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10745 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10747 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10749 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10750 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10751 Perl_sv_catpvf(aTHX_ msg,
10752 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10753 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10756 if (PL_in_eval & EVAL_WARNONLY) {
10757 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
10761 if (PL_error_count >= 10) {
10762 if (PL_in_eval && SvCUR(ERRSV))
10763 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10764 SVfARG(ERRSV), OutCopFILE(PL_curcop));
10766 Perl_croak(aTHX_ "%s has too many errors.\n",
10767 OutCopFILE(PL_curcop));
10770 PL_in_my_stash = NULL;
10774 #pragma segment Main
10778 S_swallow_bom(pTHX_ U8 *s)
10781 const STRLEN slen = SvCUR(PL_linestr);
10783 PERL_ARGS_ASSERT_SWALLOW_BOM;
10787 if (s[1] == 0xFE) {
10788 /* UTF-16 little-endian? (or UTF-32LE?) */
10789 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10790 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
10791 #ifndef PERL_NO_UTF16_FILTER
10792 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
10794 if (PL_bufend > (char*)s) {
10795 s = add_utf16_textfilter(s, TRUE);
10798 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10803 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10804 #ifndef PERL_NO_UTF16_FILTER
10805 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10807 if (PL_bufend > (char *)s) {
10808 s = add_utf16_textfilter(s, FALSE);
10811 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10816 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10817 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10818 s += 3; /* UTF-8 */
10824 if (s[2] == 0xFE && s[3] == 0xFF) {
10825 /* UTF-32 big-endian */
10826 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
10829 else if (s[2] == 0 && s[3] != 0) {
10832 * are a good indicator of UTF-16BE. */
10833 #ifndef PERL_NO_UTF16_FILTER
10834 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10835 s = add_utf16_textfilter(s, FALSE);
10837 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
10843 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
10844 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10845 s += 4; /* UTF-8 */
10851 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10854 * are a good indicator of UTF-16LE. */
10855 #ifndef PERL_NO_UTF16_FILTER
10856 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10857 s = add_utf16_textfilter(s, TRUE);
10859 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
10867 #ifndef PERL_NO_UTF16_FILTER
10869 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10872 SV *const filter = FILTER_DATA(idx);
10873 /* We re-use this each time round, throwing the contents away before we
10875 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
10876 SV *const utf8_buffer = filter;
10877 IV status = IoPAGE(filter);
10878 const bool reverse = cBOOL(IoLINES(filter));
10881 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
10883 /* As we're automatically added, at the lowest level, and hence only called
10884 from this file, we can be sure that we're not called in block mode. Hence
10885 don't bother writing code to deal with block mode. */
10887 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
10890 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
10892 DEBUG_P(PerlIO_printf(Perl_debug_log,
10893 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10894 FPTR2DPTR(void *, S_utf16_textfilter),
10895 reverse ? 'l' : 'b', idx, maxlen, status,
10896 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10903 /* First, look in our buffer of existing UTF-8 data: */
10904 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
10908 } else if (status == 0) {
10910 IoPAGE(filter) = 0;
10911 nl = SvEND(utf8_buffer);
10914 STRLEN got = nl - SvPVX(utf8_buffer);
10915 /* Did we have anything to append? */
10917 sv_catpvn(sv, SvPVX(utf8_buffer), got);
10918 /* Everything else in this code works just fine if SVp_POK isn't
10919 set. This, however, needs it, and we need it to work, else
10920 we loop infinitely because the buffer is never consumed. */
10921 sv_chop(utf8_buffer, nl);
10925 /* OK, not a complete line there, so need to read some more UTF-16.
10926 Read an extra octect if the buffer currently has an odd number. */
10930 if (SvCUR(utf16_buffer) >= 2) {
10931 /* Location of the high octet of the last complete code point.
10932 Gosh, UTF-16 is a pain. All the benefits of variable length,
10933 *coupled* with all the benefits of partial reads and
10935 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
10936 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
10938 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
10942 /* We have the first half of a surrogate. Read more. */
10943 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
10946 status = FILTER_READ(idx + 1, utf16_buffer,
10947 160 + (SvCUR(utf16_buffer) & 1));
10948 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
10949 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
10952 IoPAGE(filter) = status;
10957 chars = SvCUR(utf16_buffer) >> 1;
10958 have = SvCUR(utf8_buffer);
10959 SvGROW(utf8_buffer, have + chars * 3 + 1);
10962 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
10963 (U8*)SvPVX_const(utf8_buffer) + have,
10964 chars * 2, &newlen);
10966 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
10967 (U8*)SvPVX_const(utf8_buffer) + have,
10968 chars * 2, &newlen);
10970 SvCUR_set(utf8_buffer, have + newlen);
10973 /* No need to keep this SV "well-formed" with a '\0' after the end, as
10974 it's private to us, and utf16_to_utf8{,reversed} take a
10975 (pointer,length) pair, rather than a NUL-terminated string. */
10976 if(SvCUR(utf16_buffer) & 1) {
10977 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
10978 SvCUR_set(utf16_buffer, 1);
10980 SvCUR_set(utf16_buffer, 0);
10983 DEBUG_P(PerlIO_printf(Perl_debug_log,
10984 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
10986 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
10987 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
10992 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
10994 SV *filter = filter_add(S_utf16_textfilter, NULL);
10996 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
10998 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
10999 sv_setpvs(filter, "");
11000 IoLINES(filter) = reversed;
11001 IoPAGE(filter) = 1; /* Not EOF */
11003 /* Sadly, we have to return a valid pointer, come what may, so we have to
11004 ignore any error return from this. */
11005 SvCUR_set(PL_linestr, 0);
11006 if (FILTER_READ(0, PL_linestr, 0)) {
11007 SvUTF8_on(PL_linestr);
11009 SvUTF8_on(PL_linestr);
11011 PL_bufend = SvEND(PL_linestr);
11012 return (U8*)SvPVX(PL_linestr);
11017 Returns a pointer to the next character after the parsed
11018 vstring, as well as updating the passed in sv.
11020 Function must be called like
11023 s = scan_vstring(s,e,sv);
11025 where s and e are the start and end of the string.
11026 The sv should already be large enough to store the vstring
11027 passed in, for performance reasons.
11032 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11035 const char *pos = s;
11036 const char *start = s;
11038 PERL_ARGS_ASSERT_SCAN_VSTRING;
11040 if (*pos == 'v') pos++; /* get past 'v' */
11041 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11043 if ( *pos != '.') {
11044 /* this may not be a v-string if followed by => */
11045 const char *next = pos;
11046 while (next < e && isSPACE(*next))
11048 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
11049 /* return string not v-string */
11050 sv_setpvn(sv,(char *)s,pos-s);
11051 return (char *)pos;
11055 if (!isALPHA(*pos)) {
11056 U8 tmpbuf[UTF8_MAXBYTES+1];
11059 s++; /* get past 'v' */
11064 /* this is atoi() that tolerates underscores */
11067 const char *end = pos;
11069 while (--end >= s) {
11071 const UV orev = rev;
11072 rev += (*end - '0') * mult;
11075 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11076 "Integer overflow in decimal number");
11080 if (rev > 0x7FFFFFFF)
11081 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11083 /* Append native character for the rev point */
11084 tmpend = uvchr_to_utf8(tmpbuf, rev);
11085 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11086 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11088 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
11094 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
11098 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11105 Perl_keyword_plugin_standard(pTHX_
11106 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11108 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11109 PERL_UNUSED_CONTEXT;
11110 PERL_UNUSED_ARG(keyword_ptr);
11111 PERL_UNUSED_ARG(keyword_len);
11112 PERL_UNUSED_ARG(op_ptr);
11113 return KEYWORD_PLUGIN_DECLINE;
11116 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11118 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11120 SAVEI32(PL_lex_brackets);
11121 if (PL_lex_brackets > 100)
11122 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11123 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11124 SAVEI32(PL_lex_allbrackets);
11125 PL_lex_allbrackets = 0;
11126 SAVEI8(PL_lex_fakeeof);
11127 PL_lex_fakeeof = (U8)fakeeof;
11128 if(yyparse(gramtype) && !PL_parser->error_count)
11129 qerror(Perl_mess(aTHX_ "Parse error"));
11132 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11134 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11138 SAVEVPTR(PL_eval_root);
11139 PL_eval_root = NULL;
11140 parse_recdescent(gramtype, fakeeof);
11146 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11148 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11151 if (flags & ~PARSE_OPTIONAL)
11152 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11153 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11154 if (!exprop && !(flags & PARSE_OPTIONAL)) {
11155 if (!PL_parser->error_count)
11156 qerror(Perl_mess(aTHX_ "Parse error"));
11157 exprop = newOP(OP_NULL, 0);
11163 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11165 Parse a Perl arithmetic expression. This may contain operators of precedence
11166 down to the bit shift operators. The expression must be followed (and thus
11167 terminated) either by a comparison or lower-precedence operator or by
11168 something that would normally terminate an expression such as semicolon.
11169 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11170 otherwise it is mandatory. It is up to the caller to ensure that the
11171 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11172 the source of the code to be parsed and the lexical context for the
11175 The op tree representing the expression is returned. If an optional
11176 expression is absent, a null pointer is returned, otherwise the pointer
11179 If an error occurs in parsing or compilation, in most cases a valid op
11180 tree is returned anyway. The error is reflected in the parser state,
11181 normally resulting in a single exception at the top level of parsing
11182 which covers all the compilation errors that occurred. Some compilation
11183 errors, however, will throw an exception immediately.
11189 Perl_parse_arithexpr(pTHX_ U32 flags)
11191 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11195 =for apidoc Amx|OP *|parse_termexpr|U32 flags
11197 Parse a Perl term expression. This may contain operators of precedence
11198 down to the assignment operators. The expression must be followed (and thus
11199 terminated) either by a comma or lower-precedence operator or by
11200 something that would normally terminate an expression such as semicolon.
11201 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11202 otherwise it is mandatory. It is up to the caller to ensure that the
11203 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11204 the source of the code to be parsed and the lexical context for the
11207 The op tree representing the expression is returned. If an optional
11208 expression is absent, a null pointer is returned, otherwise the pointer
11211 If an error occurs in parsing or compilation, in most cases a valid op
11212 tree is returned anyway. The error is reflected in the parser state,
11213 normally resulting in a single exception at the top level of parsing
11214 which covers all the compilation errors that occurred. Some compilation
11215 errors, however, will throw an exception immediately.
11221 Perl_parse_termexpr(pTHX_ U32 flags)
11223 return parse_expr(LEX_FAKEEOF_COMMA, flags);
11227 =for apidoc Amx|OP *|parse_listexpr|U32 flags
11229 Parse a Perl list expression. This may contain operators of precedence
11230 down to the comma operator. The expression must be followed (and thus
11231 terminated) either by a low-precedence logic operator such as C<or> or by
11232 something that would normally terminate an expression such as semicolon.
11233 If I<flags> includes C<PARSE_OPTIONAL> then the expression is optional,
11234 otherwise it is mandatory. It is up to the caller to ensure that the
11235 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
11236 the source of the code to be parsed and the lexical context for the
11239 The op tree representing the expression is returned. If an optional
11240 expression is absent, a null pointer is returned, otherwise the pointer
11243 If an error occurs in parsing or compilation, in most cases a valid op
11244 tree is returned anyway. The error is reflected in the parser state,
11245 normally resulting in a single exception at the top level of parsing
11246 which covers all the compilation errors that occurred. Some compilation
11247 errors, however, will throw an exception immediately.
11253 Perl_parse_listexpr(pTHX_ U32 flags)
11255 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
11259 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
11261 Parse a single complete Perl expression. This allows the full
11262 expression grammar, including the lowest-precedence operators such
11263 as C<or>. The expression must be followed (and thus terminated) by a
11264 token that an expression would normally be terminated by: end-of-file,
11265 closing bracketing punctuation, semicolon, or one of the keywords that
11266 signals a postfix expression-statement modifier. If I<flags> includes
11267 C<PARSE_OPTIONAL> then the expression is optional, otherwise it is
11268 mandatory. It is up to the caller to ensure that the dynamic parser
11269 state (L</PL_parser> et al) is correctly set to reflect the source of
11270 the code to be parsed and the lexical context for the expression.
11272 The op tree representing the expression is returned. If an optional
11273 expression is absent, a null pointer is returned, otherwise the pointer
11276 If an error occurs in parsing or compilation, in most cases a valid op
11277 tree is returned anyway. The error is reflected in the parser state,
11278 normally resulting in a single exception at the top level of parsing
11279 which covers all the compilation errors that occurred. Some compilation
11280 errors, however, will throw an exception immediately.
11286 Perl_parse_fullexpr(pTHX_ U32 flags)
11288 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
11292 =for apidoc Amx|OP *|parse_block|U32 flags
11294 Parse a single complete Perl code block. This consists of an opening
11295 brace, a sequence of statements, and a closing brace. The block
11296 constitutes a lexical scope, so C<my> variables and various compile-time
11297 effects can be contained within it. It is up to the caller to ensure
11298 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11299 reflect the source of the code to be parsed and the lexical context for
11302 The op tree representing the code block is returned. This is always a
11303 real op, never a null pointer. It will normally be a C<lineseq> list,
11304 including C<nextstate> or equivalent ops. No ops to construct any kind
11305 of runtime scope are included by virtue of it being a block.
11307 If an error occurs in parsing or compilation, in most cases a valid op
11308 tree (most likely null) is returned anyway. The error is reflected in
11309 the parser state, normally resulting in a single exception at the top
11310 level of parsing which covers all the compilation errors that occurred.
11311 Some compilation errors, however, will throw an exception immediately.
11313 The I<flags> parameter is reserved for future use, and must always
11320 Perl_parse_block(pTHX_ U32 flags)
11323 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
11324 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
11328 =for apidoc Amx|OP *|parse_barestmt|U32 flags
11330 Parse a single unadorned Perl statement. This may be a normal imperative
11331 statement or a declaration that has compile-time effect. It does not
11332 include any label or other affixture. It is up to the caller to ensure
11333 that the dynamic parser state (L</PL_parser> et al) is correctly set to
11334 reflect the source of the code to be parsed and the lexical context for
11337 The op tree representing the statement is returned. This may be a
11338 null pointer if the statement is null, for example if it was actually
11339 a subroutine definition (which has compile-time side effects). If not
11340 null, it will be ops directly implementing the statement, suitable to
11341 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
11342 equivalent op (except for those embedded in a scope contained entirely
11343 within the statement).
11345 If an error occurs in parsing or compilation, in most cases a valid op
11346 tree (most likely null) is returned anyway. The error is reflected in
11347 the parser state, normally resulting in a single exception at the top
11348 level of parsing which covers all the compilation errors that occurred.
11349 Some compilation errors, however, will throw an exception immediately.
11351 The I<flags> parameter is reserved for future use, and must always
11358 Perl_parse_barestmt(pTHX_ U32 flags)
11361 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
11362 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
11366 =for apidoc Amx|SV *|parse_label|U32 flags
11368 Parse a single label, possibly optional, of the type that may prefix a
11369 Perl statement. It is up to the caller to ensure that the dynamic parser
11370 state (L</PL_parser> et al) is correctly set to reflect the source of
11371 the code to be parsed. If I<flags> includes C<PARSE_OPTIONAL> then the
11372 label is optional, otherwise it is mandatory.
11374 The name of the label is returned in the form of a fresh scalar. If an
11375 optional label is absent, a null pointer is returned.
11377 If an error occurs in parsing, which can only occur if the label is
11378 mandatory, a valid label is returned anyway. The error is reflected in
11379 the parser state, normally resulting in a single exception at the top
11380 level of parsing which covers all the compilation errors that occurred.
11386 Perl_parse_label(pTHX_ U32 flags)
11388 if (flags & ~PARSE_OPTIONAL)
11389 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
11390 if (PL_lex_state == LEX_KNOWNEXT) {
11391 PL_parser->yychar = yylex();
11392 if (PL_parser->yychar == LABEL) {
11393 char *lpv = pl_yylval.pval;
11394 STRLEN llen = strlen(lpv);
11396 PL_parser->yychar = YYEMPTY;
11397 lsv = newSV_type(SVt_PV);
11398 SvPV_set(lsv, lpv);
11399 SvCUR_set(lsv, llen);
11400 SvLEN_set(lsv, llen+1);
11410 STRLEN wlen, bufptr_pos;
11414 if (!isIDFIRST_A(c))
11418 } while(isWORDCHAR_A(c));
11420 if (word_takes_any_delimeter(s, wlen))
11422 bufptr_pos = s - SvPVX(PL_linestr);
11424 lex_read_space(LEX_KEEP_PREVIOUS);
11426 s = SvPVX(PL_linestr) + bufptr_pos;
11427 if (t[0] == ':' && t[1] != ':') {
11428 PL_oldoldbufptr = PL_oldbufptr;
11431 return newSVpvn(s, wlen);
11435 if (flags & PARSE_OPTIONAL) {
11438 qerror(Perl_mess(aTHX_ "Parse error"));
11439 return newSVpvs("x");
11446 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
11448 Parse a single complete Perl statement. This may be a normal imperative
11449 statement or a declaration that has compile-time effect, and may include
11450 optional labels. It is up to the caller to ensure that the dynamic
11451 parser state (L</PL_parser> et al) is correctly set to reflect the source
11452 of the code to be parsed and the lexical context for the statement.
11454 The op tree representing the statement is returned. This may be a
11455 null pointer if the statement is null, for example if it was actually
11456 a subroutine definition (which has compile-time side effects). If not
11457 null, it will be the result of a L</newSTATEOP> call, normally including
11458 a C<nextstate> or equivalent op.
11460 If an error occurs in parsing or compilation, in most cases a valid op
11461 tree (most likely null) is returned anyway. The error is reflected in
11462 the parser state, normally resulting in a single exception at the top
11463 level of parsing which covers all the compilation errors that occurred.
11464 Some compilation errors, however, will throw an exception immediately.
11466 The I<flags> parameter is reserved for future use, and must always
11473 Perl_parse_fullstmt(pTHX_ U32 flags)
11476 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
11477 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
11481 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
11483 Parse a sequence of zero or more Perl statements. These may be normal
11484 imperative statements, including optional labels, or declarations
11485 that have compile-time effect, or any mixture thereof. The statement
11486 sequence ends when a closing brace or end-of-file is encountered in a
11487 place where a new statement could have validly started. It is up to
11488 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
11489 is correctly set to reflect the source of the code to be parsed and the
11490 lexical context for the statements.
11492 The op tree representing the statement sequence is returned. This may
11493 be a null pointer if the statements were all null, for example if there
11494 were no statements or if there were only subroutine definitions (which
11495 have compile-time side effects). If not null, it will be a C<lineseq>
11496 list, normally including C<nextstate> or equivalent ops.
11498 If an error occurs in parsing or compilation, in most cases a valid op
11499 tree is returned anyway. The error is reflected in the parser state,
11500 normally resulting in a single exception at the top level of parsing
11501 which covers all the compilation errors that occurred. Some compilation
11502 errors, however, will throw an exception immediately.
11504 The I<flags> parameter is reserved for future use, and must always
11511 Perl_parse_stmtseq(pTHX_ U32 flags)
11516 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
11517 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
11518 c = lex_peek_unichar(0);
11519 if (c != -1 && c != /*{*/'}')
11520 qerror(Perl_mess(aTHX_ "Parse error"));
11525 Perl_munge_qwlist_to_paren_list(pTHX_ OP *qwlist)
11527 PERL_ARGS_ASSERT_MUNGE_QWLIST_TO_PAREN_LIST;
11528 deprecate("qw(...) as parentheses");
11529 force_next((4<<24)|')');
11530 if (qwlist->op_type == OP_STUB) {
11534 start_force(PL_curforce);
11535 NEXTVAL_NEXTTOKE.opval = qwlist;
11538 force_next((2<<24)|'(');
11543 * c-indentation-style: bsd
11544 * c-basic-offset: 4
11545 * indent-tabs-mode: t
11548 * ex: set ts=8 sts=4 sw=4 noet: