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
26 This is the lower layer of the Perl parser, managing characters and tokens.
28 =for apidoc AmU|yy_parser *|PL_parser
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress. The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
39 #define PERL_IN_TOKE_C
41 #include "dquote_inline.h"
42 #include "invlist_inline.h"
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_dojoin (PL_parser->lex_dojoin)
57 #define PL_lex_formbrack (PL_parser->lex_formbrack)
58 #define PL_lex_inpat (PL_parser->lex_inpat)
59 #define PL_lex_inwhat (PL_parser->lex_inwhat)
60 #define PL_lex_op (PL_parser->lex_op)
61 #define PL_lex_repl (PL_parser->lex_repl)
62 #define PL_lex_starts (PL_parser->lex_starts)
63 #define PL_lex_stuff (PL_parser->lex_stuff)
64 #define PL_multi_start (PL_parser->multi_start)
65 #define PL_multi_open (PL_parser->multi_open)
66 #define PL_multi_close (PL_parser->multi_close)
67 #define PL_preambled (PL_parser->preambled)
68 #define PL_linestr (PL_parser->linestr)
69 #define PL_expect (PL_parser->expect)
70 #define PL_copline (PL_parser->copline)
71 #define PL_bufptr (PL_parser->bufptr)
72 #define PL_oldbufptr (PL_parser->oldbufptr)
73 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
74 #define PL_linestart (PL_parser->linestart)
75 #define PL_bufend (PL_parser->bufend)
76 #define PL_last_uni (PL_parser->last_uni)
77 #define PL_last_lop (PL_parser->last_lop)
78 #define PL_last_lop_op (PL_parser->last_lop_op)
79 #define PL_lex_state (PL_parser->lex_state)
80 #define PL_rsfp (PL_parser->rsfp)
81 #define PL_rsfp_filters (PL_parser->rsfp_filters)
82 #define PL_in_my (PL_parser->in_my)
83 #define PL_in_my_stash (PL_parser->in_my_stash)
84 #define PL_tokenbuf (PL_parser->tokenbuf)
85 #define PL_multi_end (PL_parser->multi_end)
86 #define PL_error_count (PL_parser->error_count)
88 # define PL_nexttoke (PL_parser->nexttoke)
89 # define PL_nexttype (PL_parser->nexttype)
90 # define PL_nextval (PL_parser->nextval)
93 #define SvEVALED(sv) \
94 (SvTYPE(sv) >= SVt_PVNV \
95 && ((XPVIV*)SvANY(sv))->xiv_u.xivu_eval_seen)
97 static const char* const ident_too_long = "Identifier too long";
99 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
101 #define XENUMMASK 0x3f
102 #define XFAKEEOF 0x40
103 #define XFAKEBRACK 0x80
105 #ifdef USE_UTF8_SCRIPTS
106 # define UTF cBOOL(!IN_BYTES)
108 # define UTF cBOOL((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
111 /* The maximum number of characters preceding the unrecognized one to display */
112 #define UNRECOGNIZED_PRECEDE_COUNT 10
114 /* In variables named $^X, these are the legal values for X.
115 * 1999-02-27 mjd-perl-patch@plover.com */
116 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
118 #define SPACE_OR_TAB(c) isBLANK_A(c)
120 #define HEXFP_PEEK(s) \
122 (isXDIGIT(s[1]) || isALPHA_FOLD_EQ(s[1], 'p'))) || \
123 isALPHA_FOLD_EQ(s[0], 'p'))
125 /* LEX_* are values for PL_lex_state, the state of the lexer.
126 * They are arranged oddly so that the guard on the switch statement
127 * can get by with a single comparison (if the compiler is smart enough).
129 * These values refer to the various states within a sublex parse,
130 * i.e. within a double quotish string
133 /* #define LEX_NOTPARSING 11 is done in perl.h. */
135 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
136 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
137 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
138 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
139 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
141 /* at end of code, eg "$x" followed by: */
142 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
143 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
145 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
146 string or after \E, $foo, etc */
147 #define LEX_INTERPCONST 2 /* NOT USED */
148 #define LEX_FORMLINE 1 /* expecting a format line */
152 static const char* const lex_state_names[] = {
167 #include "keywords.h"
169 /* CLINE is a macro that ensures PL_copline has a sane value */
171 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
174 * Convenience functions to return different tokens and prime the
175 * lexer for the next token. They all take an argument.
177 * TOKEN : generic token (used for '(', DOLSHARP, etc)
178 * OPERATOR : generic operator
179 * AOPERATOR : assignment operator
180 * PREBLOCK : beginning the block after an if, while, foreach, ...
181 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
182 * PREREF : *EXPR where EXPR is not a simple identifier
183 * TERM : expression term
184 * POSTDEREF : postfix dereference (->$* ->@[...] etc.)
185 * LOOPX : loop exiting command (goto, last, dump, etc)
186 * FTST : file test operator
187 * FUN0 : zero-argument function
188 * FUN0OP : zero-argument function, with its op created in this file
189 * FUN1 : not used, except for not, which isn't a UNIOP
190 * BOop : bitwise or or xor
192 * BCop : bitwise complement
193 * SHop : shift operator
194 * PWop : power operator
195 * PMop : pattern-matching operator
196 * Aop : addition-level operator
197 * AopNOASSIGN : addition-level operator that is never part of .=
198 * Mop : multiplication-level operator
199 * Eop : equality-testing operator
200 * Rop : relational operator <= != gt
202 * Also see LOP and lop() below.
205 #ifdef DEBUGGING /* Serve -DT. */
206 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
208 # define REPORT(retval) (retval)
211 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
212 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
213 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, retval))
214 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
215 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
216 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
217 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
218 #define POSTDEREF(f) return (PL_bufptr = s, S_postderef(aTHX_ REPORT(f),s[1]))
219 #define LOOPX(f) return (PL_bufptr = force_word(s,BAREWORD,TRUE,FALSE), \
221 PL_expect = PL_nexttoke ? XOPERATOR : XTERM, \
223 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
224 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
225 #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
226 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
227 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITOROP))
228 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)BITANDOP))
229 #define BCop(f) return pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr = s, \
231 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)SHIFTOP))
232 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)POWOP))
233 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
234 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)ADDOP))
235 #define AopNOASSIGN(f) return (pl_yylval.ival=f, PL_bufptr=s, REPORT((int)ADDOP))
236 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, (int)MULOP))
237 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
238 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
240 /* This bit of chicanery makes a unary function followed by
241 * a parenthesis into a function with one argument, highest precedence.
242 * The UNIDOR macro is for unary functions that can be followed by the //
243 * operator (such as C<shift // 0>).
245 #define UNI3(f,x,have_x) { \
246 pl_yylval.ival = f; \
247 if (have_x) PL_expect = x; \
249 PL_last_uni = PL_oldbufptr; \
250 PL_last_lop_op = (f) < 0 ? -(f) : (f); \
252 return REPORT( (int)FUNC1 ); \
254 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
256 #define UNI(f) UNI3(f,XTERM,1)
257 #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
258 #define UNIPROTO(f,optional) { \
259 if (optional) PL_last_uni = PL_oldbufptr; \
263 #define UNIBRACK(f) UNI3(f,0,0)
265 /* grandfather return to old style */
268 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
269 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
270 pl_yylval.ival = (f); \
276 #define COPLINE_INC_WITH_HERELINES \
278 CopLINE_inc(PL_curcop); \
279 if (PL_parser->herelines) \
280 CopLINE(PL_curcop) += PL_parser->herelines, \
281 PL_parser->herelines = 0; \
283 /* Called after scan_str to update CopLINE(PL_curcop), but only when there
284 * is no sublex_push to follow. */
285 #define COPLINE_SET_FROM_MULTI_END \
287 CopLINE_set(PL_curcop, PL_multi_end); \
288 if (PL_multi_end != PL_multi_start) \
289 PL_parser->herelines = 0; \
295 /* how to interpret the pl_yylval associated with the token */
299 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
304 static struct debug_tokens {
306 enum token_type type;
308 } const debug_tokens[] =
310 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
311 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
312 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
313 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
314 { ANON_SIGSUB, TOKENTYPE_IVAL, "ANON_SIGSUB" },
315 { ARROW, TOKENTYPE_NONE, "ARROW" },
316 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
317 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
318 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
319 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
320 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
321 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
322 { DO, TOKENTYPE_NONE, "DO" },
323 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
324 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
325 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
326 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
327 { ELSE, TOKENTYPE_NONE, "ELSE" },
328 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
329 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
330 { FOR, TOKENTYPE_IVAL, "FOR" },
331 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
332 { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
333 { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
334 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
335 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
336 { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
337 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
338 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
339 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
340 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
341 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
342 { IF, TOKENTYPE_IVAL, "IF" },
343 { LABEL, TOKENTYPE_PVAL, "LABEL" },
344 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
345 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
346 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
347 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
348 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
349 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
350 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
351 { MY, TOKENTYPE_IVAL, "MY" },
352 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
353 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
354 { OROP, TOKENTYPE_IVAL, "OROP" },
355 { OROR, TOKENTYPE_NONE, "OROR" },
356 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
357 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
358 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
359 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
360 { POSTJOIN, TOKENTYPE_NONE, "POSTJOIN" },
361 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
362 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
363 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
364 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
365 { PREINC, TOKENTYPE_NONE, "PREINC" },
366 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
367 { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
368 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
369 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
370 { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
371 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
372 { SIGSUB, TOKENTYPE_NONE, "SIGSUB" },
373 { SUB, TOKENTYPE_NONE, "SUB" },
374 { THING, TOKENTYPE_OPVAL, "THING" },
375 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
376 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
377 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
378 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
379 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
380 { USE, TOKENTYPE_IVAL, "USE" },
381 { WHEN, TOKENTYPE_IVAL, "WHEN" },
382 { WHILE, TOKENTYPE_IVAL, "WHILE" },
383 { BAREWORD, TOKENTYPE_OPVAL, "BAREWORD" },
384 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
385 { 0, TOKENTYPE_NONE, NULL }
388 /* dump the returned token in rv, plus any optional arg in pl_yylval */
391 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
393 PERL_ARGS_ASSERT_TOKEREPORT;
396 const char *name = NULL;
397 enum token_type type = TOKENTYPE_NONE;
398 const struct debug_tokens *p;
399 SV* const report = newSVpvs("<== ");
401 for (p = debug_tokens; p->token; p++) {
402 if (p->token == (int)rv) {
409 Perl_sv_catpv(aTHX_ report, name);
410 else if (isGRAPH(rv))
412 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
414 sv_catpvs(report, " (pending identifier)");
417 sv_catpvs(report, "EOF");
419 Perl_sv_catpvf(aTHX_ report, "?? %" IVdf, (IV)rv);
424 Perl_sv_catpvf(aTHX_ report, "(ival=%" IVdf ")", (IV)lvalp->ival);
426 case TOKENTYPE_OPNUM:
427 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
428 PL_op_name[lvalp->ival]);
431 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
433 case TOKENTYPE_OPVAL:
435 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
436 PL_op_name[lvalp->opval->op_type]);
437 if (lvalp->opval->op_type == OP_CONST) {
438 Perl_sv_catpvf(aTHX_ report, " %s",
439 SvPEEK(cSVOPx_sv(lvalp->opval)));
444 sv_catpvs(report, "(opval=null)");
447 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
453 /* print the buffer with suitable escapes */
456 S_printbuf(pTHX_ const char *const fmt, const char *const s)
458 SV* const tmp = newSVpvs("");
460 PERL_ARGS_ASSERT_PRINTBUF;
462 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); /* fmt checked by caller */
463 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
464 GCC_DIAG_RESTORE_STMT;
473 * This subroutine looks for an '=' next to the operator that has just been
474 * parsed and turns it into an ASSIGNOP if it finds one.
478 S_ao(pTHX_ int toketype)
480 if (*PL_bufptr == '=') {
482 if (toketype == ANDAND)
483 pl_yylval.ival = OP_ANDASSIGN;
484 else if (toketype == OROR)
485 pl_yylval.ival = OP_ORASSIGN;
486 else if (toketype == DORDOR)
487 pl_yylval.ival = OP_DORASSIGN;
490 return REPORT(toketype);
495 * When Perl expects an operator and finds something else, no_op
496 * prints the warning. It always prints "<something> found where
497 * operator expected. It prints "Missing semicolon on previous line?"
498 * if the surprise occurs at the start of the line. "do you need to
499 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
500 * where the compiler doesn't know if foo is a method call or a function.
501 * It prints "Missing operator before end of line" if there's nothing
502 * after the missing operator, or "... before <...>" if there is something
503 * after the missing operator.
505 * PL_bufptr is expected to point to the start of the thing that was found,
506 * and s after the next token or partial token.
510 S_no_op(pTHX_ const char *const what, char *s)
512 char * const oldbp = PL_bufptr;
513 const bool is_first = (PL_oldbufptr == PL_linestart);
515 PERL_ARGS_ASSERT_NO_OP;
521 yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
522 if (ckWARN_d(WARN_SYNTAX)) {
524 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
525 "\t(Missing semicolon on previous line?)\n");
526 else if (PL_oldoldbufptr && isIDFIRST_lazy_if_safe(PL_oldoldbufptr,
531 for (t = PL_oldoldbufptr;
532 (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF) || *t == ':');
533 t += UTF ? UTF8SKIP(t) : 1)
537 if (t < PL_bufptr && isSPACE(*t))
538 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
539 "\t(Do you need to predeclare %" UTF8f "?)\n",
540 UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
544 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
545 "\t(Missing operator before %" UTF8f "?)\n",
546 UTF8fARG(UTF, s - oldbp, oldbp));
554 * Complain about missing quote/regexp/heredoc terminator.
555 * If it's called with NULL then it cauterizes the line buffer.
556 * If we're in a delimited string and the delimiter is a control
557 * character, it's reformatted into a two-char sequence like ^C.
562 S_missingterm(pTHX_ char *s, STRLEN len)
564 char tmpbuf[UTF8_MAXBYTES + 1];
569 char * const nl = (char *) my_memrchr(s, '\n', len);
576 else if (PL_multi_close < 32) {
578 tmpbuf[1] = (char)toCTRL(PL_multi_close);
584 if (LIKELY(PL_multi_close < 256)) {
585 *tmpbuf = (char)PL_multi_close;
590 char *end = (char *)uvchr_to_utf8((U8 *)tmpbuf, PL_multi_close);
597 q = memchr(s, '"', len) ? '\'' : '"';
598 sv = sv_2mortal(newSVpvn(s, len));
601 Perl_croak(aTHX_ "Can't find string terminator %c%" SVf "%c"
602 " anywhere before EOF", q, SVfARG(sv), q);
608 * Check whether the named feature is enabled.
611 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
613 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
615 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
617 assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
619 if (namelen > MAX_FEATURE_LEN)
621 memcpy(&he_name[8], name, namelen);
623 return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
624 REFCOUNTED_HE_EXISTS));
628 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
629 * utf16-to-utf8-reversed.
632 #ifdef PERL_CR_FILTER
636 const char *s = SvPVX_const(sv);
637 const char * const e = s + SvCUR(sv);
639 PERL_ARGS_ASSERT_STRIP_RETURN;
641 /* outer loop optimized to do nothing if there are no CR-LFs */
643 if (*s++ == '\r' && *s == '\n') {
644 /* hit a CR-LF, need to copy the rest */
648 if (*s == '\r' && s[1] == '\n')
659 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
661 const I32 count = FILTER_READ(idx+1, sv, maxlen);
662 if (count > 0 && !maxlen)
669 =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
671 Creates and initialises a new lexer/parser state object, supplying
672 a context in which to lex and parse from a new source of Perl code.
673 A pointer to the new state object is placed in L</PL_parser>. An entry
674 is made on the save stack so that upon unwinding, the new state object
675 will be destroyed and the former value of L</PL_parser> will be restored.
676 Nothing else need be done to clean up the parsing context.
678 The code to be parsed comes from C<line> and C<rsfp>. C<line>, if
679 non-null, provides a string (in SV form) containing code to be parsed.
680 A copy of the string is made, so subsequent modification of C<line>
681 does not affect parsing. C<rsfp>, if non-null, provides an input stream
682 from which code will be read to be parsed. If both are non-null, the
683 code in C<line> comes first and must consist of complete lines of input,
684 and C<rsfp> supplies the remainder of the source.
686 The C<flags> parameter is reserved for future use. Currently it is only
687 used by perl internally, so extensions should always pass zero.
692 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
693 can share filters with the current parser.
694 LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
695 caller, hence isn't owned by the parser, so shouldn't be closed on parser
696 destruction. This is used to handle the case of defaulting to reading the
697 script from the standard input because no filename was given on the command
698 line (without getting confused by situation where STDIN has been closed, so
699 the script handle is opened on fd 0) */
702 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
704 const char *s = NULL;
705 yy_parser *parser, *oparser;
707 if (flags && flags & ~LEX_START_FLAGS)
708 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
710 /* create and initialise a parser */
712 Newxz(parser, 1, yy_parser);
713 parser->old_parser = oparser = PL_parser;
716 parser->stack = NULL;
717 parser->stack_max1 = NULL;
720 /* on scope exit, free this parser and restore any outer one */
722 parser->saved_curcop = PL_curcop;
724 /* initialise lexer state */
726 parser->nexttoke = 0;
727 parser->error_count = oparser ? oparser->error_count : 0;
728 parser->copline = parser->preambling = NOLINE;
729 parser->lex_state = LEX_NORMAL;
730 parser->expect = XSTATE;
732 parser->recheck_utf8_validity = FALSE;
733 parser->rsfp_filters =
734 !(flags & LEX_START_SAME_FILTER) || !oparser
736 : MUTABLE_AV(SvREFCNT_inc(
737 oparser->rsfp_filters
738 ? oparser->rsfp_filters
739 : (oparser->rsfp_filters = newAV())
742 Newx(parser->lex_brackstack, 120, char);
743 Newx(parser->lex_casestack, 12, char);
744 *parser->lex_casestack = '\0';
745 Newxz(parser->lex_shared, 1, LEXSHARED);
749 const U8* first_bad_char_loc;
751 s = SvPV_const(line, len);
754 && UNLIKELY(! is_utf8_string_loc((U8 *) s,
756 &first_bad_char_loc)))
758 _force_out_malformed_utf8_message(first_bad_char_loc,
759 (U8 *) s + SvCUR(line),
761 1 /* 1 means die */ );
762 NOT_REACHED; /* NOTREACHED */
765 parser->linestr = flags & LEX_START_COPIED
766 ? SvREFCNT_inc_simple_NN(line)
767 : newSVpvn_flags(s, len, SvUTF8(line));
769 sv_catpvs(parser->linestr, "\n;");
771 parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
774 parser->oldoldbufptr =
777 parser->linestart = SvPVX(parser->linestr);
778 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
779 parser->last_lop = parser->last_uni = NULL;
781 STATIC_ASSERT_STMT(FITS_IN_8_BITS(LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
782 |LEX_DONT_CLOSE_RSFP));
783 parser->lex_flags = (U8) (flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
784 |LEX_DONT_CLOSE_RSFP));
786 parser->in_pod = parser->filtered = 0;
790 /* delete a parser object */
793 Perl_parser_free(pTHX_ const yy_parser *parser)
795 PERL_ARGS_ASSERT_PARSER_FREE;
797 PL_curcop = parser->saved_curcop;
798 SvREFCNT_dec(parser->linestr);
800 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
801 PerlIO_clearerr(parser->rsfp);
802 else if (parser->rsfp && (!parser->old_parser
803 || (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
804 PerlIO_close(parser->rsfp);
805 SvREFCNT_dec(parser->rsfp_filters);
806 SvREFCNT_dec(parser->lex_stuff);
807 SvREFCNT_dec(parser->lex_sub_repl);
809 Safefree(parser->lex_brackstack);
810 Safefree(parser->lex_casestack);
811 Safefree(parser->lex_shared);
812 PL_parser = parser->old_parser;
817 Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
819 I32 nexttoke = parser->nexttoke;
820 PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
822 if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
823 && parser->nextval[nexttoke].opval
824 && parser->nextval[nexttoke].opval->op_slabbed
825 && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
826 op_free(parser->nextval[nexttoke].opval);
827 parser->nextval[nexttoke].opval = NULL;
834 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
836 Buffer scalar containing the chunk currently under consideration of the
837 text currently being lexed. This is always a plain string scalar (for
838 which C<SvPOK> is true). It is not intended to be used as a scalar by
839 normal scalar means; instead refer to the buffer directly by the pointer
840 variables described below.
842 The lexer maintains various C<char*> pointers to things in the
843 C<PL_parser-E<gt>linestr> buffer. If C<PL_parser-E<gt>linestr> is ever
844 reallocated, all of these pointers must be updated. Don't attempt to
845 do this manually, but rather use L</lex_grow_linestr> if you need to
846 reallocate the buffer.
848 The content of the text chunk in the buffer is commonly exactly one
849 complete line of input, up to and including a newline terminator,
850 but there are situations where it is otherwise. The octets of the
851 buffer may be intended to be interpreted as either UTF-8 or Latin-1.
852 The function L</lex_bufutf8> tells you which. Do not use the C<SvUTF8>
853 flag on this scalar, which may disagree with it.
855 For direct examination of the buffer, the variable
856 L</PL_parser-E<gt>bufend> points to the end of the buffer. The current
857 lexing position is pointed to by L</PL_parser-E<gt>bufptr>. Direct use
858 of these pointers is usually preferable to examination of the scalar
859 through normal scalar means.
861 =for apidoc AmxU|char *|PL_parser-E<gt>bufend
863 Direct pointer to the end of the chunk of text currently being lexed, the
864 end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
865 + SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
866 always located at the end of the buffer, and does not count as part of
867 the buffer's contents.
869 =for apidoc AmxU|char *|PL_parser-E<gt>bufptr
871 Points to the current position of lexing inside the lexer buffer.
872 Characters around this point may be freely examined, within
873 the range delimited by C<SvPVX(L</PL_parser-E<gt>linestr>)> and
874 L</PL_parser-E<gt>bufend>. The octets of the buffer may be intended to be
875 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
877 Lexing code (whether in the Perl core or not) moves this pointer past
878 the characters that it consumes. It is also expected to perform some
879 bookkeeping whenever a newline character is consumed. This movement
880 can be more conveniently performed by the function L</lex_read_to>,
881 which handles newlines appropriately.
883 Interpretation of the buffer's octets can be abstracted out by
884 using the slightly higher-level functions L</lex_peek_unichar> and
885 L</lex_read_unichar>.
887 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
889 Points to the start of the current line inside the lexer buffer.
890 This is useful for indicating at which column an error occurred, and
891 not much else. This must be updated by any lexing code that consumes
892 a newline; the function L</lex_read_to> handles this detail.
898 =for apidoc Amx|bool|lex_bufutf8
900 Indicates whether the octets in the lexer buffer
901 (L</PL_parser-E<gt>linestr>) should be interpreted as the UTF-8 encoding
902 of Unicode characters. If not, they should be interpreted as Latin-1
903 characters. This is analogous to the C<SvUTF8> flag for scalars.
905 In UTF-8 mode, it is not guaranteed that the lexer buffer actually
906 contains valid UTF-8. Lexing code must be robust in the face of invalid
909 The actual C<SvUTF8> flag of the L</PL_parser-E<gt>linestr> scalar
910 is significant, but not the whole story regarding the input character
911 encoding. Normally, when a file is being read, the scalar contains octets
912 and its C<SvUTF8> flag is off, but the octets should be interpreted as
913 UTF-8 if the C<use utf8> pragma is in effect. During a string eval,
914 however, the scalar may have the C<SvUTF8> flag on, and in this case its
915 octets should be interpreted as UTF-8 unless the C<use bytes> pragma
916 is in effect. This logic may change in the future; use this function
917 instead of implementing the logic yourself.
923 Perl_lex_bufutf8(pTHX)
929 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
931 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
932 at least C<len> octets (including terminating C<NUL>). Returns a
933 pointer to the reallocated buffer. This is necessary before making
934 any direct modification of the buffer that would increase its length.
935 L</lex_stuff_pvn> provides a more convenient way to insert text into
938 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
939 this function updates all of the lexer's variables that point directly
946 Perl_lex_grow_linestr(pTHX_ STRLEN len)
950 STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
951 STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
954 linestr = PL_parser->linestr;
955 buf = SvPVX(linestr);
956 if (len <= SvLEN(linestr))
959 /* Is the lex_shared linestr SV the same as the current linestr SV?
960 * Only in this case does re_eval_start need adjusting, since it
961 * points within lex_shared->ls_linestr's buffer */
962 current = ( !PL_parser->lex_shared->ls_linestr
963 || linestr == PL_parser->lex_shared->ls_linestr);
965 bufend_pos = PL_parser->bufend - buf;
966 bufptr_pos = PL_parser->bufptr - buf;
967 oldbufptr_pos = PL_parser->oldbufptr - buf;
968 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
969 linestart_pos = PL_parser->linestart - buf;
970 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
971 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
972 re_eval_start_pos = (current && PL_parser->lex_shared->re_eval_start) ?
973 PL_parser->lex_shared->re_eval_start - buf : 0;
975 buf = sv_grow(linestr, len);
977 PL_parser->bufend = buf + bufend_pos;
978 PL_parser->bufptr = buf + bufptr_pos;
979 PL_parser->oldbufptr = buf + oldbufptr_pos;
980 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
981 PL_parser->linestart = buf + linestart_pos;
982 if (PL_parser->last_uni)
983 PL_parser->last_uni = buf + last_uni_pos;
984 if (PL_parser->last_lop)
985 PL_parser->last_lop = buf + last_lop_pos;
986 if (current && PL_parser->lex_shared->re_eval_start)
987 PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
992 =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
994 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
995 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
996 reallocating the buffer if necessary. This means that lexing code that
997 runs later will see the characters as if they had appeared in the input.
998 It is not recommended to do this as part of normal parsing, and most
999 uses of this facility run the risk of the inserted characters being
1000 interpreted in an unintended manner.
1002 The string to be inserted is represented by C<len> octets starting
1003 at C<pv>. These octets are interpreted as either UTF-8 or Latin-1,
1004 according to whether the C<LEX_STUFF_UTF8> flag is set in C<flags>.
1005 The characters are recoded for the lexer buffer, according to how the
1006 buffer is currently being interpreted (L</lex_bufutf8>). If a string
1007 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
1008 function is more convenient.
1014 Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1018 PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1019 if (flags & ~(LEX_STUFF_UTF8))
1020 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1022 if (flags & LEX_STUFF_UTF8) {
1025 STRLEN highhalf = 0; /* Count of variants */
1026 const char *p, *e = pv+len;
1027 for (p = pv; p != e; p++) {
1028 if (! UTF8_IS_INVARIANT(*p)) {
1034 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1035 bufptr = PL_parser->bufptr;
1036 Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1037 SvCUR_set(PL_parser->linestr,
1038 SvCUR(PL_parser->linestr) + len+highhalf);
1039 PL_parser->bufend += len+highhalf;
1040 for (p = pv; p != e; p++) {
1041 append_utf8_from_native_byte(*p, (U8 **) &bufptr);
1045 if (flags & LEX_STUFF_UTF8) {
1046 STRLEN highhalf = 0;
1047 const char *p, *e = pv+len;
1048 for (p = pv; p != e; p++) {
1050 if (UTF8_IS_ABOVE_LATIN1(c)) {
1051 Perl_croak(aTHX_ "Lexing code attempted to stuff "
1052 "non-Latin-1 character into Latin-1 input");
1053 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1056 } else assert(UTF8_IS_INVARIANT(c));
1060 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1061 bufptr = PL_parser->bufptr;
1062 Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1063 SvCUR_set(PL_parser->linestr,
1064 SvCUR(PL_parser->linestr) + len-highhalf);
1065 PL_parser->bufend += len-highhalf;
1068 if (UTF8_IS_INVARIANT(*p)) {
1074 *bufptr++ = EIGHT_BIT_UTF8_TO_NATIVE(*p, *(p+1));
1080 lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1081 bufptr = PL_parser->bufptr;
1082 Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1083 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1084 PL_parser->bufend += len;
1085 Copy(pv, bufptr, len, char);
1091 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1093 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1094 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1095 reallocating the buffer if necessary. This means that lexing code that
1096 runs later will see the characters as if they had appeared in the input.
1097 It is not recommended to do this as part of normal parsing, and most
1098 uses of this facility run the risk of the inserted characters being
1099 interpreted in an unintended manner.
1101 The string to be inserted is represented by octets starting at C<pv>
1102 and continuing to the first nul. These octets are interpreted as either
1103 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1104 in C<flags>. The characters are recoded for the lexer buffer, according
1105 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1106 If it is not convenient to nul-terminate a string to be inserted, the
1107 L</lex_stuff_pvn> function is more appropriate.
1113 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1115 PERL_ARGS_ASSERT_LEX_STUFF_PV;
1116 lex_stuff_pvn(pv, strlen(pv), flags);
1120 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1122 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1123 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
1124 reallocating the buffer if necessary. This means that lexing code that
1125 runs later will see the characters as if they had appeared in the input.
1126 It is not recommended to do this as part of normal parsing, and most
1127 uses of this facility run the risk of the inserted characters being
1128 interpreted in an unintended manner.
1130 The string to be inserted is the string value of C<sv>. The characters
1131 are recoded for the lexer buffer, according to how the buffer is currently
1132 being interpreted (L</lex_bufutf8>). If a string to be inserted is
1133 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1134 need to construct a scalar.
1140 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1144 PERL_ARGS_ASSERT_LEX_STUFF_SV;
1146 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1148 lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1152 =for apidoc Amx|void|lex_unstuff|char *ptr
1154 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1155 C<ptr>. Text following C<ptr> will be moved, and the buffer shortened.
1156 This hides the discarded text from any lexing code that runs later,
1157 as if the text had never appeared.
1159 This is not the normal way to consume lexed text. For that, use
1166 Perl_lex_unstuff(pTHX_ char *ptr)
1170 PERL_ARGS_ASSERT_LEX_UNSTUFF;
1171 buf = PL_parser->bufptr;
1173 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1176 bufend = PL_parser->bufend;
1178 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1179 unstuff_len = ptr - buf;
1180 Move(ptr, buf, bufend+1-ptr, char);
1181 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1182 PL_parser->bufend = bufend - unstuff_len;
1186 =for apidoc Amx|void|lex_read_to|char *ptr
1188 Consume text in the lexer buffer, from L</PL_parser-E<gt>bufptr> up
1189 to C<ptr>. This advances L</PL_parser-E<gt>bufptr> to match C<ptr>,
1190 performing the correct bookkeeping whenever a newline character is passed.
1191 This is the normal way to consume lexed text.
1193 Interpretation of the buffer's octets can be abstracted out by
1194 using the slightly higher-level functions L</lex_peek_unichar> and
1195 L</lex_read_unichar>.
1201 Perl_lex_read_to(pTHX_ char *ptr)
1204 PERL_ARGS_ASSERT_LEX_READ_TO;
1205 s = PL_parser->bufptr;
1206 if (ptr < s || ptr > PL_parser->bufend)
1207 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1208 for (; s != ptr; s++)
1210 COPLINE_INC_WITH_HERELINES;
1211 PL_parser->linestart = s+1;
1213 PL_parser->bufptr = ptr;
1217 =for apidoc Amx|void|lex_discard_to|char *ptr
1219 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1220 up to C<ptr>. The remaining content of the buffer will be moved, and
1221 all pointers into the buffer updated appropriately. C<ptr> must not
1222 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
1223 it is not permitted to discard text that has yet to be lexed.
1225 Normally it is not necessarily to do this directly, because it suffices to
1226 use the implicit discarding behaviour of L</lex_next_chunk> and things
1227 based on it. However, if a token stretches across multiple lines,
1228 and the lexing code has kept multiple lines of text in the buffer for
1229 that purpose, then after completion of the token it would be wise to
1230 explicitly discard the now-unneeded earlier lines, to avoid future
1231 multi-line tokens growing the buffer without bound.
1237 Perl_lex_discard_to(pTHX_ char *ptr)
1241 PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1242 buf = SvPVX(PL_parser->linestr);
1244 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1247 if (ptr > PL_parser->bufptr)
1248 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1249 discard_len = ptr - buf;
1250 if (PL_parser->oldbufptr < ptr)
1251 PL_parser->oldbufptr = ptr;
1252 if (PL_parser->oldoldbufptr < ptr)
1253 PL_parser->oldoldbufptr = ptr;
1254 if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1255 PL_parser->last_uni = NULL;
1256 if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1257 PL_parser->last_lop = NULL;
1258 Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1259 SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1260 PL_parser->bufend -= discard_len;
1261 PL_parser->bufptr -= discard_len;
1262 PL_parser->oldbufptr -= discard_len;
1263 PL_parser->oldoldbufptr -= discard_len;
1264 if (PL_parser->last_uni)
1265 PL_parser->last_uni -= discard_len;
1266 if (PL_parser->last_lop)
1267 PL_parser->last_lop -= discard_len;
1271 Perl_notify_parser_that_changed_to_utf8(pTHX)
1273 /* Called when $^H is changed to indicate that HINT_UTF8 has changed from
1274 * off to on. At compile time, this has the effect of entering a 'use
1275 * utf8' section. This means that any input was not previously checked for
1276 * UTF-8 (because it was off), but now we do need to check it, or our
1277 * assumptions about the input being sane could be wrong, and we could
1278 * segfault. This routine just sets a flag so that the next time we look
1279 * at the input we do the well-formed UTF-8 check. If we aren't in the
1280 * proper phase, there may not be a parser object, but if there is, setting
1281 * the flag is harmless */
1284 PL_parser->recheck_utf8_validity = TRUE;
1289 =for apidoc Amx|bool|lex_next_chunk|U32 flags
1291 Reads in the next chunk of text to be lexed, appending it to
1292 L</PL_parser-E<gt>linestr>. This should be called when lexing code has
1293 looked to the end of the current chunk and wants to know more. It is
1294 usual, but not necessary, for lexing to have consumed the entirety of
1295 the current chunk at this time.
1297 If L</PL_parser-E<gt>bufptr> is pointing to the very end of the current
1298 chunk (i.e., the current chunk has been entirely consumed), normally the
1299 current chunk will be discarded at the same time that the new chunk is
1300 read in. If C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, the current chunk
1301 will not be discarded. If the current chunk has not been entirely
1302 consumed, then it will not be discarded regardless of the flag.
1304 Returns true if some new text was added to the buffer, or false if the
1305 buffer has reached the end of the input text.
1310 #define LEX_FAKE_EOF 0x80000000
1311 #define LEX_NO_TERM 0x40000000 /* here-doc */
1314 Perl_lex_next_chunk(pTHX_ U32 flags)
1318 STRLEN old_bufend_pos, new_bufend_pos;
1319 STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1320 STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1321 bool got_some_for_debugger = 0;
1324 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1325 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1326 if (!(flags & LEX_NO_TERM) && PL_lex_inwhat)
1328 linestr = PL_parser->linestr;
1329 buf = SvPVX(linestr);
1330 if (!(flags & LEX_KEEP_PREVIOUS)
1331 && PL_parser->bufptr == PL_parser->bufend)
1333 old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1335 if (PL_parser->last_uni != PL_parser->bufend)
1336 PL_parser->last_uni = NULL;
1337 if (PL_parser->last_lop != PL_parser->bufend)
1338 PL_parser->last_lop = NULL;
1339 last_uni_pos = last_lop_pos = 0;
1343 old_bufend_pos = PL_parser->bufend - buf;
1344 bufptr_pos = PL_parser->bufptr - buf;
1345 oldbufptr_pos = PL_parser->oldbufptr - buf;
1346 oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1347 linestart_pos = PL_parser->linestart - buf;
1348 last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1349 last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1351 if (flags & LEX_FAKE_EOF) {
1353 } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1355 } else if (filter_gets(linestr, old_bufend_pos)) {
1357 got_some_for_debugger = 1;
1358 } else if (flags & LEX_NO_TERM) {
1361 if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1364 /* End of real input. Close filehandle (unless it was STDIN),
1365 * then add implicit termination.
1367 if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1368 PerlIO_clearerr(PL_parser->rsfp);
1369 else if (PL_parser->rsfp)
1370 (void)PerlIO_close(PL_parser->rsfp);
1371 PL_parser->rsfp = NULL;
1372 PL_parser->in_pod = PL_parser->filtered = 0;
1373 if (!PL_in_eval && PL_minus_p) {
1375 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1376 PL_minus_n = PL_minus_p = 0;
1377 } else if (!PL_in_eval && PL_minus_n) {
1378 sv_catpvs(linestr, /*{*/";}");
1381 sv_catpvs(linestr, ";");
1384 buf = SvPVX(linestr);
1385 new_bufend_pos = SvCUR(linestr);
1386 PL_parser->bufend = buf + new_bufend_pos;
1387 PL_parser->bufptr = buf + bufptr_pos;
1390 const U8* first_bad_char_loc;
1391 if (UNLIKELY(! is_utf8_string_loc(
1392 (U8 *) PL_parser->bufptr,
1393 PL_parser->bufend - PL_parser->bufptr,
1394 &first_bad_char_loc)))
1396 _force_out_malformed_utf8_message(first_bad_char_loc,
1397 (U8 *) PL_parser->bufend,
1399 1 /* 1 means die */ );
1400 NOT_REACHED; /* NOTREACHED */
1404 PL_parser->oldbufptr = buf + oldbufptr_pos;
1405 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1406 PL_parser->linestart = buf + linestart_pos;
1407 if (PL_parser->last_uni)
1408 PL_parser->last_uni = buf + last_uni_pos;
1409 if (PL_parser->last_lop)
1410 PL_parser->last_lop = buf + last_lop_pos;
1411 if (PL_parser->preambling != NOLINE) {
1412 CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1413 PL_parser->preambling = NOLINE;
1415 if ( got_some_for_debugger
1416 && PERLDB_LINE_OR_SAVESRC
1417 && PL_curstash != PL_debstash)
1419 /* debugger active and we're not compiling the debugger code,
1420 * so store the line into the debugger's array of lines
1422 update_debugger_info(NULL, buf+old_bufend_pos,
1423 new_bufend_pos-old_bufend_pos);
1429 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1431 Looks ahead one (Unicode) character in the text currently being lexed.
1432 Returns the codepoint (unsigned integer value) of the next character,
1433 or -1 if lexing has reached the end of the input text. To consume the
1434 peeked character, use L</lex_read_unichar>.
1436 If the next character is in (or extends into) the next chunk of input
1437 text, the next chunk will be read in. Normally the current chunk will be
1438 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1439 bit set, then the current chunk will not be discarded.
1441 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1442 is encountered, an exception is generated.
1448 Perl_lex_peek_unichar(pTHX_ U32 flags)
1452 if (flags & ~(LEX_KEEP_PREVIOUS))
1453 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1454 s = PL_parser->bufptr;
1455 bufend = PL_parser->bufend;
1461 if (!lex_next_chunk(flags))
1463 s = PL_parser->bufptr;
1464 bufend = PL_parser->bufend;
1467 if (UTF8_IS_INVARIANT(head))
1469 if (UTF8_IS_START(head)) {
1470 len = UTF8SKIP(&head);
1471 while ((STRLEN)(bufend-s) < len) {
1472 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1474 s = PL_parser->bufptr;
1475 bufend = PL_parser->bufend;
1478 unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1479 if (retlen == (STRLEN)-1) {
1480 _force_out_malformed_utf8_message((U8 *) s,
1483 1 /* 1 means die */ );
1484 NOT_REACHED; /* NOTREACHED */
1489 if (!lex_next_chunk(flags))
1491 s = PL_parser->bufptr;
1498 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1500 Reads the next (Unicode) character in the text currently being lexed.
1501 Returns the codepoint (unsigned integer value) of the character read,
1502 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1503 if lexing has reached the end of the input text. To non-destructively
1504 examine the next character, use L</lex_peek_unichar> instead.
1506 If the next character is in (or extends into) the next chunk of input
1507 text, the next chunk will be read in. Normally the current chunk will be
1508 discarded at the same time, but if C<flags> has the C<LEX_KEEP_PREVIOUS>
1509 bit set, then the current chunk will not be discarded.
1511 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1512 is encountered, an exception is generated.
1518 Perl_lex_read_unichar(pTHX_ U32 flags)
1521 if (flags & ~(LEX_KEEP_PREVIOUS))
1522 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1523 c = lex_peek_unichar(flags);
1526 COPLINE_INC_WITH_HERELINES;
1528 PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1530 ++(PL_parser->bufptr);
1536 =for apidoc Amx|void|lex_read_space|U32 flags
1538 Reads optional spaces, in Perl style, in the text currently being
1539 lexed. The spaces may include ordinary whitespace characters and
1540 Perl-style comments. C<#line> directives are processed if encountered.
1541 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1542 at a non-space character (or the end of the input text).
1544 If spaces extend into the next chunk of input text, the next chunk will
1545 be read in. Normally the current chunk will be discarded at the same
1546 time, but if C<flags> has the C<LEX_KEEP_PREVIOUS> bit set, then the current
1547 chunk will not be discarded.
1552 #define LEX_NO_INCLINE 0x40000000
1553 #define LEX_NO_NEXT_CHUNK 0x80000000
1556 Perl_lex_read_space(pTHX_ U32 flags)
1559 const bool can_incline = !(flags & LEX_NO_INCLINE);
1560 bool need_incline = 0;
1561 if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1562 Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1563 s = PL_parser->bufptr;
1564 bufend = PL_parser->bufend;
1570 } while (!(c == '\n' || (c == 0 && s == bufend)));
1571 } else if (c == '\n') {
1574 PL_parser->linestart = s;
1580 } else if (isSPACE(c)) {
1582 } else if (c == 0 && s == bufend) {
1585 if (flags & LEX_NO_NEXT_CHUNK)
1587 PL_parser->bufptr = s;
1588 l = CopLINE(PL_curcop);
1589 CopLINE(PL_curcop) += PL_parser->herelines + 1;
1590 got_more = lex_next_chunk(flags);
1591 CopLINE_set(PL_curcop, l);
1592 s = PL_parser->bufptr;
1593 bufend = PL_parser->bufend;
1596 if (can_incline && need_incline && PL_parser->rsfp) {
1606 PL_parser->bufptr = s;
1611 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1613 This function performs syntax checking on a prototype, C<proto>.
1614 If C<warn> is true, any illegal characters or mismatched brackets
1615 will trigger illegalproto warnings, declaring that they were
1616 detected in the prototype for C<name>.
1618 The return value is C<true> if this is a valid prototype, and
1619 C<false> if it is not, regardless of whether C<warn> was C<true> or
1622 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1629 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn, bool curstash)
1631 STRLEN len, origlen;
1633 bool bad_proto = FALSE;
1634 bool in_brackets = FALSE;
1635 bool after_slash = FALSE;
1636 char greedy_proto = ' ';
1637 bool proto_after_greedy_proto = FALSE;
1638 bool must_be_last = FALSE;
1639 bool underscore = FALSE;
1640 bool bad_proto_after_underscore = FALSE;
1642 PERL_ARGS_ASSERT_VALIDATE_PROTO;
1647 p = SvPV(proto, len);
1649 for (; len--; p++) {
1652 proto_after_greedy_proto = TRUE;
1654 if (!strchr(";@%", *p))
1655 bad_proto_after_underscore = TRUE;
1658 if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1665 in_brackets = FALSE;
1666 else if ((*p == '@' || *p == '%')
1670 must_be_last = TRUE;
1679 after_slash = FALSE;
1684 SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1687 ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1688 origlen, UNI_DISPLAY_ISPRINT)
1689 : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1691 if (curstash && !memchr(SvPVX(name), ':', SvCUR(name))) {
1692 SV *name2 = sv_2mortal(newSVsv(PL_curstname));
1693 sv_catpvs(name2, "::");
1694 sv_catsv(name2, (SV *)name);
1698 if (proto_after_greedy_proto)
1699 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1700 "Prototype after '%c' for %" SVf " : %s",
1701 greedy_proto, SVfARG(name), p);
1703 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1704 "Missing ']' in prototype for %" SVf " : %s",
1707 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1708 "Illegal character in prototype for %" SVf " : %s",
1710 if (bad_proto_after_underscore)
1711 Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1712 "Illegal character after '_' in prototype for %" SVf " : %s",
1716 return (! (proto_after_greedy_proto || bad_proto) );
1721 * This subroutine has nothing to do with tilting, whether at windmills
1722 * or pinball tables. Its name is short for "increment line". It
1723 * increments the current line number in CopLINE(PL_curcop) and checks
1724 * to see whether the line starts with a comment of the form
1725 * # line 500 "foo.pm"
1726 * If so, it sets the current line number and file to the values in the comment.
1730 S_incline(pTHX_ const char *s, const char *end)
1738 PERL_ARGS_ASSERT_INCLINE;
1742 COPLINE_INC_WITH_HERELINES;
1743 if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1744 && s+1 == PL_bufend && *s == ';') {
1745 /* fake newline in string eval */
1746 CopLINE_dec(PL_curcop);
1751 while (SPACE_OR_TAB(*s))
1753 if (memBEGINs(s, (STRLEN) (end - s), "line"))
1754 s += sizeof("line") - 1;
1757 if (SPACE_OR_TAB(*s))
1761 while (SPACE_OR_TAB(*s))
1769 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1771 while (SPACE_OR_TAB(*s))
1773 if (*s == '"' && (t = (char *) memchr(s+1, '"', end - s))) {
1779 while (*t && !isSPACE(*t))
1783 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1785 if (*e != '\n' && *e != '\0')
1786 return; /* false alarm */
1788 if (!grok_atoUV(n, &uv, &e))
1790 line_num = ((line_t)uv) - 1;
1793 const STRLEN len = t - s;
1795 if (!PL_rsfp && !PL_parser->filtered) {
1796 /* must copy *{"::_<(eval N)[oldfilename:L]"}
1797 * to *{"::_<newfilename"} */
1798 /* However, the long form of evals is only turned on by the
1799 debugger - usually they're "(eval %lu)" */
1800 GV * const cfgv = CopFILEGV(PL_curcop);
1803 STRLEN tmplen2 = len;
1807 if (tmplen2 + 2 <= sizeof smallbuf)
1810 Newx(tmpbuf2, tmplen2 + 2, char);
1815 memcpy(tmpbuf2 + 2, s, tmplen2);
1818 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1820 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1821 /* adjust ${"::_<newfilename"} to store the new file name */
1822 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1823 /* The line number may differ. If that is the case,
1824 alias the saved lines that are in the array.
1825 Otherwise alias the whole array. */
1826 if (CopLINE(PL_curcop) == line_num) {
1827 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1828 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1830 else if (GvAV(cfgv)) {
1831 AV * const av = GvAV(cfgv);
1832 const I32 start = CopLINE(PL_curcop)+1;
1833 I32 items = AvFILLp(av) - start;
1835 AV * const av2 = GvAVn(gv2);
1836 SV **svp = AvARRAY(av) + start;
1837 I32 l = (I32)line_num+1;
1839 av_store(av2, l++, SvREFCNT_inc(*svp++));
1844 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1847 CopFILE_free(PL_curcop);
1848 CopFILE_setn(PL_curcop, s, len);
1850 CopLINE_set(PL_curcop, line_num);
1854 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1856 AV *av = CopFILEAVx(PL_curcop);
1859 if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1861 sv = *av_fetch(av, 0, 1);
1862 SvUPGRADE(sv, SVt_PVMG);
1864 if (!SvPOK(sv)) SvPVCLEAR(sv);
1866 sv_catsv(sv, orig_sv);
1868 sv_catpvn(sv, buf, len);
1873 if (PL_parser->preambling == NOLINE)
1874 av_store(av, CopLINE(PL_curcop), sv);
1880 * Called to gobble the appropriate amount and type of whitespace.
1881 * Skips comments as well.
1882 * Returns the next character after the whitespace that is skipped.
1885 * Same thing, but look ahead without incrementing line numbers or
1886 * adjusting PL_linestart.
1889 #define skipspace(s) skipspace_flags(s, 0)
1890 #define peekspace(s) skipspace_flags(s, LEX_NO_INCLINE)
1893 S_skipspace_flags(pTHX_ char *s, U32 flags)
1895 PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1896 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1897 while (s < PL_bufend && (SPACE_OR_TAB(*s) || !*s))
1900 STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1902 lex_read_space(flags | LEX_KEEP_PREVIOUS |
1903 (PL_lex_inwhat || PL_lex_state == LEX_FORMLINE ?
1904 LEX_NO_NEXT_CHUNK : 0));
1906 PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1907 if (PL_linestart > PL_bufptr)
1908 PL_bufptr = PL_linestart;
1916 * Check the unary operators to ensure there's no ambiguity in how they're
1917 * used. An ambiguous piece of code would be:
1919 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1920 * the +5 is its argument.
1928 if (PL_oldoldbufptr != PL_last_uni)
1930 while (isSPACE(*PL_last_uni))
1933 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF) || *s == '-')
1934 s += UTF ? UTF8SKIP(s) : 1;
1935 if (s < PL_bufptr && memchr(s, '(', PL_bufptr - s))
1938 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1939 "Warning: Use of \"%" UTF8f "\" without parentheses is ambiguous",
1940 UTF8fARG(UTF, (int)(s - PL_last_uni), PL_last_uni));
1944 * LOP : macro to build a list operator. Its behaviour has been replaced
1945 * with a subroutine, S_lop() for which LOP is just another name.
1948 #define LOP(f,x) return lop(f,x,s)
1952 * Build a list operator (or something that might be one). The rules:
1953 * - if we have a next token, then it's a list operator (no parens) for
1954 * which the next token has already been parsed; e.g.,
1957 * - if the next thing is an opening paren, then it's a function
1958 * - else it's a list operator
1962 S_lop(pTHX_ I32 f, U8 x, char *s)
1964 PERL_ARGS_ASSERT_LOP;
1969 PL_last_lop = PL_oldbufptr;
1970 PL_last_lop_op = (OPCODE)f;
1975 return REPORT(FUNC);
1978 return REPORT(FUNC);
1981 if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
1982 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
1983 return REPORT(LSTOP);
1989 * When the lexer realizes it knows the next token (for instance,
1990 * it is reordering tokens for the parser) then it can call S_force_next
1991 * to know what token to return the next time the lexer is called. Caller
1992 * will need to set PL_nextval[] and possibly PL_expect to ensure
1993 * the lexer handles the token correctly.
1997 S_force_next(pTHX_ I32 type)
2001 PerlIO_printf(Perl_debug_log, "### forced token:\n");
2002 tokereport(type, &NEXTVAL_NEXTTOKE);
2005 assert(PL_nexttoke < C_ARRAY_LENGTH(PL_nexttype));
2006 PL_nexttype[PL_nexttoke] = type;
2013 * This subroutine handles postfix deref syntax after the arrow has already
2014 * been emitted. @* $* etc. are emitted as two separate tokens right here.
2015 * @[ @{ %[ %{ *{ are emitted also as two tokens, but this function emits
2016 * only the first, leaving yylex to find the next.
2020 S_postderef(pTHX_ int const funny, char const next)
2022 assert(funny == DOLSHARP || strchr("$@%&*", funny));
2024 PL_expect = XOPERATOR;
2025 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
2026 assert('@' == funny || '$' == funny || DOLSHARP == funny);
2027 PL_lex_state = LEX_INTERPEND;
2029 force_next(POSTJOIN);
2035 if ('@' == funny && PL_lex_state == LEX_INTERPNORMAL
2036 && !PL_lex_brackets)
2038 PL_expect = XOPERATOR;
2047 int yyc = PL_parser->yychar;
2048 if (yyc != YYEMPTY) {
2050 NEXTVAL_NEXTTOKE = PL_parser->yylval;
2051 if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2052 PL_lex_allbrackets--;
2054 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2055 } else if (yyc == '('/*)*/) {
2056 PL_lex_allbrackets--;
2061 PL_parser->yychar = YYEMPTY;
2066 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2068 SV * const sv = newSVpvn_utf8(start, len,
2071 && is_utf8_non_invariant_string((const U8*)start, len));
2077 * When the lexer knows the next thing is a word (for instance, it has
2078 * just seen -> and it knows that the next char is a word char, then
2079 * it calls S_force_word to stick the next word into the PL_nexttoke/val
2083 * char *start : buffer position (must be within PL_linestr)
2084 * int token : PL_next* will be this type of bare word
2085 * (e.g., METHOD,BAREWORD)
2086 * int check_keyword : if true, Perl checks to make sure the word isn't
2087 * a keyword (do this if the word is a label, e.g. goto FOO)
2088 * int allow_pack : if true, : characters will also be allowed (require,
2089 * use, etc. do this)
2093 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2098 PERL_ARGS_ASSERT_FORCE_WORD;
2100 start = skipspace(start);
2102 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
2103 || (allow_pack && *s == ':' && s[1] == ':') )
2105 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2106 if (check_keyword) {
2107 char *s2 = PL_tokenbuf;
2109 if (allow_pack && memBEGINPs(s2, len, "CORE::")) {
2110 s2 += sizeof("CORE::") - 1;
2111 len2 -= sizeof("CORE::") - 1;
2113 if (keyword(s2, len2, 0))
2116 if (token == METHOD) {
2121 PL_expect = XOPERATOR;
2124 NEXTVAL_NEXTTOKE.opval
2125 = newSVOP(OP_CONST,0,
2126 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2127 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2135 * Called when the lexer wants $foo *foo &foo etc, but the program
2136 * text only contains the "foo" portion. The first argument is a pointer
2137 * to the "foo", and the second argument is the type symbol to prefix.
2138 * Forces the next token to be a "BAREWORD".
2139 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2143 S_force_ident(pTHX_ const char *s, int kind)
2145 PERL_ARGS_ASSERT_FORCE_IDENT;
2148 const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2149 OP* const o = newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2150 UTF ? SVf_UTF8 : 0));
2151 NEXTVAL_NEXTTOKE.opval = o;
2152 force_next(BAREWORD);
2154 o->op_private = OPpCONST_ENTERED;
2155 /* XXX see note in pp_entereval() for why we forgo typo
2156 warnings if the symbol must be introduced in an eval.
2158 gv_fetchpvn_flags(s, len,
2159 (PL_in_eval ? GV_ADDMULTI
2160 : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2161 kind == '$' ? SVt_PV :
2162 kind == '@' ? SVt_PVAV :
2163 kind == '%' ? SVt_PVHV :
2171 S_force_ident_maybe_lex(pTHX_ char pit)
2173 NEXTVAL_NEXTTOKE.ival = pit;
2178 Perl_str_to_version(pTHX_ SV *sv)
2183 const char *start = SvPV_const(sv,len);
2184 const char * const end = start + len;
2185 const bool utf = cBOOL(SvUTF8(sv));
2187 PERL_ARGS_ASSERT_STR_TO_VERSION;
2189 while (start < end) {
2193 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2198 retval += ((NV)n)/nshift;
2207 * Forces the next token to be a version number.
2208 * If the next token appears to be an invalid version number, (e.g. "v2b"),
2209 * and if "guessing" is TRUE, then no new token is created (and the caller
2210 * must use an alternative parsing method).
2214 S_force_version(pTHX_ char *s, int guessing)
2219 PERL_ARGS_ASSERT_FORCE_VERSION;
2227 while (isDIGIT(*d) || *d == '_' || *d == '.')
2229 if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2231 s = scan_num(s, &pl_yylval);
2232 version = pl_yylval.opval;
2233 ver = cSVOPx(version)->op_sv;
2234 if (SvPOK(ver) && !SvNIOK(ver)) {
2235 SvUPGRADE(ver, SVt_PVNV);
2236 SvNV_set(ver, str_to_version(ver));
2237 SvNOK_on(ver); /* hint that it is a version */
2240 else if (guessing) {
2245 /* NOTE: The parser sees the package name and the VERSION swapped */
2246 NEXTVAL_NEXTTOKE.opval = version;
2247 force_next(BAREWORD);
2253 * S_force_strict_version
2254 * Forces the next token to be a version number using strict syntax rules.
2258 S_force_strict_version(pTHX_ char *s)
2261 const char *errstr = NULL;
2263 PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2265 while (isSPACE(*s)) /* leading whitespace */
2268 if (is_STRICT_VERSION(s,&errstr)) {
2270 s = (char *)scan_version(s, ver, 0);
2271 version = newSVOP(OP_CONST, 0, ver);
2273 else if ((*s != ';' && *s != '{' && *s != '}' )
2274 && (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2278 yyerror(errstr); /* version required */
2282 /* NOTE: The parser sees the package name and the VERSION swapped */
2283 NEXTVAL_NEXTTOKE.opval = version;
2284 force_next(BAREWORD);
2291 * Turns any \\ into \ in a quoted string passed in in 'sv', returning 'sv',
2292 * modified as necessary. However, if HINT_NEW_STRING is on, 'sv' is
2293 * unchanged, and a new SV containing the modified input is returned.
2297 S_tokeq(pTHX_ SV *sv)
2304 PERL_ARGS_ASSERT_TOKEQ;
2308 assert (!SvIsCOW(sv));
2309 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2313 /* This is relying on the SV being "well formed" with a trailing '\0' */
2314 while (s < send && !(*s == '\\' && s[1] == '\\'))
2319 if ( PL_hints & HINT_NEW_STRING ) {
2320 pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2321 SVs_TEMP | SvUTF8(sv));
2325 if (s + 1 < send && (s[1] == '\\'))
2326 s++; /* all that, just for this */
2331 SvCUR_set(sv, d - SvPVX_const(sv));
2333 if ( PL_hints & HINT_NEW_STRING )
2334 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2339 * Now come three functions related to double-quote context,
2340 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2341 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2342 * interact with PL_lex_state, and create fake ( ... ) argument lists
2343 * to handle functions and concatenation.
2347 * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2352 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2354 * Pattern matching will set PL_lex_op to the pattern-matching op to
2355 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2357 * OP_CONST is easy--just make the new op and return.
2359 * Everything else becomes a FUNC.
2361 * Sets PL_lex_state to LEX_INTERPPUSH unless ival was OP_NULL or we
2362 * had an OP_CONST. This just sets us up for a
2363 * call to S_sublex_push().
2367 S_sublex_start(pTHX)
2369 const I32 op_type = pl_yylval.ival;
2371 if (op_type == OP_NULL) {
2372 pl_yylval.opval = PL_lex_op;
2376 if (op_type == OP_CONST) {
2377 SV *sv = PL_lex_stuff;
2378 PL_lex_stuff = NULL;
2381 if (SvTYPE(sv) == SVt_PVIV) {
2382 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2384 const char * const p = SvPV_const(sv, len);
2385 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2389 pl_yylval.opval = newSVOP(op_type, 0, sv);
2393 PL_parser->lex_super_state = PL_lex_state;
2394 PL_parser->lex_sub_inwhat = (U16)op_type;
2395 PL_parser->lex_sub_op = PL_lex_op;
2396 PL_parser->sub_no_recover = FALSE;
2397 PL_parser->sub_error_count = PL_error_count;
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.
2422 const bool is_heredoc = PL_multi_close == '<';
2425 PL_lex_state = PL_parser->lex_super_state;
2426 SAVEI8(PL_lex_dojoin);
2427 SAVEI32(PL_lex_brackets);
2428 SAVEI32(PL_lex_allbrackets);
2429 SAVEI32(PL_lex_formbrack);
2430 SAVEI8(PL_lex_fakeeof);
2431 SAVEI32(PL_lex_casemods);
2432 SAVEI32(PL_lex_starts);
2433 SAVEI8(PL_lex_state);
2434 SAVESPTR(PL_lex_repl);
2435 SAVEVPTR(PL_lex_inpat);
2436 SAVEI16(PL_lex_inwhat);
2439 SAVECOPLINE(PL_curcop);
2440 SAVEI32(PL_multi_end);
2441 SAVEI32(PL_parser->herelines);
2442 PL_parser->herelines = 0;
2444 SAVEIV(PL_multi_close);
2445 SAVEPPTR(PL_bufptr);
2446 SAVEPPTR(PL_bufend);
2447 SAVEPPTR(PL_oldbufptr);
2448 SAVEPPTR(PL_oldoldbufptr);
2449 SAVEPPTR(PL_last_lop);
2450 SAVEPPTR(PL_last_uni);
2451 SAVEPPTR(PL_linestart);
2452 SAVESPTR(PL_linestr);
2453 SAVEGENERICPV(PL_lex_brackstack);
2454 SAVEGENERICPV(PL_lex_casestack);
2455 SAVEGENERICPV(PL_parser->lex_shared);
2456 SAVEBOOL(PL_parser->lex_re_reparsing);
2457 SAVEI32(PL_copline);
2459 /* The here-doc parser needs to be able to peek into outer lexing
2460 scopes to find the body of the here-doc. So we put PL_linestr and
2461 PL_bufptr into lex_shared, to ‘share’ those values.
2463 PL_parser->lex_shared->ls_linestr = PL_linestr;
2464 PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2466 PL_linestr = PL_lex_stuff;
2467 PL_lex_repl = PL_parser->lex_sub_repl;
2468 PL_lex_stuff = NULL;
2469 PL_parser->lex_sub_repl = NULL;
2471 /* Arrange for PL_lex_stuff to be freed on scope exit, in case it gets
2472 set for an inner quote-like operator and then an error causes scope-
2473 popping. We must not have a PL_lex_stuff value left dangling, as
2474 that breaks assumptions elsewhere. See bug #123617. */
2475 SAVEGENERICSV(PL_lex_stuff);
2476 SAVEGENERICSV(PL_parser->lex_sub_repl);
2478 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2479 = SvPVX(PL_linestr);
2480 PL_bufend += SvCUR(PL_linestr);
2481 PL_last_lop = PL_last_uni = NULL;
2482 SAVEFREESV(PL_linestr);
2483 if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2485 PL_lex_dojoin = FALSE;
2486 PL_lex_brackets = PL_lex_formbrack = 0;
2487 PL_lex_allbrackets = 0;
2488 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2489 Newx(PL_lex_brackstack, 120, char);
2490 Newx(PL_lex_casestack, 12, char);
2491 PL_lex_casemods = 0;
2492 *PL_lex_casestack = '\0';
2494 PL_lex_state = LEX_INTERPCONCAT;
2496 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2497 PL_copline = NOLINE;
2499 Newxz(shared, 1, LEXSHARED);
2500 shared->ls_prev = PL_parser->lex_shared;
2501 PL_parser->lex_shared = shared;
2503 PL_lex_inwhat = PL_parser->lex_sub_inwhat;
2504 if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2505 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2506 PL_lex_inpat = PL_parser->lex_sub_op;
2508 PL_lex_inpat = NULL;
2510 PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2511 PL_in_eval &= ~EVAL_RE_REPARSING;
2518 * Restores lexer state after a S_sublex_push.
2524 if (!PL_lex_starts++) {
2525 SV * const sv = newSVpvs("");
2526 if (SvUTF8(PL_linestr))
2528 PL_expect = XOPERATOR;
2529 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
2533 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2534 PL_lex_state = LEX_INTERPCASEMOD;
2538 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2539 assert(PL_lex_inwhat != OP_TRANSR);
2541 assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2542 PL_linestr = PL_lex_repl;
2544 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2545 PL_bufend += SvCUR(PL_linestr);
2546 PL_last_lop = PL_last_uni = NULL;
2547 PL_lex_dojoin = FALSE;
2548 PL_lex_brackets = 0;
2549 PL_lex_allbrackets = 0;
2550 PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2551 PL_lex_casemods = 0;
2552 *PL_lex_casestack = '\0';
2554 if (SvEVALED(PL_lex_repl)) {
2555 PL_lex_state = LEX_INTERPNORMAL;
2557 /* we don't clear PL_lex_repl here, so that we can check later
2558 whether this is an evalled subst; that means we rely on the
2559 logic to ensure sublex_done() is called again only via the
2560 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2563 PL_lex_state = LEX_INTERPCONCAT;
2566 if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2567 CopLINE(PL_curcop) +=
2568 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xnv_lines
2569 + PL_parser->herelines;
2570 PL_parser->herelines = 0;
2575 const line_t l = CopLINE(PL_curcop);
2577 if (PL_parser->sub_error_count != PL_error_count) {
2578 const char * const name = OutCopFILE(PL_curcop);
2579 if (PL_parser->sub_no_recover) {
2580 const char * msg = "";
2584 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
2587 abort_execution(msg, name);
2591 if (PL_multi_close == '<')
2592 PL_parser->herelines += l - PL_multi_end;
2593 PL_bufend = SvPVX(PL_linestr);
2594 PL_bufend += SvCUR(PL_linestr);
2595 PL_expect = XOPERATOR;
2601 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2603 /* <s> points to first character of interior of \N{}, <e> to one beyond the
2604 * interior, hence to the "}". Finds what the name resolves to, returning
2605 * an SV* containing it; NULL if no valid one found */
2607 SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2614 const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2616 PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2619 SvREFCNT_dec_NN(res);
2620 /* diag_listed_as: Unknown charname '%s' */
2621 yyerror("Unknown charname ''");
2625 res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2626 /* include the <}> */
2627 e - backslash_ptr + 1);
2629 SvREFCNT_dec_NN(res);
2633 /* See if the charnames handler is the Perl core's, and if so, we can skip
2634 * the validation needed for a user-supplied one, as Perl's does its own
2636 table = GvHV(PL_hintgv); /* ^H */
2637 cvp = hv_fetchs(table, "charnames", FALSE);
2638 if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2639 SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2641 const char * const name = HvNAME(stash);
2642 if (memEQs(name, HvNAMELEN(stash), "_charnames")) {
2647 /* Here, it isn't Perl's charname handler. We can't rely on a
2648 * user-supplied handler to validate the input name. For non-ut8 input,
2649 * look to see that the first character is legal. Then loop through the
2650 * rest checking that each is a continuation */
2652 /* This code makes the reasonable assumption that the only Latin1-range
2653 * characters that begin a character name alias are alphabetic, otherwise
2654 * would have to create a isCHARNAME_BEGIN macro */
2657 if (! isALPHAU(*s)) {
2662 if (! isCHARNAME_CONT(*s)) {
2665 if (*s == ' ' && *(s-1) == ' ') {
2672 /* Similarly for utf8. For invariants can check directly; for other
2673 * Latin1, can calculate their code point and check; otherwise use a
2675 if (UTF8_IS_INVARIANT(*s)) {
2676 if (! isALPHAU(*s)) {
2680 } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2681 if (! isALPHAU(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1)))) {
2687 if (! _invlist_contains_cp(PL_utf8_charname_begin,
2688 utf8_to_uvchr_buf((U8 *) s,
2698 if (UTF8_IS_INVARIANT(*s)) {
2699 if (! isCHARNAME_CONT(*s)) {
2702 if (*s == ' ' && *(s-1) == ' ') {
2707 else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2708 if (! isCHARNAME_CONT(EIGHT_BIT_UTF8_TO_NATIVE(*s, *(s+1))))
2715 if (! _invlist_contains_cp(PL_utf8_charname_continue,
2716 utf8_to_uvchr_buf((U8 *) s,
2726 if (*(s-1) == ' ') {
2727 /* diag_listed_as: charnames alias definitions may not contain
2728 trailing white-space; marked by <-- HERE in %s
2732 "charnames alias definitions may not contain trailing "
2733 "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2734 (int)(s - backslash_ptr + 1), backslash_ptr,
2735 (int)(e - s + 1), s + 1
2737 UTF ? SVf_UTF8 : 0);
2741 if (SvUTF8(res)) { /* Don't accept malformed input */
2742 const U8* first_bad_char_loc;
2744 const char* const str = SvPV_const(res, len);
2745 if (UNLIKELY(! is_utf8_string_loc((U8 *) str, len,
2746 &first_bad_char_loc)))
2748 _force_out_malformed_utf8_message(first_bad_char_loc,
2749 (U8 *) PL_parser->bufend,
2751 0 /* 0 means don't die */ );
2752 /* diag_listed_as: Malformed UTF-8 returned by \N{%s}
2753 immediately after '%s' */
2756 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2757 (int) (e - backslash_ptr + 1), backslash_ptr,
2758 (int) ((char *) first_bad_char_loc - str), str
2769 /* The final %.*s makes sure that should the trailing NUL be missing
2770 * that this print won't run off the end of the string */
2771 /* diag_listed_as: Invalid character in \N{...}; marked by <-- HERE
2775 "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2776 (int)(s - backslash_ptr + 1), backslash_ptr,
2777 (int)(e - s + 1), s + 1
2779 UTF ? SVf_UTF8 : 0);
2784 /* diag_listed_as: charnames alias definitions may not contain a
2785 sequence of multiple spaces; marked by <-- HERE
2789 "charnames alias definitions may not contain a sequence of "
2790 "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2791 (int)(s - backslash_ptr + 1), backslash_ptr,
2792 (int)(e - s + 1), s + 1
2794 UTF ? SVf_UTF8 : 0);
2801 Extracts the next constant part of a pattern, double-quoted string,
2802 or transliteration. This is terrifying code.
2804 For example, in parsing the double-quoted string "ab\x63$d", it would
2805 stop at the '$' and return an OP_CONST containing 'abc'.
2807 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2808 processing a pattern (PL_lex_inpat is true), a transliteration
2809 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2811 Returns a pointer to the character scanned up to. If this is
2812 advanced from the start pointer supplied (i.e. if anything was
2813 successfully parsed), will leave an OP_CONST for the substring scanned
2814 in pl_yylval. Caller must intuit reason for not parsing further
2815 by looking at the next characters herself.
2819 \N{FOO} => \N{U+hex_for_character_FOO}
2820 (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2823 all other \-char, including \N and \N{ apart from \N{ABC}
2826 @ and $ where it appears to be a var, but not for $ as tail anchor
2830 In transliterations:
2831 characters are VERY literal, except for - not at the start or end
2832 of the string, which indicates a range. However some backslash sequences
2833 are recognized: \r, \n, and the like
2834 \007 \o{}, \x{}, \N{}
2835 If all elements in the transliteration are below 256,
2836 scan_const expands the range to the full set of intermediate
2837 characters. If the range is in utf8, the hyphen is replaced with
2838 a certain range mark which will be handled by pmtrans() in op.c.
2840 In double-quoted strings:
2842 all those recognized in transliterations
2843 deprecated backrefs: \1 (in substitution replacements)
2844 case and quoting: \U \Q \E
2847 scan_const does *not* construct ops to handle interpolated strings.
2848 It stops processing as soon as it finds an embedded $ or @ variable
2849 and leaves it to the caller to work out what's going on.
2851 embedded arrays (whether in pattern or not) could be:
2852 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2854 $ in double-quoted strings must be the symbol of an embedded scalar.
2856 $ in pattern could be $foo or could be tail anchor. Assumption:
2857 it's a tail anchor if $ is the last thing in the string, or if it's
2858 followed by one of "()| \r\n\t"
2860 \1 (backreferences) are turned into $1 in substitutions
2862 The structure of the code is
2863 while (there's a character to process) {
2864 handle transliteration ranges
2865 skip regexp comments /(?#comment)/ and codes /(?{code})/
2866 skip #-initiated comments in //x patterns
2867 check for embedded arrays
2868 check for embedded scalars
2870 deprecate \1 in substitution replacements
2871 handle string-changing backslashes \l \U \Q \E, etc.
2872 switch (what was escaped) {
2873 handle \- in a transliteration (becomes a literal -)
2874 if a pattern and not \N{, go treat as regular character
2875 handle \132 (octal characters)
2876 handle \x15 and \x{1234} (hex characters)
2877 handle \N{name} (named characters, also \N{3,5} in a pattern)
2878 handle \cV (control characters)
2879 handle printf-style backslashes (\f, \r, \n, etc)
2882 } (end if backslash)
2883 handle regular character
2884 } (end while character to read)
2889 S_scan_const(pTHX_ char *start)
2891 char *send = PL_bufend; /* end of the constant */
2892 SV *sv = newSV(send - start); /* sv for the constant. See note below
2894 char *s = start; /* start of the constant */
2895 char *d = SvPVX(sv); /* destination for copies */
2896 bool dorange = FALSE; /* are we in a translit range? */
2897 bool didrange = FALSE; /* did we just finish a range? */
2898 bool in_charclass = FALSE; /* within /[...]/ */
2899 bool has_utf8 = FALSE; /* Output constant is UTF8 */
2900 bool this_utf8 = cBOOL(UTF); /* Is the source string assumed to be
2901 UTF8? But, this can show as true
2902 when the source isn't utf8, as for
2903 example when it is entirely composed
2905 STRLEN utf8_variant_count = 0; /* When not in UTF-8, this counts the
2906 number of characters found so far
2907 that will expand (into 2 bytes)
2908 should we have to convert to
2910 SV *res; /* result from charnames */
2911 STRLEN offset_to_max = 0; /* The offset in the output to where the range
2912 high-end character is temporarily placed */
2914 /* Does something require special handling in tr/// ? This avoids extra
2915 * work in a less likely case. As such, khw didn't feel it was worth
2916 * adding any branches to the more mainline code to handle this, which
2917 * means that this doesn't get set in some circumstances when things like
2918 * \x{100} get expanded out. As a result there needs to be extra testing
2919 * done in the tr code */
2920 bool has_above_latin1 = FALSE;
2922 /* Note on sizing: The scanned constant is placed into sv, which is
2923 * initialized by newSV() assuming one byte of output for every byte of
2924 * input. This routine expects newSV() to allocate an extra byte for a
2925 * trailing NUL, which this routine will append if it gets to the end of
2926 * the input. There may be more bytes of input than output (eg., \N{LATIN
2927 * CAPITAL LETTER A}), or more output than input if the constant ends up
2928 * recoded to utf8, but each time a construct is found that might increase
2929 * the needed size, SvGROW() is called. Its size parameter each time is
2930 * based on the best guess estimate at the time, namely the length used so
2931 * far, plus the length the current construct will occupy, plus room for
2932 * the trailing NUL, plus one byte for every input byte still unscanned */
2934 UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2937 int backslash_N = 0; /* ? was the character from \N{} */
2938 int non_portable_endpoint = 0; /* ? In a range is an endpoint
2939 platform-specific like \x65 */
2942 PERL_ARGS_ASSERT_SCAN_CONST;
2944 assert(PL_lex_inwhat != OP_TRANSR);
2945 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
2946 /* If we are doing a trans and we know we want UTF8 set expectation */
2947 has_utf8 = PL_parser->lex_sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2948 this_utf8 = PL_parser->lex_sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2951 /* Protect sv from errors and fatal warnings. */
2952 ENTER_with_name("scan_const");
2956 || dorange /* Handle tr/// range at right edge of input */
2959 /* get transliterations out of the way (they're most literal) */
2960 if (PL_lex_inwhat == OP_TRANS) {
2962 /* But there isn't any special handling necessary unless there is a
2963 * range, so for most cases we just drop down and handle the value
2964 * as any other. There are two exceptions.
2966 * 1. A hyphen indicates that we are actually going to have a
2967 * range. In this case, skip the '-', set a flag, then drop
2968 * down to handle what should be the end range value.
2969 * 2. After we've handled that value, the next time through, that
2970 * flag is set and we fix up the range.
2972 * Ranges entirely within Latin1 are expanded out entirely, in
2973 * order to make the transliteration a simple table look-up.
2974 * Ranges that extend above Latin1 have to be done differently, so
2975 * there is no advantage to expanding them here, so they are
2976 * stored here as Min, ILLEGAL_UTF8_BYTE, Max. The illegal byte
2977 * signifies a hyphen without any possible ambiguity. On EBCDIC
2978 * machines, if the range is expressed as Unicode, the Latin1
2979 * portion is expanded out even if the range extends above
2980 * Latin1. This is because each code point in it has to be
2981 * processed here individually to get its native translation */
2985 /* Here, we don't think we're in a range. If the new character
2986 * is not a hyphen; or if it is a hyphen, but it's too close to
2987 * either edge to indicate a range, or if we haven't output any
2988 * characters yet then it's a regular character. */
2989 if (*s != '-' || s >= send - 1 || s == start || d == SvPVX(sv)) {
2991 /* A regular character. Process like any other, but first
2992 * clear any flags */
2996 non_portable_endpoint = 0;
2999 /* The tests here for being above Latin1 and similar ones
3000 * in the following 'else' suffice to find all such
3001 * occurences in the constant, except those added by a
3002 * backslash escape sequence, like \x{100}. Mostly, those
3003 * set 'has_above_latin1' as appropriate */
3004 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3005 has_above_latin1 = TRUE;
3008 /* Drops down to generic code to process current byte */
3010 else { /* Is a '-' in the context where it means a range */
3011 if (didrange) { /* Something like y/A-C-Z// */
3012 Perl_croak(aTHX_ "Ambiguous range in transliteration"
3018 s++; /* Skip past the hyphen */
3020 /* d now points to where the end-range character will be
3021 * placed. Save it so won't have to go finding it later,
3022 * and drop down to get that character. (Actually we
3023 * instead save the offset, to handle the case where a
3024 * realloc in the meantime could change the actual
3025 * pointer). We'll finish processing the range the next
3026 * time through the loop */
3027 offset_to_max = d - SvPVX_const(sv);
3029 if (this_utf8 && UTF8_IS_ABOVE_LATIN1(*s)) {
3030 has_above_latin1 = TRUE;
3033 /* Drops down to generic code to process current byte */
3035 } /* End of not a range */
3037 /* Here we have parsed a range. Now must handle it. At this
3039 * 'sv' is a SV* that contains the output string we are
3040 * constructing. The final two characters in that string
3041 * are the range start and range end, in order.
3042 * 'd' points to just beyond the range end in the 'sv' string,
3043 * where we would next place something
3044 * 'offset_to_max' is the offset in 'sv' at which the character
3045 * (the range's maximum end point) before 'd' begins.
3047 char * max_ptr = SvPVX(sv) + offset_to_max;
3050 IV range_max; /* last character in range */
3052 Size_t offset_to_min = 0;
3055 bool convert_unicode;
3056 IV real_range_max = 0;
3058 /* Get the code point values of the range ends. */
3060 /* We know the utf8 is valid, because we just constructed
3061 * it ourselves in previous loop iterations */
3062 min_ptr = (char*) utf8_hop( (U8*) max_ptr, -1);
3063 range_min = valid_utf8_to_uvchr( (U8*) min_ptr, NULL);
3064 range_max = valid_utf8_to_uvchr( (U8*) max_ptr, NULL);
3066 /* This compensates for not all code setting
3067 * 'has_above_latin1', so that we don't skip stuff that
3068 * should be executed */
3069 if (range_max > 255) {
3070 has_above_latin1 = TRUE;
3074 min_ptr = max_ptr - 1;
3075 range_min = * (U8*) min_ptr;
3076 range_max = * (U8*) max_ptr;
3079 /* If the range is just a single code point, like tr/a-a/.../,
3080 * that code point is already in the output, twice. We can
3081 * just back up over the second instance and avoid all the rest
3082 * of the work. But if it is a variant character, it's been
3083 * counted twice, so decrement. (This unlikely scenario is
3084 * special cased, like the one for a range of 2 code points
3085 * below, only because the main-line code below needs a range
3086 * of 3 or more to work without special casing. Might as well
3087 * get it out of the way now.) */
3088 if (UNLIKELY(range_max == range_min)) {
3090 if (! has_utf8 && ! UVCHR_IS_INVARIANT(range_max)) {
3091 utf8_variant_count--;
3097 /* On EBCDIC platforms, we may have to deal with portable
3098 * ranges. These happen if at least one range endpoint is a
3099 * Unicode value (\N{...}), or if the range is a subset of
3100 * [A-Z] or [a-z], and both ends are literal characters,
3101 * like 'A', and not like \x{C1} */
3103 cBOOL(backslash_N) /* \N{} forces Unicode,
3104 hence portable range */
3105 || ( ! non_portable_endpoint
3106 && (( isLOWER_A(range_min) && isLOWER_A(range_max))
3107 || (isUPPER_A(range_min) && isUPPER_A(range_max))));
3108 if (convert_unicode) {
3110 /* Special handling is needed for these portable ranges.
3111 * They are defined to be in Unicode terms, which includes
3112 * all the Unicode code points between the end points.
3113 * Convert to Unicode to get the Unicode range. Later we
3114 * will convert each code point in the range back to
3116 range_min = NATIVE_TO_UNI(range_min);
3117 range_max = NATIVE_TO_UNI(range_max);
3121 if (range_min > range_max) {
3123 if (convert_unicode) {
3124 /* Need to convert back to native for meaningful
3125 * messages for this platform */
3126 range_min = UNI_TO_NATIVE(range_min);
3127 range_max = UNI_TO_NATIVE(range_max);
3130 /* Use the characters themselves for the error message if
3131 * ASCII printables; otherwise some visible representation
3133 if (isPRINT_A(range_min) && isPRINT_A(range_max)) {
3135 "Invalid range \"%c-%c\" in transliteration operator",
3136 (char)range_min, (char)range_max);
3139 else if (convert_unicode) {
3140 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3142 "Invalid range \"\\N{U+%04" UVXf "}-\\N{U+%04"
3143 UVXf "}\" in transliteration operator",
3144 range_min, range_max);
3148 /* diag_listed_as: Invalid range "%s" in transliteration operator */
3150 "Invalid range \"\\x{%04" UVXf "}-\\x{%04" UVXf "}\""
3151 " in transliteration operator",
3152 range_min, range_max);
3156 /* If the range is exactly two code points long, they are
3157 * already both in the output */
3158 if (UNLIKELY(range_min + 1 == range_max)) {
3162 /* Here the range contains at least 3 code points */
3166 /* If everything in the transliteration is below 256, we
3167 * can avoid special handling later. A translation table
3168 * for each of those bytes is created by op.c. So we
3169 * expand out all ranges to their constituent code points.
3170 * But if we've encountered something above 255, the
3171 * expanding won't help, so skip doing that. But if it's
3172 * EBCDIC, we may have to look at each character below 256
3173 * if we have to convert to/from Unicode values */
3174 if ( has_above_latin1
3176 && (range_min > 255 || ! convert_unicode)
3179 /* Move the high character one byte to the right; then
3180 * insert between it and the range begin, an illegal
3181 * byte which serves to indicate this is a range (using
3182 * a '-' would be ambiguous). */
3184 while (e-- > max_ptr) {
3187 *(e + 1) = (char) ILLEGAL_UTF8_BYTE;
3191 /* Here, we're going to expand out the range. For EBCDIC
3192 * the range can extend above 255 (not so in ASCII), so
3193 * for EBCDIC, split it into the parts above and below
3196 if (range_max > 255) {
3197 real_range_max = range_max;
3203 /* Here we need to expand out the string to contain each
3204 * character in the range. Grow the output to handle this.
3205 * For non-UTF8, we need a byte for each code point in the
3206 * range, minus the three that we've already allocated for: the
3207 * hyphen, the min, and the max. For UTF-8, we need this
3208 * plus an extra byte for each code point that occupies two
3209 * bytes (is variant) when in UTF-8 (except we've already
3210 * allocated for the end points, including if they are
3211 * variants). For ASCII platforms and Unicode ranges on EBCDIC
3212 * platforms, it's easy to calculate a precise number. To
3213 * start, we count the variants in the range, which we need
3214 * elsewhere in this function anyway. (For the case where it
3215 * isn't easy to calculate, 'extras' has been initialized to 0,
3216 * and the calculation is done in a loop further down.) */
3218 if (convert_unicode)
3221 /* This is executed unconditionally on ASCII, and for
3222 * Unicode ranges on EBCDIC. Under these conditions, all
3223 * code points above a certain value are variant; and none
3224 * under that value are. We just need to find out how much
3225 * of the range is above that value. We don't count the
3226 * end points here, as they will already have been counted
3227 * as they were parsed. */
3228 if (range_min >= UTF_CONTINUATION_MARK) {
3230 /* The whole range is made up of variants */
3231 extras = (range_max - 1) - (range_min + 1) + 1;
3233 else if (range_max >= UTF_CONTINUATION_MARK) {
3235 /* Only the higher portion of the range is variants */
3236 extras = (range_max - 1) - UTF_CONTINUATION_MARK + 1;
3239 utf8_variant_count += extras;
3242 /* The base growth is the number of code points in the range,
3243 * not including the endpoints, which have already been sized
3244 * for (and output). We don't subtract for the hyphen, as it
3245 * has been parsed but not output, and the SvGROW below is
3246 * based only on what's been output plus what's left to parse.
3248 grow = (range_max - 1) - (range_min + 1) + 1;
3252 /* In some cases in EBCDIC, we haven't yet calculated a
3253 * precise amount needed for the UTF-8 variants. Just
3254 * assume the worst case, that everything will expand by a
3256 if (! convert_unicode) {
3262 /* Otherwise we know exactly how many variants there
3263 * are in the range. */
3268 /* Grow, but position the output to overwrite the range min end
3269 * point, because in some cases we overwrite that */
3270 SvCUR_set(sv, d - SvPVX_const(sv));
3271 offset_to_min = min_ptr - SvPVX_const(sv);
3273 /* See Note on sizing above. */
3274 d = offset_to_min + SvGROW(sv, SvCUR(sv)
3277 + 1 /* Trailing NUL */ );
3279 /* Now, we can expand out the range. */
3281 if (convert_unicode) {
3284 /* Recall that the min and max are now in Unicode terms, so
3285 * we have to convert each character to its native
3288 for (i = range_min; i <= range_max; i++) {
3289 append_utf8_from_native_byte(
3290 LATIN1_TO_NATIVE((U8) i),
3295 for (i = range_min; i <= range_max; i++) {
3296 *d++ = (char)LATIN1_TO_NATIVE((U8) i);
3302 /* Always gets run for ASCII, and sometimes for EBCDIC. */
3304 /* Here, no conversions are necessary, which means that the
3305 * first character in the range is already in 'd' and
3306 * valid, so we can skip overwriting it */
3310 for (i = range_min + 1; i <= range_max; i++) {
3311 append_utf8_from_native_byte((U8) i, (U8 **) &d);
3317 assert(range_min + 1 <= range_max);
3318 for (i = range_min + 1; i < range_max; i++) {
3320 /* In this case on EBCDIC, we haven't calculated
3321 * the variants. Do it here, as we go along */
3322 if (! UVCHR_IS_INVARIANT(i)) {
3323 utf8_variant_count++;
3329 /* The range_max is done outside the loop so as to
3330 * avoid having to special case not incrementing
3331 * 'utf8_variant_count' on EBCDIC (it's already been
3332 * counted when originally parsed) */
3333 *d++ = (char) range_max;
3338 /* If the original range extended above 255, add in that
3340 if (real_range_max) {
3341 *d++ = (char) UTF8_TWO_BYTE_HI(0x100);
3342 *d++ = (char) UTF8_TWO_BYTE_LO(0x100);
3343 if (real_range_max > 0x100) {
3344 if (real_range_max > 0x101) {
3345 *d++ = (char) ILLEGAL_UTF8_BYTE;
3347 d = (char*)uvchr_to_utf8((U8*)d, real_range_max);
3353 /* mark the range as done, and continue */
3357 non_portable_endpoint = 0;
3361 } /* End of is a range */
3362 } /* End of transliteration. Joins main code after these else's */
3363 else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3366 while (s1 >= start && *s1-- == '\\')
3369 in_charclass = TRUE;
3371 else if (*s == ']' && PL_lex_inpat && in_charclass) {
3374 while (s1 >= start && *s1-- == '\\')
3377 in_charclass = FALSE;
3379 /* skip for regexp comments /(?#comment)/, except for the last
3380 * char, which will be done separately. Stop on (?{..}) and
3382 else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3384 while (s+1 < send && *s != ')')
3387 else if (!PL_lex_casemods
3388 && ( s[2] == '{' /* This should match regcomp.c */
3389 || (s[2] == '?' && s[3] == '{')))
3394 /* likewise skip #-initiated comments in //x patterns */
3398 && ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED)
3400 while (s < send && *s != '\n')
3403 /* no further processing of single-quoted regex */
3404 else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3405 goto default_action;
3407 /* check for embedded arrays
3408 * (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3410 else if (*s == '@' && s[1]) {
3412 ? isIDFIRST_utf8_safe(s+1, send)
3413 : isWORDCHAR_A(s[1]))
3417 if (strchr(":'{$", s[1]))
3419 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3420 break; /* in regexp, neither @+ nor @- are interpolated */
3422 /* check for embedded scalars. only stop if we're sure it's a
3424 else if (*s == '$') {
3425 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3427 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3429 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3430 "Possible unintended interpolation of $\\ in regex");
3432 break; /* in regexp, $ might be tail anchor */
3436 /* End of else if chain - OP_TRANS rejoin rest */
3438 if (UNLIKELY(s >= send)) {
3444 if (*s == '\\' && s+1 < send) {
3445 char* e; /* Can be used for ending '}', etc. */
3449 /* warn on \1 - \9 in substitution replacements, but note that \11
3450 * is an octal; and \19 is \1 followed by '9' */
3451 if (PL_lex_inwhat == OP_SUBST
3457 /* diag_listed_as: \%d better written as $%d */
3458 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3463 /* string-change backslash escapes */
3464 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3468 /* In a pattern, process \N, but skip any other backslash escapes.
3469 * This is because we don't want to translate an escape sequence
3470 * into a meta symbol and have the regex compiler use the meta
3471 * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3472 * in spite of this, we do have to process \N here while the proper
3473 * charnames handler is in scope. See bugs #56444 and #62056.
3475 * There is a complication because \N in a pattern may also stand
3476 * for 'match a non-nl', and not mean a charname, in which case its
3477 * processing should be deferred to the regex compiler. To be a
3478 * charname it must be followed immediately by a '{', and not look
3479 * like \N followed by a curly quantifier, i.e., not something like
3480 * \N{3,}. regcurly returns a boolean indicating if it is a legal
3482 else if (PL_lex_inpat
3485 || regcurly(s + 1)))
3488 goto default_action;
3494 if ((isALPHANUMERIC(*s)))
3495 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3496 "Unrecognized escape \\%c passed through",
3498 /* default action is to copy the quoted character */
3499 goto default_action;
3502 /* eg. \132 indicates the octal constant 0132 */
3503 case '0': case '1': case '2': case '3':
3504 case '4': case '5': case '6': case '7':
3506 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3508 uv = grok_oct(s, &len, &flags, NULL);
3510 if (len < 3 && s < send && isDIGIT(*s)
3511 && ckWARN(WARN_MISC))
3513 Perl_warner(aTHX_ packWARN(WARN_MISC),
3514 "%s", form_short_octal_warning(s, len));
3517 goto NUM_ESCAPE_INSERT;
3519 /* eg. \o{24} indicates the octal constant \024 */
3524 bool valid = grok_bslash_o(&s, PL_bufend,
3526 TRUE, /* Output warning */
3527 FALSE, /* Not strict */
3528 TRUE, /* Output warnings for
3533 uv = 0; /* drop through to ensure range ends are set */
3535 goto NUM_ESCAPE_INSERT;
3538 /* eg. \x24 indicates the hex constant 0x24 */
3543 bool valid = grok_bslash_x(&s, PL_bufend,
3545 TRUE, /* Output warning */
3546 FALSE, /* Not strict */
3547 TRUE, /* Output warnings for
3552 uv = 0; /* drop through to ensure range ends are set */
3557 /* Insert oct or hex escaped character. */
3559 /* Here uv is the ordinal of the next character being added */
3560 if (UVCHR_IS_INVARIANT(uv)) {
3564 if (!has_utf8 && uv > 255) {
3566 /* Here, 'uv' won't fit unless we convert to UTF-8.
3567 * If we've only seen invariants so far, all we have to
3568 * do is turn on the flag */
3569 if (utf8_variant_count == 0) {
3573 SvCUR_set(sv, d - SvPVX_const(sv));
3577 sv_utf8_upgrade_flags_grow(
3579 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3581 /* Since we're having to grow here,
3582 * make sure we have enough room for
3583 * this escape and a NUL, so the
3584 * code immediately below won't have
3585 * to actually grow again */
3587 + (STRLEN)(send - s) + 1);
3588 d = SvPVX(sv) + SvCUR(sv);
3591 has_above_latin1 = TRUE;
3597 utf8_variant_count++;
3600 /* Usually, there will already be enough room in 'sv'
3601 * since such escapes are likely longer than any UTF-8
3602 * sequence they can end up as. This isn't the case on
3603 * EBCDIC where \x{40000000} contains 12 bytes, and the
3604 * UTF-8 for it contains 14. And, we have to allow for
3605 * a trailing NUL. It probably can't happen on ASCII
3606 * platforms, but be safe. See Note on sizing above. */
3607 const STRLEN needed = d - SvPVX(sv)
3611 if (UNLIKELY(needed > SvLEN(sv))) {
3612 SvCUR_set(sv, d - SvPVX_const(sv));
3613 d = SvCUR(sv) + SvGROW(sv, needed);
3616 d = (char*)uvchr_to_utf8((U8*)d, uv);
3617 if (PL_lex_inwhat == OP_TRANS
3618 && PL_parser->lex_sub_op)
3620 PL_parser->lex_sub_op->op_private |=
3621 (PL_lex_repl ? OPpTRANS_FROM_UTF
3627 non_portable_endpoint++;
3632 /* In a non-pattern \N must be like \N{U+0041}, or it can be a
3633 * named character, like \N{LATIN SMALL LETTER A}, or a named
3634 * sequence, like \N{LATIN CAPITAL LETTER A WITH MACRON AND
3635 * GRAVE} (except y/// can't handle the latter, croaking). For
3636 * convenience all three forms are referred to as "named
3637 * characters" below.
3639 * For patterns, \N also can mean to match a non-newline. Code
3640 * before this 'switch' statement should already have handled
3641 * this situation, and hence this code only has to deal with
3642 * the named character cases.
3644 * For non-patterns, the named characters are converted to
3645 * their string equivalents. In patterns, named characters are
3646 * not converted to their ultimate forms for the same reasons
3647 * that other escapes aren't (mainly that the ultimate
3648 * character could be considered a meta-symbol by the regex
3649 * compiler). Instead, they are converted to the \N{U+...}
3650 * form to get the value from the charnames that is in effect
3651 * right now, while preserving the fact that it was a named
3652 * character, so that the regex compiler knows this.
3654 * The structure of this section of code (besides checking for
3655 * errors and upgrading to utf8) is:
3656 * If the named character is of the form \N{U+...}, pass it
3657 * through if a pattern; otherwise convert the code point
3659 * Otherwise must be some \N{NAME}: convert to
3660 * \N{U+c1.c2...} if a pattern; otherwise convert to utf8
3662 * Transliteration is an exception. The conversion to utf8 is
3663 * only done if the code point requires it to be representable.
3665 * Here, 's' points to the 'N'; the test below is guaranteed to
3666 * succeed if we are being called on a pattern, as we already
3667 * know from a test above that the next character is a '{'. A
3668 * non-pattern \N must mean 'named character', which requires
3672 yyerror("Missing braces on \\N{}");
3678 /* If there is no matching '}', it is an error. */
3679 if (! (e = (char *) memchr(s, '}', send - s))) {
3680 if (! PL_lex_inpat) {
3681 yyerror("Missing right brace on \\N{}");
3683 yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3685 yyquit(); /* Have exhausted the input. */
3688 /* Here it looks like a named character */
3690 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3691 s += 2; /* Skip to next char after the 'U+' */
3694 /* In patterns, we can have \N{U+xxxx.yyyy.zzzz...} */
3695 /* Check the syntax. */
3698 if (!isXDIGIT(*s)) {
3701 "Invalid hexadecimal number in \\N{U+...}"
3710 else if ((*s == '.' || *s == '_')
3716 /* Pass everything through unchanged.
3717 * +1 is for the '}' */
3718 Copy(orig_s, d, e - orig_s + 1, char);
3719 d += e - orig_s + 1;
3721 else { /* Not a pattern: convert the hex to string */
3722 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3723 | PERL_SCAN_SILENT_ILLDIGIT
3724 | PERL_SCAN_DISALLOW_PREFIX;
3726 uv = grok_hex(s, &len, &flags, NULL);
3727 if (len == 0 || (len != (STRLEN)(e - s)))
3730 /* For non-tr///, if the destination is not in utf8,
3731 * unconditionally recode it to be so. This is
3732 * because \N{} implies Unicode semantics, and scalars
3733 * have to be in utf8 to guarantee those semantics.
3734 * tr/// doesn't care about Unicode rules, so no need
3735 * there to upgrade to UTF-8 for small enough code
3737 if (! has_utf8 && ( uv > 0xFF
3738 || PL_lex_inwhat != OP_TRANS))
3740 /* See Note on sizing above. */
3741 const STRLEN extra = OFFUNISKIP(uv) + (send - e) + 1;
3743 SvCUR_set(sv, d - SvPVX_const(sv));
3747 if (utf8_variant_count == 0) {
3749 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3752 sv_utf8_upgrade_flags_grow(
3754 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3756 d = SvPVX(sv) + SvCUR(sv);
3760 has_above_latin1 = TRUE;
3763 /* Add the (Unicode) code point to the output. */
3764 if (! has_utf8 || OFFUNI_IS_INVARIANT(uv)) {
3765 *d++ = (char) LATIN1_TO_NATIVE(uv);
3768 d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3772 else /* Here is \N{NAME} but not \N{U+...}. */
3773 if ((res = get_and_check_backslash_N_name(s, e)))
3776 const char *str = SvPV_const(res, len);
3779 if (! len) { /* The name resolved to an empty string */
3780 Copy("\\N{}", d, 4, char);
3784 /* In order to not lose information for the regex
3785 * compiler, pass the result in the specially made
3786 * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3787 * the code points in hex of each character
3788 * returned by charnames */
3790 const char *str_end = str + len;
3791 const STRLEN off = d - SvPVX_const(sv);
3793 if (! SvUTF8(res)) {
3794 /* For the non-UTF-8 case, we can determine the
3795 * exact length needed without having to parse
3796 * through the string. Each character takes up
3797 * 2 hex digits plus either a trailing dot or
3799 const char initial_text[] = "\\N{U+";
3800 const STRLEN initial_len = sizeof(initial_text)
3802 d = off + SvGROW(sv, off
3805 /* +1 for trailing NUL */
3808 + (STRLEN)(send - e));
3809 Copy(initial_text, d, initial_len, char);
3811 while (str < str_end) {
3814 my_snprintf(hex_string,
3818 /* The regex compiler is
3819 * expecting Unicode, not
3821 NATIVE_TO_LATIN1(*str));
3822 PERL_MY_SNPRINTF_POST_GUARD(len,
3823 sizeof(hex_string));
3824 Copy(hex_string, d, 3, char);
3828 d--; /* Below, we will overwrite the final
3829 dot with a right brace */
3832 STRLEN char_length; /* cur char's byte length */
3834 /* and the number of bytes after this is
3835 * translated into hex digits */
3836 STRLEN output_length;
3838 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3839 * for max('U+', '.'); and 1 for NUL */
3840 char hex_string[2 * UTF8_MAXBYTES + 5];
3842 /* Get the first character of the result. */
3843 U32 uv = utf8n_to_uvchr((U8 *) str,
3847 /* Convert first code point to Unicode hex,
3848 * including the boiler plate before it. */
3850 my_snprintf(hex_string, sizeof(hex_string),
3852 (unsigned int) NATIVE_TO_UNI(uv));
3854 /* Make sure there is enough space to hold it */
3855 d = off + SvGROW(sv, off
3857 + (STRLEN)(send - e)
3858 + 2); /* '}' + NUL */
3860 Copy(hex_string, d, output_length, char);
3863 /* For each subsequent character, append dot and
3864 * its Unicode code point in hex */
3865 while ((str += char_length) < str_end) {
3866 const STRLEN off = d - SvPVX_const(sv);
3867 U32 uv = utf8n_to_uvchr((U8 *) str,
3872 my_snprintf(hex_string,
3875 (unsigned int) NATIVE_TO_UNI(uv));
3877 d = off + SvGROW(sv, off
3879 + (STRLEN)(send - e)
3880 + 2); /* '}' + NUL */
3881 Copy(hex_string, d, output_length, char);
3886 *d++ = '}'; /* Done. Add the trailing brace */
3889 else { /* Here, not in a pattern. Convert the name to a
3892 if (PL_lex_inwhat == OP_TRANS) {
3893 str = SvPV_const(res, len);
3894 if (len > ((SvUTF8(res))
3898 yyerror(Perl_form(aTHX_
3899 "%.*s must not be a named sequence"
3900 " in transliteration operator",
3901 /* +1 to include the "}" */
3902 (int) (e + 1 - start), start));
3904 goto end_backslash_N;
3907 if (SvUTF8(res) && UTF8_IS_ABOVE_LATIN1(*str)) {
3908 has_above_latin1 = TRUE;
3912 else if (! SvUTF8(res)) {
3913 /* Make sure \N{} return is UTF-8. This is because
3914 * \N{} implies Unicode semantics, and scalars have
3915 * to be in utf8 to guarantee those semantics; but
3916 * not needed in tr/// */
3917 sv_utf8_upgrade_flags(res, 0);
3918 str = SvPV_const(res, len);
3921 /* Upgrade destination to be utf8 if this new
3923 if (! has_utf8 && SvUTF8(res)) {
3924 /* See Note on sizing above. */
3925 const STRLEN extra = len + (send - s) + 1;
3927 SvCUR_set(sv, d - SvPVX_const(sv));
3931 if (utf8_variant_count == 0) {
3933 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + extra);
3936 sv_utf8_upgrade_flags_grow(sv,
3937 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3939 d = SvPVX(sv) + SvCUR(sv);
3942 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3944 /* See Note on sizing above. (NOTE: SvCUR() is not
3945 * set correctly here). */
3946 const STRLEN extra = len + (send - e) + 1;
3947 const STRLEN off = d - SvPVX_const(sv);
3948 d = off + SvGROW(sv, off + extra);
3950 Copy(str, d, len, char);
3956 } /* End \N{NAME} */
3960 backslash_N++; /* \N{} is defined to be Unicode */
3962 s = e + 1; /* Point to just after the '}' */
3965 /* \c is a control character */
3969 *d++ = grok_bslash_c(*s, 1);
3972 yyerror("Missing control char name in \\c");
3973 yyquit(); /* Are at end of input, no sense continuing */
3976 non_portable_endpoint++;
3980 /* printf-style backslashes, formfeeds, newlines, etc */
4006 } /* end if (backslash) */
4009 /* Just copy the input to the output, though we may have to convert
4012 * If the input has the same representation in UTF-8 as not, it will be
4013 * a single byte, and we don't care about UTF8ness; just copy the byte */
4014 if (NATIVE_BYTE_IS_INVARIANT((U8)(*s))) {
4017 else if (! this_utf8 && ! has_utf8) {
4018 /* If neither source nor output is UTF-8, is also a single byte,
4019 * just copy it; but this byte counts should we later have to
4020 * convert to UTF-8 */
4022 utf8_variant_count++;
4024 else if (this_utf8 && has_utf8) { /* Both UTF-8, can just copy */
4025 const STRLEN len = UTF8SKIP(s);
4027 /* We expect the source to have already been checked for
4029 assert(isUTF8_CHAR((U8 *) s, (U8 *) send));
4031 Copy(s, d, len, U8);
4035 else { /* UTF8ness matters and doesn't match, need to convert */
4037 const UV nextuv = (this_utf8)
4038 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
4040 STRLEN need = UVCHR_SKIP(nextuv);
4043 SvCUR_set(sv, d - SvPVX_const(sv));
4047 /* See Note on sizing above. */
4048 need += (STRLEN)(send - s) + 1;
4050 if (utf8_variant_count == 0) {
4052 d = SvCUR(sv) + SvGROW(sv, SvCUR(sv) + need);
4055 sv_utf8_upgrade_flags_grow(sv,
4056 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
4058 d = SvPVX(sv) + SvCUR(sv);
4061 } else if (need > len) {
4062 /* encoded value larger than old, may need extra space (NOTE:
4063 * SvCUR() is not set correctly here). See Note on sizing
4065 const STRLEN extra = need + (send - s) + 1;
4066 const STRLEN off = d - SvPVX_const(sv);
4067 d = off + SvGROW(sv, off + extra);
4071 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
4073 } /* while loop to process each character */
4075 /* terminate the string and set up the sv */
4077 SvCUR_set(sv, d - SvPVX_const(sv));
4078 if (SvCUR(sv) >= SvLEN(sv))
4079 Perl_croak(aTHX_ "panic: constant overflowed allocated space, %" UVuf
4080 " >= %" UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
4085 if (PL_lex_inwhat == OP_TRANS && PL_parser->lex_sub_op) {
4086 PL_parser->lex_sub_op->op_private |=
4087 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
4091 /* shrink the sv if we allocated more than we used */
4092 if (SvCUR(sv) + 5 < SvLEN(sv)) {
4093 SvPV_shrink_to_cur(sv);
4096 /* return the substring (via pl_yylval) only if we parsed anything */
4099 for (; s2 < s; s2++) {
4101 COPLINE_INC_WITH_HERELINES;
4103 SvREFCNT_inc_simple_void_NN(sv);
4104 if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
4105 && ! PL_parser->lex_re_reparsing)
4107 const char *const key = PL_lex_inpat ? "qr" : "q";
4108 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
4112 if (PL_lex_inwhat == OP_TRANS) {
4115 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
4118 } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
4126 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
4129 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
4131 LEAVE_with_name("scan_const");
4136 * Returns TRUE if there's more to the expression (e.g., a subscript),
4139 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
4141 * ->[ and ->{ return TRUE
4142 * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
4143 * { and [ outside a pattern are always subscripts, so return TRUE
4144 * if we're outside a pattern and it's not { or [, then return FALSE
4145 * if we're in a pattern and the first char is a {
4146 * {4,5} (any digits around the comma) returns FALSE
4147 * if we're in a pattern and the first char is a [
4149 * [SOMETHING] has a funky algorithm to decide whether it's a
4150 * character class or not. It has to deal with things like
4151 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
4152 * anything else returns TRUE
4155 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
4158 S_intuit_more(pTHX_ char *s, char *e)
4160 PERL_ARGS_ASSERT_INTUIT_MORE;
4162 if (PL_lex_brackets)
4164 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
4166 if (*s == '-' && s[1] == '>'
4167 && FEATURE_POSTDEREF_QQ_IS_ENABLED
4168 && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
4169 ||(s[2] == '@' && strchr("*[{",s[3])) ))
4171 if (*s != '{' && *s != '[')
4173 PL_parser->sub_no_recover = TRUE;
4177 /* In a pattern, so maybe we have {n,m}. */
4185 /* On the other hand, maybe we have a character class */
4188 if (*s == ']' || *s == '^')
4191 /* this is terrifying, and it works */
4194 const char * const send = (char *) memchr(s, ']', e - s);
4195 unsigned char un_char, last_un_char;
4196 char tmpbuf[sizeof PL_tokenbuf * 4];
4198 if (!send) /* has to be an expression */
4200 weight = 2; /* let's weigh the evidence */
4204 else if (isDIGIT(*s)) {
4206 if (isDIGIT(s[1]) && s[2] == ']')
4212 Zero(seen,256,char);
4214 for (; s < send; s++) {
4215 last_un_char = un_char;
4216 un_char = (unsigned char)*s;
4221 weight -= seen[un_char] * 10;
4222 if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) {
4224 scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
4225 len = (int)strlen(tmpbuf);
4226 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
4227 UTF ? SVf_UTF8 : 0, SVt_PV))
4234 && strchr("[#!%*<>()-=",s[1]))
4236 if (/*{*/ strchr("])} =",s[2]))
4245 if (strchr("wds]",s[1]))
4247 else if (seen[(U8)'\''] || seen[(U8)'"'])
4249 else if (strchr("rnftbxcav",s[1]))
4251 else if (isDIGIT(s[1])) {
4253 while (s[1] && isDIGIT(s[1]))
4263 if (strchr("aA01! ",last_un_char))
4265 if (strchr("zZ79~",s[1]))
4267 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4268 weight -= 5; /* cope with negative subscript */
4271 if (!isWORDCHAR(last_un_char)
4272 && !(last_un_char == '$' || last_un_char == '@'
4273 || last_un_char == '&')
4274 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4278 if (keyword(d, s - d, 0))
4281 if (un_char == last_un_char + 1)
4283 weight -= seen[un_char];
4288 if (weight >= 0) /* probably a character class */
4298 * Does all the checking to disambiguate
4300 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4301 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4303 * First argument is the stuff after the first token, e.g. "bar".
4305 * Not a method if foo is a filehandle.
4306 * Not a method if foo is a subroutine prototyped to take a filehandle.
4307 * Not a method if it's really "Foo $bar"
4308 * Method if it's "foo $bar"
4309 * Not a method if it's really "print foo $bar"
4310 * Method if it's really "foo package::" (interpreted as package->foo)
4311 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4312 * Not a method if bar is a filehandle or package, but is quoted with
4317 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
4319 char *s = start + (*start == '$');
4320 char tmpbuf[sizeof PL_tokenbuf];
4323 /* Mustn't actually add anything to a symbol table.
4324 But also don't want to "initialise" any placeholder
4325 constants that might already be there into full
4326 blown PVGVs with attached PVCV. */
4328 ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
4330 PERL_ARGS_ASSERT_INTUIT_METHOD;
4332 if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4334 if (cv && SvPOK(cv)) {
4335 const char *proto = CvPROTO(cv);
4337 while (*proto && (isSPACE(*proto) || *proto == ';'))
4344 if (*start == '$') {
4345 SSize_t start_off = start - SvPVX(PL_linestr);
4346 if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY
4347 || isUPPER(*PL_tokenbuf))
4349 /* this could be $# */
4352 PL_bufptr = SvPVX(PL_linestr) + start_off;
4354 return *s == '(' ? FUNCMETH : METHOD;
4357 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4358 /* start is the beginning of the possible filehandle/object,
4359 * and s is the end of it
4360 * tmpbuf is a copy of it (but with single quotes as double colons)
4363 if (!keyword(tmpbuf, len, 0)) {
4364 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4369 indirgv = gv_fetchpvn_flags(tmpbuf, len,
4370 GV_NOADD_NOINIT|( UTF ? SVf_UTF8 : 0 ),
4372 if (indirgv && SvTYPE(indirgv) != SVt_NULL
4373 && (!isGV(indirgv) || GvCVu(indirgv)))
4375 /* filehandle or package name makes it a method */
4376 if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4378 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4379 return 0; /* no assumptions -- "=>" quotes bareword */
4381 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0,
4382 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4383 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4385 force_next(BAREWORD);
4387 return *s == '(' ? FUNCMETH : METHOD;
4393 /* Encoded script support. filter_add() effectively inserts a
4394 * 'pre-processing' function into the current source input stream.
4395 * Note that the filter function only applies to the current source file
4396 * (e.g., it will not affect files 'require'd or 'use'd by this one).
4398 * The datasv parameter (which may be NULL) can be used to pass
4399 * private data to this instance of the filter. The filter function
4400 * can recover the SV using the FILTER_DATA macro and use it to
4401 * store private buffers and state information.
4403 * The supplied datasv parameter is upgraded to a PVIO type
4404 * and the IoDIRP/IoANY field is used to store the function pointer,
4405 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4406 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4407 * private use must be set using malloc'd pointers.
4411 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4419 if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4420 Perl_croak(aTHX_ "Source filters apply only to byte streams");
4422 if (!PL_rsfp_filters)
4423 PL_rsfp_filters = newAV();
4426 SvUPGRADE(datasv, SVt_PVIO);
4427 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4428 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4429 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4430 FPTR2DPTR(void *, IoANY(datasv)),
4431 SvPV_nolen(datasv)));
4432 av_unshift(PL_rsfp_filters, 1);
4433 av_store(PL_rsfp_filters, 0, datasv) ;
4435 !PL_parser->filtered
4436 && PL_parser->lex_flags & LEX_EVALBYTES
4437 && PL_bufptr < PL_bufend
4439 const char *s = PL_bufptr;
4440 while (s < PL_bufend) {
4442 SV *linestr = PL_parser->linestr;
4443 char *buf = SvPVX(linestr);
4444 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4445 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4446 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4447 STRLEN const linestart_pos = PL_parser->linestart - buf;
4448 STRLEN const last_uni_pos =
4449 PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4450 STRLEN const last_lop_pos =
4451 PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4452 av_push(PL_rsfp_filters, linestr);
4453 PL_parser->linestr =
4454 newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4455 buf = SvPVX(PL_parser->linestr);
4456 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4457 PL_parser->bufptr = buf + bufptr_pos;
4458 PL_parser->oldbufptr = buf + oldbufptr_pos;
4459 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4460 PL_parser->linestart = buf + linestart_pos;
4461 if (PL_parser->last_uni)
4462 PL_parser->last_uni = buf + last_uni_pos;
4463 if (PL_parser->last_lop)
4464 PL_parser->last_lop = buf + last_lop_pos;
4465 SvLEN_set(linestr, SvCUR(linestr));
4466 SvCUR_set(linestr, s - SvPVX(linestr));
4467 PL_parser->filtered = 1;
4477 /* Delete most recently added instance of this filter function. */
4479 Perl_filter_del(pTHX_ filter_t funcp)
4483 PERL_ARGS_ASSERT_FILTER_DEL;
4486 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4487 FPTR2DPTR(void*, funcp)));
4489 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4491 /* if filter is on top of stack (usual case) just pop it off */
4492 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4493 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4494 sv_free(av_pop(PL_rsfp_filters));
4498 /* we need to search for the correct entry and clear it */
4499 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4503 /* Invoke the idxth filter function for the current rsfp. */
4504 /* maxlen 0 = read one text line */
4506 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4511 /* This API is bad. It should have been using unsigned int for maxlen.
4512 Not sure if we want to change the API, but if not we should sanity
4513 check the value here. */
4514 unsigned int correct_length = maxlen < 0 ? PERL_INT_MAX : maxlen;
4516 PERL_ARGS_ASSERT_FILTER_READ;
4518 if (!PL_parser || !PL_rsfp_filters)
4520 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4521 /* Provide a default input filter to make life easy. */
4522 /* Note that we append to the line. This is handy. */
4523 DEBUG_P(PerlIO_printf(Perl_debug_log,
4524 "filter_read %d: from rsfp\n", idx));
4525 if (correct_length) {
4528 const int old_len = SvCUR(buf_sv);
4530 /* ensure buf_sv is large enough */
4531 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4532 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4533 correct_length)) <= 0) {
4534 if (PerlIO_error(PL_rsfp))
4535 return -1; /* error */
4537 return 0 ; /* end of file */
4539 SvCUR_set(buf_sv, old_len + len) ;
4540 SvPVX(buf_sv)[old_len + len] = '\0';
4543 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4544 if (PerlIO_error(PL_rsfp))
4545 return -1; /* error */
4547 return 0 ; /* end of file */
4550 return SvCUR(buf_sv);
4552 /* Skip this filter slot if filter has been deleted */
4553 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4554 DEBUG_P(PerlIO_printf(Perl_debug_log,
4555 "filter_read %d: skipped (filter deleted)\n",
4557 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4559 if (SvTYPE(datasv) != SVt_PVIO) {
4560 if (correct_length) {
4562 const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4563 if (!remainder) return 0; /* eof */
4564 if (correct_length > remainder) correct_length = remainder;
4565 sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4566 SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4569 const char *s = SvEND(datasv);
4570 const char *send = SvPVX(datasv) + SvLEN(datasv);
4578 if (s == send) return 0; /* eof */
4579 sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4580 SvCUR_set(datasv, s-SvPVX(datasv));
4582 return SvCUR(buf_sv);
4584 /* Get function pointer hidden within datasv */
4585 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4586 DEBUG_P(PerlIO_printf(Perl_debug_log,
4587 "filter_read %d: via function %p (%s)\n",
4588 idx, (void*)datasv, SvPV_nolen_const(datasv)));
4589 /* Call function. The function is expected to */
4590 /* call "FILTER_READ(idx+1, buf_sv)" first. */
4591 /* Return: <0:error, =0:eof, >0:not eof */
4593 save_scalar(PL_errgv);
4594 ret = (*funcp)(aTHX_ idx, buf_sv, correct_length);
4600 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4602 PERL_ARGS_ASSERT_FILTER_GETS;
4604 #ifdef PERL_CR_FILTER
4605 if (!PL_rsfp_filters) {
4606 filter_add(S_cr_textfilter,NULL);
4609 if (PL_rsfp_filters) {
4611 SvCUR_set(sv, 0); /* start with empty line */
4612 if (FILTER_READ(0, sv, 0) > 0)
4613 return ( SvPVX(sv) ) ;
4618 return (sv_gets(sv, PL_rsfp, append));
4622 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4626 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4628 if (memEQs(pkgname, len, "__PACKAGE__"))
4632 && (pkgname[len - 2] == ':' && pkgname[len - 1] == ':')
4633 && (gv = gv_fetchpvn_flags(pkgname,
4635 ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4637 return GvHV(gv); /* Foo:: */
4640 /* use constant CLASS => 'MyClass' */
4641 gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4642 if (gv && GvCV(gv)) {
4643 SV * const sv = cv_const_sv(GvCV(gv));
4645 return gv_stashsv(sv, 0);
4648 return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4653 S_tokenize_use(pTHX_ int is_use, char *s) {
4654 PERL_ARGS_ASSERT_TOKENIZE_USE;
4656 if (PL_expect != XSTATE)
4657 /* diag_listed_as: "use" not allowed in expression */
4658 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4659 is_use ? "use" : "no"));
4662 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4663 s = force_version(s, TRUE);
4664 if (*s == ';' || *s == '}'
4665 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4666 NEXTVAL_NEXTTOKE.opval = NULL;
4667 force_next(BAREWORD);
4669 else if (*s == 'v') {
4670 s = force_word(s,BAREWORD,FALSE,TRUE);
4671 s = force_version(s, FALSE);
4675 s = force_word(s,BAREWORD,FALSE,TRUE);
4676 s = force_version(s, FALSE);
4678 pl_yylval.ival = is_use;
4682 static const char* const exp_name[] =
4683 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4684 "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4685 "SIGVAR", "TERMORDORDOR"
4689 #define word_takes_any_delimiter(p,l) S_word_takes_any_delimiter(p,l)
4691 S_word_takes_any_delimiter(char *p, STRLEN len)
4693 return (len == 1 && strchr("msyq", p[0]))
4695 && ((p[0] == 't' && p[1] == 'r')
4696 || (p[0] == 'q' && strchr("qwxr", p[1]))));
4700 S_check_scalar_slice(pTHX_ char *s)
4703 while (SPACE_OR_TAB(*s)) s++;
4704 if (*s == 'q' && s[1] == 'w' && !isWORDCHAR_lazy_if_safe(s+2,
4710 while ( isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF)
4711 || (*s && strchr(" \t$#+-'\"", *s)))
4713 s += UTF ? UTF8SKIP(s) : 1;
4715 if (*s == '}' || *s == ']')
4716 pl_yylval.ival = OPpSLICEWARNING;
4719 #define lex_token_boundary() S_lex_token_boundary(aTHX)
4721 S_lex_token_boundary(pTHX)
4723 PL_oldoldbufptr = PL_oldbufptr;
4724 PL_oldbufptr = PL_bufptr;
4727 #define vcs_conflict_marker(s) S_vcs_conflict_marker(aTHX_ s)
4729 S_vcs_conflict_marker(pTHX_ char *s)
4731 lex_token_boundary();
4733 yyerror("Version control conflict marker");
4734 while (s < PL_bufend && *s != '\n')
4742 Works out what to call the token just pulled out of the input
4743 stream. The yacc parser takes care of taking the ops we return and
4744 stitching them into a tree.
4747 The type of the next token
4750 Check if we have already built the token; if so, use it.
4751 Switch based on the current state:
4752 - if we have a case modifier in a string, deal with that
4753 - handle other cases of interpolation inside a string
4754 - scan the next line if we are inside a format
4755 In the normal state, switch on the next character:
4757 if alphabetic, go to key lookup
4758 unrecognized character - croak
4759 - 0/4/26: handle end-of-line or EOF
4760 - cases for whitespace
4761 - \n and #: handle comments and line numbers
4762 - various operators, brackets and sigils
4765 - 'v': vstrings (or go to key lookup)
4766 - 'x' repetition operator (or go to key lookup)
4767 - other ASCII alphanumerics (key lookup begins here):
4770 scan built-in keyword (but do nothing with it yet)
4771 check for statement label
4772 check for lexical subs
4773 goto just_a_word if there is one
4774 see whether built-in keyword is overridden
4775 switch on keyword number:
4776 - default: just_a_word:
4777 not a built-in keyword; handle bareword lookup
4778 disambiguate between method and sub call
4779 fall back to bareword
4780 - cases for built-in keywords
4788 char *s = PL_bufptr;
4792 const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4796 /* orig_keyword, gvp, and gv are initialized here because
4797 * jump to the label just_a_word_zero can bypass their
4798 * initialization later. */
4799 I32 orig_keyword = 0;
4803 if (UNLIKELY(PL_parser->recheck_utf8_validity)) {
4804 const U8* first_bad_char_loc;
4805 if (UTF && UNLIKELY(! is_utf8_string_loc((U8 *) PL_bufptr,
4806 PL_bufend - PL_bufptr,
4807 &first_bad_char_loc)))
4809 _force_out_malformed_utf8_message(first_bad_char_loc,
4812 1 /* 1 means die */ );
4813 NOT_REACHED; /* NOTREACHED */
4815 PL_parser->recheck_utf8_validity = FALSE;
4818 SV* tmp = newSVpvs("");
4819 PerlIO_printf(Perl_debug_log, "### %" IVdf ":LEX_%s/X%s %s\n",
4820 (IV)CopLINE(PL_curcop),
4821 lex_state_names[PL_lex_state],
4822 exp_name[PL_expect],
4823 pv_display(tmp, s, strlen(s), 0, 60));
4827 /* when we've already built the next token, just pull it out of the queue */
4830 pl_yylval = PL_nextval[PL_nexttoke];
4833 next_type = PL_nexttype[PL_nexttoke];
4834 if (next_type & (7<<24)) {
4835 if (next_type & (1<<24)) {
4836 if (PL_lex_brackets > 100)
4837 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4838 PL_lex_brackstack[PL_lex_brackets++] =
4839 (char) ((next_type >> 16) & 0xff);
4841 if (next_type & (2<<24))
4842 PL_lex_allbrackets++;
4843 if (next_type & (4<<24))
4844 PL_lex_allbrackets--;
4845 next_type &= 0xffff;
4847 return REPORT(next_type == 'p' ? pending_ident() : next_type);
4851 switch (PL_lex_state) {
4853 case LEX_INTERPNORMAL:
4856 /* interpolated case modifiers like \L \U, including \Q and \E.
4857 when we get here, PL_bufptr is at the \
4859 case LEX_INTERPCASEMOD:
4861 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4863 "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4864 PL_bufptr, PL_bufend, *PL_bufptr);
4866 /* handle \E or end of string */
4867 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4869 if (PL_lex_casemods) {
4870 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4871 PL_lex_casestack[PL_lex_casemods] = '\0';
4873 if (PL_bufptr != PL_bufend
4874 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4875 || oldmod == 'F')) {
4877 PL_lex_state = LEX_INTERPCONCAT;
4879 PL_lex_allbrackets--;
4882 else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4883 /* Got an unpaired \E */
4884 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4885 "Useless use of \\E");
4887 if (PL_bufptr != PL_bufend)
4889 PL_lex_state = LEX_INTERPCONCAT;
4893 DEBUG_T({ PerlIO_printf(Perl_debug_log,
4894 "### Saw case modifier\n"); });
4896 if (s[1] == '\\' && s[2] == 'E') {
4898 PL_lex_state = LEX_INTERPCONCAT;
4903 if ( memBEGINs(s, (STRLEN) (PL_bufend - s), "L\\u")
4904 || memBEGINs(s, (STRLEN) (PL_bufend - s), "U\\l"))
4906 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4908 if ((*s == 'L' || *s == 'U' || *s == 'F')
4909 && (strpbrk(PL_lex_casestack, "LUF")))
4911 PL_lex_casestack[--PL_lex_casemods] = '\0';
4912 PL_lex_allbrackets--;
4915 if (PL_lex_casemods > 10)
4916 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4917 PL_lex_casestack[PL_lex_casemods++] = *s;
4918 PL_lex_casestack[PL_lex_casemods] = '\0';
4919 PL_lex_state = LEX_INTERPCONCAT;
4920 NEXTVAL_NEXTTOKE.ival = 0;
4921 force_next((2<<24)|'(');
4923 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4925 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4927 NEXTVAL_NEXTTOKE.ival = OP_LC;
4929 NEXTVAL_NEXTTOKE.ival = OP_UC;
4931 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4933 NEXTVAL_NEXTTOKE.ival = OP_FC;
4935 Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4939 if (PL_lex_starts) {
4942 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4943 if (PL_lex_casemods == 1 && PL_lex_inpat)
4946 AopNOASSIGN(OP_CONCAT);
4952 case LEX_INTERPPUSH:
4953 return REPORT(sublex_push());
4955 case LEX_INTERPSTART:
4956 if (PL_bufptr == PL_bufend)
4957 return REPORT(sublex_done());
4958 DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4959 "### Interpolated variable\n"); });
4961 /* for /@a/, we leave the joining for the regex engine to do
4962 * (unless we're within \Q etc) */
4963 PL_lex_dojoin = (*PL_bufptr == '@'
4964 && (!PL_lex_inpat || PL_lex_casemods));
4965 PL_lex_state = LEX_INTERPNORMAL;
4966 if (PL_lex_dojoin) {
4967 NEXTVAL_NEXTTOKE.ival = 0;
4969 force_ident("\"", '$');
4970 NEXTVAL_NEXTTOKE.ival = 0;
4972 NEXTVAL_NEXTTOKE.ival = 0;
4973 force_next((2<<24)|'(');
4974 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4977 /* Convert (?{...}) and friends to 'do {...}' */
4978 if (PL_lex_inpat && *PL_bufptr == '(') {
4979 PL_parser->lex_shared->re_eval_start = PL_bufptr;
4981 if (*PL_bufptr != '{')
4983 PL_expect = XTERMBLOCK;
4987 if (PL_lex_starts++) {
4989 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4990 if (!PL_lex_casemods && PL_lex_inpat)
4993 AopNOASSIGN(OP_CONCAT);
4997 case LEX_INTERPENDMAYBE:
4998 if (intuit_more(PL_bufptr, PL_bufend)) {
4999 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
5005 if (PL_lex_dojoin) {
5006 const U8 dojoin_was = PL_lex_dojoin;
5007 PL_lex_dojoin = FALSE;
5008 PL_lex_state = LEX_INTERPCONCAT;
5009 PL_lex_allbrackets--;
5010 return REPORT(dojoin_was == 1 ? (int)')' : (int)POSTJOIN);
5012 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
5013 && SvEVALED(PL_lex_repl))
5015 if (PL_bufptr != PL_bufend)
5016 Perl_croak(aTHX_ "Bad evalled substitution pattern");
5019 /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
5020 re_eval_str. If the here-doc body’s length equals the previous
5021 value of re_eval_start, re_eval_start will now be null. So
5022 check re_eval_str as well. */
5023 if (PL_parser->lex_shared->re_eval_start
5024 || PL_parser->lex_shared->re_eval_str) {
5026 if (*PL_bufptr != ')')
5027 Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5029 /* having compiled a (?{..}) expression, return the original
5030 * text too, as a const */
5031 if (PL_parser->lex_shared->re_eval_str) {
5032 sv = PL_parser->lex_shared->re_eval_str;
5033 PL_parser->lex_shared->re_eval_str = NULL;
5035 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5036 SvPV_shrink_to_cur(sv);
5038 else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5039 PL_bufptr - PL_parser->lex_shared->re_eval_start);
5040 NEXTVAL_NEXTTOKE.opval =
5041 newSVOP(OP_CONST, 0,
5044 PL_parser->lex_shared->re_eval_start = NULL;
5050 case LEX_INTERPCONCAT:
5052 if (PL_lex_brackets)
5053 Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5054 (long) PL_lex_brackets);
5056 if (PL_bufptr == PL_bufend)
5057 return REPORT(sublex_done());
5059 /* m'foo' still needs to be parsed for possible (?{...}) */
5060 if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
5061 SV *sv = newSVsv(PL_linestr);
5063 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
5067 int save_error_count = PL_error_count;
5069 s = scan_const(PL_bufptr);
5071 /* Set flag if this was a pattern and there were errors. op.c will
5072 * refuse to compile a pattern with this flag set. Otherwise, we
5073 * could get segfaults, etc. */
5074 if (PL_lex_inpat && PL_error_count > save_error_count) {
5075 ((PMOP*)PL_lex_inpat)->op_pmflags |= PMf_HAS_ERROR;
5078 PL_lex_state = LEX_INTERPCASEMOD;
5080 PL_lex_state = LEX_INTERPSTART;
5083 if (s != PL_bufptr) {
5084 NEXTVAL_NEXTTOKE = pl_yylval;
5087 if (PL_lex_starts++) {
5088 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5089 if (!PL_lex_casemods && PL_lex_inpat)
5092 AopNOASSIGN(OP_CONCAT);
5102 assert(PL_lex_formbrack);
5103 s = scan_formline(PL_bufptr);
5104 if (!PL_lex_formbrack)
5113 /* We really do *not* want PL_linestr ever becoming a COW. */
5114 assert (!SvIsCOW(PL_linestr));
5116 PL_oldoldbufptr = PL_oldbufptr;
5118 PL_parser->saw_infix_sigil = 0;
5120 if (PL_in_my == KEY_sigvar) {
5121 /* we expect the sigil and optional var name part of a
5122 * signature element here. Since a '$' is not necessarily
5123 * followed by a var name, handle it specially here; the general
5124 * yylex code would otherwise try to interpret whatever follows
5125 * as a var; e.g. ($, ...) would be seen as the var '$,'
5132 PL_bufptr = s; /* for error reporting */
5137 /* spot stuff that looks like an prototype */
5138 if (strchr("$:@%&*;\\[]", *s)) {
5139 yyerror("Illegal character following sigil in a subroutine signature");
5142 /* '$#' is banned, while '$ # comment' isn't */
5144 yyerror("'#' not allowed immediately following a sigil in a subroutine signature");
5148 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5149 char *dest = PL_tokenbuf + 1;
5150 /* read var name, including sigil, into PL_tokenbuf */
5151 PL_tokenbuf[0] = sigil;
5152 parse_ident(&s, &dest, dest + sizeof(PL_tokenbuf) - 1,
5153 0, cBOOL(UTF), FALSE, FALSE);
5155 assert(PL_tokenbuf[1]); /* we have a variable name */
5163 /* parse the = for the default ourselves to avoid '+=' etc being accepted here
5164 * as the ASSIGNOP, and exclude other tokens that start with =
5166 if (*s == '=' && (!s[1] || strchr("=~>", s[1]) == 0)) {
5167 /* save now to report with the same context as we did when
5168 * all ASSIGNOPS were accepted */
5172 NEXTVAL_NEXTTOKE.ival = 0;
5173 force_next(ASSIGNOP);
5176 else if (*s == ',' || *s == ')') {
5177 PL_expect = XOPERATOR;
5180 /* make sure the context shows the unexpected character and
5181 * hopefully a bit more */
5183 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5185 PL_bufptr = s; /* for error reporting */
5186 yyerror("Illegal operator following parameter in a subroutine signature");
5190 NEXTVAL_NEXTTOKE.ival = sigil;
5191 force_next('p'); /* force a signature pending identifier */
5198 case ',': /* handle ($a,,$b) */
5203 yyerror("A signature parameter must start with '$', '@' or '%'");
5204 /* very crude error recovery: skip to likely next signature
5206 while (*s && *s != '$' && *s != '@' && *s != '%' && *s != ')')
5217 if (isIDFIRST_utf8_safe(s, PL_bufend)) {
5221 else if (isALNUMC(*s)) {
5225 SV *dsv = newSVpvs_flags("", SVs_TEMP);
5228 STRLEN skiplen = UTF8SKIP(s);
5229 STRLEN stravail = PL_bufend - s;
5230 c = sv_uni_display(dsv, newSVpvn_flags(s,
5231 skiplen > stravail ? stravail : skiplen,
5232 SVs_TEMP | SVf_UTF8),
5233 10, UNI_DISPLAY_ISPRINT);
5236 c = Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5239 if (s >= PL_linestart) {
5243 /* somehow (probably due to a parse failure), PL_linestart has advanced
5244 * pass PL_bufptr, get a reasonable beginning of line
5247 while (d > SvPVX(PL_linestr) && d[-1] && d[-1] != '\n')
5250 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) d, (U8 *) s) : (STRLEN) (s - d);
5251 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5252 d = UTF ? (char *) utf8_hop_back((U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT, (U8 *)d) : s - UNRECOGNIZED_PRECEDE_COUNT;
5255 Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %" UTF8f "<-- HERE near column %d", c,
5256 UTF8fARG(UTF, (s - d), d),
5261 goto fake_eof; /* emulate EOF on ^D or ^Z */
5263 if ((!PL_rsfp || PL_lex_inwhat)
5264 && (!PL_parser->filtered || s+1 < PL_bufend)) {
5268 && PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF)
5270 yyerror((const char *)
5272 ? "Format not terminated"
5273 : "Missing right curly or square bracket"));
5275 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5276 "### Tokener got EOF\n");
5280 if (s++ < PL_bufend)
5281 goto retry; /* ignore stray nulls */
5284 if (!PL_in_eval && !PL_preambled) {
5285 PL_preambled = TRUE;
5287 /* Generate a string of Perl code to load the debugger.
5288 * If PERL5DB is set, it will return the contents of that,
5289 * otherwise a compile-time require of perl5db.pl. */
5291 const char * const pdb = PerlEnv_getenv("PERL5DB");
5294 sv_setpv(PL_linestr, pdb);
5295 sv_catpvs(PL_linestr,";");
5297 SETERRNO(0,SS_NORMAL);
5298 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5300 PL_parser->preambling = CopLINE(PL_curcop);
5302 SvPVCLEAR(PL_linestr);
5303 if (PL_preambleav) {
5304 SV **svp = AvARRAY(PL_preambleav);
5305 SV **const end = svp + AvFILLp(PL_preambleav);
5307 sv_catsv(PL_linestr, *svp);
5309 sv_catpvs(PL_linestr, ";");
5311 sv_free(MUTABLE_SV(PL_preambleav));
5312 PL_preambleav = NULL;
5315 sv_catpvs(PL_linestr,
5316 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5317 if (PL_minus_n || PL_minus_p) {
5318 sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5320 sv_catpvs(PL_linestr,"chomp;");
5323 if ( ( *PL_splitstr == '/'
5324 || *PL_splitstr == '\''
5325 || *PL_splitstr == '"')
5326 && strchr(PL_splitstr + 1, *PL_splitstr))
5328 /* strchr is ok, because -F pattern can't contain
5330 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5333 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5334 bytes can be used as quoting characters. :-) */
5335 const char *splits = PL_splitstr;
5336 sv_catpvs(PL_linestr, "our @F=split(q\0");
5339 if (*splits == '\\')
5340 sv_catpvn(PL_linestr, splits, 1);
5341 sv_catpvn(PL_linestr, splits, 1);
5342 } while (*splits++);
5343 /* This loop will embed the trailing NUL of
5344 PL_linestr as the last thing it does before
5346 sv_catpvs(PL_linestr, ");");
5350 sv_catpvs(PL_linestr,"our @F=split(' ');");
5353 sv_catpvs(PL_linestr, "\n");
5354 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5355 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5356 PL_last_lop = PL_last_uni = NULL;
5357 if (PERLDB_LINE_OR_SAVESRC && PL_curstash != PL_debstash)
5358 update_debugger_info(PL_linestr, NULL, 0);
5363 bof = cBOOL(PL_rsfp);
5366 fake_eof = LEX_FAKE_EOF;
5368 PL_bufptr = PL_bufend;
5369 COPLINE_INC_WITH_HERELINES;
5370 if (!lex_next_chunk(fake_eof)) {
5371 CopLINE_dec(PL_curcop);
5373 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5375 CopLINE_dec(PL_curcop);
5377 /* If it looks like the start of a BOM or raw UTF-16,
5378 * check if it in fact is. */
5381 || *(U8*)s == BOM_UTF8_FIRST_BYTE
5385 Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5386 bof = (offset == (Off_t)SvCUR(PL_linestr));
5387 #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5388 /* offset may include swallowed CR */
5390 bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5393 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5394 s = swallow_bom((U8*)s);
5397 if (PL_parser->in_pod) {
5398 /* Incest with pod. */
5399 if ( memBEGINPs(s, (STRLEN) (PL_bufend - s), "=cut")
5402 SvPVCLEAR(PL_linestr);
5403 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5404 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5405 PL_last_lop = PL_last_uni = NULL;
5406 PL_parser->in_pod = 0;
5409 if (PL_rsfp || PL_parser->filtered)
5410 incline(s, PL_bufend);
5411 } while (PL_parser->in_pod);
5412 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5413 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5414 PL_last_lop = PL_last_uni = NULL;
5415 if (CopLINE(PL_curcop) == 1) {
5416 while (s < PL_bufend && isSPACE(*s))
5418 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
5422 if (*s == '#' && *(s+1) == '!')
5424 #ifdef ALTERNATE_SHEBANG
5426 static char const as[] = ALTERNATE_SHEBANG;
5427 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5428 d = s + (sizeof(as) - 1);
5430 #endif /* ALTERNATE_SHEBANG */
5439 while (*d && !isSPACE(*d))
5443 #ifdef ARG_ZERO_IS_SCRIPT
5444 if (ipathend > ipath) {
5446 * HP-UX (at least) sets argv[0] to the script name,
5447 * which makes $^X incorrect. And Digital UNIX and Linux,
5448 * at least, set argv[0] to the basename of the Perl
5449 * interpreter. So, having found "#!", we'll set it right.
5451 SV* copfilesv = CopFILESV(PL_curcop);
5454 GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5456 assert(SvPOK(x) || SvGMAGICAL(x));
5457 if (sv_eq(x, copfilesv)) {
5458 sv_setpvn(x, ipath, ipathend - ipath);
5464 const char *bstart = SvPV_const(copfilesv, blen);
5465 const char * const lstart = SvPV_const(x, llen);
5467 bstart += blen - llen;
5468 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5469 sv_setpvn(x, ipath, ipathend - ipath);
5476 /* Anything to do if no copfilesv? */
5478 TAINT_NOT; /* $^X is always tainted, but that's OK */
5480 #endif /* ARG_ZERO_IS_SCRIPT */
5485 d = instr(s,"perl -");
5487 d = instr(s,"perl");
5489 /* avoid getting into infinite loops when shebang
5490 * line contains "Perl" rather than "perl" */
5492 for (d = ipathend-4; d >= ipath; --d) {
5493 if (isALPHA_FOLD_EQ(*d, 'p')
5494 && !ibcmp(d, "perl", 4))
5504 #ifdef ALTERNATE_SHEBANG
5506 * If the ALTERNATE_SHEBANG on this system starts with a
5507 * character that can be part of a Perl expression, then if
5508 * we see it but not "perl", we're probably looking at the
5509 * start of Perl code, not a request to hand off to some
5510 * other interpreter. Similarly, if "perl" is there, but
5511 * not in the first 'word' of the line, we assume the line
5512 * contains the start of the Perl program.
5514 if (d && *s != '#') {
5515 const char *c = ipath;
5516 while (*c && !strchr("; \t\r\n\f\v#", *c))
5519 d = NULL; /* "perl" not in first word; ignore */
5521 *s = '#'; /* Don't try to parse shebang line */
5523 #endif /* ALTERNATE_SHEBANG */
5528 && !instr(s,"indir")
5529 && instr(PL_origargv[0],"perl"))
5536 while (s < PL_bufend && isSPACE(*s))
5538 if (s < PL_bufend) {
5539 Newx(newargv,PL_origargc+3,char*);
5541 while (s < PL_bufend && !isSPACE(*s))
5544 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5547 newargv = PL_origargv;
5550 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5552 Perl_croak(aTHX_ "Can't exec %s", ipath);
5555 while (*d && !isSPACE(*d))
5557 while (SPACE_OR_TAB(*d))
5561 const bool switches_done = PL_doswitches;
5562 const U32 oldpdb = PL_perldb;
5563 const bool oldn = PL_minus_n;
5564 const bool oldp = PL_minus_p;
5568 bool baduni = FALSE;
5570 const char *d2 = d1 + 1;
5571 if (parse_unicode_opts((const char **)&d2)
5575 if (baduni || isALPHA_FOLD_EQ(*d1, 'M')) {
5576 const char * const m = d1;
5577 while (*d1 && !isSPACE(*d1))
5579 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5582 d1 = moreswitches(d1);
5584 if (PL_doswitches && !switches_done) {
5585 int argc = PL_origargc;
5586 char **argv = PL_origargv;
5589 } while (argc && argv[0][0] == '-' && argv[0][1]);
5590 init_argv_symbols(argc,argv);
5592 if ( (PERLDB_LINE_OR_SAVESRC && !oldpdb)
5593 || ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
5594 /* if we have already added "LINE: while (<>) {",
5595 we must not do it again */
5597 SvPVCLEAR(PL_linestr);
5598 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5599 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5600 PL_last_lop = PL_last_uni = NULL;
5601 PL_preambled = FALSE;
5602 if (PERLDB_LINE_OR_SAVESRC)
5603 (void)gv_fetchfile(PL_origfilename);
5610 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5611 PL_lex_state = LEX_FORMLINE;
5612 force_next(FORMRBRACK);
5617 #ifdef PERL_STRICT_CR
5618 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5620 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5622 case ' ': case '\t': case '\f': case '\v':
5627 if (PL_lex_state != LEX_NORMAL
5628 || (PL_in_eval && !PL_rsfp && !PL_parser->filtered))
5630 const bool in_comment = *s == '#';
5631 if (*s == '#' && s == PL_linestart && PL_in_eval
5632 && !PL_rsfp && !PL_parser->filtered) {
5633 /* handle eval qq[#line 1 "foo"\n ...] */
5634 CopLINE_dec(PL_curcop);
5635 incline(s, PL_bufend);
5638 while (d < PL_bufend && *d != '\n')
5643 if (in_comment && d == PL_bufend
5644 && PL_lex_state == LEX_INTERPNORMAL
5645 && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
5646 && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
5648 incline(s, PL_bufend);
5649 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
5650 PL_lex_state = LEX_FORMLINE;
5651 force_next(FORMRBRACK);
5656 while (s < PL_bufend && *s != '\n')
5662 incline(s, PL_bufend);
5667 if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
5675 while (s < PL_bufend && SPACE_OR_TAB(*s))
5678 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=>")) {
5679 s = force_word(PL_bufptr,BAREWORD,FALSE,FALSE);
5680 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5681 OPERATOR('-'); /* unary minus */
5684 case 'r': ftst = OP_FTEREAD; break;
5685 case 'w': ftst = OP_FTEWRITE; break;
5686 case 'x': ftst = OP_FTEEXEC; break;
5687 case 'o': ftst = OP_FTEOWNED; break;
5688 case 'R': ftst = OP_FTRREAD; break;
5689 case 'W': ftst = OP_FTRWRITE; break;
5690 case 'X': ftst = OP_FTREXEC; break;
5691 case 'O': ftst = OP_FTROWNED; break;
5692 case 'e': ftst = OP_FTIS; break;
5693 case 'z': ftst = OP_FTZERO; break;
5694 case 's': ftst = OP_FTSIZE; break;
5695 case 'f': ftst = OP_FTFILE; break;
5696 case 'd': ftst = OP_FTDIR; break;
5697 case 'l': ftst = OP_FTLINK; break;
5698 case 'p': ftst = OP_FTPIPE; break;
5699 case 'S': ftst = OP_FTSOCK; break;
5700 case 'u': ftst = OP_FTSUID; break;
5701 case 'g': ftst = OP_FTSGID; break;
5702 case 'k': ftst = OP_FTSVTX; break;
5703 case 'b': ftst = OP_FTBLK; break;
5704 case 'c': ftst = OP_FTCHR; break;
5705 case 't': ftst = OP_FTTTY; break;
5706 case 'T': ftst = OP_FTTEXT; break;
5707 case 'B': ftst = OP_FTBINARY; break;
5708 case 'M': case 'A': case 'C':
5709 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5711 case 'M': ftst = OP_FTMTIME; break;
5712 case 'A': ftst = OP_FTATIME; break;
5713 case 'C': ftst = OP_FTCTIME; break;
5721 PL_last_uni = PL_oldbufptr;
5722 PL_last_lop_op = (OPCODE)ftst;
5723 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5724 "### Saw file test %c\n", (int)tmp);
5729 /* Assume it was a minus followed by a one-letter named
5730 * subroutine call (or a -bareword), then. */
5731 DEBUG_T( { PerlIO_printf(Perl_debug_log,
5732 "### '-%c' looked like a file test but was not\n",
5739 const char tmp = *s++;
5742 if (PL_expect == XOPERATOR)
5747 else if (*s == '>') {
5750 if (((*s == '$' || *s == '&') && s[1] == '*')
5751 ||(*s == '$' && s[1] == '#' && s[2] == '*')
5752 ||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
5753 ||(*s == '*' && (s[1] == '*' || s[1] == '{'))
5756 PL_expect = XPOSTDEREF;
5759 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5760 s = force_word(s,METHOD,FALSE,TRUE);
5768 if (PL_expect == XOPERATOR) {
5770 && !PL_lex_allbrackets
5771 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5779 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5781 OPERATOR('-'); /* unary minus */
5787 const char tmp = *s++;
5790 if (PL_expect == XOPERATOR)
5795 if (PL_expect == XOPERATOR) {
5797 && !PL_lex_allbrackets
5798 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5806 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
5813 if (PL_expect == XPOSTDEREF) POSTDEREF('*');
5814 if (PL_expect != XOPERATOR) {
5815 s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5816 PL_expect = XOPERATOR;
5817 force_ident(PL_tokenbuf, '*');
5825 if (*s == '=' && !PL_lex_allbrackets
5826 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5834 && !PL_lex_allbrackets
5835 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5840 PL_parser->saw_infix_sigil = 1;
5845 if (PL_expect == XOPERATOR) {
5847 && !PL_lex_allbrackets
5848 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5853 PL_parser->saw_infix_sigil = 1;
5856 else if (PL_expect == XPOSTDEREF) POSTDEREF('%');
5857 PL_tokenbuf[0] = '%';
5858 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5860 if (!PL_tokenbuf[1]) {
5863 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
5864 && intuit_more(s, PL_bufend)) {
5866 PL_tokenbuf[0] = '@';
5868 PL_expect = XOPERATOR;
5869 force_ident_maybe_lex('%');
5874 bof = FEATURE_BITWISE_IS_ENABLED;
5875 if (bof && s[1] == '.')
5877 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
5878 (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5884 BOop(bof ? d == s-2 ? OP_SBIT_XOR : OP_NBIT_XOR : OP_BIT_XOR);
5886 if (PL_lex_brackets > 100)
5887 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5888 PL_lex_brackstack[PL_lex_brackets++] = 0;
5889 PL_lex_allbrackets++;
5891 const char tmp = *s++;
5896 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5898 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
5901 Perl_ck_warner_d(aTHX_
5902 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5903 "Smartmatch is experimental");
5907 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.') {
5909 BCop(OP_SCOMPLEMENT);
5911 BCop(bof ? OP_NCOMPLEMENT : OP_COMPLEMENT);
5913 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
5920 goto just_a_word_zero_gv;
5926 switch (PL_expect) {
5928 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
5930 PL_bufptr = s; /* update in case we back off */
5933 "Use of := for an empty attribute list is not allowed");
5940 PL_expect = XTERMBLOCK;
5942 /* NB: as well as parsing normal attributes, we also end up
5943 * here if there is something looking like attributes
5944 * following a signature (which is illegal, but used to be
5945 * legal in 5.20..5.26). If the latter, we still parse the
5946 * attributes so that error messages(s) are less confusing,
5947 * but ignore them (parser->sig_seen).
5951 while (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
5952 bool sig = PL_parser->sig_seen;
5955 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5956 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
5957 if (tmp < 0) tmp = -tmp;
5972 sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
5974 d = scan_str(d,TRUE,TRUE,FALSE,NULL);
5979 Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
5981 COPLINE_SET_FROM_MULTI_END;
5984 sv_catsv(sv, PL_lex_stuff);
5985 attrs = op_append_elem(OP_LIST, attrs,
5986 newSVOP(OP_CONST, 0, sv));
5987 SvREFCNT_dec_NN(PL_lex_stuff);
5988 PL_lex_stuff = NULL;
5991 /* NOTE: any CV attrs applied here need to be part of
5992 the CVf_BUILTIN_ATTRS define in cv.h! */
5993 if (!PL_in_my && memEQs(SvPVX(sv), len, "lvalue")) {
5996 CvLVALUE_on(PL_compcv);
5998 else if (!PL_in_my && memEQs(SvPVX(sv), len, "method")) {
6001 CvMETHOD_on(PL_compcv);
6003 else if (!PL_in_my && memEQs(SvPVX(sv), len, "const"))
6007 Perl_ck_warner_d(aTHX_
6008 packWARN(WARN_EXPERIMENTAL__CONST_ATTR),
6009 ":const is experimental"
6011 CvANONCONST_on(PL_compcv);
6012 if (!CvANON(PL_compcv))
6013 yyerror(":const is not permitted on named "
6017 /* After we've set the flags, it could be argued that
6018 we don't need to do the attributes.pm-based setting
6019 process, and shouldn't bother appending recognized
6020 flags. To experiment with that, uncomment the
6021 following "else". (Note that's already been
6022 uncommented. That keeps the above-applied built-in
6023 attributes from being intercepted (and possibly
6024 rejected) by a package's attribute routines, but is
6025 justified by the performance win for the common case
6026 of applying only built-in attributes.) */
6028 attrs = op_append_elem(OP_LIST, attrs,
6029 newSVOP(OP_CONST, 0,
6033 if (*s == ':' && s[1] != ':')
6036 break; /* require real whitespace or :'s */
6037 /* XXX losing whitespace on sequential attributes here */
6042 && !(PL_expect == XOPERATOR
6043 ? (*s == '=' || *s == ')')
6044 : (*s == '{' || *s == '(')))
6046 const char q = ((*s == '\'') ? '"' : '\'');
6047 /* If here for an expression, and parsed no attrs, back
6049 if (PL_expect == XOPERATOR && !attrs) {
6053 /* MUST advance bufptr here to avoid bogus "at end of line"
6054 context messages from yyerror().
6057 yyerror( (const char *)
6059 ? Perl_form(aTHX_ "Invalid separator character "
6060 "%c%c%c in attribute list", q, *s, q)
6061 : "Unterminated attribute list" ) );
6068 if (PL_parser->sig_seen) {
6069 /* see comment about about sig_seen and parser error
6073 Perl_croak(aTHX_ "Subroutine attributes must come "
6074 "before the signature");
6077 NEXTVAL_NEXTTOKE.opval = attrs;
6083 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
6087 PL_lex_allbrackets--;
6091 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
6092 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6096 PL_lex_allbrackets++;
6099 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
6106 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
6109 PL_lex_allbrackets--;
6115 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6118 if (PL_lex_brackets <= 0)
6119 /* diag_listed_as: Unmatched right %s bracket */
6120 yyerror("Unmatched right square bracket");
6123 PL_lex_allbrackets--;
6124 if (PL_lex_state == LEX_INTERPNORMAL) {
6125 if (PL_lex_brackets == 0) {
6126 if (*s == '-' && s[1] == '>')
6127 PL_lex_state = LEX_INTERPENDMAYBE;
6128 else if (*s != '[' && *s != '{')
6129 PL_lex_state = LEX_INTERPEND;
6136 if (PL_lex_brackets > 100) {
6137 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6139 switch (PL_expect) {
6142 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6143 PL_lex_allbrackets++;
6144 OPERATOR(HASHBRACK);
6146 while (s < PL_bufend && SPACE_OR_TAB(*s))
6149 PL_tokenbuf[0] = '\0';
6150 if (d < PL_bufend && *d == '-') {
6151 PL_tokenbuf[0] = '-';
6153 while (d < PL_bufend && SPACE_OR_TAB(*d))
6156 if (d < PL_bufend && isIDFIRST_lazy_if_safe(d, PL_bufend, UTF)) {
6157 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6159 while (d < PL_bufend && SPACE_OR_TAB(*d))
6162 const char minus = (PL_tokenbuf[0] == '-');
6163 s = force_word(s + minus, BAREWORD, FALSE, TRUE);
6171 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6172 PL_lex_allbrackets++;
6177 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6178 PL_lex_allbrackets++;
6182 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6183 PL_lex_allbrackets++;
6188 if (PL_oldoldbufptr == PL_last_lop)
6189 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6191 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6192 PL_lex_allbrackets++;
6195 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
6197 /* This hack is to get the ${} in the message. */
6199 yyerror("syntax error");
6202 OPERATOR(HASHBRACK);
6204 if (PL_expect == XREF && PL_oldoldbufptr != PL_last_lop) {
6205 /* ${...} or @{...} etc., but not print {...}
6206 * Skip the disambiguation and treat this as a block.
6208 goto block_expectation;
6210 /* This hack serves to disambiguate a pair of curlies
6211 * as being a block or an anon hash. Normally, expectation
6212 * determines that, but in cases where we're not in a
6213 * position to expect anything in particular (like inside
6214 * eval"") we have to resolve the ambiguity. This code
6215 * covers the case where the first term in the curlies is a
6216 * quoted string. Most other cases need to be explicitly
6217 * disambiguated by prepending a "+" before the opening
6218 * curly in order to force resolution as an anon hash.
6220 * XXX should probably propagate the outer expectation
6221 * into eval"" to rely less on this hack, but that could
6222 * potentially break current behavior of eval"".
6226 if (*s == '\'' || *s == '"' || *s == '`') {
6227 /* common case: get past first string, handling escapes */
6228 for (t++; t < PL_bufend && *t != *s;)
6233 else if (*s == 'q') {
6236 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
6237 && !isWORDCHAR(*t))))
6239 /* skip q//-like construct */
6241 char open, close, term;
6244 while (t < PL_bufend && isSPACE(*t))
6246 /* check for q => */
6247 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
6248 OPERATOR(HASHBRACK);
6252 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6256 for (t++; t < PL_bufend; t++) {
6257 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
6259 else if (*t == open)
6263 for (t++; t < PL_bufend; t++) {
6264 if (*t == '\\' && t+1 < PL_bufend)
6266 else if (*t == close && --brackets <= 0)
6268 else if (*t == open)
6275 /* skip plain q word */
6276 while ( t < PL_bufend
6277 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6279 t += UTF ? UTF8SKIP(t) : 1;
6282 else if (isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)) {
6283 t += UTF ? UTF8SKIP(t) : 1;
6284 while ( t < PL_bufend
6285 && isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF))
6287 t += UTF ? UTF8SKIP(t) : 1;
6290 while (t < PL_bufend && isSPACE(*t))
6292 /* if comma follows first term, call it an anon hash */
6293 /* XXX it could be a comma expression with loop modifiers */
6294 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
6295 || (*t == '=' && t[1] == '>')))
6296 OPERATOR(HASHBRACK);
6297 if (PL_expect == XREF)
6300 /* If there is an opening brace or 'sub:', treat it
6301 as a term to make ${{...}}{k} and &{sub:attr...}
6302 dwim. Otherwise, treat it as a statement, so
6303 map {no strict; ...} works.
6310 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "sub")) {
6323 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6329 pl_yylval.ival = CopLINE(PL_curcop);
6330 PL_copline = NOLINE; /* invalidate current command line number */
6331 TOKEN(formbrack ? '=' : '{');
6333 if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
6336 assert(s != PL_bufend);
6338 if (PL_lex_brackets <= 0)
6339 /* diag_listed_as: Unmatched right %s bracket */
6340 yyerror("Unmatched right curly bracket");
6342 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6343 PL_lex_allbrackets--;
6344 if (PL_lex_state == LEX_INTERPNORMAL) {
6345 if (PL_lex_brackets == 0) {
6346 if (PL_expect & XFAKEBRACK) {
6347 PL_expect &= XENUMMASK;
6348 PL_lex_state = LEX_INTERPEND;
6350 return yylex(); /* ignore fake brackets */
6352 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
6353 && SvEVALED(PL_lex_repl))
6354 PL_lex_state = LEX_INTERPEND;
6355 else if (*s == '-' && s[1] == '>')
6356 PL_lex_state = LEX_INTERPENDMAYBE;
6357 else if (*s != '[' && *s != '{')
6358 PL_lex_state = LEX_INTERPEND;
6361 if (PL_expect & XFAKEBRACK) {
6362 PL_expect &= XENUMMASK;
6364 return yylex(); /* ignore fake brackets */
6366 force_next(formbrack ? '.' : '}');
6367 if (formbrack) LEAVE_with_name("lex_format");
6368 if (formbrack == 2) { /* means . where arguments were expected */
6374 if (PL_expect == XPOSTDEREF) POSTDEREF('&');
6377 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6378 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6385 if (PL_expect == XOPERATOR) {
6386 if ( PL_bufptr == PL_linestart
6387 && ckWARN(WARN_SEMICOLON)
6388 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
6390 CopLINE_dec(PL_curcop);
6391 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6392 CopLINE_inc(PL_curcop);
6395 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6397 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6398 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6404 PL_parser->saw_infix_sigil = 1;
6405 BAop(bof ? OP_NBIT_AND : OP_BIT_AND);
6411 PL_tokenbuf[0] = '&';
6412 s = scan_ident(s - 1, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
6413 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6414 if (PL_tokenbuf[1]) {
6415 force_ident_maybe_lex('&');
6424 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6425 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6433 if ((bof = FEATURE_BITWISE_IS_ENABLED) && *s == '.')
6435 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6436 (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6440 BOop(bof ? s == d ? OP_NBIT_OR : OP_SBIT_OR : OP_BIT_OR);
6444 const char tmp = *s++;
6446 if ( (s == PL_linestart+2 || s[-3] == '\n')
6447 && memBEGINs(s, (STRLEN) (PL_bufend - s), "====="))
6449 s = vcs_conflict_marker(s + 5);
6452 if (!PL_lex_allbrackets
6453 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6461 if (!PL_lex_allbrackets
6462 && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
6471 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
6472 && strchr("+-*/%.^&|<",tmp))
6473 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6474 "Reversed %c= operator",(int)tmp);
6476 if (PL_expect == XSTATE
6478 && (s == PL_linestart+1 || s[-2] == '\n') )
6480 if ( (PL_in_eval && !PL_rsfp && !PL_parser->filtered)
6481 || PL_lex_state != LEX_NORMAL)
6486 incline(s, PL_bufend);
6487 if (memBEGINs(s, (STRLEN) (PL_bufend - s), "=cut"))
6489 s = (char *) memchr(s,'\n', d - s);
6494 incline(s, PL_bufend);
6502 PL_parser->in_pod = 1;
6506 if (PL_expect == XBLOCK) {
6508 #ifdef PERL_STRICT_CR
6509 while (SPACE_OR_TAB(*t))
6511 while (SPACE_OR_TAB(*t) || *t == '\r')
6514 if (*t == '\n' || *t == '#') {
6516 ENTER_with_name("lex_format");
6517 SAVEI8(PL_parser->form_lex_state);
6518 SAVEI32(PL_lex_formbrack);
6519 PL_parser->form_lex_state = PL_lex_state;
6520 PL_lex_formbrack = PL_lex_brackets + 1;
6524 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6533 const char tmp = *s++;
6535 /* was this !=~ where !~ was meant?
6536 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6538 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
6539 const char *t = s+1;
6541 while (t < PL_bufend && isSPACE(*t))
6544 if (*t == '/' || *t == '?'
6545 || ((*t == 'm' || *t == 's' || *t == 'y')
6546 && !isWORDCHAR(t[1]))
6547 || (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
6548 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6549 "!=~ should be !~");
6551 if (!PL_lex_allbrackets
6552 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6565 if (PL_expect != XOPERATOR) {
6566 if (s[1] != '<' && !memchr(s,'>', PL_bufend - s))
6568 if (s[1] == '<' && s[2] != '>') {
6569 if ( (s == PL_linestart || s[-1] == '\n')
6570 && memBEGINs(s+2, (STRLEN) (PL_bufend - (s+2)), "<<<<<"))
6572 s = vcs_conflict_marker(s + 7);
6575 s = scan_heredoc(s);
6578 s = scan_inputsymbol(s);
6579 PL_expect = XOPERATOR;
6580 TOKEN(sublex_start());
6586 if ( (s == PL_linestart+2 || s[-3] == '\n')
6587 && memBEGINs(s, (STRLEN) (PL_bufend - s), "<<<<<"))
6589 s = vcs_conflict_marker(s + 5);
6592 if (*s == '=' && !PL_lex_allbrackets
6593 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6598 SHop(OP_LEFT_SHIFT);
6603 if (!PL_lex_allbrackets
6604 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6612 if (!PL_lex_allbrackets
6613 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6622 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6630 const char tmp = *s++;
6632 if ( (s == PL_linestart+2 || s[-3] == '\n')
6633 && memBEGINs(s, (STRLEN) (PL_bufend - s), ">>>>>"))
6635 s = vcs_conflict_marker(s + 5);
6638 if (*s == '=' && !PL_lex_allbrackets
6639 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6644 SHop(OP_RIGHT_SHIFT);
6646 else if (tmp == '=') {
6647 if (!PL_lex_allbrackets
6648 && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
6657 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6666 if (PL_expect == XPOSTDEREF) {
6669 POSTDEREF(DOLSHARP);
6675 && ( isIDFIRST_lazy_if_safe(s+2, PL_bufend, UTF)
6676 || strchr("{$:+-@", s[2])))
6678 PL_tokenbuf[0] = '@';
6679 s = scan_ident(s + 1, PL_tokenbuf + 1,
6680 sizeof PL_tokenbuf - 1, FALSE);
6681 if (PL_expect == XOPERATOR) {
6683 if (PL_bufptr > s) {
6685 PL_bufptr = PL_oldbufptr;
6687 no_op("Array length", d);
6689 if (!PL_tokenbuf[1])
6691 PL_expect = XOPERATOR;
6692 force_ident_maybe_lex('#');
6696 PL_tokenbuf[0] = '$';
6697 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6698 if (PL_expect == XOPERATOR) {
6700 if (PL_bufptr > s) {
6702 PL_bufptr = PL_oldbufptr;
6706 if (!PL_tokenbuf[1]) {
6708 yyerror("Final $ should be \\$ or $name");
6714 const char tmp = *s;
6715 if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
6718 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6719 && intuit_more(s, PL_bufend)) {
6721 PL_tokenbuf[0] = '@';
6722 if (ckWARN(WARN_SYNTAX)) {
6726 || isWORDCHAR_lazy_if_safe(t, PL_bufend, UTF)
6729 t += UTF ? UTF8SKIP(t) : 1;
6732 PL_bufptr = skipspace(PL_bufptr); /* XXX can realloc */
6733 while (t < PL_bufend && *t != ']')
6735 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6736 "Multidimensional syntax %" UTF8f " not supported",
6737 UTF8fARG(UTF,(int)((t - PL_bufptr) + 1), PL_bufptr));
6741 else if (*s == '{') {
6743 PL_tokenbuf[0] = '%';
6744 if ( strEQ(PL_tokenbuf+1, "SIG")
6745 && ckWARN(WARN_SYNTAX)
6746 && (t = (char *) memchr(s, '}', PL_bufend - s))
6747 && (t = (char *) memchr(t, '=', PL_bufend - t)))
6749 char tmpbuf[sizeof PL_tokenbuf];
6752 } while (isSPACE(*t));
6753 if (isIDFIRST_lazy_if_safe(t, PL_bufend, UTF)) {
6755 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6760 && get_cvn_flags(tmpbuf, len, UTF
6764 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6765 "You need to quote \"%" UTF8f "\"",
6766 UTF8fARG(UTF, len, tmpbuf));
6773 PL_expect = XOPERATOR;
6774 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
6775 const bool islop = (PL_last_lop == PL_oldoldbufptr);
6776 if (!islop || PL_last_lop_op == OP_GREPSTART)
6777 PL_expect = XOPERATOR;
6778 else if (strchr("$@\"'`q", *s))
6779 PL_expect = XTERM; /* e.g. print $fh "foo" */
6780 else if ( strchr("&*<%", *s)
6781 && isIDFIRST_lazy_if_safe(s+1, PL_bufend, UTF))
6783 PL_expect = XTERM; /* e.g. print $fh &sub */
6785 else if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
6786 char tmpbuf[sizeof PL_tokenbuf];
6788 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6789 if ((t2 = keyword(tmpbuf, len, 0))) {
6790 /* binary operators exclude handle interpretations */
6802 PL_expect = XTERM; /* e.g. print $fh length() */
6807 PL_expect = XTERM; /* e.g. print $fh subr() */
6810 else if (isDIGIT(*s))
6811 PL_expect = XTERM; /* e.g. print $fh 3 */
6812 else if (*s == '.' && isDIGIT(s[1]))
6813 PL_expect = XTERM; /* e.g. print $fh .3 */
6814 else if ((*s == '?' || *s == '-' || *s == '+')
6815 && !isSPACE(s[1]) && s[1] != '=')
6816 PL_expect = XTERM; /* e.g. print $fh -1 */
6817 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
6819 PL_expect = XTERM; /* e.g. print $fh /.../
6820 XXX except DORDOR operator
6822 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
6824 PL_expect = XTERM; /* print $fh <<"EOF" */
6827 force_ident_maybe_lex('$');
6831 if (PL_expect == XPOSTDEREF)
6833 PL_tokenbuf[0] = '@';
6834 s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6835 if (PL_expect == XOPERATOR) {
6837 if (PL_bufptr > s) {
6839 PL_bufptr = PL_oldbufptr;
6844 if (!PL_tokenbuf[1]) {
6847 if (PL_lex_state == LEX_NORMAL)
6849 if ( (PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
6850 && intuit_more(s, PL_bufend))
6853 PL_tokenbuf[0] = '%';
6855 /* Warn about @ where they meant $. */
6856 if (*s == '[' || *s == '{') {
6857 if (ckWARN(WARN_SYNTAX)) {
6858 S_check_scalar_slice(aTHX_ s);
6862 PL_expect = XOPERATOR;
6863 force_ident_maybe_lex('@');
6866 case '/': /* may be division, defined-or, or pattern */
6867 if ((PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) && s[1] == '/') {
6868 if (!PL_lex_allbrackets && PL_lex_fakeeof >=
6869 (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6874 else if (PL_expect == XOPERATOR) {
6876 if (*s == '=' && !PL_lex_allbrackets
6877 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6885 /* Disable warning on "study /blah/" */
6886 if ( PL_oldoldbufptr == PL_last_uni
6887 && ( *PL_last_uni != 's' || s - PL_last_uni < 5
6888 || memNE(PL_last_uni, "study", 5)
6889 || isWORDCHAR_lazy_if_safe(PL_last_uni+5, PL_bufend, UTF)
6892 s = scan_pat(s,OP_MATCH);
6893 TERM(sublex_start());
6896 case '?': /* conditional */
6898 if (!PL_lex_allbrackets
6899 && PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE)
6904 PL_lex_allbrackets++;
6908 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
6909 #ifdef PERL_STRICT_CR
6912 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
6914 && (s == PL_linestart || s[-1] == '\n') )
6917 formbrack = 2; /* dot seen where arguments expected */
6920 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
6924 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
6927 if (!PL_lex_allbrackets
6928 && PL_lex_fakeeof >= LEX_FAKEEOF_RANGE)
6936 pl_yylval.ival = OPf_SPECIAL;
6942 if (*s == '=' && !PL_lex_allbrackets
6943 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
6951 case '0': case '1': case '2': case '3': case '4':
6952 case '5': case '6': case '7': case '8': case '9':
6953 s = scan_num(s, &pl_yylval);
6954 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6955 if (PL_expect == XOPERATOR)
6960 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6962 missingterm(NULL, 0);
6963 COPLINE_SET_FROM_MULTI_END;
6964 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6965 if (PL_expect == XOPERATOR) {
6968 pl_yylval.ival = OP_CONST;
6969 TERM(sublex_start());
6972 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
6975 printbuf("### Saw string before %s\n", s);
6977 PerlIO_printf(Perl_debug_log,
6978 "### Saw unterminated string\n");
6980 if (PL_expect == XOPERATOR) {
6984 missingterm(NULL, 0);
6985 pl_yylval.ival = OP_CONST;
6986 /* FIXME. I think that this can be const if char *d is replaced by
6987 more localised variables. */
6988 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
6989 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
6990 pl_yylval.ival = OP_STRINGIFY;
6994 if (pl_yylval.ival == OP_CONST)
6995 COPLINE_SET_FROM_MULTI_END;
6996 TERM(sublex_start());
6999 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
7002 printbuf("### Saw backtick string before %s\n", s);
7004 PerlIO_printf(Perl_debug_log,
7005 "### Saw unterminated backtick string\n");
7007 if (PL_expect == XOPERATOR)
7008 no_op("Backticks",s);
7010 missingterm(NULL, 0);
7011 pl_yylval.ival = OP_BACKTICK;
7012 TERM(sublex_start());
7016 if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
7018 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
7020 if (PL_expect == XOPERATOR)
7021 no_op("Backslash",s);
7025 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
7026 char *start = s + 2;
7027 while (isDIGIT(*start) || *start == '_')
7029 if (*start == '.' && isDIGIT(start[1])) {
7030 s = scan_num(s, &pl_yylval);
7033 else if ((*start == ':' && start[1] == ':')
7034 || (PL_expect == XSTATE && *start == ':'))
7036 else if (PL_expect == XSTATE) {
7038 while (d < PL_bufend && isSPACE(*d)) d++;
7039 if (*d == ':') goto keylookup;
7041 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
7042 if (!isALPHA(*start) && (PL_expect == XTERM
7043 || PL_expect == XREF || PL_expect == XSTATE
7044 || PL_expect == XTERMORDORDOR)) {
7045 GV *const gv = gv_fetchpvn_flags(s, start - s,
7046 UTF ? SVf_UTF8 : 0, SVt_PVCV);
7048 s = scan_num(s, &pl_yylval);
7055 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
7108 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7110 /* Some keywords can be followed by any delimiter, including ':' */
7111 anydelim = word_takes_any_delimiter(PL_tokenbuf, len);
7113 /* x::* is just a word, unless x is "CORE" */
7114 if (!anydelim && *s == ':' && s[1] == ':') {
7115 if (memEQs(PL_tokenbuf, len, "CORE")) goto case_KEY_CORE;
7120 while (d < PL_bufend && isSPACE(*d))
7121 d++; /* no comments skipped here, or s### is misparsed */
7123 /* Is this a word before a => operator? */
7124 if (*d == '=' && d[1] == '>') {
7128 = newSVOP(OP_CONST, 0,
7129 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
7130 pl_yylval.opval->op_private = OPpCONST_BARE;
7134 /* Check for plugged-in keyword */
7138 char *saved_bufptr = PL_bufptr;
7140 result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
7142 if (result == KEYWORD_PLUGIN_DECLINE) {
7143 /* not a plugged-in keyword */
7144 PL_bufptr = saved_bufptr;
7145 } else if (result == KEYWORD_PLUGIN_STMT) {
7146 pl_yylval.opval = o;
7148 if (!PL_nexttoke) PL_expect = XSTATE;
7149 return REPORT(PLUGSTMT);
7150 } else if (result == KEYWORD_PLUGIN_EXPR) {
7151 pl_yylval.opval = o;
7153 if (!PL_nexttoke) PL_expect = XOPERATOR;
7154 return REPORT(PLUGEXPR);
7156 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
7161 /* Check for built-in keyword */
7162 tmp = keyword(PL_tokenbuf, len, 0);
7164 /* Is this a label? */
7165 if (!anydelim && PL_expect == XSTATE
7166 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
7168 pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
7169 pl_yylval.pval[len] = '\0';
7170 pl_yylval.pval[len+1] = UTF ? 1 : 0;
7175 /* Check for lexical sub */
7176 if (PL_expect != XOPERATOR) {
7177 char tmpbuf[sizeof PL_tokenbuf + 1];
7179 Copy(PL_tokenbuf, tmpbuf+1, len, char);
7180 off = pad_findmy_pvn(tmpbuf, len+1, 0);
7181 if (off != NOT_IN_PAD) {
7182 assert(off); /* we assume this is boolean-true below */
7183 if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7184 HV * const stash = PAD_COMPNAME_OURSTASH(off);
7185 HEK * const stashname = HvNAME_HEK(stash);
7186 sv = newSVhek(stashname);
7187 sv_catpvs(sv, "::");
7188 sv_catpvn_flags(sv, PL_tokenbuf, len,
7189 (UTF ? SV_CATUTF8 : SV_CATBYTES));
7190 gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7200 rv2cv_op = newOP(OP_PADANY, 0);
7201 rv2cv_op->op_targ = off;
7202 cv = find_lexical_cv(off);
7210 if (tmp < 0) { /* second-class keyword? */
7211 GV *ogv = NULL; /* override (winner) */
7212 GV *hgv = NULL; /* hidden (loser) */
7213 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
7215 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
7216 (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
7218 && (cv = GvCVu(gv)))
7220 if (GvIMPORTED_CV(gv))
7222 else if (! CvMETHOD(cv))
7226 && (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
7229 && (isGV_with_GP(gv)
7230 ? GvCVu(gv) && GvIMPORTED_CV(gv)
7231 : SvPCS_IMPORTED(gv)
7232 && (gv_init(gv, PL_globalstash, PL_tokenbuf,
7240 tmp = 0; /* overridden by import or by GLOBAL */
7243 && -tmp==KEY_lock /* XXX generalizable kludge */
7246 tmp = 0; /* any sub overrides "weak" keyword */
7248 else { /* no override */
7250 if (tmp == KEY_dump) {
7251 Perl_ck_warner_d(aTHX_ packWARN2(WARN_MISC,WARN_DEPRECATED),
7252 "dump() better written as CORE::dump(). "
7253 "dump() will no longer be available "
7258 if (hgv && tmp != KEY_x) /* never ambiguous */
7259 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7260 "Ambiguous call resolved as CORE::%s(), "
7261 "qualify as such or use &",
7266 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
7267 && (!anydelim || *s != '#')) {
7268 /* no override, and not s### either; skipspace is safe here
7269 * check for => on following line */
7271 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
7272 STRLEN soff = s - SvPVX(PL_linestr);
7274 arrow = *s == '=' && s[1] == '>';
7275 PL_bufptr = SvPVX(PL_linestr) + bufoff;
7276 s = SvPVX(PL_linestr) + soff;
7284 /* Trade off - by using this evil construction we can pull the
7285 variable gv into the block labelled keylookup. If not, then
7286 we have to give it function scope so that the goto from the
7287 earlier ':' case doesn't bypass the initialisation. */
7288 just_a_word_zero_gv:
7298 default: /* not a keyword */
7301 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7303 bool no_op_error = FALSE;
7305 if (PL_expect == XOPERATOR) {
7306 if (PL_bufptr == PL_linestart) {
7307 CopLINE_dec(PL_curcop);
7308 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7309 CopLINE_inc(PL_curcop);
7312 /* We want to call no_op with s pointing after the
7313 bareword, so defer it. But we want it to come
7314 before the Bad name croak. */
7318 /* Get the rest if it looks like a package qualifier */
7320 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7322 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7325 no_op("Bareword",s);
7326 no_op_error = FALSE;
7329 Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
7330 UTF8fARG(UTF, len, PL_tokenbuf),
7331 *s == '\'' ? "'" : "::");
7337 no_op("Bareword",s);
7339 /* See if the name is "Foo::",
7340 in which case Foo is a bareword
7341 (and a package name). */
7344 && PL_tokenbuf[len - 2] == ':'
7345 && PL_tokenbuf[len - 1] == ':')
7347 if (ckWARN(WARN_BAREWORD)
7348 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7349 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7350 "Bareword \"%" UTF8f
7351 "\" refers to nonexistent package",
7352 UTF8fARG(UTF, len, PL_tokenbuf));
7354 PL_tokenbuf[len] = '\0';
7363 /* if we saw a global override before, get the right name */
7366 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7369 SV * const tmp_sv = sv;
7370 sv = newSVpvs("CORE::GLOBAL::");
7371 sv_catsv(sv, tmp_sv);
7372 SvREFCNT_dec(tmp_sv);
7376 /* Presume this is going to be a bareword of some sort. */
7378 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
7379 pl_yylval.opval->op_private = OPpCONST_BARE;
7381 /* And if "Foo::", then that's what it certainly is. */
7387 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7388 const_op->op_private = OPpCONST_BARE;
7390 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
7394 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
7397 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
7400 /* Use this var to track whether intuit_method has been
7401 called. intuit_method returns 0 or > 255. */
7404 /* See if it's the indirect object for a list operator. */
7407 && PL_oldoldbufptr < PL_bufptr
7408 && (PL_oldoldbufptr == PL_last_lop
7409 || PL_oldoldbufptr == PL_last_uni)
7410 && /* NO SKIPSPACE BEFORE HERE! */
7412 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
7415 bool immediate_paren = *s == '(';
7418 /* (Now we can afford to cross potential line boundary.) */
7421 /* intuit_method() can indirectly call lex_next_chunk(),
7424 s_off = s - SvPVX(PL_linestr);
7425 /* Two barewords in a row may indicate method call. */
7426 if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
7428 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7430 /* the code at method: doesn't use s */
7433 s = SvPVX(PL_linestr) + s_off;
7435 /* If not a declared subroutine, it's an indirect object. */
7436 /* (But it's an indir obj regardless for sort.) */
7437 /* Also, if "_" follows a filetest operator, it's a bareword */
7440 ( !immediate_paren && (PL_last_lop_op == OP_SORT
7442 && (PL_last_lop_op != OP_MAPSTART
7443 && PL_last_lop_op != OP_GREPSTART))))
7444 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7445 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
7449 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7454 PL_expect = XOPERATOR;
7457 /* Is this a word before a => operator? */
7458 if (*s == '=' && s[1] == '>' && !pkgname) {
7461 if (gvp || (lex && !off)) {
7462 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
7463 /* This is our own scalar, created a few lines
7464 above, so this is safe. */
7466 sv_setpv(sv, PL_tokenbuf);
7467 if (UTF && !IN_BYTES
7468 && is_utf8_string((U8*)PL_tokenbuf, len))
7475 /* If followed by a paren, it's certainly a subroutine. */
7480 while (SPACE_OR_TAB(*d))
7482 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
7487 NEXTVAL_NEXTTOKE.opval =
7488 off ? rv2cv_op : pl_yylval.opval;
7490 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7491 else op_free(rv2cv_op), force_next(BAREWORD);
7496 /* If followed by var or block, call it a method (unless sub) */
7498 if ((*s == '$' || *s == '{') && !cv) {
7500 PL_last_lop = PL_oldbufptr;
7501 PL_last_lop_op = OP_METHOD;
7502 if (!PL_lex_allbrackets
7503 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7505 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7507 PL_expect = XBLOCKTERM;
7509 return REPORT(METHOD);
7512 /* If followed by a bareword, see if it looks like indir obj. */
7516 && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
7517 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7521 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
7523 sv_setpvn(sv, PL_tokenbuf, len);
7524 if (UTF && !IN_BYTES
7525 && is_utf8_string((U8*)PL_tokenbuf, len))
7527 else SvUTF8_off(sv);
7530 if (tmp == METHOD && !PL_lex_allbrackets
7531 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7533 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7538 /* Not a method, so call it a subroutine (if defined) */
7541 /* Check for a constant sub */
7542 if ((sv = cv_const_sv_or_av(cv))) {
7545 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7546 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7547 if (SvTYPE(sv) == SVt_PVAV)
7548 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7551 pl_yylval.opval->op_private = 0;
7552 pl_yylval.opval->op_folded = 1;
7553 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7558 op_free(pl_yylval.opval);
7560 off ? newCVREF(0, rv2cv_op) : rv2cv_op;
7561 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7562 PL_last_lop = PL_oldbufptr;
7563 PL_last_lop_op = OP_ENTERSUB;
7564 /* Is there a prototype? */
7568 STRLEN protolen = CvPROTOLEN(cv);
7569 const char *proto = CvPROTO(cv);
7571 proto = S_strip_spaces(aTHX_ proto, &protolen);
7574 if ((optional = *proto == ';'))
7577 while (*proto == ';');
7581 *proto == '$' || *proto == '_'
7582 || *proto == '*' || *proto == '+'
7587 *proto == '\\' && proto[1] && proto[2] == '\0'
7590 UNIPROTO(UNIOPSUB,optional);
7591 if (*proto == '\\' && proto[1] == '[') {
7592 const char *p = proto + 2;
7593 while(*p && *p != ']')
7595 if(*p == ']' && !p[1])
7596 UNIPROTO(UNIOPSUB,optional);
7598 if (*proto == '&' && *s == '{') {
7600 sv_setpvs(PL_subname, "__ANON__");
7602 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7603 if (!PL_lex_allbrackets
7604 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7606 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7611 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7613 force_next(off ? PRIVATEREF : BAREWORD);
7614 if (!PL_lex_allbrackets
7615 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7617 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7622 /* Call it a bare word */
7624 if (PL_hints & HINT_STRICT_SUBS)
7625 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7628 /* after "print" and similar functions (corresponding to
7629 * "F? L" in opcode.pl), whatever wasn't already parsed as
7630 * a filehandle should be subject to "strict subs".
7631 * Likewise for the optional indirect-object argument to system
7632 * or exec, which can't be a bareword */
7633 if ((PL_last_lop_op == OP_PRINT
7634 || PL_last_lop_op == OP_PRTF
7635 || PL_last_lop_op == OP_SAY
7636 || PL_last_lop_op == OP_SYSTEM
7637 || PL_last_lop_op == OP_EXEC)
7638 && (PL_hints & HINT_STRICT_SUBS))
7639 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7640 if (lastchar != '-') {
7641 if (ckWARN(WARN_RESERVED)) {
7645 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7647 /* PL_warn_reserved is constant */
7648 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
7649 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7651 GCC_DIAG_RESTORE_STMT;
7659 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7660 && saw_infix_sigil) {
7661 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7662 "Operator or semicolon missing before %c%" UTF8f,
7664 UTF8fARG(UTF, strlen(PL_tokenbuf),
7666 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7667 "Ambiguous use of %c resolved as operator %c",
7668 lastchar, lastchar);
7675 newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7680 newSVOP(OP_CONST, 0,
7681 Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
7684 case KEY___PACKAGE__:
7686 newSVOP(OP_CONST, 0,
7688 ? newSVhek(HvNAME_HEK(PL_curstash))
7695 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7696 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7699 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7701 gv_init(gv,stash,"DATA",4,0);
7704 GvIOp(gv) = newIO();
7705 IoIFP(GvIOp(gv)) = PL_rsfp;
7706 /* Mark this internal pseudo-handle as clean */
7707 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7708 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7709 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7711 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7712 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7713 /* if the script was opened in binmode, we need to revert
7714 * it to text mode for compatibility; but only iff it has CRs
7715 * XXX this is a questionable hack at best. */
7716 if (PL_bufend-PL_bufptr > 2
7717 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7720 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7721 loc = PerlIO_tell(PL_rsfp);
7722 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7725 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7727 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7728 #endif /* NETWARE */
7730 PerlIO_seek(PL_rsfp, loc, 0);
7734 #ifdef PERLIO_LAYERS
7737 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7746 FUN0OP(CvCLONE(PL_compcv)
7747 ? newOP(OP_RUNCV, 0)
7748 : newPVOP(OP_RUNCV,0,NULL));
7757 if (PL_expect == XSTATE) {
7768 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7769 if ((*s == ':' && s[1] == ':')
7770 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7774 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7778 Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
7779 UTF8fARG(UTF, len, PL_tokenbuf));
7782 else if (tmp == KEY_require || tmp == KEY_do
7784 /* that's a way to remember we saw "CORE::" */
7796 LOP(OP_ACCEPT,XTERM);
7799 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7804 LOP(OP_ATAN2,XTERM);
7810 LOP(OP_BINMODE,XTERM);
7813 LOP(OP_BLESS,XTERM);
7822 /* We have to disambiguate the two senses of
7823 "continue". If the next token is a '{' then
7824 treat it as the start of a continue block;
7825 otherwise treat it as a control operator.
7835 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7845 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7854 if (!PL_cryptseen) {
7855 PL_cryptseen = TRUE;
7859 LOP(OP_CRYPT,XTERM);
7862 LOP(OP_CHMOD,XTERM);
7865 LOP(OP_CHOWN,XTERM);
7868 LOP(OP_CONNECT,XTERM);
7888 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7890 if (len && memNEs(PL_tokenbuf+1, len, "CORE")
7891 && !keyword(PL_tokenbuf + 1, len, 0)) {
7892 SSize_t off = s-SvPVX(PL_linestr);
7894 s = SvPVX(PL_linestr)+off;
7896 force_ident_maybe_lex('&');
7901 if (orig_keyword == KEY_do) {
7910 PL_hints |= HINT_BLOCK_SCOPE;
7920 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7921 STR_WITH_LEN("NDBM_File::"),
7922 STR_WITH_LEN("DB_File::"),
7923 STR_WITH_LEN("GDBM_File::"),
7924 STR_WITH_LEN("SDBM_File::"),
7925 STR_WITH_LEN("ODBM_File::"),
7927 LOP(OP_DBMOPEN,XTERM);
7939 pl_yylval.ival = CopLINE(PL_curcop);
7943 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7955 if (*s == '{') { /* block eval */
7956 PL_expect = XTERMBLOCK;
7957 UNIBRACK(OP_ENTERTRY);
7959 else { /* string eval */
7961 UNIBRACK(OP_ENTEREVAL);
7966 UNIBRACK(-OP_ENTEREVAL);
7980 case KEY_endhostent:
7986 case KEY_endservent:
7989 case KEY_endprotoent:
8000 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8002 pl_yylval.ival = CopLINE(PL_curcop);
8004 if ( PL_expect == XSTATE
8005 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
8008 SSize_t s_off = s - SvPVX(PL_linestr);
8010 if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "my")
8011 && isSPACE(*(p + 2)))
8015 else if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "our")
8016 && isSPACE(*(p + 3)))
8022 /* skip optional package name, as in "for my abc $x (..)" */
8023 if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
8024 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8027 if (*p != '$' && *p != '\\')
8028 Perl_croak(aTHX_ "Missing $ on loop variable");
8030 /* The buffer may have been reallocated, update s */
8031 s = SvPVX(PL_linestr) + s_off;
8036 LOP(OP_FORMLINE,XTERM);
8045 LOP(OP_FCNTL,XTERM);
8051 LOP(OP_FLOCK,XTERM);
8054 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8059 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8064 LOP(OP_GREPSTART, XREF);
8081 case KEY_getpriority:
8082 LOP(OP_GETPRIORITY,XTERM);
8084 case KEY_getprotobyname:
8087 case KEY_getprotobynumber:
8088 LOP(OP_GPBYNUMBER,XTERM);
8090 case KEY_getprotoent:
8102 case KEY_getpeername:
8103 UNI(OP_GETPEERNAME);
8105 case KEY_gethostbyname:
8108 case KEY_gethostbyaddr:
8109 LOP(OP_GHBYADDR,XTERM);
8111 case KEY_gethostent:
8114 case KEY_getnetbyname:
8117 case KEY_getnetbyaddr:
8118 LOP(OP_GNBYADDR,XTERM);
8123 case KEY_getservbyname:
8124 LOP(OP_GSBYNAME,XTERM);
8126 case KEY_getservbyport:
8127 LOP(OP_GSBYPORT,XTERM);
8129 case KEY_getservent:
8132 case KEY_getsockname:
8133 UNI(OP_GETSOCKNAME);
8135 case KEY_getsockopt:
8136 LOP(OP_GSOCKOPT,XTERM);
8151 pl_yylval.ival = CopLINE(PL_curcop);
8152 Perl_ck_warner_d(aTHX_
8153 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8154 "given is experimental");
8159 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
8167 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8169 pl_yylval.ival = CopLINE(PL_curcop);
8173 LOP(OP_INDEX,XTERM);
8179 LOP(OP_IOCTL,XTERM);
8206 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8211 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8225 LOP(OP_LISTEN,XTERM);
8234 s = scan_pat(s,OP_MATCH);
8235 TERM(sublex_start());
8238 LOP(OP_MAPSTART, XREF);
8241 LOP(OP_MKDIR,XTERM);
8244 LOP(OP_MSGCTL,XTERM);
8247 LOP(OP_MSGGET,XTERM);
8250 LOP(OP_MSGRCV,XTERM);
8253 LOP(OP_MSGSND,XTERM);
8260 yyerror(Perl_form(aTHX_
8261 "Can't redeclare \"%s\" in \"%s\"",
8262 tmp == KEY_my ? "my" :
8263 tmp == KEY_state ? "state" : "our",
8264 PL_in_my == KEY_my ? "my" :
8265 PL_in_my == KEY_state ? "state" : "our"));
8267 PL_in_my = (U16)tmp;
8269 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8270 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8271 if (memEQs(PL_tokenbuf, len, "sub"))
8273 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8274 if (!PL_in_my_stash) {
8278 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8279 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
8280 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8283 else if (*s == '\\') {
8284 if (!FEATURE_MYREF_IS_ENABLED)
8285 Perl_croak(aTHX_ "The experimental declared_refs "
8286 "feature is not enabled");
8287 Perl_ck_warner_d(aTHX_
8288 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
8289 "Declaring references is experimental");
8297 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8302 s = tokenize_use(0, s);
8306 if (*s == '(' || (s = skipspace(s), *s == '('))
8309 if (!PL_lex_allbrackets
8310 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8312 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8319 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8321 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8323 for (t=d; isSPACE(*t);)
8325 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8327 && !(t[0] == '=' && t[1] == '>')
8328 && !(t[0] == ':' && t[1] == ':')
8329 && !keyword(s, d-s, 0)
8331 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8332 "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
8333 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8339 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8341 pl_yylval.ival = OP_OR;
8351 LOP(OP_OPEN_DIR,XTERM);
8354 checkcomma(s,PL_tokenbuf,"filehandle");
8358 checkcomma(s,PL_tokenbuf,"filehandle");
8377 s = force_word(s,BAREWORD,FALSE,TRUE);
8379 s = force_strict_version(s);
8383 LOP(OP_PIPE_OP,XTERM);
8386 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8388 missingterm(NULL, 0);
8389 COPLINE_SET_FROM_MULTI_END;
8390 pl_yylval.ival = OP_CONST;
8391 TERM(sublex_start());
8398 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8400 missingterm(NULL, 0);
8401 COPLINE_SET_FROM_MULTI_END;
8402 PL_expect = XOPERATOR;
8403 if (SvCUR(PL_lex_stuff)) {
8404 int warned_comma = !ckWARN(WARN_QW);
8405 int warned_comment = warned_comma;
8406 d = SvPV_force(PL_lex_stuff, len);
8408 for (; isSPACE(*d) && len; --len, ++d)
8413 if (!warned_comma || !warned_comment) {
8414 for (; !isSPACE(*d) && len; --len, ++d) {
8415 if (!warned_comma && *d == ',') {
8416 Perl_warner(aTHX_ packWARN(WARN_QW),
8417 "Possible attempt to separate words with commas");
8420 else if (!warned_comment && *d == '#') {
8421 Perl_warner(aTHX_ packWARN(WARN_QW),
8422 "Possible attempt to put comments in qw() list");
8428 for (; !isSPACE(*d) && len; --len, ++d)
8431 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8432 words = op_append_elem(OP_LIST, words,
8433 newSVOP(OP_CONST, 0, tokeq(sv)));
8438 words = newNULLLIST();
8439 SvREFCNT_dec_NN(PL_lex_stuff);
8440 PL_lex_stuff = NULL;
8441 PL_expect = XOPERATOR;
8442 pl_yylval.opval = sawparens(words);
8447 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8449 missingterm(NULL, 0);
8450 pl_yylval.ival = OP_STRINGIFY;
8451 if (SvIVX(PL_lex_stuff) == '\'')
8452 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8453 TERM(sublex_start());
8456 s = scan_pat(s,OP_QR);
8457 TERM(sublex_start());
8460 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8462 missingterm(NULL, 0);
8463 pl_yylval.ival = OP_BACKTICK;
8464 TERM(sublex_start());
8472 s = force_version(s, FALSE);
8474 else if (*s != 'v' || !isDIGIT(s[1])
8475 || (s = force_version(s, TRUE), *s == 'v'))
8477 *PL_tokenbuf = '\0';
8478 s = force_word(s,BAREWORD,TRUE,TRUE);
8479 if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
8480 PL_tokenbuf + sizeof(PL_tokenbuf),
8483 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8484 GV_ADD | (UTF ? SVf_UTF8 : 0));
8487 yyerror("<> at require-statement should be quotes");
8489 if (orig_keyword == KEY_require) {
8495 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
8497 PL_last_uni = PL_oldbufptr;
8498 PL_last_lop_op = OP_REQUIRE;
8500 return REPORT( (int)REQUIRE );
8509 LOP(OP_RENAME,XTERM);
8518 LOP(OP_RINDEX,XTERM);
8527 UNIDOR(OP_READLINE);
8530 UNIDOR(OP_BACKTICK);
8539 LOP(OP_REVERSE,XTERM);
8542 UNIDOR(OP_READLINK);
8549 if (pl_yylval.opval)
8550 TERM(sublex_start());
8552 TOKEN(1); /* force error */
8555 checkcomma(s,PL_tokenbuf,"filehandle");
8565 LOP(OP_SELECT,XTERM);
8571 LOP(OP_SEMCTL,XTERM);
8574 LOP(OP_SEMGET,XTERM);
8577 LOP(OP_SEMOP,XTERM);
8583 LOP(OP_SETPGRP,XTERM);
8585 case KEY_setpriority:
8586 LOP(OP_SETPRIORITY,XTERM);
8588 case KEY_sethostent:
8594 case KEY_setservent:
8597 case KEY_setprotoent:
8607 LOP(OP_SEEKDIR,XTERM);
8609 case KEY_setsockopt:
8610 LOP(OP_SSOCKOPT,XTERM);
8616 LOP(OP_SHMCTL,XTERM);
8619 LOP(OP_SHMGET,XTERM);
8622 LOP(OP_SHMREAD,XTERM);
8625 LOP(OP_SHMWRITE,XTERM);
8628 LOP(OP_SHUTDOWN,XTERM);
8637 LOP(OP_SOCKET,XTERM);
8639 case KEY_socketpair:
8640 LOP(OP_SOCKPAIR,XTERM);
8643 checkcomma(s,PL_tokenbuf,"subroutine name");
8646 s = force_word(s,BAREWORD,TRUE,TRUE);
8650 LOP(OP_SPLIT,XTERM);
8653 LOP(OP_SPRINTF,XTERM);
8656 LOP(OP_SPLICE,XTERM);
8671 LOP(OP_SUBSTR,XTERM);
8677 char * const tmpbuf = PL_tokenbuf + 1;
8678 bool have_name, have_proto;
8679 const int key = tmp;
8680 SV *format_name = NULL;
8681 bool is_sigsub = FEATURE_SIGNATURES_IS_ENABLED;
8683 SSize_t off = s-SvPVX(PL_linestr);
8685 d = SvPVX(PL_linestr)+off;
8687 SAVEBOOL(PL_parser->sig_seen);
8688 PL_parser->sig_seen = FALSE;
8690 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
8692 || (*s == ':' && s[1] == ':'))
8695 PL_expect = XATTRBLOCK;
8696 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8698 if (key == KEY_format)
8699 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8701 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8703 PL_tokenbuf, len + 1, 0
8705 sv_setpvn(PL_subname, tmpbuf, len);
8707 sv_setsv(PL_subname,PL_curstname);
8708 sv_catpvs(PL_subname,"::");
8709 sv_catpvn(PL_subname,tmpbuf,len);
8711 if (SvUTF8(PL_linestr))
8712 SvUTF8_on(PL_subname);
8719 if (key == KEY_my || key == KEY_our || key==KEY_state)
8722 /* diag_listed_as: Missing name in "%s sub" */
8724 "Missing name in \"%s\"", PL_bufptr);
8726 PL_expect = XATTRTERM;
8727 sv_setpvs(PL_subname,"?");
8731 if (key == KEY_format) {
8733 NEXTVAL_NEXTTOKE.opval
8734 = newSVOP(OP_CONST,0, format_name);
8735 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8736 force_next(BAREWORD);
8741 /* Look for a prototype */
8742 if (*s == '(' && !is_sigsub) {
8743 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8744 COPLINE_SET_FROM_MULTI_END;
8746 Perl_croak(aTHX_ "Prototype not terminated");
8747 (void)validate_proto(PL_subname, PL_lex_stuff,
8748 ckWARN(WARN_ILLEGALPROTO), 0);
8756 if ( !(*s == ':' && s[1] != ':')
8757 && (*s != '{' && *s != '(') && key != KEY_format)
8759 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8760 key == KEY_DESTROY || key == KEY_BEGIN ||
8761 key == KEY_UNITCHECK || key == KEY_CHECK ||
8762 key == KEY_INIT || key == KEY_END ||
8763 key == KEY_my || key == KEY_state ||
8766 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8767 else if (*s != ';' && *s != '}')
8768 Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
8772 NEXTVAL_NEXTTOKE.opval =
8773 newSVOP(OP_CONST, 0, PL_lex_stuff);
8774 PL_lex_stuff = NULL;
8779 sv_setpvs(PL_subname, "__ANON__");
8781 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8787 force_ident_maybe_lex('&');
8795 LOP(OP_SYSTEM,XREF);
8798 LOP(OP_SYMLINK,XTERM);
8801 LOP(OP_SYSCALL,XTERM);
8804 LOP(OP_SYSOPEN,XTERM);
8807 LOP(OP_SYSSEEK,XTERM);
8810 LOP(OP_SYSREAD,XTERM);
8813 LOP(OP_SYSWRITE,XTERM);
8818 TERM(sublex_start());
8839 LOP(OP_TRUNCATE,XTERM);
8851 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8853 pl_yylval.ival = CopLINE(PL_curcop);
8857 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8859 pl_yylval.ival = CopLINE(PL_curcop);
8863 LOP(OP_UNLINK,XTERM);
8869 LOP(OP_UNPACK,XTERM);
8872 LOP(OP_UTIME,XTERM);
8878 LOP(OP_UNSHIFT,XTERM);
8881 s = tokenize_use(1, s);
8891 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8893 pl_yylval.ival = CopLINE(PL_curcop);
8894 Perl_ck_warner_d(aTHX_
8895 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8896 "when is experimental");
8900 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8902 pl_yylval.ival = CopLINE(PL_curcop);
8906 PL_hints |= HINT_BLOCK_SCOPE;
8913 LOP(OP_WAITPID,XTERM);
8919 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8920 * we use the same number on EBCDIC */
8921 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8925 if (PL_expect == XOPERATOR) {
8926 if (*s == '=' && !PL_lex_allbrackets
8927 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8937 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8939 pl_yylval.ival = OP_XOR;
8948 Looks up an identifier in the pad or in a package
8950 is_sig indicates that this is a subroutine signature variable
8951 rather than a plain pad var.
8954 PRIVATEREF if this is a lexical name.
8955 BAREWORD if this belongs to a package.
8958 if we're in a my declaration
8959 croak if they tried to say my($foo::bar)
8960 build the ops for a my() declaration
8961 if it's an access to a my() variable
8962 build ops for access to a my() variable
8963 if in a dq string, and they've said @foo and we can't find @foo
8965 build ops for a bareword
8969 S_pending_ident(pTHX)
8972 const char pit = (char)pl_yylval.ival;
8973 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8974 /* All routes through this function want to know if there is a colon. */
8975 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8977 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8978 "### Pending identifier '%s'\n", PL_tokenbuf); });
8979 assert(tokenbuf_len >= 2);
8981 /* if we're in a my(), we can't allow dynamics here.
8982 $foo'bar has already been turned into $foo::bar, so
8983 just check for colons.
8985 if it's a legal name, the OP is a PADANY.
8988 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8990 /* diag_listed_as: No package name allowed for variable %s
8992 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8993 "%se %s in \"our\"",
8994 *PL_tokenbuf=='&' ?"subroutin":"variabl",
8995 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8996 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
9001 /* "my" variable %s can't be in a package */
9002 /* PL_no_myglob is constant */
9003 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
9004 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
9005 PL_in_my == KEY_my ? "my" : "state",
9006 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
9008 UTF ? SVf_UTF8 : 0);
9009 GCC_DIAG_RESTORE_STMT;
9012 if (PL_in_my == KEY_sigvar) {
9013 /* A signature 'padop' needs in addition, an op_first to
9014 * point to a child sigdefelem, and an extra field to hold
9015 * the signature index. We can achieve both by using an
9016 * UNOP_AUX and (ab)using the op_aux field to hold the
9017 * index. If we ever need more fields, use a real malloced
9018 * aux strut instead.
9020 o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
9021 INT2PTR(UNOP_AUX_item *,
9022 (PL_parser->sig_elems)));
9023 o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
9024 : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
9028 o = newOP(OP_PADANY, 0);
9029 o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
9030 UTF ? SVf_UTF8 : 0);
9031 if (PL_in_my == KEY_sigvar)
9034 pl_yylval.opval = o;
9040 build the ops for accesses to a my() variable.
9045 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
9047 if (tmp != NOT_IN_PAD) {
9048 /* might be an "our" variable" */
9049 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9050 /* build ops for a bareword */
9051 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9052 HEK * const stashname = HvNAME_HEK(stash);
9053 SV * const sym = newSVhek(stashname);
9054 sv_catpvs(sym, "::");
9055 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9056 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
9057 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9061 ((PL_tokenbuf[0] == '$') ? SVt_PV
9062 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9067 pl_yylval.opval = newOP(OP_PADANY, 0);
9068 pl_yylval.opval->op_targ = tmp;
9074 Whine if they've said @foo or @foo{key} in a doublequoted string,
9075 and @foo (or %foo) isn't a variable we can find in the symbol
9078 if (ckWARN(WARN_AMBIGUOUS)
9080 && PL_lex_state != LEX_NORMAL
9081 && !PL_lex_brackets)
9083 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9084 ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
9086 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9089 /* Downgraded from fatal to warning 20000522 mjd */
9090 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9091 "Possible unintended interpolation of %" UTF8f
9093 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9097 /* build ops for a bareword */
9098 pl_yylval.opval = newSVOP(OP_CONST, 0,
9099 newSVpvn_flags(PL_tokenbuf + 1,
9100 tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9101 UTF ? SVf_UTF8 : 0 ));
9102 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9104 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9105 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
9106 | ( UTF ? SVf_UTF8 : 0 ),
9107 ((PL_tokenbuf[0] == '$') ? SVt_PV
9108 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9114 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9116 PERL_ARGS_ASSERT_CHECKCOMMA;
9118 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9119 if (ckWARN(WARN_SYNTAX)) {
9122 for (w = s+2; *w && level; w++) {
9130 /* the list of chars below is for end of statements or
9131 * block / parens, boolean operators (&&, ||, //) and branch
9132 * constructs (or, and, if, until, unless, while, err, for).
9133 * Not a very solid hack... */
9134 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9135 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9136 "%s (...) interpreted as function",name);
9139 while (s < PL_bufend && isSPACE(*s))
9143 while (s < PL_bufend && isSPACE(*s))
9145 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
9146 const char * const w = s;
9147 s += UTF ? UTF8SKIP(s) : 1;
9148 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9149 s += UTF ? UTF8SKIP(s) : 1;
9150 while (s < PL_bufend && isSPACE(*s))
9154 if (keyword(w, s - w, 0))
9157 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9158 if (gv && GvCVu(gv))
9163 Copy(w, tmpbuf+1, s - w, char);
9165 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
9166 if (off != NOT_IN_PAD) return;
9168 Perl_croak(aTHX_ "No comma allowed after %s", what);
9173 /* S_new_constant(): do any overload::constant lookup.
9175 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9176 Best used as sv=new_constant(..., sv, ...).
9177 If s, pv are NULL, calls subroutine with one argument,
9178 and <type> is used with error messages only.
9179 <type> is assumed to be well formed UTF-8 */
9182 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9183 SV *sv, SV *pv, const char *type, STRLEN typelen)
9186 HV * table = GvHV(PL_hintgv); /* ^H */
9191 const char *why1 = "", *why2 = "", *why3 = "";
9193 PERL_ARGS_ASSERT_NEW_CONSTANT;
9194 /* We assume that this is true: */
9195 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9198 /* charnames doesn't work well if there have been errors found */
9199 if (PL_error_count > 0 && *key == 'c')
9201 SvREFCNT_dec_NN(sv);
9202 return &PL_sv_undef;
9205 sv_2mortal(sv); /* Parent created it permanently */
9207 || ! (PL_hints & HINT_LOCALIZE_HH)
9208 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9213 /* Here haven't found what we're looking for. If it is charnames,
9214 * perhaps it needs to be loaded. Try doing that before giving up */
9216 Perl_load_module(aTHX_
9218 newSVpvs("_charnames"),
9219 /* version parameter; no need to specify it, as if
9220 * we get too early a version, will fail anyway,
9221 * not being able to find '_charnames' */
9226 assert(sp == PL_stack_sp);
9227 table = GvHV(PL_hintgv);
9229 && (PL_hints & HINT_LOCALIZE_HH)
9230 && (cvp = hv_fetch(table, key, keylen, FALSE))
9236 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9237 msg = Perl_form(aTHX_
9238 "Constant(%.*s) unknown",
9239 (int)(type ? typelen : len),
9245 why3 = "} is not defined";
9248 msg = Perl_form(aTHX_
9249 /* The +3 is for '\N{'; -4 for that, plus '}' */
9250 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9254 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9255 (int)(type ? typelen : len),
9256 (type ? type: s), why1, why2, why3);
9259 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9260 return SvREFCNT_inc_simple_NN(sv);
9265 pv = newSVpvn_flags(s, len, SVs_TEMP);
9267 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9269 typesv = &PL_sv_undef;
9271 PUSHSTACKi(PERLSI_OVERLOAD);
9283 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9287 /* Check the eval first */
9288 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9290 const char * errstr;
9291 sv_catpvs(errsv, "Propagated");
9292 errstr = SvPV_const(errsv, errlen);
9293 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9295 res = SvREFCNT_inc_simple_NN(sv);
9299 SvREFCNT_inc_simple_void_NN(res);
9308 why1 = "Call to &{$^H{";
9310 why3 = "}} did not return a defined value";
9312 (void)sv_2mortal(sv);
9319 PERL_STATIC_INLINE void
9320 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package,
9321 bool is_utf8, bool check_dollar, bool tick_warn)
9324 const char *olds = *s;
9325 PERL_ARGS_ASSERT_PARSE_IDENT;
9327 while (*s < PL_bufend) {
9329 Perl_croak(aTHX_ "%s", ident_too_long);
9330 if (is_utf8 && isIDFIRST_utf8_safe(*s, PL_bufend)) {
9331 /* The UTF-8 case must come first, otherwise things
9332 * like c\N{COMBINING TILDE} would start failing, as the
9333 * isWORDCHAR_A case below would gobble the 'c' up.
9336 char *t = *s + UTF8SKIP(*s);
9337 while (isIDCONT_utf8_safe((const U8*) t, (const U8*) PL_bufend)) {
9340 if (*d + (t - *s) > e)
9341 Perl_croak(aTHX_ "%s", ident_too_long);
9342 Copy(*s, *d, t - *s, char);
9346 else if ( isWORDCHAR_A(**s) ) {
9349 } while (isWORDCHAR_A(**s) && *d < e);
9351 else if ( allow_package
9353 && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8))
9360 else if (allow_package && **s == ':' && (*s)[1] == ':'
9361 /* Disallow things like Foo::$bar. For the curious, this is
9362 * the code path that triggers the "Bad name after" warning
9363 * when looking for barewords.
9365 && !(check_dollar && (*s)[2] == '$')) {
9372 if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL
9373 && !PL_lex_brackets && ckWARN(WARN_SYNTAX))) {
9376 Newx(d, *s - olds + saw_tick + 2, char); /* +2 for $# */
9379 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9380 "Old package separator used in string");
9381 if (olds[-1] == '#')
9385 if (*olds == '\'') {
9392 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9393 "\t(Did you mean \"%" UTF8f "\" instead?)\n",
9394 UTF8fARG(is_utf8, d2-d, d));
9399 /* Returns a NUL terminated string, with the length of the string written to
9403 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9406 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9407 bool is_utf8 = cBOOL(UTF);
9409 PERL_ARGS_ASSERT_SCAN_WORD;
9411 parse_ident(&s, &d, e, allow_package, is_utf8, TRUE, FALSE);
9417 /* Is the byte 'd' a legal single character identifier name? 'u' is true
9418 * iff Unicode semantics are to be used. The legal ones are any of:
9419 * a) all ASCII characters except:
9420 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
9422 * The final case currently doesn't get this far in the program, so we
9423 * don't test for it. If that were to change, it would be ok to allow it.
9424 * b) When not under Unicode rules, any upper Latin1 character
9425 * c) Otherwise, when unicode rules are used, all XIDS characters.
9427 * Because all ASCII characters have the same representation whether
9428 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
9429 * '{' without knowing if is UTF-8 or not. */
9430 #define VALID_LEN_ONE_IDENT(s, e, is_utf8) \
9431 (isGRAPH_A(*(s)) || ((is_utf8) \
9432 ? isIDFIRST_utf8_safe(s, e) \
9434 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
9437 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
9439 I32 herelines = PL_parser->herelines;
9440 SSize_t bracket = -1;
9443 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9444 bool is_utf8 = cBOOL(UTF);
9445 I32 orig_copline = 0, tmp_copline = 0;
9447 PERL_ARGS_ASSERT_SCAN_IDENT;
9449 if (isSPACE(*s) || !*s)
9452 while (isDIGIT(*s)) {
9454 Perl_croak(aTHX_ "%s", ident_too_long);
9458 else { /* See if it is a "normal" identifier */
9459 parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE);
9464 /* Either a digit variable, or parse_ident() found an identifier
9465 (anything valid as a bareword), so job done and return. */
9466 if (PL_lex_state != LEX_NORMAL)
9467 PL_lex_state = LEX_INTERPENDMAYBE;
9471 /* Here, it is not a run-of-the-mill identifier name */
9473 if (*s == '$' && s[1]
9474 && ( isIDFIRST_lazy_if_safe(s+1, PL_bufend, is_utf8)
9475 || isDIGIT_A((U8)s[1])
9478 || memBEGINs(s+1, (STRLEN) (PL_bufend - (s+1)), "::")) )
9480 /* Dereferencing a value in a scalar variable.
9481 The alternatives are different syntaxes for a scalar variable.
9482 Using ' as a leading package separator isn't allowed. :: is. */
9485 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9487 bracket = s - SvPVX(PL_linestr);
9489 orig_copline = CopLINE(PL_curcop);
9490 if (s < PL_bufend && isSPACE(*s)) {
9494 if ((s <= PL_bufend - (is_utf8)
9497 && VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
9500 const STRLEN skip = UTF8SKIP(s);
9503 for ( i = 0; i < skip; i++ )
9511 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9512 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9516 /* Warn about ambiguous code after unary operators if {...} notation isn't
9517 used. There's no difference in ambiguity; it's merely a heuristic
9518 about when not to warn. */
9519 else if (ck_uni && bracket == -1)
9521 if (bracket != -1) {
9524 /* If we were processing {...} notation then... */
9525 if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
9526 || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9529 /* note we have to check for a normal identifier first,
9530 * as it handles utf8 symbols, and only after that has
9531 * been ruled out can we look at the caret words */
9532 if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
9533 /* if it starts as a valid identifier, assume that it is one.
9534 (the later check for } being at the expected point will trap
9535 cases where this doesn't pan out.) */
9536 d += is_utf8 ? UTF8SKIP(d) : 1;
9537 parse_ident(&s, &d, e, 1, is_utf8, TRUE, TRUE);
9540 else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
9542 while (isWORDCHAR(*s) && d < e) {
9546 Perl_croak(aTHX_ "%s", ident_too_long);
9549 tmp_copline = CopLINE(PL_curcop);
9550 if (s < PL_bufend && isSPACE(*s)) {
9553 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9554 /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
9555 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9556 const char * const brack =
9558 ((*s == '[') ? "[...]" : "{...}");
9559 orig_copline = CopLINE(PL_curcop);
9560 CopLINE_set(PL_curcop, tmp_copline);
9561 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9562 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9563 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9564 funny, dest, brack, funny, dest, brack);
9565 CopLINE_set(PL_curcop, orig_copline);
9568 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9569 PL_lex_allbrackets++;
9575 tmp_copline = CopLINE(PL_curcop);
9576 if ((skip = s < PL_bufend && isSPACE(*s))) {
9577 /* Avoid incrementing line numbers or resetting PL_linestart,
9578 in case we have to back up. */
9579 STRLEN s_off = s - SvPVX(PL_linestr);
9581 s = SvPVX(PL_linestr) + s_off;
9586 /* Expect to find a closing } after consuming any trailing whitespace.
9589 /* Now increment line numbers if applicable. */
9593 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9594 PL_lex_state = LEX_INTERPEND;
9597 if (PL_lex_state == LEX_NORMAL) {
9598 if (ckWARN(WARN_AMBIGUOUS)
9599 && (keyword(dest, d - dest, 0)
9600 || get_cvn_flags(dest, d - dest, is_utf8
9604 SV *tmp = newSVpvn_flags( dest, d - dest,
9605 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9608 orig_copline = CopLINE(PL_curcop);
9609 CopLINE_set(PL_curcop, tmp_copline);
9610 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9611 "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf,
9612 funny, SVfARG(tmp), funny, SVfARG(tmp));
9613 CopLINE_set(PL_curcop, orig_copline);
9618 /* Didn't find the closing } at the point we expected, so restore
9619 state such that the next thing to process is the opening { and */
9620 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
9621 CopLINE_set(PL_curcop, orig_copline);
9622 PL_parser->herelines = herelines;
9624 PL_parser->sub_no_recover = TRUE;
9627 else if ( PL_lex_state == LEX_INTERPNORMAL
9629 && !intuit_more(s, PL_bufend))
9630 PL_lex_state = LEX_INTERPEND;
9635 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
9637 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
9638 * found in the parse starting at 's', based on the subset that are valid
9639 * in this context input to this routine in 'valid_flags'. Advances s.
9640 * Returns TRUE if the input should be treated as a valid flag, so the next
9641 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
9642 * upon first call on the current regex. This routine will set it to any
9643 * charset modifier found. The caller shouldn't change it. This way,
9644 * another charset modifier encountered in the parse can be detected as an
9645 * error, as we have decided to allow only one */
9648 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9650 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9651 if (isWORDCHAR_lazy_if_safe( *s, PL_bufend, UTF)) {
9652 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9653 UTF ? SVf_UTF8 : 0);
9655 /* Pretend that it worked, so will continue processing before
9664 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
9665 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9666 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9667 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9668 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9669 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9670 case LOCALE_PAT_MOD:
9672 goto multiple_charsets;
9674 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9677 case UNICODE_PAT_MOD:
9679 goto multiple_charsets;
9681 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9684 case ASCII_RESTRICT_PAT_MOD:
9686 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9690 /* Error if previous modifier wasn't an 'a', but if it was, see
9691 * if, and accept, a second occurrence (only) */
9693 || get_regex_charset(*pmfl)
9694 != REGEX_ASCII_RESTRICTED_CHARSET)
9696 goto multiple_charsets;
9698 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9702 case DEPENDS_PAT_MOD:
9704 goto multiple_charsets;
9706 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9715 if (*charset != c) {
9716 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9718 else if (c == 'a') {
9719 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9720 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9723 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9726 /* Pretend that it worked, so will continue processing before dieing */
9732 S_scan_pat(pTHX_ char *start, I32 type)
9736 const char * const valid_flags =
9737 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9738 char charset = '\0'; /* character set modifier */
9739 unsigned int x_mod_count = 0;
9741 PERL_ARGS_ASSERT_SCAN_PAT;
9743 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9745 Perl_croak(aTHX_ "Search pattern not terminated");
9747 pm = (PMOP*)newPMOP(type, 0);
9748 if (PL_multi_open == '?') {
9749 /* This is the only point in the code that sets PMf_ONCE: */
9750 pm->op_pmflags |= PMf_ONCE;
9752 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9753 allows us to restrict the list needed by reset to just the ??
9755 assert(type != OP_TRANS);
9757 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9760 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9763 elements = mg->mg_len / sizeof(PMOP**);
9764 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9765 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9766 mg->mg_len = elements * sizeof(PMOP**);
9767 PmopSTASH_set(pm,PL_curstash);
9771 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9772 * anon CV. False positives like qr/[(?{]/ are harmless */
9774 if (type == OP_QR) {
9776 char *e, *p = SvPV(PL_lex_stuff, len);
9778 for (; p < e; p++) {
9779 if (p[0] == '(' && p[1] == '?'
9780 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9782 pm->op_pmflags |= PMf_HAS_CV;
9786 pm->op_pmflags |= PMf_IS_QR;
9789 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9790 &s, &charset, &x_mod_count))
9792 /* issue a warning if /c is specified,but /g is not */
9793 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9795 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9796 "Use of /c modifier is meaningless without /g" );
9799 PL_lex_op = (OP*)pm;
9800 pl_yylval.ival = OP_MATCH;
9805 S_scan_subst(pTHX_ char *start)
9811 line_t linediff = 0;
9813 char charset = '\0'; /* character set modifier */
9814 unsigned int x_mod_count = 0;
9817 PERL_ARGS_ASSERT_SCAN_SUBST;
9819 pl_yylval.ival = OP_NULL;
9821 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9824 Perl_croak(aTHX_ "Substitution pattern not terminated");
9828 first_start = PL_multi_start;
9829 first_line = CopLINE(PL_curcop);
9830 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9832 SvREFCNT_dec_NN(PL_lex_stuff);
9833 PL_lex_stuff = NULL;
9834 Perl_croak(aTHX_ "Substitution replacement not terminated");
9836 PL_multi_start = first_start; /* so whole substitution is taken together */
9838 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9842 if (*s == EXEC_PAT_MOD) {
9846 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9847 &s, &charset, &x_mod_count))
9853 if ((pm->op_pmflags & PMf_CONTINUE)) {
9854 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9858 SV * const repl = newSVpvs("");
9861 pm->op_pmflags |= PMf_EVAL;
9862 for (; es > 1; es--) {
9863 sv_catpvs(repl, "eval ");
9865 sv_catpvs(repl, "do {");
9866 sv_catsv(repl, PL_parser->lex_sub_repl);
9867 sv_catpvs(repl, "}");
9868 SvREFCNT_dec(PL_parser->lex_sub_repl);
9869 PL_parser->lex_sub_repl = repl;
9873 linediff = CopLINE(PL_curcop) - first_line;
9875 CopLINE_set(PL_curcop, first_line);
9877 if (linediff || es) {
9878 /* the IVX field indicates that the replacement string is a s///e;
9879 * the NVX field indicates how many src code lines the replacement
9881 sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
9882 ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
9883 ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
9887 PL_lex_op = (OP*)pm;
9888 pl_yylval.ival = OP_SUBST;
9893 S_scan_trans(pTHX_ char *start)
9900 bool nondestruct = 0;
9903 PERL_ARGS_ASSERT_SCAN_TRANS;
9905 pl_yylval.ival = OP_NULL;
9907 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9909 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9913 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9915 SvREFCNT_dec_NN(PL_lex_stuff);
9916 PL_lex_stuff = NULL;
9917 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9920 complement = del = squash = 0;
9924 complement = OPpTRANS_COMPLEMENT;
9927 del = OPpTRANS_DELETE;
9930 squash = OPpTRANS_SQUASH;
9942 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9943 o->op_private &= ~OPpTRANS_ALL;
9944 o->op_private |= del|squash|complement|
9945 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9946 (DO_UTF8(PL_parser->lex_sub_repl) ? OPpTRANS_TO_UTF : 0);
9949 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9956 Takes a pointer to the first < in <<FOO.
9957 Returns a pointer to the byte following <<FOO.
9959 This function scans a heredoc, which involves different methods
9960 depending on whether we are in a string eval, quoted construct, etc.
9961 This is because PL_linestr could containing a single line of input, or
9962 a whole string being evalled, or the contents of the current quote-
9965 The two basic methods are:
9966 - Steal lines from the input stream
9967 - Scan the heredoc in PL_linestr and remove it therefrom
9969 In a file scope or filtered eval, the first method is used; in a
9970 string eval, the second.
9972 In a quote-like operator, we have to choose between the two,
9973 depending on where we can find a newline. We peek into outer lex-
9974 ing scopes until we find one with a newline in it. If we reach the
9975 outermost lexing scope and it is a file, we use the stream method.
9976 Otherwise it is treated as an eval.
9980 S_scan_heredoc(pTHX_ char *s)
9982 I32 op_type = OP_SCALAR;
9991 bool indented = FALSE;
9992 const bool infile = PL_rsfp || PL_parser->filtered;
9993 const line_t origline = CopLINE(PL_curcop);
9994 LEXSHARED *shared = PL_parser->lex_shared;
9996 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9999 d = PL_tokenbuf + 1;
10000 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
10001 *PL_tokenbuf = '\n';
10003 if (*peek == '~') {
10007 while (SPACE_OR_TAB(*peek))
10009 if (*peek == '`' || *peek == '\'' || *peek =='"') {
10012 s = delimcpy(d, e, s, PL_bufend, term, &len);
10013 if (s == PL_bufend)
10014 Perl_croak(aTHX_ "Unterminated delimiter for here document");
10020 /* <<\FOO is equivalent to <<'FOO' */
10024 if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
10025 Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden");
10027 while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) {
10028 peek += UTF ? UTF8SKIP(peek) : 1;
10030 len = (peek - s >= e - d) ? (e - d) : (peek - s);
10031 Copy(s, d, len, char);
10035 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10036 Perl_croak(aTHX_ "Delimiter for here document is too long");
10039 len = d - PL_tokenbuf;
10041 #ifndef PERL_STRICT_CR
10042 d = (char *) memchr(s, '\r', PL_bufend - s);
10044 char * const olds = s;
10046 while (s < PL_bufend) {
10052 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
10061 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10066 tmpstr = newSV_type(SVt_PVIV);
10067 SvGROW(tmpstr, 80);
10068 if (term == '\'') {
10069 op_type = OP_CONST;
10070 SvIV_set(tmpstr, -1);
10072 else if (term == '`') {
10073 op_type = OP_BACKTICK;
10074 SvIV_set(tmpstr, '\\');
10077 PL_multi_start = origline + 1 + PL_parser->herelines;
10078 PL_multi_open = PL_multi_close = '<';
10079 /* inside a string eval or quote-like operator */
10080 if (!infile || PL_lex_inwhat) {
10083 char * const olds = s;
10084 PERL_CONTEXT * const cx = CX_CUR();
10085 /* These two fields are not set until an inner lexing scope is
10086 entered. But we need them set here. */
10087 shared->ls_bufptr = s;
10088 shared->ls_linestr = PL_linestr;
10090 /* Look for a newline. If the current buffer does not have one,
10091 peek into the line buffer of the parent lexing scope, going
10092 up as many levels as necessary to find one with a newline
10095 while (!(s = (char *)memchr(
10096 (void *)shared->ls_bufptr, '\n',
10097 SvEND(shared->ls_linestr)-shared->ls_bufptr
10099 shared = shared->ls_prev;
10100 /* shared is only null if we have gone beyond the outermost
10101 lexing scope. In a file, we will have broken out of the
10102 loop in the previous iteration. In an eval, the string buf-
10103 fer ends with "\n;", so the while condition above will have
10104 evaluated to false. So shared can never be null. Or so you
10105 might think. Odd syntax errors like s;@{<<; can gobble up
10106 the implicit semicolon at the end of a flie, causing the
10107 file handle to be closed even when we are not in a string
10108 eval. So shared may be null in that case.
10109 (Closing '}' here to balance the earlier open brace for
10110 editors that look for matched pairs.) */
10111 if (UNLIKELY(!shared))
10113 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10114 most lexing scope. In a file, shared->ls_linestr at that
10115 level is just one line, so there is no body to steal. */
10116 if (infile && !shared->ls_prev) {
10121 else { /* eval or we've already hit EOF */
10122 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10126 linestr = shared->ls_linestr;
10127 bufend = SvEND(linestr);
10132 while (s < bufend - len + 1) {
10134 ++PL_parser->herelines;
10136 if (memEQ(s, PL_tokenbuf + 1, len - 1)) {
10140 /* Only valid if it's preceded by whitespace only */
10141 while (backup != myolds && --backup >= myolds) {
10142 if (! SPACE_OR_TAB(*backup)) {
10149 /* No whitespace or all! */
10150 if (backup == s || *backup == '\n') {
10151 Newx(indent, indent_len + 1, char);
10152 memcpy(indent, backup + 1, indent_len);
10153 indent[indent_len] = 0;
10154 s--; /* before our delimiter */
10155 PL_parser->herelines--; /* this line doesn't count */
10161 while (s < bufend - len + 1
10162 && memNE(s,PL_tokenbuf,len) )
10165 ++PL_parser->herelines;
10169 if (s >= bufend - len + 1) {
10172 sv_setpvn(tmpstr,d+1,s-d);
10174 /* the preceding stmt passes a newline */
10175 PL_parser->herelines++;
10177 /* s now points to the newline after the heredoc terminator.
10178 d points to the newline before the body of the heredoc.
10181 /* We are going to modify linestr in place here, so set
10182 aside copies of the string if necessary for re-evals or
10184 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10185 check shared->re_eval_str. */
10186 if (shared->re_eval_start || shared->re_eval_str) {
10187 /* Set aside the rest of the regexp */
10188 if (!shared->re_eval_str)
10189 shared->re_eval_str =
10190 newSVpvn(shared->re_eval_start,
10191 bufend - shared->re_eval_start);
10192 shared->re_eval_start -= s-d;
10194 if (cxstack_ix >= 0
10195 && CxTYPE(cx) == CXt_EVAL
10196 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
10197 && cx->blk_eval.cur_text == linestr)
10199 cx->blk_eval.cur_text = newSVsv(linestr);
10200 cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
10202 /* Copy everything from s onwards back to d. */
10203 Move(s,d,bufend-s + 1,char);
10204 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10205 /* Setting PL_bufend only applies when we have not dug deeper
10206 into other scopes, because sublex_done sets PL_bufend to
10207 SvEND(PL_linestr). */
10208 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10214 char *oldbufptr_save;
10215 char *oldoldbufptr_save;
10217 SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
10218 term = PL_tokenbuf[1];
10220 linestr_save = PL_linestr; /* must restore this afterwards */
10221 d = s; /* and this */
10222 oldbufptr_save = PL_oldbufptr;
10223 oldoldbufptr_save = PL_oldoldbufptr;
10224 PL_linestr = newSVpvs("");
10225 PL_bufend = SvPVX(PL_linestr);
10227 PL_bufptr = PL_bufend;
10228 CopLINE_set(PL_curcop,
10229 origline + 1 + PL_parser->herelines);
10230 if (!lex_next_chunk(LEX_NO_TERM)
10231 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10232 /* Simply freeing linestr_save might seem simpler here, as it
10233 does not matter what PL_linestr points to, since we are
10234 about to croak; but in a quote-like op, linestr_save
10235 will have been prospectively freed already, via
10236 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
10237 restore PL_linestr. */
10238 SvREFCNT_dec_NN(PL_linestr);
10239 PL_linestr = linestr_save;
10240 PL_oldbufptr = oldbufptr_save;
10241 PL_oldoldbufptr = oldoldbufptr_save;
10244 CopLINE_set(PL_curcop, origline);
10245 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10246 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10247 /* ^That should be enough to avoid this needing to grow: */
10248 sv_catpvs(PL_linestr, "\n\0");
10249 assert(s == SvPVX(PL_linestr));
10250 PL_bufend = SvEND(PL_linestr);
10253 PL_parser->herelines++;
10254 PL_last_lop = PL_last_uni = NULL;
10255 #ifndef PERL_STRICT_CR
10256 if (PL_bufend - PL_linestart >= 2) {
10257 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
10258 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10260 PL_bufend[-2] = '\n';
10262 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10264 else if (PL_bufend[-1] == '\r')
10265 PL_bufend[-1] = '\n';
10267 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10268 PL_bufend[-1] = '\n';
10270 if (indented && (PL_bufend-s) >= len) {
10271 char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
10274 char *backup = found;
10277 /* Only valid if it's preceded by whitespace only */
10278 while (backup != s && --backup >= s) {
10279 if (! SPACE_OR_TAB(*backup)) {
10285 /* All whitespace or none! */
10286 if (backup == found || SPACE_OR_TAB(*backup)) {
10287 Newx(indent, indent_len + 1, char);
10288 memcpy(indent, backup, indent_len);
10289 indent[indent_len] = 0;
10290 SvREFCNT_dec(PL_linestr);
10291 PL_linestr = linestr_save;
10292 PL_linestart = SvPVX(linestr_save);
10293 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10294 PL_oldbufptr = oldbufptr_save;
10295 PL_oldoldbufptr = oldoldbufptr_save;
10301 /* Didn't find it */
10302 sv_catsv(tmpstr,PL_linestr);
10304 if (*s == term && PL_bufend-s >= len
10305 && memEQ(s,PL_tokenbuf + 1,len))
10307 SvREFCNT_dec(PL_linestr);
10308 PL_linestr = linestr_save;
10309 PL_linestart = SvPVX(linestr_save);
10310 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10311 PL_oldbufptr = oldbufptr_save;
10312 PL_oldoldbufptr = oldoldbufptr_save;
10316 sv_catsv(tmpstr,PL_linestr);
10321 PL_multi_end = origline + PL_parser->herelines;
10322 if (indented && indent) {
10323 STRLEN linecount = 1;
10324 STRLEN herelen = SvCUR(tmpstr);
10325 char *ss = SvPVX(tmpstr);
10326 char *se = ss + herelen;
10327 SV *newstr = newSV(herelen+1);
10330 /* Trim leading whitespace */
10332 /* newline only? Copy and move on */
10334 sv_catpvs(newstr,"\n");
10338 /* Found our indentation? Strip it */
10339 } else if (se - ss >= indent_len
10340 && memEQ(ss, indent, indent_len))
10346 while ((ss + le) < se && *(ss + le) != '\n')
10349 sv_catpvn(newstr, ss, le);
10353 /* Line doesn't begin with our indentation? Croak */
10356 "Indentation on line %d of here-doc doesn't match delimiter",
10361 /* avoid sv_setsv() as we dont wan't to COW here */
10362 sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
10364 SvREFCNT_dec_NN(newstr);
10366 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10367 SvPV_shrink_to_cur(tmpstr);
10370 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10373 PL_lex_stuff = tmpstr;
10374 pl_yylval.ival = op_type;
10378 SvREFCNT_dec(tmpstr);
10379 CopLINE_set(PL_curcop, origline);
10380 missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1);
10383 /* scan_inputsymbol
10384 takes: position of first '<' in input buffer
10385 returns: position of first char following the matching '>' in
10387 side-effects: pl_yylval and lex_op are set.
10392 <<>> read from ARGV without magic open
10393 <FH> read from filehandle
10394 <pkg::FH> read from package qualified filehandle
10395 <pkg'FH> read from package qualified filehandle
10396 <$fh> read from filehandle in $fh
10397 <*.h> filename glob
10402 S_scan_inputsymbol(pTHX_ char *start)
10404 char *s = start; /* current position in buffer */
10407 bool nomagicopen = FALSE;
10408 char *d = PL_tokenbuf; /* start of temp holding space */
10409 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10411 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10413 end = (char *) memchr(s, '\n', PL_bufend - s);
10416 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
10417 nomagicopen = TRUE;
10423 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10425 /* die if we didn't have space for the contents of the <>,
10426 or if it didn't end, or if we see a newline
10429 if (len >= (I32)sizeof PL_tokenbuf)
10430 Perl_croak(aTHX_ "Excessively long <> operator");
10432 Perl_croak(aTHX_ "Unterminated <> operator");
10437 Remember, only scalar variables are interpreted as filehandles by
10438 this code. Anything more complex (e.g., <$fh{$num}>) will be
10439 treated as a glob() call.
10440 This code makes use of the fact that except for the $ at the front,
10441 a scalar variable and a filehandle look the same.
10443 if (*d == '$' && d[1]) d++;
10445 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10446 while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') {
10447 d += UTF ? UTF8SKIP(d) : 1;
10450 /* If we've tried to read what we allow filehandles to look like, and
10451 there's still text left, then it must be a glob() and not a getline.
10452 Use scan_str to pull out the stuff between the <> and treat it
10453 as nothing more than a string.
10456 if (d - PL_tokenbuf != len) {
10457 pl_yylval.ival = OP_GLOB;
10458 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
10460 Perl_croak(aTHX_ "Glob not terminated");
10464 bool readline_overriden = FALSE;
10466 /* we're in a filehandle read situation */
10469 /* turn <> into <ARGV> */
10471 Copy("ARGV",d,5,char);
10473 /* Check whether readline() is overriden */
10474 if ((gv_readline = gv_override("readline",8)))
10475 readline_overriden = TRUE;
10477 /* if <$fh>, create the ops to turn the variable into a
10481 /* try to find it in the pad for this block, otherwise find
10482 add symbol table ops
10484 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
10485 if (tmp != NOT_IN_PAD) {
10486 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10487 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10488 HEK * const stashname = HvNAME_HEK(stash);
10489 SV * const sym = sv_2mortal(newSVhek(stashname));
10490 sv_catpvs(sym, "::");
10491 sv_catpv(sym, d+1);
10496 OP * const o = newOP(OP_PADSV, 0);
10498 PL_lex_op = readline_overriden
10499 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10500 op_append_elem(OP_LIST, o,
10501 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10502 : newUNOP(OP_READLINE, 0, o);
10510 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
10512 PL_lex_op = readline_overriden
10513 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10514 op_append_elem(OP_LIST,
10515 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10516 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10517 : newUNOP(OP_READLINE, 0,
10518 newUNOP(OP_RV2SV, 0,
10519 newGVOP(OP_GV, 0, gv)));
10521 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10522 pl_yylval.ival = OP_NULL;
10525 /* If it's none of the above, it must be a literal filehandle
10526 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10528 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10529 PL_lex_op = readline_overriden
10530 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10531 op_append_elem(OP_LIST,
10532 newGVOP(OP_GV, 0, gv),
10533 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10534 : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
10535 pl_yylval.ival = OP_NULL;
10545 start position in buffer
10546 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
10547 only if they are of the open/close form
10548 keep_delims preserve the delimiters around the string
10549 re_reparse compiling a run-time /(?{})/:
10550 collapse // to /, and skip encoding src
10551 delimp if non-null, this is set to the position of
10552 the closing delimiter, or just after it if
10553 the closing and opening delimiters differ
10554 (i.e., the opening delimiter of a substitu-
10556 returns: position to continue reading from buffer
10557 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10558 updates the read buffer.
10560 This subroutine pulls a string out of the input. It is called for:
10561 q single quotes q(literal text)
10562 ' single quotes 'literal text'
10563 qq double quotes qq(interpolate $here please)
10564 " double quotes "interpolate $here please"
10565 qx backticks qx(/bin/ls -l)
10566 ` backticks `/bin/ls -l`
10567 qw quote words @EXPORT_OK = qw( func() $spam )
10568 m// regexp match m/this/
10569 s/// regexp substitute s/this/that/
10570 tr/// string transliterate tr/this/that/
10571 y/// string transliterate y/this/that/
10572 ($*@) sub prototypes sub foo ($)
10573 (stuff) sub attr parameters sub foo : attr(stuff)
10574 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10576 In most of these cases (all but <>, patterns and transliterate)
10577 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10578 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10579 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10582 It skips whitespace before the string starts, and treats the first
10583 character as the delimiter. If the delimiter is one of ([{< then
10584 the corresponding "close" character )]}> is used as the closing
10585 delimiter. It allows quoting of delimiters, and if the string has
10586 balanced delimiters ([{<>}]) it allows nesting.
10588 On success, the SV with the resulting string is put into lex_stuff or,
10589 if that is already non-NULL, into lex_repl. The second case occurs only
10590 when parsing the RHS of the special constructs s/// and tr/// (y///).
10591 For convenience, the terminating delimiter character is stuffed into
10596 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
10600 SV *sv; /* scalar value: string */
10601 const char *tmps; /* temp string, used for delimiter matching */
10602 char *s = start; /* current position in the buffer */
10603 char term; /* terminating character */
10604 char *to; /* current position in the sv's data */
10605 I32 brackets = 1; /* bracket nesting level */
10606 bool has_utf8 = FALSE; /* is there any utf8 content? */
10607 IV termcode; /* terminating char. code */
10608 U8 termstr[UTF8_MAXBYTES+1]; /* terminating string */
10609 STRLEN termlen; /* length of terminating string */
10612 /* The delimiters that have a mirror-image closing one */
10613 const char * opening_delims = "([{<";
10614 const char * closing_delims = ")]}>";
10616 /* The only non-UTF character that isn't a stand alone grapheme is
10617 * white-space, hence can't be a delimiter. */
10618 const char * non_grapheme_msg = "Use of unassigned code point or"
10619 " non-standalone grapheme for a delimiter"
10621 PERL_ARGS_ASSERT_SCAN_STR;
10623 /* skip space before the delimiter */
10628 /* mark where we are, in case we need to report errors */
10631 /* after skipping whitespace, the next character is the terminator */
10633 if (!UTF || UTF8_IS_INVARIANT(term)) {
10634 termcode = termstr[0] = term;
10638 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10639 if (UTF && UNLIKELY(! _is_grapheme((U8 *) start,
10644 yyerror(non_grapheme_msg);
10647 Copy(s, termstr, termlen, U8);
10650 /* mark where we are */
10651 PL_multi_start = CopLINE(PL_curcop);
10652 PL_multi_open = termcode;
10653 herelines = PL_parser->herelines;
10655 /* If the delimiter has a mirror-image closing one, get it */
10656 if (term && (tmps = strchr(opening_delims, term))) {
10657 termcode = termstr[0] = term = closing_delims[tmps - opening_delims];
10660 PL_multi_close = termcode;
10662 if (PL_multi_open == PL_multi_close) {
10663 keep_bracketed_quoted = FALSE;
10666 /* create a new SV to hold the contents. 79 is the SV's initial length.
10667 What a random number. */
10668 sv = newSV_type(SVt_PVIV);
10670 SvIV_set(sv, termcode);
10671 (void)SvPOK_only(sv); /* validate pointer */
10673 /* move past delimiter and try to read a complete string */
10675 sv_catpvn(sv, s, termlen);
10678 /* extend sv if need be */
10679 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10680 /* set 'to' to the next character in the sv's string */
10681 to = SvPVX(sv)+SvCUR(sv);
10683 /* if open delimiter is the close delimiter read unbridle */
10684 if (PL_multi_open == PL_multi_close) {
10685 for (; s < PL_bufend; s++,to++) {
10686 /* embedded newlines increment the current line number */
10687 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10688 COPLINE_INC_WITH_HERELINES;
10689 /* handle quoted delimiters */
10690 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10691 if (!keep_bracketed_quoted
10693 || (re_reparse && s[1] == '\\'))
10696 else /* any other quotes are simply copied straight through */
10699 /* terminate when run out of buffer (the for() condition), or
10700 have found the terminator */
10701 else if (*s == term) { /* First byte of terminator matches */
10702 if (termlen == 1) /* If is the only byte, are done */
10705 /* If the remainder of the terminator matches, also are
10706 * done, after checking that is a separate grapheme */
10707 if ( s + termlen <= PL_bufend
10708 && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
10711 && UNLIKELY(! _is_grapheme((U8 *) start,
10716 yyerror(non_grapheme_msg);
10721 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
10729 /* if the terminator isn't the same as the start character (e.g.,
10730 matched brackets), we have to allow more in the quoting, and
10731 be prepared for nested brackets.
10734 /* read until we run out of string, or we find the terminator */
10735 for (; s < PL_bufend; s++,to++) {
10736 /* embedded newlines increment the line count */
10737 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10738 COPLINE_INC_WITH_HERELINES;
10739 /* backslashes can escape the open or closing characters */
10740 if (*s == '\\' && s+1 < PL_bufend) {
10741 if (!keep_bracketed_quoted
10742 && ( ((UV)s[1] == PL_multi_open)
10743 || ((UV)s[1] == PL_multi_close) ))
10750 /* allow nested opens and closes */
10751 else if ((UV)*s == PL_multi_close && --brackets <= 0)
10753 else if ((UV)*s == PL_multi_open)
10755 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10760 /* terminate the copied string and update the sv's end-of-string */
10762 SvCUR_set(sv, to - SvPVX_const(sv));
10765 * this next chunk reads more into the buffer if we're not done yet
10769 break; /* handle case where we are done yet :-) */
10771 #ifndef PERL_STRICT_CR
10772 if (to - SvPVX_const(sv) >= 2) {
10773 if ( (to[-2] == '\r' && to[-1] == '\n')
10774 || (to[-2] == '\n' && to[-1] == '\r'))
10778 SvCUR_set(sv, to - SvPVX_const(sv));
10780 else if (to[-1] == '\r')
10783 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10787 /* if we're out of file, or a read fails, bail and reset the current
10788 line marker so we can report where the unterminated string began
10790 COPLINE_INC_WITH_HERELINES;
10791 PL_bufptr = PL_bufend;
10792 if (!lex_next_chunk(0)) {
10794 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10797 s = start = PL_bufptr;
10800 /* at this point, we have successfully read the delimited string */
10803 sv_catpvn(sv, s, termlen);
10809 PL_multi_end = CopLINE(PL_curcop);
10810 CopLINE_set(PL_curcop, PL_multi_start);
10811 PL_parser->herelines = herelines;
10813 /* if we allocated too much space, give some back */
10814 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10815 SvLEN_set(sv, SvCUR(sv) + 1);
10816 SvPV_renew(sv, SvLEN(sv));
10819 /* decide whether this is the first or second quoted string we've read
10824 PL_parser->lex_sub_repl = sv;
10827 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10833 takes: pointer to position in buffer
10834 returns: pointer to new position in buffer
10835 side-effects: builds ops for the constant in pl_yylval.op
10837 Read a number in any of the formats that Perl accepts:
10839 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10840 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10841 0b[01](_?[01])* binary integers
10842 0[0-7](_?[0-7])* octal integers
10843 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10844 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10846 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10849 If it reads a number without a decimal point or an exponent, it will
10850 try converting the number to an integer and see if it can do so
10851 without loss of precision.
10855 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10857 const char *s = start; /* current position in buffer */
10858 char *d; /* destination in temp buffer */
10859 char *e; /* end of temp buffer */
10860 NV nv; /* number read, as a double */
10861 SV *sv = NULL; /* place to put the converted number */
10862 bool floatit; /* boolean: int or float? */
10863 const char *lastub = NULL; /* position of last underbar */
10864 static const char* const number_too_long = "Number too long";
10865 bool warned_about_underscore = 0;
10866 #define WARN_ABOUT_UNDERSCORE() \
10868 if (!warned_about_underscore) { \
10869 warned_about_underscore = 1; \
10870 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \
10871 "Misplaced _ in number"); \
10874 /* Hexadecimal floating point.
10876 * In many places (where we have quads and NV is IEEE 754 double)
10877 * we can fit the mantissa bits of a NV into an unsigned quad.
10878 * (Note that UVs might not be quads even when we have quads.)
10879 * This will not work everywhere, though (either no quads, or
10880 * using long doubles), in which case we have to resort to NV,
10881 * which will probably mean horrible loss of precision due to
10882 * multiple fp operations. */
10883 bool hexfp = FALSE;
10884 int total_bits = 0;
10885 int significant_bits = 0;
10886 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10887 # define HEXFP_UQUAD
10888 Uquad_t hexfp_uquad = 0;
10889 int hexfp_frac_bits = 0;
10894 NV hexfp_mult = 1.0;
10895 UV high_non_zero = 0; /* highest digit */
10896 int non_zero_integer_digits = 0;
10898 PERL_ARGS_ASSERT_SCAN_NUM;
10900 /* We use the first character to decide what type of number this is */
10904 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10906 /* if it starts with a 0, it could be an octal number, a decimal in
10907 0.13 disguise, or a hexadecimal number, or a binary number. */
10911 u holds the "number so far"
10912 shift the power of 2 of the base
10913 (hex == 4, octal == 3, binary == 1)
10914 overflowed was the number more than we can hold?
10916 Shift is used when we add a digit. It also serves as an "are
10917 we in octal/hex/binary?" indicator to disallow hex characters
10918 when in octal mode.
10923 bool overflowed = FALSE;
10924 bool just_zero = TRUE; /* just plain 0 or binary number? */
10925 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10926 static const char* const bases[5] =
10927 { "", "binary", "", "octal", "hexadecimal" };
10928 static const char* const Bases[5] =
10929 { "", "Binary", "", "Octal", "Hexadecimal" };
10930 static const char* const maxima[5] =
10932 "0b11111111111111111111111111111111",
10936 const char *base, *Base, *max;
10938 /* check for hex */
10939 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10943 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10948 /* check for a decimal in disguise */
10949 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10951 /* so it must be octal */
10958 WARN_ABOUT_UNDERSCORE();
10962 base = bases[shift];
10963 Base = Bases[shift];
10964 max = maxima[shift];
10966 /* read the rest of the number */
10968 /* x is used in the overflow test,
10969 b is the digit we're adding on. */
10974 /* if we don't mention it, we're done */
10978 /* _ are ignored -- but warned about if consecutive */
10980 if (lastub && s == lastub + 1)
10981 WARN_ABOUT_UNDERSCORE();
10985 /* 8 and 9 are not octal */
10986 case '8': case '9':
10988 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10992 case '2': case '3': case '4':
10993 case '5': case '6': case '7':
10995 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10998 case '0': case '1':
10999 b = *s++ & 15; /* ASCII digit -> value of digit */
11003 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11004 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11005 /* make sure they said 0x */
11008 b = (*s++ & 7) + 9;
11010 /* Prepare to put the digit we have onto the end
11011 of the number so far. We check for overflows.
11017 assert(shift >= 0);
11018 x = u << shift; /* make room for the digit */
11020 total_bits += shift;
11022 if ((x >> shift) != u
11023 && !(PL_hints & HINT_NEW_BINARY)) {
11026 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11027 "Integer overflow in %s number",
11030 u = x | b; /* add the digit to the end */
11033 n *= nvshift[shift];
11034 /* If an NV has not enough bits in its
11035 * mantissa to represent an UV this summing of
11036 * small low-order numbers is a waste of time
11037 * (because the NV cannot preserve the
11038 * low-order bits anyway): we could just
11039 * remember when did we overflow and in the
11040 * end just multiply n by the right
11045 if (high_non_zero == 0 && b > 0)
11049 non_zero_integer_digits++;
11051 /* this could be hexfp, but peek ahead
11052 * to avoid matching ".." */
11053 if (UNLIKELY(HEXFP_PEEK(s))) {
11061 /* if we get here, we had success: make a scalar value from
11066 /* final misplaced underbar check */
11068 WARN_ABOUT_UNDERSCORE();
11070 if (UNLIKELY(HEXFP_PEEK(s))) {
11071 /* Do sloppy (on the underbars) but quick detection
11072 * (and value construction) for hexfp, the decimal
11073 * detection will shortly be more thorough with the
11074 * underbar checks. */
11076 significant_bits = non_zero_integer_digits * shift;
11079 #else /* HEXFP_NV */
11082 /* Ignore the leading zero bits of
11083 * the high (first) non-zero digit. */
11084 if (high_non_zero) {
11085 if (high_non_zero < 0x8)
11086 significant_bits--;
11087 if (high_non_zero < 0x4)
11088 significant_bits--;
11089 if (high_non_zero < 0x2)
11090 significant_bits--;
11097 bool accumulate = TRUE;
11099 int lim = 1 << shift;
11100 for (h++; ((isXDIGIT(*h) && (b = XDIGIT_VALUE(*h)) < lim) ||
11102 if (isXDIGIT(*h)) {
11103 significant_bits += shift;
11106 if (significant_bits < NV_MANT_DIG) {
11107 /* We are in the long "run" of xdigits,
11108 * accumulate the full four bits. */
11109 assert(shift >= 0);
11110 hexfp_uquad <<= shift;
11112 hexfp_frac_bits += shift;
11113 } else if (significant_bits - shift < NV_MANT_DIG) {
11114 /* We are at a hexdigit either at,
11115 * or straddling, the edge of mantissa.
11116 * We will try grabbing as many as
11117 * possible bits. */
11119 significant_bits - NV_MANT_DIG;
11123 hexfp_uquad <<= tail;
11124 assert((shift - tail) >= 0);
11125 hexfp_uquad |= b >> (shift - tail);
11126 hexfp_frac_bits += tail;
11128 /* Ignore the trailing zero bits
11129 * of the last non-zero xdigit.
11131 * The assumption here is that if
11132 * one has input of e.g. the xdigit
11133 * eight (0x8), there is only one
11134 * bit being input, not the full
11135 * four bits. Conversely, if one
11136 * specifies a zero xdigit, the
11137 * assumption is that one really
11138 * wants all those bits to be zero. */
11140 if ((b & 0x1) == 0x0) {
11141 significant_bits--;
11142 if ((b & 0x2) == 0x0) {
11143 significant_bits--;
11144 if ((b & 0x4) == 0x0) {
11145 significant_bits--;
11151 accumulate = FALSE;
11154 /* Keep skipping the xdigits, and
11155 * accumulating the significant bits,
11156 * but do not shift the uquad
11157 * (which would catastrophically drop
11158 * high-order bits) or accumulate the
11159 * xdigits anymore. */
11161 #else /* HEXFP_NV */
11163 nv_mult /= nvshift[shift];
11165 hexfp_nv += b * nv_mult;
11167 accumulate = FALSE;
11171 if (significant_bits >= NV_MANT_DIG)
11172 accumulate = FALSE;
11176 if ((total_bits > 0 || significant_bits > 0) &&
11177 isALPHA_FOLD_EQ(*h, 'p')) {
11178 bool negexp = FALSE;
11182 else if (*h == '-') {
11188 while (isDIGIT(*h) || *h == '_') {
11191 hexfp_exp += *h - '0';
11194 && -hexfp_exp < NV_MIN_EXP - 1) {
11195 /* NOTE: this means that the exponent
11196 * underflow warning happens for
11197 * the IEEE 754 subnormals (denormals),
11198 * because DBL_MIN_EXP etc are the lowest
11199 * possible binary (or, rather, DBL_RADIX-base)
11200 * exponent for normals, not subnormals.
11202 * This may or may not be a good thing. */
11203 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11204 "Hexadecimal float: exponent underflow");
11210 && hexfp_exp > NV_MAX_EXP - 1) {
11211 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11212 "Hexadecimal float: exponent overflow");
11220 hexfp_exp = -hexfp_exp;
11222 hexfp_exp -= hexfp_frac_bits;
11224 hexfp_mult = Perl_pow(2.0, hexfp_exp);
11232 if (n > 4294967295.0)
11233 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11234 "%s number > %s non-portable",
11240 if (u > 0xffffffff)
11241 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11242 "%s number > %s non-portable",
11247 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11248 sv = new_constant(start, s - start, "integer",
11249 sv, NULL, NULL, 0);
11250 else if (PL_hints & HINT_NEW_BINARY)
11251 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11256 handle decimal numbers.
11257 we're also sent here when we read a 0 as the first digit
11259 case '1': case '2': case '3': case '4': case '5':
11260 case '6': case '7': case '8': case '9': case '.':
11263 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11272 /* read next group of digits and _ and copy into d */
11275 || UNLIKELY(hexfp && isXDIGIT(*s)))
11277 /* skip underscores, checking for misplaced ones
11281 if (lastub && s == lastub + 1)
11282 WARN_ABOUT_UNDERSCORE();
11286 /* check for end of fixed-length buffer */
11288 Perl_croak(aTHX_ "%s", number_too_long);
11289 /* if we're ok, copy the character */
11294 /* final misplaced underbar check */
11295 if (lastub && s == lastub + 1)
11296 WARN_ABOUT_UNDERSCORE();
11298 /* read a decimal portion if there is one. avoid
11299 3..5 being interpreted as the number 3. followed
11302 if (*s == '.' && s[1] != '.') {
11307 WARN_ABOUT_UNDERSCORE();
11311 /* copy, ignoring underbars, until we run out of digits.
11315 || UNLIKELY(hexfp && isXDIGIT(*s));
11318 /* fixed length buffer check */
11320 Perl_croak(aTHX_ "%s", number_too_long);
11322 if (lastub && s == lastub + 1)
11323 WARN_ABOUT_UNDERSCORE();
11329 /* fractional part ending in underbar? */
11331 WARN_ABOUT_UNDERSCORE();
11332 if (*s == '.' && isDIGIT(s[1])) {
11333 /* oops, it's really a v-string, but without the "v" */
11339 /* read exponent part, if present */
11340 if ((isALPHA_FOLD_EQ(*s, 'e')
11341 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
11342 && strchr("+-0123456789_", s[1]))
11344 int exp_digits = 0;
11345 const char *save_s = s;
11348 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
11349 ditto for p (hexfloats) */
11350 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
11351 /* At least some Mach atof()s don't grok 'E' */
11354 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
11361 /* stray preinitial _ */
11363 WARN_ABOUT_UNDERSCORE();
11367 /* allow positive or negative exponent */
11368 if (*s == '+' || *s == '-')
11371 /* stray initial _ */
11373 WARN_ABOUT_UNDERSCORE();
11377 /* read digits of exponent */
11378 while (isDIGIT(*s) || *s == '_') {
11382 Perl_croak(aTHX_ "%s", number_too_long);
11386 if (((lastub && s == lastub + 1)
11387 || (!isDIGIT(s[1]) && s[1] != '_')))
11388 WARN_ABOUT_UNDERSCORE();
11394 /* no exponent digits, the [eEpP] could be for something else,
11395 * though in practice we don't get here for p since that's preparsed
11396 * earlier, and results in only the 0xX being consumed, so behave similarly
11397 * for decimal floats and consume only the D.DD, leaving the [eE] to the
11410 We try to do an integer conversion first if no characters
11411 indicating "float" have been found.
11416 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11418 if (flags == IS_NUMBER_IN_UV) {
11420 sv = newSViv(uv); /* Prefer IVs over UVs. */
11423 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11424 if (uv <= (UV) IV_MIN)
11425 sv = newSViv(-(IV)uv);
11432 /* terminate the string */
11434 if (UNLIKELY(hexfp)) {
11435 # ifdef NV_MANT_DIG
11436 if (significant_bits > NV_MANT_DIG)
11437 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11438 "Hexadecimal float: mantissa overflow");
11441 nv = hexfp_uquad * hexfp_mult;
11442 #else /* HEXFP_NV */
11443 nv = hexfp_nv * hexfp_mult;
11446 nv = Atof(PL_tokenbuf);
11452 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11453 const char *const key = floatit ? "float" : "integer";
11454 const STRLEN keylen = floatit ? 5 : 7;
11455 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11456 key, keylen, sv, NULL, NULL, 0);
11460 /* if it starts with a v, it could be a v-string */
11463 sv = newSV(5); /* preallocate storage space */
11464 ENTER_with_name("scan_vstring");
11466 s = scan_vstring(s, PL_bufend, sv);
11467 SvREFCNT_inc_simple_void_NN(sv);
11468 LEAVE_with_name("scan_vstring");
11472 /* make the op for the constant and return */
11475 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11477 lvalp->opval = NULL;
11483 S_scan_formline(pTHX_ char *s)
11485 SV * const stuff = newSVpvs("");
11486 bool needargs = FALSE;
11487 bool eofmt = FALSE;
11489 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11491 while (!needargs) {
11495 #ifdef PERL_STRICT_CR
11496 while (SPACE_OR_TAB(*t))
11499 while (SPACE_OR_TAB(*t) || *t == '\r')
11502 if (*t == '\n' || t == PL_bufend) {
11507 eol = (char *) memchr(s,'\n',PL_bufend-s);
11512 for (t = s; t < eol; t++) {
11513 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11515 goto enough; /* ~~ must be first line in formline */
11517 if (*t == '@' || *t == '^')
11521 sv_catpvn(stuff, s, eol-s);
11522 #ifndef PERL_STRICT_CR
11523 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11524 char *end = SvPVX(stuff) + SvCUR(stuff);
11527 SvCUR_set(stuff, SvCUR(stuff) - 1);
11535 if ((PL_rsfp || PL_parser->filtered)
11536 && PL_parser->form_lex_state == LEX_NORMAL) {
11538 PL_bufptr = PL_bufend;
11539 COPLINE_INC_WITH_HERELINES;
11540 got_some = lex_next_chunk(0);
11541 CopLINE_dec(PL_curcop);
11546 incline(s, PL_bufend);
11549 if (!SvCUR(stuff) || needargs)
11550 PL_lex_state = PL_parser->form_lex_state;
11551 if (SvCUR(stuff)) {
11552 PL_expect = XSTATE;
11554 const char *s2 = s;
11555 while (isSPACE(*s2) && *s2 != '\n')
11558 PL_expect = XTERMBLOCK;
11559 NEXTVAL_NEXTTOKE.ival = 0;
11562 NEXTVAL_NEXTTOKE.ival = 0;
11563 force_next(FORMLBRACK);
11566 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11569 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
11573 SvREFCNT_dec(stuff);
11575 PL_lex_formbrack = 0;
11581 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11583 const I32 oldsavestack_ix = PL_savestack_ix;
11584 CV* const outsidecv = PL_compcv;
11586 SAVEI32(PL_subline);
11587 save_item(PL_subname);
11588 SAVESPTR(PL_compcv);
11590 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11591 CvFLAGS(PL_compcv) |= flags;
11593 PL_subline = CopLINE(PL_curcop);
11594 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11595 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11596 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11597 if (outsidecv && CvPADLIST(outsidecv))
11598 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
11600 return oldsavestack_ix;
11604 /* Do extra initialisation of a CV (typically one just created by
11605 * start_subparse()) if that CV is for a named sub
11609 Perl_init_named_cv(pTHX_ CV *cv, OP *nameop)
11611 PERL_ARGS_ASSERT_INIT_NAMED_CV;
11613 if (nameop->op_type == OP_CONST) {
11614 const char *const name = SvPV_nolen_const(((SVOP*)nameop)->op_sv);
11615 if ( strEQ(name, "BEGIN")
11616 || strEQ(name, "END")
11617 || strEQ(name, "INIT")
11618 || strEQ(name, "CHECK")
11619 || strEQ(name, "UNITCHECK")
11624 /* State subs inside anonymous subs need to be
11625 clonable themselves. */
11626 if ( CvANON(CvOUTSIDE(cv))
11627 || CvCLONE(CvOUTSIDE(cv))
11628 || !PadnameIsSTATE(PadlistNAMESARRAY(CvPADLIST(
11630 ))[nameop->op_targ])
11637 S_yywarn(pTHX_ const char *const s, U32 flags)
11639 PERL_ARGS_ASSERT_YYWARN;
11641 PL_in_eval |= EVAL_WARNONLY;
11642 yyerror_pv(s, flags);
11647 Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
11649 PERL_ARGS_ASSERT_ABORT_EXECUTION;
11652 Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
11655 "%sExecution of %s aborted due to compilation errors.\n", msg, name);
11657 NOT_REACHED; /* NOTREACHED */
11663 /* Called, after at least one error has been found, to abort the parse now,
11664 * instead of trying to forge ahead */
11666 yyerror_pvn(NULL, 0, 0);
11670 Perl_yyerror(pTHX_ const char *const s)
11672 PERL_ARGS_ASSERT_YYERROR;
11673 return yyerror_pvn(s, strlen(s), 0);
11677 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11679 PERL_ARGS_ASSERT_YYERROR_PV;
11680 return yyerror_pvn(s, strlen(s), flags);
11684 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11686 const char *context = NULL;
11689 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11690 int yychar = PL_parser->yychar;
11692 /* Output error message 's' with length 'len'. 'flags' are SV flags that
11693 * apply. If the number of errors found is large enough, it abandons
11694 * parsing. If 's' is NULL, there is no message, and it abandons
11695 * processing unconditionally */
11698 if (!yychar || (yychar == ';' && !PL_rsfp))
11699 sv_catpvs(where_sv, "at EOF");
11700 else if ( PL_oldoldbufptr
11701 && PL_bufptr > PL_oldoldbufptr
11702 && PL_bufptr - PL_oldoldbufptr < 200
11703 && PL_oldoldbufptr != PL_oldbufptr
11704 && PL_oldbufptr != PL_bufptr)
11708 The code below is removed for NetWare because it
11709 abends/crashes on NetWare when the script has error such as
11710 not having the closing quotes like:
11711 if ($var eq "value)
11712 Checking of white spaces is anyway done in NetWare code.
11715 while (isSPACE(*PL_oldoldbufptr))
11718 context = PL_oldoldbufptr;
11719 contlen = PL_bufptr - PL_oldoldbufptr;
11721 else if ( PL_oldbufptr
11722 && PL_bufptr > PL_oldbufptr
11723 && PL_bufptr - PL_oldbufptr < 200
11724 && PL_oldbufptr != PL_bufptr) {
11727 The code below is removed for NetWare because it
11728 abends/crashes on NetWare when the script has error such as
11729 not having the closing quotes like:
11730 if ($var eq "value)
11731 Checking of white spaces is anyway done in NetWare code.
11734 while (isSPACE(*PL_oldbufptr))
11737 context = PL_oldbufptr;
11738 contlen = PL_bufptr - PL_oldbufptr;
11740 else if (yychar > 255)
11741 sv_catpvs(where_sv, "next token ???");
11742 else if (yychar == YYEMPTY) {
11743 if (PL_lex_state == LEX_NORMAL)
11744 sv_catpvs(where_sv, "at end of line");
11745 else if (PL_lex_inpat)
11746 sv_catpvs(where_sv, "within pattern");
11748 sv_catpvs(where_sv, "within string");
11751 sv_catpvs(where_sv, "next char ");
11753 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11754 else if (isPRINT_LC(yychar)) {
11755 const char string = yychar;
11756 sv_catpvn(where_sv, &string, 1);
11759 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11761 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11762 Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
11763 OutCopFILE(PL_curcop),
11764 (IV)(PL_parser->preambling == NOLINE
11765 ? CopLINE(PL_curcop)
11766 : PL_parser->preambling));
11768 Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
11769 UTF8fARG(UTF, contlen, context));
11771 Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
11772 if ( PL_multi_start < PL_multi_end
11773 && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
11775 Perl_sv_catpvf(aTHX_ msg,
11776 " (Might be a runaway multi-line %c%c string starting on"
11777 " line %" IVdf ")\n",
11778 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11781 if (PL_in_eval & EVAL_WARNONLY) {
11782 PL_in_eval &= ~EVAL_WARNONLY;
11783 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
11789 if (s == NULL || PL_error_count >= 10) {
11790 const char * msg = "";
11791 const char * const name = OutCopFILE(PL_curcop);
11794 SV * errsv = ERRSV;
11795 if (SvCUR(errsv)) {
11796 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
11801 abort_execution(msg, name);
11804 Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
11808 PL_in_my_stash = NULL;
11813 S_swallow_bom(pTHX_ U8 *s)
11815 const STRLEN slen = SvCUR(PL_linestr);
11817 PERL_ARGS_ASSERT_SWALLOW_BOM;
11821 if (s[1] == 0xFE) {
11822 /* UTF-16 little-endian? (or UTF-32LE?) */
11823 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11824 /* diag_listed_as: Unsupported script encoding %s */
11825 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11826 #ifndef PERL_NO_UTF16_FILTER
11828 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11831 if (PL_bufend > (char*)s) {
11832 s = add_utf16_textfilter(s, TRUE);
11835 /* diag_listed_as: Unsupported script encoding %s */
11836 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11841 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11842 #ifndef PERL_NO_UTF16_FILTER
11844 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11847 if (PL_bufend > (char *)s) {
11848 s = add_utf16_textfilter(s, FALSE);
11851 /* diag_listed_as: Unsupported script encoding %s */
11852 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11856 case BOM_UTF8_FIRST_BYTE: {
11857 if (memBEGINs(s+1, slen - 1, BOM_UTF8_TAIL)) {
11859 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11861 s += sizeof(BOM_UTF8) - 1; /* UTF-8 */
11868 if (s[2] == 0xFE && s[3] == 0xFF) {
11869 /* UTF-32 big-endian */
11870 /* diag_listed_as: Unsupported script encoding %s */
11871 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11874 else if (s[2] == 0 && s[3] != 0) {
11877 * are a good indicator of UTF-16BE. */
11878 #ifndef PERL_NO_UTF16_FILTER
11880 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11882 s = add_utf16_textfilter(s, FALSE);
11884 /* diag_listed_as: Unsupported script encoding %s */
11885 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11892 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11895 * are a good indicator of UTF-16LE. */
11896 #ifndef PERL_NO_UTF16_FILTER
11898 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11900 s = add_utf16_textfilter(s, TRUE);
11902 /* diag_listed_as: Unsupported script encoding %s */
11903 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11911 #ifndef PERL_NO_UTF16_FILTER
11913 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11915 SV *const filter = FILTER_DATA(idx);
11916 /* We re-use this each time round, throwing the contents away before we
11918 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11919 SV *const utf8_buffer = filter;
11920 IV status = IoPAGE(filter);
11921 const bool reverse = cBOOL(IoLINES(filter));
11924 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11926 /* As we're automatically added, at the lowest level, and hence only called
11927 from this file, we can be sure that we're not called in block mode. Hence
11928 don't bother writing code to deal with block mode. */
11930 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11933 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status);
11935 DEBUG_P(PerlIO_printf(Perl_debug_log,
11936 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11937 FPTR2DPTR(void *, S_utf16_textfilter),
11938 reverse ? 'l' : 'b', idx, maxlen, status,
11939 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11946 /* First, look in our buffer of existing UTF-8 data: */
11947 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11951 } else if (status == 0) {
11953 IoPAGE(filter) = 0;
11954 nl = SvEND(utf8_buffer);
11957 STRLEN got = nl - SvPVX(utf8_buffer);
11958 /* Did we have anything to append? */
11960 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11961 /* Everything else in this code works just fine if SVp_POK isn't
11962 set. This, however, needs it, and we need it to work, else
11963 we loop infinitely because the buffer is never consumed. */
11964 sv_chop(utf8_buffer, nl);
11968 /* OK, not a complete line there, so need to read some more UTF-16.
11969 Read an extra octect if the buffer currently has an odd number. */
11973 if (SvCUR(utf16_buffer) >= 2) {
11974 /* Location of the high octet of the last complete code point.
11975 Gosh, UTF-16 is a pain. All the benefits of variable length,
11976 *coupled* with all the benefits of partial reads and
11978 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11979 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11981 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11985 /* We have the first half of a surrogate. Read more. */
11986 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11989 status = FILTER_READ(idx + 1, utf16_buffer,
11990 160 + (SvCUR(utf16_buffer) & 1));
11991 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer)));
11992 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11995 IoPAGE(filter) = status;
12000 /* 'chars' isn't quite the right name, as code points above 0xFFFF
12001 * require 4 bytes per char */
12002 chars = SvCUR(utf16_buffer) >> 1;
12003 have = SvCUR(utf8_buffer);
12005 /* Assume the worst case size as noted by the functions: twice the
12006 * number of input bytes */
12007 SvGROW(utf8_buffer, have + chars * 4 + 1);
12010 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
12011 (U8*)SvPVX_const(utf8_buffer) + have,
12012 chars * 2, &newlen);
12014 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
12015 (U8*)SvPVX_const(utf8_buffer) + have,
12016 chars * 2, &newlen);
12018 SvCUR_set(utf8_buffer, have + newlen);
12021 /* No need to keep this SV "well-formed" with a '\0' after the end, as
12022 it's private to us, and utf16_to_utf8{,reversed} take a
12023 (pointer,length) pair, rather than a NUL-terminated string. */
12024 if(SvCUR(utf16_buffer) & 1) {
12025 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
12026 SvCUR_set(utf16_buffer, 1);
12028 SvCUR_set(utf16_buffer, 0);
12031 DEBUG_P(PerlIO_printf(Perl_debug_log,
12032 "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
12034 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12035 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
12040 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
12042 SV *filter = filter_add(S_utf16_textfilter, NULL);
12044 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
12046 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
12048 IoLINES(filter) = reversed;
12049 IoPAGE(filter) = 1; /* Not EOF */
12051 /* Sadly, we have to return a valid pointer, come what may, so we have to
12052 ignore any error return from this. */
12053 SvCUR_set(PL_linestr, 0);
12054 if (FILTER_READ(0, PL_linestr, 0)) {
12055 SvUTF8_on(PL_linestr);
12057 SvUTF8_on(PL_linestr);
12059 PL_bufend = SvEND(PL_linestr);
12060 return (U8*)SvPVX(PL_linestr);
12065 Returns a pointer to the next character after the parsed
12066 vstring, as well as updating the passed in sv.
12068 Function must be called like
12070 sv = sv_2mortal(newSV(5));
12071 s = scan_vstring(s,e,sv);
12073 where s and e are the start and end of the string.
12074 The sv should already be large enough to store the vstring
12075 passed in, for performance reasons.
12077 This function may croak if fatal warnings are enabled in the
12078 calling scope, hence the sv_2mortal in the example (to prevent
12079 a leak). Make sure to do SvREFCNT_inc afterwards if you use
12085 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12087 const char *pos = s;
12088 const char *start = s;
12090 PERL_ARGS_ASSERT_SCAN_VSTRING;
12092 if (*pos == 'v') pos++; /* get past 'v' */
12093 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12095 if ( *pos != '.') {
12096 /* this may not be a v-string if followed by => */
12097 const char *next = pos;
12098 while (next < e && isSPACE(*next))
12100 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12101 /* return string not v-string */
12102 sv_setpvn(sv,(char *)s,pos-s);
12103 return (char *)pos;
12107 if (!isALPHA(*pos)) {
12108 U8 tmpbuf[UTF8_MAXBYTES+1];
12111 s++; /* get past 'v' */
12116 /* this is atoi() that tolerates underscores */
12119 const char *end = pos;
12121 while (--end >= s) {
12123 const UV orev = rev;
12124 rev += (*end - '0') * mult;
12127 /* diag_listed_as: Integer overflow in %s number */
12128 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
12129 "Integer overflow in decimal number");
12133 /* Append native character for the rev point */
12134 tmpend = uvchr_to_utf8(tmpbuf, rev);
12135 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12136 if (!UVCHR_IS_INVARIANT(rev))
12138 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12144 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12148 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12155 Perl_keyword_plugin_standard(pTHX_
12156 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
12158 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
12159 PERL_UNUSED_CONTEXT;
12160 PERL_UNUSED_ARG(keyword_ptr);
12161 PERL_UNUSED_ARG(keyword_len);
12162 PERL_UNUSED_ARG(op_ptr);
12163 return KEYWORD_PLUGIN_DECLINE;
12167 =for apidoc Amx|void|wrap_keyword_plugin|Perl_keyword_plugin_t new_plugin|Perl_keyword_plugin_t *old_plugin_p
12169 Puts a C function into the chain of keyword plugins. This is the
12170 preferred way to manipulate the L</PL_keyword_plugin> variable.
12171 C<new_plugin> is a pointer to the C function that is to be added to the
12172 keyword plugin chain, and C<old_plugin_p> points to the storage location
12173 where a pointer to the next function in the chain will be stored. The
12174 value of C<new_plugin> is written into the L</PL_keyword_plugin> variable,
12175 while the value previously stored there is written to C<*old_plugin_p>.
12177 L</PL_keyword_plugin> is global to an entire process, and a module wishing
12178 to hook keyword parsing may find itself invoked more than once per
12179 process, typically in different threads. To handle that situation, this
12180 function is idempotent. The location C<*old_plugin_p> must initially
12181 (once per process) contain a null pointer. A C variable of static
12182 duration (declared at file scope, typically also marked C<static> to give
12183 it internal linkage) will be implicitly initialised appropriately, if it
12184 does not have an explicit initialiser. This function will only actually
12185 modify the plugin chain if it finds C<*old_plugin_p> to be null. This
12186 function is also thread safe on the small scale. It uses appropriate
12187 locking to avoid race conditions in accessing L</PL_keyword_plugin>.
12189 When this function is called, the function referenced by C<new_plugin>
12190 must be ready to be called, except for C<*old_plugin_p> being unfilled.
12191 In a threading situation, C<new_plugin> may be called immediately, even
12192 before this function has returned. C<*old_plugin_p> will always be
12193 appropriately set before C<new_plugin> is called. If C<new_plugin>
12194 decides not to do anything special with the identifier that it is given
12195 (which is the usual case for most calls to a keyword plugin), it must
12196 chain the plugin function referenced by C<*old_plugin_p>.
12198 Taken all together, XS code to install a keyword plugin should typically
12199 look something like this:
12201 static Perl_keyword_plugin_t next_keyword_plugin;
12202 static OP *my_keyword_plugin(pTHX_
12203 char *keyword_plugin, STRLEN keyword_len, OP **op_ptr)
12205 if (memEQs(keyword_ptr, keyword_len,
12206 "my_new_keyword")) {
12209 return next_keyword_plugin(aTHX_
12210 keyword_ptr, keyword_len, op_ptr);
12214 wrap_keyword_plugin(my_keyword_plugin,
12215 &next_keyword_plugin);
12217 Direct access to L</PL_keyword_plugin> should be avoided.
12223 Perl_wrap_keyword_plugin(pTHX_
12224 Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
12228 PERL_UNUSED_CONTEXT;
12229 PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;
12230 if (*old_plugin_p) return;
12231 KEYWORD_PLUGIN_MUTEX_LOCK;
12232 if (!*old_plugin_p) {
12233 *old_plugin_p = PL_keyword_plugin;
12234 PL_keyword_plugin = new_plugin;
12236 KEYWORD_PLUGIN_MUTEX_UNLOCK;
12239 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
12241 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
12243 SAVEI32(PL_lex_brackets);
12244 if (PL_lex_brackets > 100)
12245 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
12246 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
12247 SAVEI32(PL_lex_allbrackets);
12248 PL_lex_allbrackets = 0;
12249 SAVEI8(PL_lex_fakeeof);
12250 PL_lex_fakeeof = (U8)fakeeof;
12251 if(yyparse(gramtype) && !PL_parser->error_count)
12252 qerror(Perl_mess(aTHX_ "Parse error"));
12255 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
12257 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
12261 SAVEVPTR(PL_eval_root);
12262 PL_eval_root = NULL;
12263 parse_recdescent(gramtype, fakeeof);
12269 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
12271 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
12274 if (flags & ~PARSE_OPTIONAL)
12275 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
12276 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
12277 if (!exprop && !(flags & PARSE_OPTIONAL)) {
12278 if (!PL_parser->error_count)
12279 qerror(Perl_mess(aTHX_ "Parse error"));
12280 exprop = newOP(OP_NULL, 0);
12286 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
12288 Parse a Perl arithmetic expression. This may contain operators of precedence
12289 down to the bit shift operators. The expression must be followed (and thus
12290 terminated) either by a comparison or lower-precedence operator or by
12291 something that would normally terminate an expression such as semicolon.
12292 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12293 otherwise it is mandatory. It is up to the caller to ensure that the
12294 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12295 the source of the code to be parsed and the lexical context for the
12298 The op tree representing the expression is returned. If an optional
12299 expression is absent, a null pointer is returned, otherwise the pointer
12302 If an error occurs in parsing or compilation, in most cases a valid op
12303 tree is returned anyway. The error is reflected in the parser state,
12304 normally resulting in a single exception at the top level of parsing
12305 which covers all the compilation errors that occurred. Some compilation
12306 errors, however, will throw an exception immediately.
12312 Perl_parse_arithexpr(pTHX_ U32 flags)
12314 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
12318 =for apidoc Amx|OP *|parse_termexpr|U32 flags
12320 Parse a Perl term expression. This may contain operators of precedence
12321 down to the assignment operators. The expression must be followed (and thus
12322 terminated) either by a comma or lower-precedence operator or by
12323 something that would normally terminate an expression such as semicolon.
12324 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12325 otherwise it is mandatory. It is up to the caller to ensure that the
12326 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12327 the source of the code to be parsed and the lexical context for the
12330 The op tree representing the expression is returned. If an optional
12331 expression is absent, a null pointer is returned, otherwise the pointer
12334 If an error occurs in parsing or compilation, in most cases a valid op
12335 tree is returned anyway. The error is reflected in the parser state,
12336 normally resulting in a single exception at the top level of parsing
12337 which covers all the compilation errors that occurred. Some compilation
12338 errors, however, will throw an exception immediately.
12344 Perl_parse_termexpr(pTHX_ U32 flags)
12346 return parse_expr(LEX_FAKEEOF_COMMA, flags);
12350 =for apidoc Amx|OP *|parse_listexpr|U32 flags
12352 Parse a Perl list expression. This may contain operators of precedence
12353 down to the comma operator. The expression must be followed (and thus
12354 terminated) either by a low-precedence logic operator such as C<or> or by
12355 something that would normally terminate an expression such as semicolon.
12356 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12357 otherwise it is mandatory. It is up to the caller to ensure that the
12358 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12359 the source of the code to be parsed and the lexical context for the
12362 The op tree representing the expression is returned. If an optional
12363 expression is absent, a null pointer is returned, otherwise the pointer
12366 If an error occurs in parsing or compilation, in most cases a valid op
12367 tree is returned anyway. The error is reflected in the parser state,
12368 normally resulting in a single exception at the top level of parsing
12369 which covers all the compilation errors that occurred. Some compilation
12370 errors, however, will throw an exception immediately.
12376 Perl_parse_listexpr(pTHX_ U32 flags)
12378 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12382 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
12384 Parse a single complete Perl expression. This allows the full
12385 expression grammar, including the lowest-precedence operators such
12386 as C<or>. The expression must be followed (and thus terminated) by a
12387 token that an expression would normally be terminated by: end-of-file,
12388 closing bracketing punctuation, semicolon, or one of the keywords that
12389 signals a postfix expression-statement modifier. If C<flags> has the
12390 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
12391 mandatory. It is up to the caller to ensure that the dynamic parser
12392 state (L</PL_parser> et al) is correctly set to reflect the source of
12393 the code to be parsed and the lexical context for the expression.
12395 The op tree representing the expression is returned. If an optional
12396 expression is absent, a null pointer is returned, otherwise the pointer
12399 If an error occurs in parsing or compilation, in most cases a valid op
12400 tree is returned anyway. The error is reflected in the parser state,
12401 normally resulting in a single exception at the top level of parsing
12402 which covers all the compilation errors that occurred. Some compilation
12403 errors, however, will throw an exception immediately.
12409 Perl_parse_fullexpr(pTHX_ U32 flags)
12411 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12415 =for apidoc Amx|OP *|parse_block|U32 flags
12417 Parse a single complete Perl code block. This consists of an opening
12418 brace, a sequence of statements, and a closing brace. The block
12419 constitutes a lexical scope, so C<my> variables and various compile-time
12420 effects can be contained within it. It is up to the caller to ensure
12421 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12422 reflect the source of the code to be parsed and the lexical context for
12425 The op tree representing the code block is returned. This is always a
12426 real op, never a null pointer. It will normally be a C<lineseq> list,
12427 including C<nextstate> or equivalent ops. No ops to construct any kind
12428 of runtime scope are included by virtue of it being a block.
12430 If an error occurs in parsing or compilation, in most cases a valid op
12431 tree (most likely null) is returned anyway. The error is reflected in
12432 the parser state, normally resulting in a single exception at the top
12433 level of parsing which covers all the compilation errors that occurred.
12434 Some compilation errors, however, will throw an exception immediately.
12436 The C<flags> parameter is reserved for future use, and must always
12443 Perl_parse_block(pTHX_ U32 flags)
12446 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12447 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12451 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12453 Parse a single unadorned Perl statement. This may be a normal imperative
12454 statement or a declaration that has compile-time effect. It does not
12455 include any label or other affixture. It is up to the caller to ensure
12456 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12457 reflect the source of the code to be parsed and the lexical context for
12460 The op tree representing the statement is returned. This may be a
12461 null pointer if the statement is null, for example if it was actually
12462 a subroutine definition (which has compile-time side effects). If not
12463 null, it will be ops directly implementing the statement, suitable to
12464 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12465 equivalent op (except for those embedded in a scope contained entirely
12466 within the statement).
12468 If an error occurs in parsing or compilation, in most cases a valid op
12469 tree (most likely null) is returned anyway. The error is reflected in
12470 the parser state, normally resulting in a single exception at the top
12471 level of parsing which covers all the compilation errors that occurred.
12472 Some compilation errors, however, will throw an exception immediately.
12474 The C<flags> parameter is reserved for future use, and must always
12481 Perl_parse_barestmt(pTHX_ U32 flags)
12484 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12485 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12489 =for apidoc Amx|SV *|parse_label|U32 flags
12491 Parse a single label, possibly optional, of the type that may prefix a
12492 Perl statement. It is up to the caller to ensure that the dynamic parser
12493 state (L</PL_parser> et al) is correctly set to reflect the source of
12494 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
12495 label is optional, otherwise it is mandatory.
12497 The name of the label is returned in the form of a fresh scalar. If an
12498 optional label is absent, a null pointer is returned.
12500 If an error occurs in parsing, which can only occur if the label is
12501 mandatory, a valid label is returned anyway. The error is reflected in
12502 the parser state, normally resulting in a single exception at the top
12503 level of parsing which covers all the compilation errors that occurred.
12509 Perl_parse_label(pTHX_ U32 flags)
12511 if (flags & ~PARSE_OPTIONAL)
12512 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12514 PL_parser->yychar = yylex();
12515 if (PL_parser->yychar == LABEL) {
12516 char * const lpv = pl_yylval.pval;
12517 STRLEN llen = strlen(lpv);
12518 PL_parser->yychar = YYEMPTY;
12519 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12526 STRLEN wlen, bufptr_pos;
12529 if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
12531 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12532 if (word_takes_any_delimiter(s, wlen))
12534 bufptr_pos = s - SvPVX(PL_linestr);
12536 lex_read_space(LEX_KEEP_PREVIOUS);
12538 s = SvPVX(PL_linestr) + bufptr_pos;
12539 if (t[0] == ':' && t[1] != ':') {
12540 PL_oldoldbufptr = PL_oldbufptr;
12543 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12547 if (flags & PARSE_OPTIONAL) {
12550 qerror(Perl_mess(aTHX_ "Parse error"));
12551 return newSVpvs("x");
12558 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12560 Parse a single complete Perl statement. This may be a normal imperative
12561 statement or a declaration that has compile-time effect, and may include
12562 optional labels. It is up to the caller to ensure that the dynamic
12563 parser state (L</PL_parser> et al) is correctly set to reflect the source
12564 of the code to be parsed and the lexical context for the statement.
12566 The op tree representing the statement is returned. This may be a
12567 null pointer if the statement is null, for example if it was actually
12568 a subroutine definition (which has compile-time side effects). If not
12569 null, it will be the result of a L</newSTATEOP> call, normally including
12570 a C<nextstate> or equivalent op.
12572 If an error occurs in parsing or compilation, in most cases a valid op
12573 tree (most likely null) is returned anyway. The error is reflected in
12574 the parser state, normally resulting in a single exception at the top
12575 level of parsing which covers all the compilation errors that occurred.
12576 Some compilation errors, however, will throw an exception immediately.
12578 The C<flags> parameter is reserved for future use, and must always
12585 Perl_parse_fullstmt(pTHX_ U32 flags)
12588 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12589 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12593 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12595 Parse a sequence of zero or more Perl statements. These may be normal
12596 imperative statements, including optional labels, or declarations
12597 that have compile-time effect, or any mixture thereof. The statement
12598 sequence ends when a closing brace or end-of-file is encountered in a
12599 place where a new statement could have validly started. It is up to
12600 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12601 is correctly set to reflect the source of the code to be parsed and the
12602 lexical context for the statements.
12604 The op tree representing the statement sequence is returned. This may
12605 be a null pointer if the statements were all null, for example if there
12606 were no statements or if there were only subroutine definitions (which
12607 have compile-time side effects). If not null, it will be a C<lineseq>
12608 list, normally including C<nextstate> or equivalent ops.
12610 If an error occurs in parsing or compilation, in most cases a valid op
12611 tree is returned anyway. The error is reflected in the parser state,
12612 normally resulting in a single exception at the top level of parsing
12613 which covers all the compilation errors that occurred. Some compilation
12614 errors, however, will throw an exception immediately.
12616 The C<flags> parameter is reserved for future use, and must always
12623 Perl_parse_stmtseq(pTHX_ U32 flags)
12628 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12629 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12630 c = lex_peek_unichar(0);
12631 if (c != -1 && c != /*{*/'}')
12632 qerror(Perl_mess(aTHX_ "Parse error"));
12637 * ex: set ts=8 sts=4 sw=4 et: