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_croak(aTHX_ "dump() must be written as CORE::dump() as of Perl 5.30");
7255 if (hgv && tmp != KEY_x) /* never ambiguous */
7256 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7257 "Ambiguous call resolved as CORE::%s(), "
7258 "qualify as such or use &",
7263 if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
7264 && (!anydelim || *s != '#')) {
7265 /* no override, and not s### either; skipspace is safe here
7266 * check for => on following line */
7268 STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
7269 STRLEN soff = s - SvPVX(PL_linestr);
7271 arrow = *s == '=' && s[1] == '>';
7272 PL_bufptr = SvPVX(PL_linestr) + bufoff;
7273 s = SvPVX(PL_linestr) + soff;
7281 /* Trade off - by using this evil construction we can pull the
7282 variable gv into the block labelled keylookup. If not, then
7283 we have to give it function scope so that the goto from the
7284 earlier ':' case doesn't bypass the initialisation. */
7285 just_a_word_zero_gv:
7295 default: /* not a keyword */
7298 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7300 bool no_op_error = FALSE;
7302 if (PL_expect == XOPERATOR) {
7303 if (PL_bufptr == PL_linestart) {
7304 CopLINE_dec(PL_curcop);
7305 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7306 CopLINE_inc(PL_curcop);
7309 /* We want to call no_op with s pointing after the
7310 bareword, so defer it. But we want it to come
7311 before the Bad name croak. */
7315 /* Get the rest if it looks like a package qualifier */
7317 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
7319 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7322 no_op("Bareword",s);
7323 no_op_error = FALSE;
7326 Perl_croak(aTHX_ "Bad name after %" UTF8f "%s",
7327 UTF8fARG(UTF, len, PL_tokenbuf),
7328 *s == '\'' ? "'" : "::");
7334 no_op("Bareword",s);
7336 /* See if the name is "Foo::",
7337 in which case Foo is a bareword
7338 (and a package name). */
7341 && PL_tokenbuf[len - 2] == ':'
7342 && PL_tokenbuf[len - 1] == ':')
7344 if (ckWARN(WARN_BAREWORD)
7345 && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
7346 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
7347 "Bareword \"%" UTF8f
7348 "\" refers to nonexistent package",
7349 UTF8fARG(UTF, len, PL_tokenbuf));
7351 PL_tokenbuf[len] = '\0';
7360 /* if we saw a global override before, get the right name */
7363 sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7366 SV * const tmp_sv = sv;
7367 sv = newSVpvs("CORE::GLOBAL::");
7368 sv_catsv(sv, tmp_sv);
7369 SvREFCNT_dec(tmp_sv);
7373 /* Presume this is going to be a bareword of some sort. */
7375 pl_yylval.opval = newSVOP(OP_CONST, 0, sv);
7376 pl_yylval.opval->op_private = OPpCONST_BARE;
7378 /* And if "Foo::", then that's what it certainly is. */
7384 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7385 const_op->op_private = OPpCONST_BARE;
7387 newCVREF(OPpMAY_RETURN_CONSTANT<<8, const_op);
7391 : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
7394 : rv2cv_op_cv(rv2cv_op, RV2CVOPCV_RETURN_STUB);
7397 /* Use this var to track whether intuit_method has been
7398 called. intuit_method returns 0 or > 255. */
7401 /* See if it's the indirect object for a list operator. */
7404 && PL_oldoldbufptr < PL_bufptr
7405 && (PL_oldoldbufptr == PL_last_lop
7406 || PL_oldoldbufptr == PL_last_uni)
7407 && /* NO SKIPSPACE BEFORE HERE! */
7409 || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7)
7412 bool immediate_paren = *s == '(';
7415 /* (Now we can afford to cross potential line boundary.) */
7418 /* intuit_method() can indirectly call lex_next_chunk(),
7421 s_off = s - SvPVX(PL_linestr);
7422 /* Two barewords in a row may indicate method call. */
7423 if ( ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
7425 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7427 /* the code at method: doesn't use s */
7430 s = SvPVX(PL_linestr) + s_off;
7432 /* If not a declared subroutine, it's an indirect object. */
7433 /* (But it's an indir obj regardless for sort.) */
7434 /* Also, if "_" follows a filetest operator, it's a bareword */
7437 ( !immediate_paren && (PL_last_lop_op == OP_SORT
7439 && (PL_last_lop_op != OP_MAPSTART
7440 && PL_last_lop_op != OP_GREPSTART))))
7441 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7442 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK)
7446 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7451 PL_expect = XOPERATOR;
7454 /* Is this a word before a => operator? */
7455 if (*s == '=' && s[1] == '>' && !pkgname) {
7458 if (gvp || (lex && !off)) {
7459 assert (cSVOPx(pl_yylval.opval)->op_sv == sv);
7460 /* This is our own scalar, created a few lines
7461 above, so this is safe. */
7463 sv_setpv(sv, PL_tokenbuf);
7464 if (UTF && !IN_BYTES
7465 && is_utf8_string((U8*)PL_tokenbuf, len))
7472 /* If followed by a paren, it's certainly a subroutine. */
7477 while (SPACE_OR_TAB(*d))
7479 if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
7484 NEXTVAL_NEXTTOKE.opval =
7485 off ? rv2cv_op : pl_yylval.opval;
7487 op_free(pl_yylval.opval), force_next(PRIVATEREF);
7488 else op_free(rv2cv_op), force_next(BAREWORD);
7493 /* If followed by var or block, call it a method (unless sub) */
7495 if ((*s == '$' || *s == '{') && !cv) {
7497 PL_last_lop = PL_oldbufptr;
7498 PL_last_lop_op = OP_METHOD;
7499 if (!PL_lex_allbrackets
7500 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7502 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7504 PL_expect = XBLOCKTERM;
7506 return REPORT(METHOD);
7509 /* If followed by a bareword, see if it looks like indir obj. */
7513 && (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF) || *s == '$')
7514 && (tmp = intuit_method(s, lex ? NULL : sv, cv)))
7518 assert(cSVOPx(pl_yylval.opval)->op_sv == sv);
7520 sv_setpvn(sv, PL_tokenbuf, len);
7521 if (UTF && !IN_BYTES
7522 && is_utf8_string((U8*)PL_tokenbuf, len))
7524 else SvUTF8_off(sv);
7527 if (tmp == METHOD && !PL_lex_allbrackets
7528 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7530 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7535 /* Not a method, so call it a subroutine (if defined) */
7538 /* Check for a constant sub */
7539 if ((sv = cv_const_sv_or_av(cv))) {
7542 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7543 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7544 if (SvTYPE(sv) == SVt_PVAV)
7545 pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7548 pl_yylval.opval->op_private = 0;
7549 pl_yylval.opval->op_folded = 1;
7550 pl_yylval.opval->op_flags |= OPf_SPECIAL;
7555 op_free(pl_yylval.opval);
7557 off ? newCVREF(0, rv2cv_op) : rv2cv_op;
7558 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7559 PL_last_lop = PL_oldbufptr;
7560 PL_last_lop_op = OP_ENTERSUB;
7561 /* Is there a prototype? */
7565 STRLEN protolen = CvPROTOLEN(cv);
7566 const char *proto = CvPROTO(cv);
7568 proto = S_strip_spaces(aTHX_ proto, &protolen);
7571 if ((optional = *proto == ';'))
7574 while (*proto == ';');
7578 *proto == '$' || *proto == '_'
7579 || *proto == '*' || *proto == '+'
7584 *proto == '\\' && proto[1] && proto[2] == '\0'
7587 UNIPROTO(UNIOPSUB,optional);
7588 if (*proto == '\\' && proto[1] == '[') {
7589 const char *p = proto + 2;
7590 while(*p && *p != ']')
7592 if(*p == ']' && !p[1])
7593 UNIPROTO(UNIOPSUB,optional);
7595 if (*proto == '&' && *s == '{') {
7597 sv_setpvs(PL_subname, "__ANON__");
7599 sv_setpvs(PL_subname, "__ANON__::__ANON__");
7600 if (!PL_lex_allbrackets
7601 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7603 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7608 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7610 force_next(off ? PRIVATEREF : BAREWORD);
7611 if (!PL_lex_allbrackets
7612 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7614 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7619 /* Call it a bare word */
7621 if (PL_hints & HINT_STRICT_SUBS)
7622 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7625 /* after "print" and similar functions (corresponding to
7626 * "F? L" in opcode.pl), whatever wasn't already parsed as
7627 * a filehandle should be subject to "strict subs".
7628 * Likewise for the optional indirect-object argument to system
7629 * or exec, which can't be a bareword */
7630 if ((PL_last_lop_op == OP_PRINT
7631 || PL_last_lop_op == OP_PRTF
7632 || PL_last_lop_op == OP_SAY
7633 || PL_last_lop_op == OP_SYSTEM
7634 || PL_last_lop_op == OP_EXEC)
7635 && (PL_hints & HINT_STRICT_SUBS))
7636 pl_yylval.opval->op_private |= OPpCONST_STRICT;
7637 if (lastchar != '-') {
7638 if (ckWARN(WARN_RESERVED)) {
7642 if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
7644 /* PL_warn_reserved is constant */
7645 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
7646 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7648 GCC_DIAG_RESTORE_STMT;
7656 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
7657 && saw_infix_sigil) {
7658 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7659 "Operator or semicolon missing before %c%" UTF8f,
7661 UTF8fARG(UTF, strlen(PL_tokenbuf),
7663 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7664 "Ambiguous use of %c resolved as operator %c",
7665 lastchar, lastchar);
7672 newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7677 newSVOP(OP_CONST, 0,
7678 Perl_newSVpvf(aTHX_ "%" IVdf, (IV)CopLINE(PL_curcop)))
7681 case KEY___PACKAGE__:
7683 newSVOP(OP_CONST, 0,
7685 ? newSVhek(HvNAME_HEK(PL_curstash))
7692 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
7693 HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7696 gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7698 gv_init(gv,stash,"DATA",4,0);
7701 GvIOp(gv) = newIO();
7702 IoIFP(GvIOp(gv)) = PL_rsfp;
7703 /* Mark this internal pseudo-handle as clean */
7704 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7705 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7706 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7708 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7709 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7710 /* if the script was opened in binmode, we need to revert
7711 * it to text mode for compatibility; but only iff it has CRs
7712 * XXX this is a questionable hack at best. */
7713 if (PL_bufend-PL_bufptr > 2
7714 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7717 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7718 loc = PerlIO_tell(PL_rsfp);
7719 (void)PerlIO_seek(PL_rsfp, 0L, 0);
7722 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7724 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7725 #endif /* NETWARE */
7727 PerlIO_seek(PL_rsfp, loc, 0);
7731 #ifdef PERLIO_LAYERS
7734 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7743 FUN0OP(CvCLONE(PL_compcv)
7744 ? newOP(OP_RUNCV, 0)
7745 : newPVOP(OP_RUNCV,0,NULL));
7754 if (PL_expect == XSTATE) {
7765 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7766 if ((*s == ':' && s[1] == ':')
7767 || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
7771 Copy(PL_bufptr, PL_tokenbuf, olen, char);
7775 Perl_croak(aTHX_ "CORE::%" UTF8f " is not a keyword",
7776 UTF8fARG(UTF, len, PL_tokenbuf));
7779 else if (tmp == KEY_require || tmp == KEY_do
7781 /* that's a way to remember we saw "CORE::" */
7793 LOP(OP_ACCEPT,XTERM);
7796 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
7801 LOP(OP_ATAN2,XTERM);
7807 LOP(OP_BINMODE,XTERM);
7810 LOP(OP_BLESS,XTERM);
7819 /* We have to disambiguate the two senses of
7820 "continue". If the next token is a '{' then
7821 treat it as the start of a continue block;
7822 otherwise treat it as a control operator.
7832 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7842 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7851 if (!PL_cryptseen) {
7852 PL_cryptseen = TRUE;
7856 LOP(OP_CRYPT,XTERM);
7859 LOP(OP_CHMOD,XTERM);
7862 LOP(OP_CHOWN,XTERM);
7865 LOP(OP_CONNECT,XTERM);
7885 d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7887 if (len && memNEs(PL_tokenbuf+1, len, "CORE")
7888 && !keyword(PL_tokenbuf + 1, len, 0)) {
7889 SSize_t off = s-SvPVX(PL_linestr);
7891 s = SvPVX(PL_linestr)+off;
7893 force_ident_maybe_lex('&');
7898 if (orig_keyword == KEY_do) {
7907 PL_hints |= HINT_BLOCK_SCOPE;
7917 Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7918 STR_WITH_LEN("NDBM_File::"),
7919 STR_WITH_LEN("DB_File::"),
7920 STR_WITH_LEN("GDBM_File::"),
7921 STR_WITH_LEN("SDBM_File::"),
7922 STR_WITH_LEN("ODBM_File::"),
7924 LOP(OP_DBMOPEN,XTERM);
7936 pl_yylval.ival = CopLINE(PL_curcop);
7940 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
7952 if (*s == '{') { /* block eval */
7953 PL_expect = XTERMBLOCK;
7954 UNIBRACK(OP_ENTERTRY);
7956 else { /* string eval */
7958 UNIBRACK(OP_ENTEREVAL);
7963 UNIBRACK(-OP_ENTEREVAL);
7977 case KEY_endhostent:
7983 case KEY_endservent:
7986 case KEY_endprotoent:
7997 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
7999 pl_yylval.ival = CopLINE(PL_curcop);
8001 if ( PL_expect == XSTATE
8002 && isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
8005 SSize_t s_off = s - SvPVX(PL_linestr);
8007 if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "my")
8008 && isSPACE(*(p + 2)))
8012 else if ( memBEGINPs(p, (STRLEN) (PL_bufend - p), "our")
8013 && isSPACE(*(p + 3)))
8019 /* skip optional package name, as in "for my abc $x (..)" */
8020 if (isIDFIRST_lazy_if_safe(p, PL_bufend, UTF)) {
8021 p = scan_word(p, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8024 if (*p != '$' && *p != '\\')
8025 Perl_croak(aTHX_ "Missing $ on loop variable");
8027 /* The buffer may have been reallocated, update s */
8028 s = SvPVX(PL_linestr) + s_off;
8033 LOP(OP_FORMLINE,XTERM);
8042 LOP(OP_FCNTL,XTERM);
8048 LOP(OP_FLOCK,XTERM);
8051 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8056 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8061 LOP(OP_GREPSTART, XREF);
8078 case KEY_getpriority:
8079 LOP(OP_GETPRIORITY,XTERM);
8081 case KEY_getprotobyname:
8084 case KEY_getprotobynumber:
8085 LOP(OP_GPBYNUMBER,XTERM);
8087 case KEY_getprotoent:
8099 case KEY_getpeername:
8100 UNI(OP_GETPEERNAME);
8102 case KEY_gethostbyname:
8105 case KEY_gethostbyaddr:
8106 LOP(OP_GHBYADDR,XTERM);
8108 case KEY_gethostent:
8111 case KEY_getnetbyname:
8114 case KEY_getnetbyaddr:
8115 LOP(OP_GNBYADDR,XTERM);
8120 case KEY_getservbyname:
8121 LOP(OP_GSBYNAME,XTERM);
8123 case KEY_getservbyport:
8124 LOP(OP_GSBYPORT,XTERM);
8126 case KEY_getservent:
8129 case KEY_getsockname:
8130 UNI(OP_GETSOCKNAME);
8132 case KEY_getsockopt:
8133 LOP(OP_GSOCKOPT,XTERM);
8148 pl_yylval.ival = CopLINE(PL_curcop);
8149 Perl_ck_warner_d(aTHX_
8150 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8151 "given is experimental");
8156 orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
8164 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8166 pl_yylval.ival = CopLINE(PL_curcop);
8170 LOP(OP_INDEX,XTERM);
8176 LOP(OP_IOCTL,XTERM);
8203 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8208 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8222 LOP(OP_LISTEN,XTERM);
8231 s = scan_pat(s,OP_MATCH);
8232 TERM(sublex_start());
8235 LOP(OP_MAPSTART, XREF);
8238 LOP(OP_MKDIR,XTERM);
8241 LOP(OP_MSGCTL,XTERM);
8244 LOP(OP_MSGGET,XTERM);
8247 LOP(OP_MSGRCV,XTERM);
8250 LOP(OP_MSGSND,XTERM);
8257 yyerror(Perl_form(aTHX_
8258 "Can't redeclare \"%s\" in \"%s\"",
8259 tmp == KEY_my ? "my" :
8260 tmp == KEY_state ? "state" : "our",
8261 PL_in_my == KEY_my ? "my" :
8262 PL_in_my == KEY_state ? "state" : "our"));
8264 PL_in_my = (U16)tmp;
8266 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8267 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8268 if (memEQs(PL_tokenbuf, len, "sub"))
8270 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8271 if (!PL_in_my_stash) {
8275 len = my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8276 PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(tmpbuf));
8277 yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
8280 else if (*s == '\\') {
8281 if (!FEATURE_MYREF_IS_ENABLED)
8282 Perl_croak(aTHX_ "The experimental declared_refs "
8283 "feature is not enabled");
8284 Perl_ck_warner_d(aTHX_
8285 packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
8286 "Declaring references is experimental");
8294 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
8299 s = tokenize_use(0, s);
8303 if (*s == '(' || (s = skipspace(s), *s == '('))
8306 if (!PL_lex_allbrackets
8307 && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8309 PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8316 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
8318 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8320 for (t=d; isSPACE(*t);)
8322 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
8324 && !(t[0] == '=' && t[1] == '>')
8325 && !(t[0] == ':' && t[1] == ':')
8326 && !keyword(s, d-s, 0)
8328 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
8329 "Precedence problem: open %" UTF8f " should be open(%" UTF8f ")",
8330 UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
8336 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8338 pl_yylval.ival = OP_OR;
8348 LOP(OP_OPEN_DIR,XTERM);
8351 checkcomma(s,PL_tokenbuf,"filehandle");
8355 checkcomma(s,PL_tokenbuf,"filehandle");
8374 s = force_word(s,BAREWORD,FALSE,TRUE);
8376 s = force_strict_version(s);
8380 LOP(OP_PIPE_OP,XTERM);
8383 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8385 missingterm(NULL, 0);
8386 COPLINE_SET_FROM_MULTI_END;
8387 pl_yylval.ival = OP_CONST;
8388 TERM(sublex_start());
8395 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8397 missingterm(NULL, 0);
8398 COPLINE_SET_FROM_MULTI_END;
8399 PL_expect = XOPERATOR;
8400 if (SvCUR(PL_lex_stuff)) {
8401 int warned_comma = !ckWARN(WARN_QW);
8402 int warned_comment = warned_comma;
8403 d = SvPV_force(PL_lex_stuff, len);
8405 for (; isSPACE(*d) && len; --len, ++d)
8410 if (!warned_comma || !warned_comment) {
8411 for (; !isSPACE(*d) && len; --len, ++d) {
8412 if (!warned_comma && *d == ',') {
8413 Perl_warner(aTHX_ packWARN(WARN_QW),
8414 "Possible attempt to separate words with commas");
8417 else if (!warned_comment && *d == '#') {
8418 Perl_warner(aTHX_ packWARN(WARN_QW),
8419 "Possible attempt to put comments in qw() list");
8425 for (; !isSPACE(*d) && len; --len, ++d)
8428 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
8429 words = op_append_elem(OP_LIST, words,
8430 newSVOP(OP_CONST, 0, tokeq(sv)));
8435 words = newNULLLIST();
8436 SvREFCNT_dec_NN(PL_lex_stuff);
8437 PL_lex_stuff = NULL;
8438 PL_expect = XOPERATOR;
8439 pl_yylval.opval = sawparens(words);
8444 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8446 missingterm(NULL, 0);
8447 pl_yylval.ival = OP_STRINGIFY;
8448 if (SvIVX(PL_lex_stuff) == '\'')
8449 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8450 TERM(sublex_start());
8453 s = scan_pat(s,OP_QR);
8454 TERM(sublex_start());
8457 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8459 missingterm(NULL, 0);
8460 pl_yylval.ival = OP_BACKTICK;
8461 TERM(sublex_start());
8469 s = force_version(s, FALSE);
8471 else if (*s != 'v' || !isDIGIT(s[1])
8472 || (s = force_version(s, TRUE), *s == 'v'))
8474 *PL_tokenbuf = '\0';
8475 s = force_word(s,BAREWORD,TRUE,TRUE);
8476 if (isIDFIRST_lazy_if_safe(PL_tokenbuf,
8477 PL_tokenbuf + sizeof(PL_tokenbuf),
8480 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
8481 GV_ADD | (UTF ? SVf_UTF8 : 0));
8484 yyerror("<> at require-statement should be quotes");
8486 if (orig_keyword == KEY_require) {
8492 PL_expect = PL_nexttoke ? XOPERATOR : XTERM;
8494 PL_last_uni = PL_oldbufptr;
8495 PL_last_lop_op = OP_REQUIRE;
8497 return REPORT( (int)REQUIRE );
8506 LOP(OP_RENAME,XTERM);
8515 LOP(OP_RINDEX,XTERM);
8524 UNIDOR(OP_READLINE);
8527 UNIDOR(OP_BACKTICK);
8536 LOP(OP_REVERSE,XTERM);
8539 UNIDOR(OP_READLINK);
8546 if (pl_yylval.opval)
8547 TERM(sublex_start());
8549 TOKEN(1); /* force error */
8552 checkcomma(s,PL_tokenbuf,"filehandle");
8562 LOP(OP_SELECT,XTERM);
8568 LOP(OP_SEMCTL,XTERM);
8571 LOP(OP_SEMGET,XTERM);
8574 LOP(OP_SEMOP,XTERM);
8580 LOP(OP_SETPGRP,XTERM);
8582 case KEY_setpriority:
8583 LOP(OP_SETPRIORITY,XTERM);
8585 case KEY_sethostent:
8591 case KEY_setservent:
8594 case KEY_setprotoent:
8604 LOP(OP_SEEKDIR,XTERM);
8606 case KEY_setsockopt:
8607 LOP(OP_SSOCKOPT,XTERM);
8613 LOP(OP_SHMCTL,XTERM);
8616 LOP(OP_SHMGET,XTERM);
8619 LOP(OP_SHMREAD,XTERM);
8622 LOP(OP_SHMWRITE,XTERM);
8625 LOP(OP_SHUTDOWN,XTERM);
8634 LOP(OP_SOCKET,XTERM);
8636 case KEY_socketpair:
8637 LOP(OP_SOCKPAIR,XTERM);
8640 checkcomma(s,PL_tokenbuf,"subroutine name");
8643 s = force_word(s,BAREWORD,TRUE,TRUE);
8647 LOP(OP_SPLIT,XTERM);
8650 LOP(OP_SPRINTF,XTERM);
8653 LOP(OP_SPLICE,XTERM);
8668 LOP(OP_SUBSTR,XTERM);
8674 char * const tmpbuf = PL_tokenbuf + 1;
8675 bool have_name, have_proto;
8676 const int key = tmp;
8677 SV *format_name = NULL;
8678 bool is_sigsub = FEATURE_SIGNATURES_IS_ENABLED;
8680 SSize_t off = s-SvPVX(PL_linestr);
8682 d = SvPVX(PL_linestr)+off;
8684 SAVEBOOL(PL_parser->sig_seen);
8685 PL_parser->sig_seen = FALSE;
8687 if ( isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)
8689 || (*s == ':' && s[1] == ':'))
8692 PL_expect = XATTRBLOCK;
8693 d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8695 if (key == KEY_format)
8696 format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8698 if (memchr(tmpbuf, ':', len) || key != KEY_sub
8700 PL_tokenbuf, len + 1, 0
8702 sv_setpvn(PL_subname, tmpbuf, len);
8704 sv_setsv(PL_subname,PL_curstname);
8705 sv_catpvs(PL_subname,"::");
8706 sv_catpvn(PL_subname,tmpbuf,len);
8708 if (SvUTF8(PL_linestr))
8709 SvUTF8_on(PL_subname);
8716 if (key == KEY_my || key == KEY_our || key==KEY_state)
8719 /* diag_listed_as: Missing name in "%s sub" */
8721 "Missing name in \"%s\"", PL_bufptr);
8723 PL_expect = XATTRTERM;
8724 sv_setpvs(PL_subname,"?");
8728 if (key == KEY_format) {
8730 NEXTVAL_NEXTTOKE.opval
8731 = newSVOP(OP_CONST,0, format_name);
8732 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8733 force_next(BAREWORD);
8738 /* Look for a prototype */
8739 if (*s == '(' && !is_sigsub) {
8740 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
8741 COPLINE_SET_FROM_MULTI_END;
8743 Perl_croak(aTHX_ "Prototype not terminated");
8744 (void)validate_proto(PL_subname, PL_lex_stuff,
8745 ckWARN(WARN_ILLEGALPROTO), 0);
8753 if ( !(*s == ':' && s[1] != ':')
8754 && (*s != '{' && *s != '(') && key != KEY_format)
8756 assert(key == KEY_sub || key == KEY_AUTOLOAD ||
8757 key == KEY_DESTROY || key == KEY_BEGIN ||
8758 key == KEY_UNITCHECK || key == KEY_CHECK ||
8759 key == KEY_INIT || key == KEY_END ||
8760 key == KEY_my || key == KEY_state ||
8763 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8764 else if (*s != ';' && *s != '}')
8765 Perl_croak(aTHX_ "Illegal declaration of subroutine %" SVf, SVfARG(PL_subname));
8769 NEXTVAL_NEXTTOKE.opval =
8770 newSVOP(OP_CONST, 0, PL_lex_stuff);
8771 PL_lex_stuff = NULL;
8776 sv_setpvs(PL_subname, "__ANON__");
8778 sv_setpvs(PL_subname, "__ANON__::__ANON__");
8784 force_ident_maybe_lex('&');
8792 LOP(OP_SYSTEM,XREF);
8795 LOP(OP_SYMLINK,XTERM);
8798 LOP(OP_SYSCALL,XTERM);
8801 LOP(OP_SYSOPEN,XTERM);
8804 LOP(OP_SYSSEEK,XTERM);
8807 LOP(OP_SYSREAD,XTERM);
8810 LOP(OP_SYSWRITE,XTERM);
8815 TERM(sublex_start());
8836 LOP(OP_TRUNCATE,XTERM);
8848 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8850 pl_yylval.ival = CopLINE(PL_curcop);
8854 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8856 pl_yylval.ival = CopLINE(PL_curcop);
8860 LOP(OP_UNLINK,XTERM);
8866 LOP(OP_UNPACK,XTERM);
8869 LOP(OP_UTIME,XTERM);
8875 LOP(OP_UNSHIFT,XTERM);
8878 s = tokenize_use(1, s);
8888 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8890 pl_yylval.ival = CopLINE(PL_curcop);
8891 Perl_ck_warner_d(aTHX_
8892 packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8893 "when is experimental");
8897 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
8899 pl_yylval.ival = CopLINE(PL_curcop);
8903 PL_hints |= HINT_BLOCK_SCOPE;
8910 LOP(OP_WAITPID,XTERM);
8916 /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8917 * we use the same number on EBCDIC */
8918 gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8922 if (PL_expect == XOPERATOR) {
8923 if (*s == '=' && !PL_lex_allbrackets
8924 && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8934 if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
8936 pl_yylval.ival = OP_XOR;
8945 Looks up an identifier in the pad or in a package
8947 is_sig indicates that this is a subroutine signature variable
8948 rather than a plain pad var.
8951 PRIVATEREF if this is a lexical name.
8952 BAREWORD if this belongs to a package.
8955 if we're in a my declaration
8956 croak if they tried to say my($foo::bar)
8957 build the ops for a my() declaration
8958 if it's an access to a my() variable
8959 build ops for access to a my() variable
8960 if in a dq string, and they've said @foo and we can't find @foo
8962 build ops for a bareword
8966 S_pending_ident(pTHX)
8969 const char pit = (char)pl_yylval.ival;
8970 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8971 /* All routes through this function want to know if there is a colon. */
8972 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8974 DEBUG_T({ PerlIO_printf(Perl_debug_log,
8975 "### Pending identifier '%s'\n", PL_tokenbuf); });
8976 assert(tokenbuf_len >= 2);
8978 /* if we're in a my(), we can't allow dynamics here.
8979 $foo'bar has already been turned into $foo::bar, so
8980 just check for colons.
8982 if it's a legal name, the OP is a PADANY.
8985 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8987 /* diag_listed_as: No package name allowed for variable %s
8989 yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
8990 "%se %s in \"our\"",
8991 *PL_tokenbuf=='&' ?"subroutin":"variabl",
8992 PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8993 tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
8998 /* "my" variable %s can't be in a package */
8999 /* PL_no_myglob is constant */
9000 GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral);
9001 yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
9002 PL_in_my == KEY_my ? "my" : "state",
9003 *PL_tokenbuf == '&' ? "subroutin" : "variabl",
9005 UTF ? SVf_UTF8 : 0);
9006 GCC_DIAG_RESTORE_STMT;
9009 if (PL_in_my == KEY_sigvar) {
9010 /* A signature 'padop' needs in addition, an op_first to
9011 * point to a child sigdefelem, and an extra field to hold
9012 * the signature index. We can achieve both by using an
9013 * UNOP_AUX and (ab)using the op_aux field to hold the
9014 * index. If we ever need more fields, use a real malloced
9015 * aux strut instead.
9017 o = newUNOP_AUX(OP_ARGELEM, 0, NULL,
9018 INT2PTR(UNOP_AUX_item *,
9019 (PL_parser->sig_elems)));
9020 o->op_private |= ( PL_tokenbuf[0] == '$' ? OPpARGELEM_SV
9021 : PL_tokenbuf[0] == '@' ? OPpARGELEM_AV
9025 o = newOP(OP_PADANY, 0);
9026 o->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
9027 UTF ? SVf_UTF8 : 0);
9028 if (PL_in_my == KEY_sigvar)
9031 pl_yylval.opval = o;
9037 build the ops for accesses to a my() variable.
9042 tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
9044 if (tmp != NOT_IN_PAD) {
9045 /* might be an "our" variable" */
9046 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9047 /* build ops for a bareword */
9048 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9049 HEK * const stashname = HvNAME_HEK(stash);
9050 SV * const sym = newSVhek(stashname);
9051 sv_catpvs(sym, "::");
9052 sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
9053 pl_yylval.opval = newSVOP(OP_CONST, 0, sym);
9054 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9058 ((PL_tokenbuf[0] == '$') ? SVt_PV
9059 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9064 pl_yylval.opval = newOP(OP_PADANY, 0);
9065 pl_yylval.opval->op_targ = tmp;
9071 Whine if they've said @foo or @foo{key} in a doublequoted string,
9072 and @foo (or %foo) isn't a variable we can find in the symbol
9075 if (ckWARN(WARN_AMBIGUOUS)
9077 && PL_lex_state != LEX_NORMAL
9078 && !PL_lex_brackets)
9080 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9081 ( UTF ? SVf_UTF8 : 0 ) | GV_ADDMG,
9083 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
9086 /* Downgraded from fatal to warning 20000522 mjd */
9087 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9088 "Possible unintended interpolation of %" UTF8f
9090 UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
9094 /* build ops for a bareword */
9095 pl_yylval.opval = newSVOP(OP_CONST, 0,
9096 newSVpvn_flags(PL_tokenbuf + 1,
9097 tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9098 UTF ? SVf_UTF8 : 0 ));
9099 pl_yylval.opval->op_private = OPpCONST_ENTERED;
9101 gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len > 0 ? tokenbuf_len - 1 : 0,
9102 (PL_in_eval ? GV_ADDMULTI : GV_ADD)
9103 | ( UTF ? SVf_UTF8 : 0 ),
9104 ((PL_tokenbuf[0] == '$') ? SVt_PV
9105 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9111 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9113 PERL_ARGS_ASSERT_CHECKCOMMA;
9115 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
9116 if (ckWARN(WARN_SYNTAX)) {
9119 for (w = s+2; *w && level; w++) {
9127 /* the list of chars below is for end of statements or
9128 * block / parens, boolean operators (&&, ||, //) and branch
9129 * constructs (or, and, if, until, unless, while, err, for).
9130 * Not a very solid hack... */
9131 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
9132 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9133 "%s (...) interpreted as function",name);
9136 while (s < PL_bufend && isSPACE(*s))
9140 while (s < PL_bufend && isSPACE(*s))
9142 if (isIDFIRST_lazy_if_safe(s, PL_bufend, UTF)) {
9143 const char * const w = s;
9144 s += UTF ? UTF8SKIP(s) : 1;
9145 while (isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
9146 s += UTF ? UTF8SKIP(s) : 1;
9147 while (s < PL_bufend && isSPACE(*s))
9151 if (keyword(w, s - w, 0))
9154 gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
9155 if (gv && GvCVu(gv))
9160 Copy(w, tmpbuf+1, s - w, char);
9162 off = pad_findmy_pvn(tmpbuf, s-w+1, 0);
9163 if (off != NOT_IN_PAD) return;
9165 Perl_croak(aTHX_ "No comma allowed after %s", what);
9170 /* S_new_constant(): do any overload::constant lookup.
9172 Either returns sv, or mortalizes/frees sv and returns a new SV*.
9173 Best used as sv=new_constant(..., sv, ...).
9174 If s, pv are NULL, calls subroutine with one argument,
9175 and <type> is used with error messages only.
9176 <type> is assumed to be well formed UTF-8 */
9179 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9180 SV *sv, SV *pv, const char *type, STRLEN typelen)
9183 HV * table = GvHV(PL_hintgv); /* ^H */
9188 const char *why1 = "", *why2 = "", *why3 = "";
9190 PERL_ARGS_ASSERT_NEW_CONSTANT;
9191 /* We assume that this is true: */
9192 if (*key == 'c') { assert (strEQ(key, "charnames")); }
9195 /* charnames doesn't work well if there have been errors found */
9196 if (PL_error_count > 0 && *key == 'c')
9198 SvREFCNT_dec_NN(sv);
9199 return &PL_sv_undef;
9202 sv_2mortal(sv); /* Parent created it permanently */
9204 || ! (PL_hints & HINT_LOCALIZE_HH)
9205 || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9210 /* Here haven't found what we're looking for. If it is charnames,
9211 * perhaps it needs to be loaded. Try doing that before giving up */
9213 Perl_load_module(aTHX_
9215 newSVpvs("_charnames"),
9216 /* version parameter; no need to specify it, as if
9217 * we get too early a version, will fail anyway,
9218 * not being able to find '_charnames' */
9223 assert(sp == PL_stack_sp);
9224 table = GvHV(PL_hintgv);
9226 && (PL_hints & HINT_LOCALIZE_HH)
9227 && (cvp = hv_fetch(table, key, keylen, FALSE))
9233 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9234 msg = Perl_form(aTHX_
9235 "Constant(%.*s) unknown",
9236 (int)(type ? typelen : len),
9242 why3 = "} is not defined";
9245 msg = Perl_form(aTHX_
9246 /* The +3 is for '\N{'; -4 for that, plus '}' */
9247 "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9251 msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
9252 (int)(type ? typelen : len),
9253 (type ? type: s), why1, why2, why3);
9256 yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
9257 return SvREFCNT_inc_simple_NN(sv);
9262 pv = newSVpvn_flags(s, len, SVs_TEMP);
9264 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9266 typesv = &PL_sv_undef;
9268 PUSHSTACKi(PERLSI_OVERLOAD);
9280 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9284 /* Check the eval first */
9285 if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
9287 const char * errstr;
9288 sv_catpvs(errsv, "Propagated");
9289 errstr = SvPV_const(errsv, errlen);
9290 yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9292 res = SvREFCNT_inc_simple_NN(sv);
9296 SvREFCNT_inc_simple_void_NN(res);
9305 why1 = "Call to &{$^H{";
9307 why3 = "}} did not return a defined value";
9309 (void)sv_2mortal(sv);
9316 PERL_STATIC_INLINE void
9317 S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package,
9318 bool is_utf8, bool check_dollar, bool tick_warn)
9321 const char *olds = *s;
9322 PERL_ARGS_ASSERT_PARSE_IDENT;
9324 while (*s < PL_bufend) {
9326 Perl_croak(aTHX_ "%s", ident_too_long);
9327 if (is_utf8 && isIDFIRST_utf8_safe(*s, PL_bufend)) {
9328 /* The UTF-8 case must come first, otherwise things
9329 * like c\N{COMBINING TILDE} would start failing, as the
9330 * isWORDCHAR_A case below would gobble the 'c' up.
9333 char *t = *s + UTF8SKIP(*s);
9334 while (isIDCONT_utf8_safe((const U8*) t, (const U8*) PL_bufend)) {
9337 if (*d + (t - *s) > e)
9338 Perl_croak(aTHX_ "%s", ident_too_long);
9339 Copy(*s, *d, t - *s, char);
9343 else if ( isWORDCHAR_A(**s) ) {
9346 } while (isWORDCHAR_A(**s) && *d < e);
9348 else if ( allow_package
9350 && isIDFIRST_lazy_if_safe((*s)+1, PL_bufend, is_utf8))
9357 else if (allow_package && **s == ':' && (*s)[1] == ':'
9358 /* Disallow things like Foo::$bar. For the curious, this is
9359 * the code path that triggers the "Bad name after" warning
9360 * when looking for barewords.
9362 && !(check_dollar && (*s)[2] == '$')) {
9369 if (UNLIKELY(tick_warn && saw_tick && PL_lex_state == LEX_INTERPNORMAL
9370 && !PL_lex_brackets && ckWARN(WARN_SYNTAX))) {
9373 Newx(d, *s - olds + saw_tick + 2, char); /* +2 for $# */
9376 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9377 "Old package separator used in string");
9378 if (olds[-1] == '#')
9382 if (*olds == '\'') {
9389 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9390 "\t(Did you mean \"%" UTF8f "\" instead?)\n",
9391 UTF8fARG(is_utf8, d2-d, d));
9396 /* Returns a NUL terminated string, with the length of the string written to
9400 S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9403 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9404 bool is_utf8 = cBOOL(UTF);
9406 PERL_ARGS_ASSERT_SCAN_WORD;
9408 parse_ident(&s, &d, e, allow_package, is_utf8, TRUE, FALSE);
9414 /* Is the byte 'd' a legal single character identifier name? 'u' is true
9415 * iff Unicode semantics are to be used. The legal ones are any of:
9416 * a) all ASCII characters except:
9417 * 1) control and space-type ones, like NUL, SOH, \t, and SPACE;
9419 * The final case currently doesn't get this far in the program, so we
9420 * don't test for it. If that were to change, it would be ok to allow it.
9421 * b) When not under Unicode rules, any upper Latin1 character
9422 * c) Otherwise, when unicode rules are used, all XIDS characters.
9424 * Because all ASCII characters have the same representation whether
9425 * encoded in UTF-8 or not, we can use the foo_A macros below and '\0' and
9426 * '{' without knowing if is UTF-8 or not. */
9427 #define VALID_LEN_ONE_IDENT(s, e, is_utf8) \
9428 (isGRAPH_A(*(s)) || ((is_utf8) \
9429 ? isIDFIRST_utf8_safe(s, e) \
9431 && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD)))))
9434 S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni)
9436 I32 herelines = PL_parser->herelines;
9437 SSize_t bracket = -1;
9440 char * const e = d + destlen - 3; /* two-character token, ending NUL */
9441 bool is_utf8 = cBOOL(UTF);
9442 I32 orig_copline = 0, tmp_copline = 0;
9444 PERL_ARGS_ASSERT_SCAN_IDENT;
9446 if (isSPACE(*s) || !*s)
9449 while (isDIGIT(*s)) {
9451 Perl_croak(aTHX_ "%s", ident_too_long);
9455 else { /* See if it is a "normal" identifier */
9456 parse_ident(&s, &d, e, 1, is_utf8, FALSE, TRUE);
9461 /* Either a digit variable, or parse_ident() found an identifier
9462 (anything valid as a bareword), so job done and return. */
9463 if (PL_lex_state != LEX_NORMAL)
9464 PL_lex_state = LEX_INTERPENDMAYBE;
9468 /* Here, it is not a run-of-the-mill identifier name */
9470 if (*s == '$' && s[1]
9471 && ( isIDFIRST_lazy_if_safe(s+1, PL_bufend, is_utf8)
9472 || isDIGIT_A((U8)s[1])
9475 || memBEGINs(s+1, (STRLEN) (PL_bufend - (s+1)), "::")) )
9477 /* Dereferencing a value in a scalar variable.
9478 The alternatives are different syntaxes for a scalar variable.
9479 Using ' as a leading package separator isn't allowed. :: is. */
9482 /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9484 bracket = s - SvPVX(PL_linestr);
9486 orig_copline = CopLINE(PL_curcop);
9487 if (s < PL_bufend && isSPACE(*s)) {
9491 if ((s <= PL_bufend - (is_utf8)
9494 && VALID_LEN_ONE_IDENT(s, PL_bufend, is_utf8))
9497 const STRLEN skip = UTF8SKIP(s);
9500 for ( i = 0; i < skip; i++ )
9508 /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9509 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9513 /* Warn about ambiguous code after unary operators if {...} notation isn't
9514 used. There's no difference in ambiguity; it's merely a heuristic
9515 about when not to warn. */
9516 else if (ck_uni && bracket == -1)
9518 if (bracket != -1) {
9521 /* If we were processing {...} notation then... */
9522 if (isIDFIRST_lazy_if_safe(d, e, is_utf8)
9523 || (!isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9526 /* note we have to check for a normal identifier first,
9527 * as it handles utf8 symbols, and only after that has
9528 * been ruled out can we look at the caret words */
9529 if (isIDFIRST_lazy_if_safe(d, e, is_utf8) ) {
9530 /* if it starts as a valid identifier, assume that it is one.
9531 (the later check for } being at the expected point will trap
9532 cases where this doesn't pan out.) */
9533 d += is_utf8 ? UTF8SKIP(d) : 1;
9534 parse_ident(&s, &d, e, 1, is_utf8, TRUE, TRUE);
9537 else { /* caret word: ${^Foo} ${^CAPTURE[0]} */
9539 while (isWORDCHAR(*s) && d < e) {
9543 Perl_croak(aTHX_ "%s", ident_too_long);
9546 tmp_copline = CopLINE(PL_curcop);
9547 if (s < PL_bufend && isSPACE(*s)) {
9550 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9551 /* ${foo[0]} and ${foo{bar}} and ${^CAPTURE[0]} notation. */
9552 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
9553 const char * const brack =
9555 ((*s == '[') ? "[...]" : "{...}");
9556 orig_copline = CopLINE(PL_curcop);
9557 CopLINE_set(PL_curcop, tmp_copline);
9558 /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9559 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9560 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9561 funny, dest, brack, funny, dest, brack);
9562 CopLINE_set(PL_curcop, orig_copline);
9565 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9566 PL_lex_allbrackets++;
9572 tmp_copline = CopLINE(PL_curcop);
9573 if ((skip = s < PL_bufend && isSPACE(*s))) {
9574 /* Avoid incrementing line numbers or resetting PL_linestart,
9575 in case we have to back up. */
9576 STRLEN s_off = s - SvPVX(PL_linestr);
9578 s = SvPVX(PL_linestr) + s_off;
9583 /* Expect to find a closing } after consuming any trailing whitespace.
9586 /* Now increment line numbers if applicable. */
9590 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9591 PL_lex_state = LEX_INTERPEND;
9594 if (PL_lex_state == LEX_NORMAL) {
9595 if (ckWARN(WARN_AMBIGUOUS)
9596 && (keyword(dest, d - dest, 0)
9597 || get_cvn_flags(dest, d - dest, is_utf8
9601 SV *tmp = newSVpvn_flags( dest, d - dest,
9602 SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9605 orig_copline = CopLINE(PL_curcop);
9606 CopLINE_set(PL_curcop, tmp_copline);
9607 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9608 "Ambiguous use of %c{%" SVf "} resolved to %c%" SVf,
9609 funny, SVfARG(tmp), funny, SVfARG(tmp));
9610 CopLINE_set(PL_curcop, orig_copline);
9615 /* Didn't find the closing } at the point we expected, so restore
9616 state such that the next thing to process is the opening { and */
9617 s = SvPVX(PL_linestr) + bracket; /* let the parser handle it */
9618 CopLINE_set(PL_curcop, orig_copline);
9619 PL_parser->herelines = herelines;
9621 PL_parser->sub_no_recover = TRUE;
9624 else if ( PL_lex_state == LEX_INTERPNORMAL
9626 && !intuit_more(s, PL_bufend))
9627 PL_lex_state = LEX_INTERPEND;
9632 S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset, unsigned int * x_mod_count) {
9634 /* Adds, subtracts to/from 'pmfl' based on the next regex modifier flag
9635 * found in the parse starting at 's', based on the subset that are valid
9636 * in this context input to this routine in 'valid_flags'. Advances s.
9637 * Returns TRUE if the input should be treated as a valid flag, so the next
9638 * char may be as well; otherwise FALSE. 'charset' should point to a NUL
9639 * upon first call on the current regex. This routine will set it to any
9640 * charset modifier found. The caller shouldn't change it. This way,
9641 * another charset modifier encountered in the parse can be detected as an
9642 * error, as we have decided to allow only one */
9645 STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
9647 if ( charlen != 1 || ! strchr(valid_flags, c) ) {
9648 if (isWORDCHAR_lazy_if_safe( *s, PL_bufend, UTF)) {
9649 yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
9650 UTF ? SVf_UTF8 : 0);
9652 /* Pretend that it worked, so will continue processing before
9661 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl, *x_mod_count);
9662 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9663 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9664 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9665 case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9666 case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9667 case LOCALE_PAT_MOD:
9669 goto multiple_charsets;
9671 set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9674 case UNICODE_PAT_MOD:
9676 goto multiple_charsets;
9678 set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9681 case ASCII_RESTRICT_PAT_MOD:
9683 set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9687 /* Error if previous modifier wasn't an 'a', but if it was, see
9688 * if, and accept, a second occurrence (only) */
9690 || get_regex_charset(*pmfl)
9691 != REGEX_ASCII_RESTRICTED_CHARSET)
9693 goto multiple_charsets;
9695 set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9699 case DEPENDS_PAT_MOD:
9701 goto multiple_charsets;
9703 set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9712 if (*charset != c) {
9713 yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9715 else if (c == 'a') {
9716 /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
9717 yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9720 yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9723 /* Pretend that it worked, so will continue processing before dieing */
9729 S_scan_pat(pTHX_ char *start, I32 type)
9733 const char * const valid_flags =
9734 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9735 char charset = '\0'; /* character set modifier */
9736 unsigned int x_mod_count = 0;
9738 PERL_ARGS_ASSERT_SCAN_PAT;
9740 s = scan_str(start,TRUE,FALSE, (PL_in_eval & EVAL_RE_REPARSING), NULL);
9742 Perl_croak(aTHX_ "Search pattern not terminated");
9744 pm = (PMOP*)newPMOP(type, 0);
9745 if (PL_multi_open == '?') {
9746 /* This is the only point in the code that sets PMf_ONCE: */
9747 pm->op_pmflags |= PMf_ONCE;
9749 /* Hence it's safe to do this bit of PMOP book-keeping here, which
9750 allows us to restrict the list needed by reset to just the ??
9752 assert(type != OP_TRANS);
9754 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9757 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9760 elements = mg->mg_len / sizeof(PMOP**);
9761 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9762 ((PMOP**)mg->mg_ptr) [elements++] = pm;
9763 mg->mg_len = elements * sizeof(PMOP**);
9764 PmopSTASH_set(pm,PL_curstash);
9768 /* if qr/...(?{..}).../, then need to parse the pattern within a new
9769 * anon CV. False positives like qr/[(?{]/ are harmless */
9771 if (type == OP_QR) {
9773 char *e, *p = SvPV(PL_lex_stuff, len);
9775 for (; p < e; p++) {
9776 if (p[0] == '(' && p[1] == '?'
9777 && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
9779 pm->op_pmflags |= PMf_HAS_CV;
9783 pm->op_pmflags |= PMf_IS_QR;
9786 while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags),
9787 &s, &charset, &x_mod_count))
9789 /* issue a warning if /c is specified,but /g is not */
9790 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9792 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9793 "Use of /c modifier is meaningless without /g" );
9796 PL_lex_op = (OP*)pm;
9797 pl_yylval.ival = OP_MATCH;
9802 S_scan_subst(pTHX_ char *start)
9808 line_t linediff = 0;
9810 char charset = '\0'; /* character set modifier */
9811 unsigned int x_mod_count = 0;
9814 PERL_ARGS_ASSERT_SCAN_SUBST;
9816 pl_yylval.ival = OP_NULL;
9818 s = scan_str(start, TRUE, FALSE, FALSE, &t);
9821 Perl_croak(aTHX_ "Substitution pattern not terminated");
9825 first_start = PL_multi_start;
9826 first_line = CopLINE(PL_curcop);
9827 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9829 SvREFCNT_dec_NN(PL_lex_stuff);
9830 PL_lex_stuff = NULL;
9831 Perl_croak(aTHX_ "Substitution replacement not terminated");
9833 PL_multi_start = first_start; /* so whole substitution is taken together */
9835 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9839 if (*s == EXEC_PAT_MOD) {
9843 else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags),
9844 &s, &charset, &x_mod_count))
9850 if ((pm->op_pmflags & PMf_CONTINUE)) {
9851 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9855 SV * const repl = newSVpvs("");
9858 pm->op_pmflags |= PMf_EVAL;
9859 for (; es > 1; es--) {
9860 sv_catpvs(repl, "eval ");
9862 sv_catpvs(repl, "do {");
9863 sv_catsv(repl, PL_parser->lex_sub_repl);
9864 sv_catpvs(repl, "}");
9865 SvREFCNT_dec(PL_parser->lex_sub_repl);
9866 PL_parser->lex_sub_repl = repl;
9870 linediff = CopLINE(PL_curcop) - first_line;
9872 CopLINE_set(PL_curcop, first_line);
9874 if (linediff || es) {
9875 /* the IVX field indicates that the replacement string is a s///e;
9876 * the NVX field indicates how many src code lines the replacement
9878 sv_upgrade(PL_parser->lex_sub_repl, SVt_PVNV);
9879 ((XPVNV*)SvANY(PL_parser->lex_sub_repl))->xnv_u.xnv_lines = linediff;
9880 ((XPVIV*)SvANY(PL_parser->lex_sub_repl))->xiv_u.xivu_eval_seen =
9884 PL_lex_op = (OP*)pm;
9885 pl_yylval.ival = OP_SUBST;
9890 S_scan_trans(pTHX_ char *start)
9897 bool nondestruct = 0;
9900 PERL_ARGS_ASSERT_SCAN_TRANS;
9902 pl_yylval.ival = OP_NULL;
9904 s = scan_str(start,FALSE,FALSE,FALSE,&t);
9906 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9910 s = scan_str(s,FALSE,FALSE,FALSE,NULL);
9912 SvREFCNT_dec_NN(PL_lex_stuff);
9913 PL_lex_stuff = NULL;
9914 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9917 complement = del = squash = 0;
9921 complement = OPpTRANS_COMPLEMENT;
9924 del = OPpTRANS_DELETE;
9927 squash = OPpTRANS_SQUASH;
9939 o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9940 o->op_private &= ~OPpTRANS_ALL;
9941 o->op_private |= del|squash|complement|
9942 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9943 (DO_UTF8(PL_parser->lex_sub_repl) ? OPpTRANS_TO_UTF : 0);
9946 pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9953 Takes a pointer to the first < in <<FOO.
9954 Returns a pointer to the byte following <<FOO.
9956 This function scans a heredoc, which involves different methods
9957 depending on whether we are in a string eval, quoted construct, etc.
9958 This is because PL_linestr could containing a single line of input, or
9959 a whole string being evalled, or the contents of the current quote-
9962 The two basic methods are:
9963 - Steal lines from the input stream
9964 - Scan the heredoc in PL_linestr and remove it therefrom
9966 In a file scope or filtered eval, the first method is used; in a
9967 string eval, the second.
9969 In a quote-like operator, we have to choose between the two,
9970 depending on where we can find a newline. We peek into outer lex-
9971 ing scopes until we find one with a newline in it. If we reach the
9972 outermost lexing scope and it is a file, we use the stream method.
9973 Otherwise it is treated as an eval.
9977 S_scan_heredoc(pTHX_ char *s)
9979 I32 op_type = OP_SCALAR;
9988 bool indented = FALSE;
9989 const bool infile = PL_rsfp || PL_parser->filtered;
9990 const line_t origline = CopLINE(PL_curcop);
9991 LEXSHARED *shared = PL_parser->lex_shared;
9993 PERL_ARGS_ASSERT_SCAN_HEREDOC;
9996 d = PL_tokenbuf + 1;
9997 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9998 *PL_tokenbuf = '\n';
10000 if (*peek == '~') {
10004 while (SPACE_OR_TAB(*peek))
10006 if (*peek == '`' || *peek == '\'' || *peek =='"') {
10009 s = delimcpy(d, e, s, PL_bufend, term, &len);
10010 if (s == PL_bufend)
10011 Perl_croak(aTHX_ "Unterminated delimiter for here document");
10017 /* <<\FOO is equivalent to <<'FOO' */
10021 if (! isWORDCHAR_lazy_if_safe(s, PL_bufend, UTF))
10022 Perl_croak(aTHX_ "Use of bare << to mean <<\"\" is forbidden");
10024 while (isWORDCHAR_lazy_if_safe(peek, PL_bufend, UTF)) {
10025 peek += UTF ? UTF8SKIP(peek) : 1;
10027 len = (peek - s >= e - d) ? (e - d) : (peek - s);
10028 Copy(s, d, len, char);
10032 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10033 Perl_croak(aTHX_ "Delimiter for here document is too long");
10036 len = d - PL_tokenbuf;
10038 #ifndef PERL_STRICT_CR
10039 d = (char *) memchr(s, '\r', PL_bufend - s);
10041 char * const olds = s;
10043 while (s < PL_bufend) {
10049 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
10058 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10063 tmpstr = newSV_type(SVt_PVIV);
10064 SvGROW(tmpstr, 80);
10065 if (term == '\'') {
10066 op_type = OP_CONST;
10067 SvIV_set(tmpstr, -1);
10069 else if (term == '`') {
10070 op_type = OP_BACKTICK;
10071 SvIV_set(tmpstr, '\\');
10074 PL_multi_start = origline + 1 + PL_parser->herelines;
10075 PL_multi_open = PL_multi_close = '<';
10076 /* inside a string eval or quote-like operator */
10077 if (!infile || PL_lex_inwhat) {
10080 char * const olds = s;
10081 PERL_CONTEXT * const cx = CX_CUR();
10082 /* These two fields are not set until an inner lexing scope is
10083 entered. But we need them set here. */
10084 shared->ls_bufptr = s;
10085 shared->ls_linestr = PL_linestr;
10087 /* Look for a newline. If the current buffer does not have one,
10088 peek into the line buffer of the parent lexing scope, going
10089 up as many levels as necessary to find one with a newline
10092 while (!(s = (char *)memchr(
10093 (void *)shared->ls_bufptr, '\n',
10094 SvEND(shared->ls_linestr)-shared->ls_bufptr
10096 shared = shared->ls_prev;
10097 /* shared is only null if we have gone beyond the outermost
10098 lexing scope. In a file, we will have broken out of the
10099 loop in the previous iteration. In an eval, the string buf-
10100 fer ends with "\n;", so the while condition above will have
10101 evaluated to false. So shared can never be null. Or so you
10102 might think. Odd syntax errors like s;@{<<; can gobble up
10103 the implicit semicolon at the end of a flie, causing the
10104 file handle to be closed even when we are not in a string
10105 eval. So shared may be null in that case.
10106 (Closing '}' here to balance the earlier open brace for
10107 editors that look for matched pairs.) */
10108 if (UNLIKELY(!shared))
10110 /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10111 most lexing scope. In a file, shared->ls_linestr at that
10112 level is just one line, so there is no body to steal. */
10113 if (infile && !shared->ls_prev) {
10118 else { /* eval or we've already hit EOF */
10119 s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10123 linestr = shared->ls_linestr;
10124 bufend = SvEND(linestr);
10129 while (s < bufend - len + 1) {
10131 ++PL_parser->herelines;
10133 if (memEQ(s, PL_tokenbuf + 1, len - 1)) {
10137 /* Only valid if it's preceded by whitespace only */
10138 while (backup != myolds && --backup >= myolds) {
10139 if (! SPACE_OR_TAB(*backup)) {
10146 /* No whitespace or all! */
10147 if (backup == s || *backup == '\n') {
10148 Newx(indent, indent_len + 1, char);
10149 memcpy(indent, backup + 1, indent_len);
10150 indent[indent_len] = 0;
10151 s--; /* before our delimiter */
10152 PL_parser->herelines--; /* this line doesn't count */
10158 while (s < bufend - len + 1
10159 && memNE(s,PL_tokenbuf,len) )
10162 ++PL_parser->herelines;
10166 if (s >= bufend - len + 1) {
10169 sv_setpvn(tmpstr,d+1,s-d);
10171 /* the preceding stmt passes a newline */
10172 PL_parser->herelines++;
10174 /* s now points to the newline after the heredoc terminator.
10175 d points to the newline before the body of the heredoc.
10178 /* We are going to modify linestr in place here, so set
10179 aside copies of the string if necessary for re-evals or
10181 /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10182 check shared->re_eval_str. */
10183 if (shared->re_eval_start || shared->re_eval_str) {
10184 /* Set aside the rest of the regexp */
10185 if (!shared->re_eval_str)
10186 shared->re_eval_str =
10187 newSVpvn(shared->re_eval_start,
10188 bufend - shared->re_eval_start);
10189 shared->re_eval_start -= s-d;
10191 if (cxstack_ix >= 0
10192 && CxTYPE(cx) == CXt_EVAL
10193 && CxOLD_OP_TYPE(cx) == OP_ENTEREVAL
10194 && cx->blk_eval.cur_text == linestr)
10196 cx->blk_eval.cur_text = newSVsv(linestr);
10197 cx->blk_u16 |= 0x40; /* indicate cur_text is ref counted */
10199 /* Copy everything from s onwards back to d. */
10200 Move(s,d,bufend-s + 1,char);
10201 SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10202 /* Setting PL_bufend only applies when we have not dug deeper
10203 into other scopes, because sublex_done sets PL_bufend to
10204 SvEND(PL_linestr). */
10205 if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10211 char *oldbufptr_save;
10212 char *oldoldbufptr_save;
10214 SvPVCLEAR(tmpstr); /* avoid "uninitialized" warning */
10215 term = PL_tokenbuf[1];
10217 linestr_save = PL_linestr; /* must restore this afterwards */
10218 d = s; /* and this */
10219 oldbufptr_save = PL_oldbufptr;
10220 oldoldbufptr_save = PL_oldoldbufptr;
10221 PL_linestr = newSVpvs("");
10222 PL_bufend = SvPVX(PL_linestr);
10224 PL_bufptr = PL_bufend;
10225 CopLINE_set(PL_curcop,
10226 origline + 1 + PL_parser->herelines);
10227 if (!lex_next_chunk(LEX_NO_TERM)
10228 && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
10229 /* Simply freeing linestr_save might seem simpler here, as it
10230 does not matter what PL_linestr points to, since we are
10231 about to croak; but in a quote-like op, linestr_save
10232 will have been prospectively freed already, via
10233 SAVEFREESV(PL_linestr) in sublex_push, so it’s easier to
10234 restore PL_linestr. */
10235 SvREFCNT_dec_NN(PL_linestr);
10236 PL_linestr = linestr_save;
10237 PL_oldbufptr = oldbufptr_save;
10238 PL_oldoldbufptr = oldoldbufptr_save;
10241 CopLINE_set(PL_curcop, origline);
10242 if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
10243 s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10244 /* ^That should be enough to avoid this needing to grow: */
10245 sv_catpvs(PL_linestr, "\n\0");
10246 assert(s == SvPVX(PL_linestr));
10247 PL_bufend = SvEND(PL_linestr);
10250 PL_parser->herelines++;
10251 PL_last_lop = PL_last_uni = NULL;
10252 #ifndef PERL_STRICT_CR
10253 if (PL_bufend - PL_linestart >= 2) {
10254 if ( (PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n')
10255 || (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10257 PL_bufend[-2] = '\n';
10259 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10261 else if (PL_bufend[-1] == '\r')
10262 PL_bufend[-1] = '\n';
10264 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
10265 PL_bufend[-1] = '\n';
10267 if (indented && (PL_bufend-s) >= len) {
10268 char * found = ninstr(s, PL_bufend, (PL_tokenbuf + 1), (PL_tokenbuf +1 + len));
10271 char *backup = found;
10274 /* Only valid if it's preceded by whitespace only */
10275 while (backup != s && --backup >= s) {
10276 if (! SPACE_OR_TAB(*backup)) {
10282 /* All whitespace or none! */
10283 if (backup == found || SPACE_OR_TAB(*backup)) {
10284 Newx(indent, indent_len + 1, char);
10285 memcpy(indent, backup, indent_len);
10286 indent[indent_len] = 0;
10287 SvREFCNT_dec(PL_linestr);
10288 PL_linestr = linestr_save;
10289 PL_linestart = SvPVX(linestr_save);
10290 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10291 PL_oldbufptr = oldbufptr_save;
10292 PL_oldoldbufptr = oldoldbufptr_save;
10298 /* Didn't find it */
10299 sv_catsv(tmpstr,PL_linestr);
10301 if (*s == term && PL_bufend-s >= len
10302 && memEQ(s,PL_tokenbuf + 1,len))
10304 SvREFCNT_dec(PL_linestr);
10305 PL_linestr = linestr_save;
10306 PL_linestart = SvPVX(linestr_save);
10307 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10308 PL_oldbufptr = oldbufptr_save;
10309 PL_oldoldbufptr = oldoldbufptr_save;
10313 sv_catsv(tmpstr,PL_linestr);
10318 PL_multi_end = origline + PL_parser->herelines;
10319 if (indented && indent) {
10320 STRLEN linecount = 1;
10321 STRLEN herelen = SvCUR(tmpstr);
10322 char *ss = SvPVX(tmpstr);
10323 char *se = ss + herelen;
10324 SV *newstr = newSV(herelen+1);
10327 /* Trim leading whitespace */
10329 /* newline only? Copy and move on */
10331 sv_catpvs(newstr,"\n");
10335 /* Found our indentation? Strip it */
10336 } else if (se - ss >= indent_len
10337 && memEQ(ss, indent, indent_len))
10343 while ((ss + le) < se && *(ss + le) != '\n')
10346 sv_catpvn(newstr, ss, le);
10350 /* Line doesn't begin with our indentation? Croak */
10353 "Indentation on line %d of here-doc doesn't match delimiter",
10358 /* avoid sv_setsv() as we dont wan't to COW here */
10359 sv_setpvn(tmpstr,SvPVX(newstr),SvCUR(newstr));
10361 SvREFCNT_dec_NN(newstr);
10363 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10364 SvPV_shrink_to_cur(tmpstr);
10367 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
10370 PL_lex_stuff = tmpstr;
10371 pl_yylval.ival = op_type;
10375 SvREFCNT_dec(tmpstr);
10376 CopLINE_set(PL_curcop, origline);
10377 missingterm(PL_tokenbuf + 1, sizeof(PL_tokenbuf) - 1);
10380 /* scan_inputsymbol
10381 takes: position of first '<' in input buffer
10382 returns: position of first char following the matching '>' in
10384 side-effects: pl_yylval and lex_op are set.
10389 <<>> read from ARGV without magic open
10390 <FH> read from filehandle
10391 <pkg::FH> read from package qualified filehandle
10392 <pkg'FH> read from package qualified filehandle
10393 <$fh> read from filehandle in $fh
10394 <*.h> filename glob
10399 S_scan_inputsymbol(pTHX_ char *start)
10401 char *s = start; /* current position in buffer */
10404 bool nomagicopen = FALSE;
10405 char *d = PL_tokenbuf; /* start of temp holding space */
10406 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10408 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10410 end = (char *) memchr(s, '\n', PL_bufend - s);
10413 if (s[1] == '<' && s[2] == '>' && s[3] == '>') {
10414 nomagicopen = TRUE;
10420 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10422 /* die if we didn't have space for the contents of the <>,
10423 or if it didn't end, or if we see a newline
10426 if (len >= (I32)sizeof PL_tokenbuf)
10427 Perl_croak(aTHX_ "Excessively long <> operator");
10429 Perl_croak(aTHX_ "Unterminated <> operator");
10434 Remember, only scalar variables are interpreted as filehandles by
10435 this code. Anything more complex (e.g., <$fh{$num}>) will be
10436 treated as a glob() call.
10437 This code makes use of the fact that except for the $ at the front,
10438 a scalar variable and a filehandle look the same.
10440 if (*d == '$' && d[1]) d++;
10442 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
10443 while (isWORDCHAR_lazy_if_safe(d, e, UTF) || *d == '\'' || *d == ':') {
10444 d += UTF ? UTF8SKIP(d) : 1;
10447 /* If we've tried to read what we allow filehandles to look like, and
10448 there's still text left, then it must be a glob() and not a getline.
10449 Use scan_str to pull out the stuff between the <> and treat it
10450 as nothing more than a string.
10453 if (d - PL_tokenbuf != len) {
10454 pl_yylval.ival = OP_GLOB;
10455 s = scan_str(start,FALSE,FALSE,FALSE,NULL);
10457 Perl_croak(aTHX_ "Glob not terminated");
10461 bool readline_overriden = FALSE;
10463 /* we're in a filehandle read situation */
10466 /* turn <> into <ARGV> */
10468 Copy("ARGV",d,5,char);
10470 /* Check whether readline() is overriden */
10471 if ((gv_readline = gv_override("readline",8)))
10472 readline_overriden = TRUE;
10474 /* if <$fh>, create the ops to turn the variable into a
10478 /* try to find it in the pad for this block, otherwise find
10479 add symbol table ops
10481 const PADOFFSET tmp = pad_findmy_pvn(d, len, 0);
10482 if (tmp != NOT_IN_PAD) {
10483 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10484 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10485 HEK * const stashname = HvNAME_HEK(stash);
10486 SV * const sym = sv_2mortal(newSVhek(stashname));
10487 sv_catpvs(sym, "::");
10488 sv_catpv(sym, d+1);
10493 OP * const o = newOP(OP_PADSV, 0);
10495 PL_lex_op = readline_overriden
10496 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10497 op_append_elem(OP_LIST, o,
10498 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10499 : newUNOP(OP_READLINE, 0, o);
10507 GV_ADDMULTI | ( UTF ? SVf_UTF8 : 0 ),
10509 PL_lex_op = readline_overriden
10510 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10511 op_append_elem(OP_LIST,
10512 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10513 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10514 : newUNOP(OP_READLINE, 0,
10515 newUNOP(OP_RV2SV, 0,
10516 newGVOP(OP_GV, 0, gv)));
10518 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10519 pl_yylval.ival = OP_NULL;
10522 /* If it's none of the above, it must be a literal filehandle
10523 (<Foo::BAR> or <FOO>) so build a simple readline OP */
10525 GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
10526 PL_lex_op = readline_overriden
10527 ? newUNOP(OP_ENTERSUB, OPf_STACKED,
10528 op_append_elem(OP_LIST,
10529 newGVOP(OP_GV, 0, gv),
10530 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10531 : newUNOP(OP_READLINE, nomagicopen ? OPf_SPECIAL : 0, newGVOP(OP_GV, 0, gv));
10532 pl_yylval.ival = OP_NULL;
10542 start position in buffer
10543 keep_bracketed_quoted preserve \ quoting of embedded delimiters, but
10544 only if they are of the open/close form
10545 keep_delims preserve the delimiters around the string
10546 re_reparse compiling a run-time /(?{})/:
10547 collapse // to /, and skip encoding src
10548 delimp if non-null, this is set to the position of
10549 the closing delimiter, or just after it if
10550 the closing and opening delimiters differ
10551 (i.e., the opening delimiter of a substitu-
10553 returns: position to continue reading from buffer
10554 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10555 updates the read buffer.
10557 This subroutine pulls a string out of the input. It is called for:
10558 q single quotes q(literal text)
10559 ' single quotes 'literal text'
10560 qq double quotes qq(interpolate $here please)
10561 " double quotes "interpolate $here please"
10562 qx backticks qx(/bin/ls -l)
10563 ` backticks `/bin/ls -l`
10564 qw quote words @EXPORT_OK = qw( func() $spam )
10565 m// regexp match m/this/
10566 s/// regexp substitute s/this/that/
10567 tr/// string transliterate tr/this/that/
10568 y/// string transliterate y/this/that/
10569 ($*@) sub prototypes sub foo ($)
10570 (stuff) sub attr parameters sub foo : attr(stuff)
10571 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
10573 In most of these cases (all but <>, patterns and transliterate)
10574 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10575 calls scan_str(). s/// makes yylex() call scan_subst() which calls
10576 scan_str(). tr/// and y/// make yylex() call scan_trans() which
10579 It skips whitespace before the string starts, and treats the first
10580 character as the delimiter. If the delimiter is one of ([{< then
10581 the corresponding "close" character )]}> is used as the closing
10582 delimiter. It allows quoting of delimiters, and if the string has
10583 balanced delimiters ([{<>}]) it allows nesting.
10585 On success, the SV with the resulting string is put into lex_stuff or,
10586 if that is already non-NULL, into lex_repl. The second case occurs only
10587 when parsing the RHS of the special constructs s/// and tr/// (y///).
10588 For convenience, the terminating delimiter character is stuffed into
10593 S_scan_str(pTHX_ char *start, int keep_bracketed_quoted, int keep_delims, int re_reparse,
10597 SV *sv; /* scalar value: string */
10598 const char *tmps; /* temp string, used for delimiter matching */
10599 char *s = start; /* current position in the buffer */
10600 char term; /* terminating character */
10601 char *to; /* current position in the sv's data */
10602 I32 brackets = 1; /* bracket nesting level */
10603 bool has_utf8 = FALSE; /* is there any utf8 content? */
10604 IV termcode; /* terminating char. code */
10605 U8 termstr[UTF8_MAXBYTES+1]; /* terminating string */
10606 STRLEN termlen; /* length of terminating string */
10609 /* The delimiters that have a mirror-image closing one */
10610 const char * opening_delims = "([{<";
10611 const char * closing_delims = ")]}>";
10613 /* The only non-UTF character that isn't a stand alone grapheme is
10614 * white-space, hence can't be a delimiter. */
10615 const char * non_grapheme_msg = "Use of unassigned code point or"
10616 " non-standalone grapheme for a delimiter"
10618 PERL_ARGS_ASSERT_SCAN_STR;
10620 /* skip space before the delimiter */
10625 /* mark where we are, in case we need to report errors */
10628 /* after skipping whitespace, the next character is the terminator */
10630 if (!UTF || UTF8_IS_INVARIANT(term)) {
10631 termcode = termstr[0] = term;
10635 termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10636 if (UTF && UNLIKELY(! _is_grapheme((U8 *) start,
10641 yyerror(non_grapheme_msg);
10644 Copy(s, termstr, termlen, U8);
10647 /* mark where we are */
10648 PL_multi_start = CopLINE(PL_curcop);
10649 PL_multi_open = termcode;
10650 herelines = PL_parser->herelines;
10652 /* If the delimiter has a mirror-image closing one, get it */
10653 if (term && (tmps = strchr(opening_delims, term))) {
10654 termcode = termstr[0] = term = closing_delims[tmps - opening_delims];
10657 PL_multi_close = termcode;
10659 if (PL_multi_open == PL_multi_close) {
10660 keep_bracketed_quoted = FALSE;
10663 /* create a new SV to hold the contents. 79 is the SV's initial length.
10664 What a random number. */
10665 sv = newSV_type(SVt_PVIV);
10667 SvIV_set(sv, termcode);
10668 (void)SvPOK_only(sv); /* validate pointer */
10670 /* move past delimiter and try to read a complete string */
10672 sv_catpvn(sv, s, termlen);
10675 /* extend sv if need be */
10676 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10677 /* set 'to' to the next character in the sv's string */
10678 to = SvPVX(sv)+SvCUR(sv);
10680 /* if open delimiter is the close delimiter read unbridle */
10681 if (PL_multi_open == PL_multi_close) {
10682 for (; s < PL_bufend; s++,to++) {
10683 /* embedded newlines increment the current line number */
10684 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10685 COPLINE_INC_WITH_HERELINES;
10686 /* handle quoted delimiters */
10687 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10688 if (!keep_bracketed_quoted
10690 || (re_reparse && s[1] == '\\'))
10693 else /* any other quotes are simply copied straight through */
10696 /* terminate when run out of buffer (the for() condition), or
10697 have found the terminator */
10698 else if (*s == term) { /* First byte of terminator matches */
10699 if (termlen == 1) /* If is the only byte, are done */
10702 /* If the remainder of the terminator matches, also are
10703 * done, after checking that is a separate grapheme */
10704 if ( s + termlen <= PL_bufend
10705 && memEQ(s + 1, (char*)termstr + 1, termlen - 1))
10708 && UNLIKELY(! _is_grapheme((U8 *) start,
10713 yyerror(non_grapheme_msg);
10718 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) {
10726 /* if the terminator isn't the same as the start character (e.g.,
10727 matched brackets), we have to allow more in the quoting, and
10728 be prepared for nested brackets.
10731 /* read until we run out of string, or we find the terminator */
10732 for (; s < PL_bufend; s++,to++) {
10733 /* embedded newlines increment the line count */
10734 if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
10735 COPLINE_INC_WITH_HERELINES;
10736 /* backslashes can escape the open or closing characters */
10737 if (*s == '\\' && s+1 < PL_bufend) {
10738 if (!keep_bracketed_quoted
10739 && ( ((UV)s[1] == PL_multi_open)
10740 || ((UV)s[1] == PL_multi_close) ))
10747 /* allow nested opens and closes */
10748 else if ((UV)*s == PL_multi_close && --brackets <= 0)
10750 else if ((UV)*s == PL_multi_open)
10752 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10757 /* terminate the copied string and update the sv's end-of-string */
10759 SvCUR_set(sv, to - SvPVX_const(sv));
10762 * this next chunk reads more into the buffer if we're not done yet
10766 break; /* handle case where we are done yet :-) */
10768 #ifndef PERL_STRICT_CR
10769 if (to - SvPVX_const(sv) >= 2) {
10770 if ( (to[-2] == '\r' && to[-1] == '\n')
10771 || (to[-2] == '\n' && to[-1] == '\r'))
10775 SvCUR_set(sv, to - SvPVX_const(sv));
10777 else if (to[-1] == '\r')
10780 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10784 /* if we're out of file, or a read fails, bail and reset the current
10785 line marker so we can report where the unterminated string began
10787 COPLINE_INC_WITH_HERELINES;
10788 PL_bufptr = PL_bufend;
10789 if (!lex_next_chunk(0)) {
10791 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10794 s = start = PL_bufptr;
10797 /* at this point, we have successfully read the delimited string */
10800 sv_catpvn(sv, s, termlen);
10806 PL_multi_end = CopLINE(PL_curcop);
10807 CopLINE_set(PL_curcop, PL_multi_start);
10808 PL_parser->herelines = herelines;
10810 /* if we allocated too much space, give some back */
10811 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10812 SvLEN_set(sv, SvCUR(sv) + 1);
10813 SvPV_renew(sv, SvLEN(sv));
10816 /* decide whether this is the first or second quoted string we've read
10821 PL_parser->lex_sub_repl = sv;
10824 if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
10830 takes: pointer to position in buffer
10831 returns: pointer to new position in buffer
10832 side-effects: builds ops for the constant in pl_yylval.op
10834 Read a number in any of the formats that Perl accepts:
10836 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10837 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10838 0b[01](_?[01])* binary integers
10839 0[0-7](_?[0-7])* octal integers
10840 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* hexadecimal integers
10841 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*(?:\.\d*)?p[+-]?[0-9]+ hexadecimal floats
10843 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10846 If it reads a number without a decimal point or an exponent, it will
10847 try converting the number to an integer and see if it can do so
10848 without loss of precision.
10852 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10854 const char *s = start; /* current position in buffer */
10855 char *d; /* destination in temp buffer */
10856 char *e; /* end of temp buffer */
10857 NV nv; /* number read, as a double */
10858 SV *sv = NULL; /* place to put the converted number */
10859 bool floatit; /* boolean: int or float? */
10860 const char *lastub = NULL; /* position of last underbar */
10861 static const char* const number_too_long = "Number too long";
10862 bool warned_about_underscore = 0;
10863 #define WARN_ABOUT_UNDERSCORE() \
10865 if (!warned_about_underscore) { \
10866 warned_about_underscore = 1; \
10867 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), \
10868 "Misplaced _ in number"); \
10871 /* Hexadecimal floating point.
10873 * In many places (where we have quads and NV is IEEE 754 double)
10874 * we can fit the mantissa bits of a NV into an unsigned quad.
10875 * (Note that UVs might not be quads even when we have quads.)
10876 * This will not work everywhere, though (either no quads, or
10877 * using long doubles), in which case we have to resort to NV,
10878 * which will probably mean horrible loss of precision due to
10879 * multiple fp operations. */
10880 bool hexfp = FALSE;
10881 int total_bits = 0;
10882 int significant_bits = 0;
10883 #if NVSIZE == 8 && defined(HAS_QUAD) && defined(Uquad_t)
10884 # define HEXFP_UQUAD
10885 Uquad_t hexfp_uquad = 0;
10886 int hexfp_frac_bits = 0;
10891 NV hexfp_mult = 1.0;
10892 UV high_non_zero = 0; /* highest digit */
10893 int non_zero_integer_digits = 0;
10895 PERL_ARGS_ASSERT_SCAN_NUM;
10897 /* We use the first character to decide what type of number this is */
10901 Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10903 /* if it starts with a 0, it could be an octal number, a decimal in
10904 0.13 disguise, or a hexadecimal number, or a binary number. */
10908 u holds the "number so far"
10909 shift the power of 2 of the base
10910 (hex == 4, octal == 3, binary == 1)
10911 overflowed was the number more than we can hold?
10913 Shift is used when we add a digit. It also serves as an "are
10914 we in octal/hex/binary?" indicator to disallow hex characters
10915 when in octal mode.
10920 bool overflowed = FALSE;
10921 bool just_zero = TRUE; /* just plain 0 or binary number? */
10922 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10923 static const char* const bases[5] =
10924 { "", "binary", "", "octal", "hexadecimal" };
10925 static const char* const Bases[5] =
10926 { "", "Binary", "", "Octal", "Hexadecimal" };
10927 static const char* const maxima[5] =
10929 "0b11111111111111111111111111111111",
10933 const char *base, *Base, *max;
10935 /* check for hex */
10936 if (isALPHA_FOLD_EQ(s[1], 'x')) {
10940 } else if (isALPHA_FOLD_EQ(s[1], 'b')) {
10945 /* check for a decimal in disguise */
10946 else if (s[1] == '.' || isALPHA_FOLD_EQ(s[1], 'e'))
10948 /* so it must be octal */
10955 WARN_ABOUT_UNDERSCORE();
10959 base = bases[shift];
10960 Base = Bases[shift];
10961 max = maxima[shift];
10963 /* read the rest of the number */
10965 /* x is used in the overflow test,
10966 b is the digit we're adding on. */
10971 /* if we don't mention it, we're done */
10975 /* _ are ignored -- but warned about if consecutive */
10977 if (lastub && s == lastub + 1)
10978 WARN_ABOUT_UNDERSCORE();
10982 /* 8 and 9 are not octal */
10983 case '8': case '9':
10985 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10989 case '2': case '3': case '4':
10990 case '5': case '6': case '7':
10992 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10995 case '0': case '1':
10996 b = *s++ & 15; /* ASCII digit -> value of digit */
11000 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11001 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11002 /* make sure they said 0x */
11005 b = (*s++ & 7) + 9;
11007 /* Prepare to put the digit we have onto the end
11008 of the number so far. We check for overflows.
11014 assert(shift >= 0);
11015 x = u << shift; /* make room for the digit */
11017 total_bits += shift;
11019 if ((x >> shift) != u
11020 && !(PL_hints & HINT_NEW_BINARY)) {
11023 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11024 "Integer overflow in %s number",
11027 u = x | b; /* add the digit to the end */
11030 n *= nvshift[shift];
11031 /* If an NV has not enough bits in its
11032 * mantissa to represent an UV this summing of
11033 * small low-order numbers is a waste of time
11034 * (because the NV cannot preserve the
11035 * low-order bits anyway): we could just
11036 * remember when did we overflow and in the
11037 * end just multiply n by the right
11042 if (high_non_zero == 0 && b > 0)
11046 non_zero_integer_digits++;
11048 /* this could be hexfp, but peek ahead
11049 * to avoid matching ".." */
11050 if (UNLIKELY(HEXFP_PEEK(s))) {
11058 /* if we get here, we had success: make a scalar value from
11063 /* final misplaced underbar check */
11065 WARN_ABOUT_UNDERSCORE();
11067 if (UNLIKELY(HEXFP_PEEK(s))) {
11068 /* Do sloppy (on the underbars) but quick detection
11069 * (and value construction) for hexfp, the decimal
11070 * detection will shortly be more thorough with the
11071 * underbar checks. */
11073 significant_bits = non_zero_integer_digits * shift;
11076 #else /* HEXFP_NV */
11079 /* Ignore the leading zero bits of
11080 * the high (first) non-zero digit. */
11081 if (high_non_zero) {
11082 if (high_non_zero < 0x8)
11083 significant_bits--;
11084 if (high_non_zero < 0x4)
11085 significant_bits--;
11086 if (high_non_zero < 0x2)
11087 significant_bits--;
11094 bool accumulate = TRUE;
11096 int lim = 1 << shift;
11097 for (h++; ((isXDIGIT(*h) && (b = XDIGIT_VALUE(*h)) < lim) ||
11099 if (isXDIGIT(*h)) {
11100 significant_bits += shift;
11103 if (significant_bits < NV_MANT_DIG) {
11104 /* We are in the long "run" of xdigits,
11105 * accumulate the full four bits. */
11106 assert(shift >= 0);
11107 hexfp_uquad <<= shift;
11109 hexfp_frac_bits += shift;
11110 } else if (significant_bits - shift < NV_MANT_DIG) {
11111 /* We are at a hexdigit either at,
11112 * or straddling, the edge of mantissa.
11113 * We will try grabbing as many as
11114 * possible bits. */
11116 significant_bits - NV_MANT_DIG;
11120 hexfp_uquad <<= tail;
11121 assert((shift - tail) >= 0);
11122 hexfp_uquad |= b >> (shift - tail);
11123 hexfp_frac_bits += tail;
11125 /* Ignore the trailing zero bits
11126 * of the last non-zero xdigit.
11128 * The assumption here is that if
11129 * one has input of e.g. the xdigit
11130 * eight (0x8), there is only one
11131 * bit being input, not the full
11132 * four bits. Conversely, if one
11133 * specifies a zero xdigit, the
11134 * assumption is that one really
11135 * wants all those bits to be zero. */
11137 if ((b & 0x1) == 0x0) {
11138 significant_bits--;
11139 if ((b & 0x2) == 0x0) {
11140 significant_bits--;
11141 if ((b & 0x4) == 0x0) {
11142 significant_bits--;
11148 accumulate = FALSE;
11151 /* Keep skipping the xdigits, and
11152 * accumulating the significant bits,
11153 * but do not shift the uquad
11154 * (which would catastrophically drop
11155 * high-order bits) or accumulate the
11156 * xdigits anymore. */
11158 #else /* HEXFP_NV */
11160 nv_mult /= nvshift[shift];
11162 hexfp_nv += b * nv_mult;
11164 accumulate = FALSE;
11168 if (significant_bits >= NV_MANT_DIG)
11169 accumulate = FALSE;
11173 if ((total_bits > 0 || significant_bits > 0) &&
11174 isALPHA_FOLD_EQ(*h, 'p')) {
11175 bool negexp = FALSE;
11179 else if (*h == '-') {
11185 while (isDIGIT(*h) || *h == '_') {
11188 hexfp_exp += *h - '0';
11191 && -hexfp_exp < NV_MIN_EXP - 1) {
11192 /* NOTE: this means that the exponent
11193 * underflow warning happens for
11194 * the IEEE 754 subnormals (denormals),
11195 * because DBL_MIN_EXP etc are the lowest
11196 * possible binary (or, rather, DBL_RADIX-base)
11197 * exponent for normals, not subnormals.
11199 * This may or may not be a good thing. */
11200 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11201 "Hexadecimal float: exponent underflow");
11207 && hexfp_exp > NV_MAX_EXP - 1) {
11208 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11209 "Hexadecimal float: exponent overflow");
11217 hexfp_exp = -hexfp_exp;
11219 hexfp_exp -= hexfp_frac_bits;
11221 hexfp_mult = Perl_pow(2.0, hexfp_exp);
11229 if (n > 4294967295.0)
11230 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11231 "%s number > %s non-portable",
11237 if (u > 0xffffffff)
11238 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11239 "%s number > %s non-portable",
11244 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11245 sv = new_constant(start, s - start, "integer",
11246 sv, NULL, NULL, 0);
11247 else if (PL_hints & HINT_NEW_BINARY)
11248 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11253 handle decimal numbers.
11254 we're also sent here when we read a 0 as the first digit
11256 case '1': case '2': case '3': case '4': case '5':
11257 case '6': case '7': case '8': case '9': case '.':
11260 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11269 /* read next group of digits and _ and copy into d */
11272 || UNLIKELY(hexfp && isXDIGIT(*s)))
11274 /* skip underscores, checking for misplaced ones
11278 if (lastub && s == lastub + 1)
11279 WARN_ABOUT_UNDERSCORE();
11283 /* check for end of fixed-length buffer */
11285 Perl_croak(aTHX_ "%s", number_too_long);
11286 /* if we're ok, copy the character */
11291 /* final misplaced underbar check */
11292 if (lastub && s == lastub + 1)
11293 WARN_ABOUT_UNDERSCORE();
11295 /* read a decimal portion if there is one. avoid
11296 3..5 being interpreted as the number 3. followed
11299 if (*s == '.' && s[1] != '.') {
11304 WARN_ABOUT_UNDERSCORE();
11308 /* copy, ignoring underbars, until we run out of digits.
11312 || UNLIKELY(hexfp && isXDIGIT(*s));
11315 /* fixed length buffer check */
11317 Perl_croak(aTHX_ "%s", number_too_long);
11319 if (lastub && s == lastub + 1)
11320 WARN_ABOUT_UNDERSCORE();
11326 /* fractional part ending in underbar? */
11328 WARN_ABOUT_UNDERSCORE();
11329 if (*s == '.' && isDIGIT(s[1])) {
11330 /* oops, it's really a v-string, but without the "v" */
11336 /* read exponent part, if present */
11337 if ((isALPHA_FOLD_EQ(*s, 'e')
11338 || UNLIKELY(hexfp && isALPHA_FOLD_EQ(*s, 'p')))
11339 && strchr("+-0123456789_", s[1]))
11341 int exp_digits = 0;
11342 const char *save_s = s;
11345 /* regardless of whether user said 3E5 or 3e5, use lower 'e',
11346 ditto for p (hexfloats) */
11347 if ((isALPHA_FOLD_EQ(*s, 'e'))) {
11348 /* At least some Mach atof()s don't grok 'E' */
11351 else if (UNLIKELY(hexfp && (isALPHA_FOLD_EQ(*s, 'p')))) {
11358 /* stray preinitial _ */
11360 WARN_ABOUT_UNDERSCORE();
11364 /* allow positive or negative exponent */
11365 if (*s == '+' || *s == '-')
11368 /* stray initial _ */
11370 WARN_ABOUT_UNDERSCORE();
11374 /* read digits of exponent */
11375 while (isDIGIT(*s) || *s == '_') {
11379 Perl_croak(aTHX_ "%s", number_too_long);
11383 if (((lastub && s == lastub + 1)
11384 || (!isDIGIT(s[1]) && s[1] != '_')))
11385 WARN_ABOUT_UNDERSCORE();
11391 /* no exponent digits, the [eEpP] could be for something else,
11392 * though in practice we don't get here for p since that's preparsed
11393 * earlier, and results in only the 0xX being consumed, so behave similarly
11394 * for decimal floats and consume only the D.DD, leaving the [eE] to the
11407 We try to do an integer conversion first if no characters
11408 indicating "float" have been found.
11413 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11415 if (flags == IS_NUMBER_IN_UV) {
11417 sv = newSViv(uv); /* Prefer IVs over UVs. */
11420 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11421 if (uv <= (UV) IV_MIN)
11422 sv = newSViv(-(IV)uv);
11429 /* terminate the string */
11431 if (UNLIKELY(hexfp)) {
11432 # ifdef NV_MANT_DIG
11433 if (significant_bits > NV_MANT_DIG)
11434 Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
11435 "Hexadecimal float: mantissa overflow");
11438 nv = hexfp_uquad * hexfp_mult;
11439 #else /* HEXFP_NV */
11440 nv = hexfp_nv * hexfp_mult;
11443 nv = Atof(PL_tokenbuf);
11449 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11450 const char *const key = floatit ? "float" : "integer";
11451 const STRLEN keylen = floatit ? 5 : 7;
11452 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11453 key, keylen, sv, NULL, NULL, 0);
11457 /* if it starts with a v, it could be a v-string */
11460 sv = newSV(5); /* preallocate storage space */
11461 ENTER_with_name("scan_vstring");
11463 s = scan_vstring(s, PL_bufend, sv);
11464 SvREFCNT_inc_simple_void_NN(sv);
11465 LEAVE_with_name("scan_vstring");
11469 /* make the op for the constant and return */
11472 lvalp->opval = newSVOP(OP_CONST, 0, sv);
11474 lvalp->opval = NULL;
11480 S_scan_formline(pTHX_ char *s)
11482 SV * const stuff = newSVpvs("");
11483 bool needargs = FALSE;
11484 bool eofmt = FALSE;
11486 PERL_ARGS_ASSERT_SCAN_FORMLINE;
11488 while (!needargs) {
11492 #ifdef PERL_STRICT_CR
11493 while (SPACE_OR_TAB(*t))
11496 while (SPACE_OR_TAB(*t) || *t == '\r')
11499 if (*t == '\n' || t == PL_bufend) {
11504 eol = (char *) memchr(s,'\n',PL_bufend-s);
11509 for (t = s; t < eol; t++) {
11510 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
11512 goto enough; /* ~~ must be first line in formline */
11514 if (*t == '@' || *t == '^')
11518 sv_catpvn(stuff, s, eol-s);
11519 #ifndef PERL_STRICT_CR
11520 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
11521 char *end = SvPVX(stuff) + SvCUR(stuff);
11524 SvCUR_set(stuff, SvCUR(stuff) - 1);
11532 if ((PL_rsfp || PL_parser->filtered)
11533 && PL_parser->form_lex_state == LEX_NORMAL) {
11535 PL_bufptr = PL_bufend;
11536 COPLINE_INC_WITH_HERELINES;
11537 got_some = lex_next_chunk(0);
11538 CopLINE_dec(PL_curcop);
11543 incline(s, PL_bufend);
11546 if (!SvCUR(stuff) || needargs)
11547 PL_lex_state = PL_parser->form_lex_state;
11548 if (SvCUR(stuff)) {
11549 PL_expect = XSTATE;
11551 const char *s2 = s;
11552 while (isSPACE(*s2) && *s2 != '\n')
11555 PL_expect = XTERMBLOCK;
11556 NEXTVAL_NEXTTOKE.ival = 0;
11559 NEXTVAL_NEXTTOKE.ival = 0;
11560 force_next(FORMLBRACK);
11563 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
11566 NEXTVAL_NEXTTOKE.opval = newSVOP(OP_CONST, 0, stuff);
11570 SvREFCNT_dec(stuff);
11572 PL_lex_formbrack = 0;
11578 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11580 const I32 oldsavestack_ix = PL_savestack_ix;
11581 CV* const outsidecv = PL_compcv;
11583 SAVEI32(PL_subline);
11584 save_item(PL_subname);
11585 SAVESPTR(PL_compcv);
11587 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11588 CvFLAGS(PL_compcv) |= flags;
11590 PL_subline = CopLINE(PL_curcop);
11591 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11592 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11593 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11594 if (outsidecv && CvPADLIST(outsidecv))
11595 CvPADLIST(PL_compcv)->xpadl_outid = CvPADLIST(outsidecv)->xpadl_id;
11597 return oldsavestack_ix;
11601 /* Do extra initialisation of a CV (typically one just created by
11602 * start_subparse()) if that CV is for a named sub
11606 Perl_init_named_cv(pTHX_ CV *cv, OP *nameop)
11608 PERL_ARGS_ASSERT_INIT_NAMED_CV;
11610 if (nameop->op_type == OP_CONST) {
11611 const char *const name = SvPV_nolen_const(((SVOP*)nameop)->op_sv);
11612 if ( strEQ(name, "BEGIN")
11613 || strEQ(name, "END")
11614 || strEQ(name, "INIT")
11615 || strEQ(name, "CHECK")
11616 || strEQ(name, "UNITCHECK")
11621 /* State subs inside anonymous subs need to be
11622 clonable themselves. */
11623 if ( CvANON(CvOUTSIDE(cv))
11624 || CvCLONE(CvOUTSIDE(cv))
11625 || !PadnameIsSTATE(PadlistNAMESARRAY(CvPADLIST(
11627 ))[nameop->op_targ])
11634 S_yywarn(pTHX_ const char *const s, U32 flags)
11636 PERL_ARGS_ASSERT_YYWARN;
11638 PL_in_eval |= EVAL_WARNONLY;
11639 yyerror_pv(s, flags);
11644 Perl_abort_execution(pTHX_ const char * const msg, const char * const name)
11646 PERL_ARGS_ASSERT_ABORT_EXECUTION;
11649 Perl_croak(aTHX_ "%s%s had compilation errors.\n", msg, name);
11652 "%sExecution of %s aborted due to compilation errors.\n", msg, name);
11654 NOT_REACHED; /* NOTREACHED */
11660 /* Called, after at least one error has been found, to abort the parse now,
11661 * instead of trying to forge ahead */
11663 yyerror_pvn(NULL, 0, 0);
11667 Perl_yyerror(pTHX_ const char *const s)
11669 PERL_ARGS_ASSERT_YYERROR;
11670 return yyerror_pvn(s, strlen(s), 0);
11674 Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11676 PERL_ARGS_ASSERT_YYERROR_PV;
11677 return yyerror_pvn(s, strlen(s), flags);
11681 Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11683 const char *context = NULL;
11686 SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11687 int yychar = PL_parser->yychar;
11689 /* Output error message 's' with length 'len'. 'flags' are SV flags that
11690 * apply. If the number of errors found is large enough, it abandons
11691 * parsing. If 's' is NULL, there is no message, and it abandons
11692 * processing unconditionally */
11695 if (!yychar || (yychar == ';' && !PL_rsfp))
11696 sv_catpvs(where_sv, "at EOF");
11697 else if ( PL_oldoldbufptr
11698 && PL_bufptr > PL_oldoldbufptr
11699 && PL_bufptr - PL_oldoldbufptr < 200
11700 && PL_oldoldbufptr != PL_oldbufptr
11701 && PL_oldbufptr != PL_bufptr)
11705 The code below is removed for NetWare because it
11706 abends/crashes on NetWare when the script has error such as
11707 not having the closing quotes like:
11708 if ($var eq "value)
11709 Checking of white spaces is anyway done in NetWare code.
11712 while (isSPACE(*PL_oldoldbufptr))
11715 context = PL_oldoldbufptr;
11716 contlen = PL_bufptr - PL_oldoldbufptr;
11718 else if ( PL_oldbufptr
11719 && PL_bufptr > PL_oldbufptr
11720 && PL_bufptr - PL_oldbufptr < 200
11721 && PL_oldbufptr != PL_bufptr) {
11724 The code below is removed for NetWare because it
11725 abends/crashes on NetWare when the script has error such as
11726 not having the closing quotes like:
11727 if ($var eq "value)
11728 Checking of white spaces is anyway done in NetWare code.
11731 while (isSPACE(*PL_oldbufptr))
11734 context = PL_oldbufptr;
11735 contlen = PL_bufptr - PL_oldbufptr;
11737 else if (yychar > 255)
11738 sv_catpvs(where_sv, "next token ???");
11739 else if (yychar == YYEMPTY) {
11740 if (PL_lex_state == LEX_NORMAL)
11741 sv_catpvs(where_sv, "at end of line");
11742 else if (PL_lex_inpat)
11743 sv_catpvs(where_sv, "within pattern");
11745 sv_catpvs(where_sv, "within string");
11748 sv_catpvs(where_sv, "next char ");
11750 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
11751 else if (isPRINT_LC(yychar)) {
11752 const char string = yychar;
11753 sv_catpvn(where_sv, &string, 1);
11756 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11758 msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11759 Perl_sv_catpvf(aTHX_ msg, " at %s line %" IVdf ", ",
11760 OutCopFILE(PL_curcop),
11761 (IV)(PL_parser->preambling == NOLINE
11762 ? CopLINE(PL_curcop)
11763 : PL_parser->preambling));
11765 Perl_sv_catpvf(aTHX_ msg, "near \"%" UTF8f "\"\n",
11766 UTF8fARG(UTF, contlen, context));
11768 Perl_sv_catpvf(aTHX_ msg, "%" SVf "\n", SVfARG(where_sv));
11769 if ( PL_multi_start < PL_multi_end
11770 && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1)
11772 Perl_sv_catpvf(aTHX_ msg,
11773 " (Might be a runaway multi-line %c%c string starting on"
11774 " line %" IVdf ")\n",
11775 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11778 if (PL_in_eval & EVAL_WARNONLY) {
11779 PL_in_eval &= ~EVAL_WARNONLY;
11780 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%" SVf, SVfARG(msg));
11786 if (s == NULL || PL_error_count >= 10) {
11787 const char * msg = "";
11788 const char * const name = OutCopFILE(PL_curcop);
11791 SV * errsv = ERRSV;
11792 if (SvCUR(errsv)) {
11793 msg = Perl_form(aTHX_ "%" SVf, SVfARG(errsv));
11798 abort_execution(msg, name);
11801 Perl_croak(aTHX_ "%s%s has too many errors.\n", msg, name);
11805 PL_in_my_stash = NULL;
11810 S_swallow_bom(pTHX_ U8 *s)
11812 const STRLEN slen = SvCUR(PL_linestr);
11814 PERL_ARGS_ASSERT_SWALLOW_BOM;
11818 if (s[1] == 0xFE) {
11819 /* UTF-16 little-endian? (or UTF-32LE?) */
11820 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
11821 /* diag_listed_as: Unsupported script encoding %s */
11822 Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11823 #ifndef PERL_NO_UTF16_FILTER
11825 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11828 if (PL_bufend > (char*)s) {
11829 s = add_utf16_textfilter(s, TRUE);
11832 /* diag_listed_as: Unsupported script encoding %s */
11833 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11838 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11839 #ifndef PERL_NO_UTF16_FILTER
11841 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11844 if (PL_bufend > (char *)s) {
11845 s = add_utf16_textfilter(s, FALSE);
11848 /* diag_listed_as: Unsupported script encoding %s */
11849 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11853 case BOM_UTF8_FIRST_BYTE: {
11854 if (memBEGINs(s+1, slen - 1, BOM_UTF8_TAIL)) {
11856 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11858 s += sizeof(BOM_UTF8) - 1; /* UTF-8 */
11865 if (s[2] == 0xFE && s[3] == 0xFF) {
11866 /* UTF-32 big-endian */
11867 /* diag_listed_as: Unsupported script encoding %s */
11868 Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11871 else if (s[2] == 0 && s[3] != 0) {
11874 * are a good indicator of UTF-16BE. */
11875 #ifndef PERL_NO_UTF16_FILTER
11877 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11879 s = add_utf16_textfilter(s, FALSE);
11881 /* diag_listed_as: Unsupported script encoding %s */
11882 Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11889 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
11892 * are a good indicator of UTF-16LE. */
11893 #ifndef PERL_NO_UTF16_FILTER
11895 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11897 s = add_utf16_textfilter(s, TRUE);
11899 /* diag_listed_as: Unsupported script encoding %s */
11900 Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11908 #ifndef PERL_NO_UTF16_FILTER
11910 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11912 SV *const filter = FILTER_DATA(idx);
11913 /* We re-use this each time round, throwing the contents away before we
11915 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11916 SV *const utf8_buffer = filter;
11917 IV status = IoPAGE(filter);
11918 const bool reverse = cBOOL(IoLINES(filter));
11921 PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11923 /* As we're automatically added, at the lowest level, and hence only called
11924 from this file, we can be sure that we're not called in block mode. Hence
11925 don't bother writing code to deal with block mode. */
11927 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11930 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%" IVdf ")", status);
11932 DEBUG_P(PerlIO_printf(Perl_debug_log,
11933 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
11934 FPTR2DPTR(void *, S_utf16_textfilter),
11935 reverse ? 'l' : 'b', idx, maxlen, status,
11936 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11943 /* First, look in our buffer of existing UTF-8 data: */
11944 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11948 } else if (status == 0) {
11950 IoPAGE(filter) = 0;
11951 nl = SvEND(utf8_buffer);
11954 STRLEN got = nl - SvPVX(utf8_buffer);
11955 /* Did we have anything to append? */
11957 sv_catpvn(sv, SvPVX(utf8_buffer), got);
11958 /* Everything else in this code works just fine if SVp_POK isn't
11959 set. This, however, needs it, and we need it to work, else
11960 we loop infinitely because the buffer is never consumed. */
11961 sv_chop(utf8_buffer, nl);
11965 /* OK, not a complete line there, so need to read some more UTF-16.
11966 Read an extra octect if the buffer currently has an odd number. */
11970 if (SvCUR(utf16_buffer) >= 2) {
11971 /* Location of the high octet of the last complete code point.
11972 Gosh, UTF-16 is a pain. All the benefits of variable length,
11973 *coupled* with all the benefits of partial reads and
11975 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11976 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11978 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11982 /* We have the first half of a surrogate. Read more. */
11983 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11986 status = FILTER_READ(idx + 1, utf16_buffer,
11987 160 + (SvCUR(utf16_buffer) & 1));
11988 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%" IVdf " SvCUR(sv)=%" UVuf "\n", status, (UV)SvCUR(utf16_buffer)));
11989 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11992 IoPAGE(filter) = status;
11997 /* 'chars' isn't quite the right name, as code points above 0xFFFF
11998 * require 4 bytes per char */
11999 chars = SvCUR(utf16_buffer) >> 1;
12000 have = SvCUR(utf8_buffer);
12002 /* Assume the worst case size as noted by the functions: twice the
12003 * number of input bytes */
12004 SvGROW(utf8_buffer, have + chars * 4 + 1);
12007 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
12008 (U8*)SvPVX_const(utf8_buffer) + have,
12009 chars * 2, &newlen);
12011 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
12012 (U8*)SvPVX_const(utf8_buffer) + have,
12013 chars * 2, &newlen);
12015 SvCUR_set(utf8_buffer, have + newlen);
12018 /* No need to keep this SV "well-formed" with a '\0' after the end, as
12019 it's private to us, and utf16_to_utf8{,reversed} take a
12020 (pointer,length) pair, rather than a NUL-terminated string. */
12021 if(SvCUR(utf16_buffer) & 1) {
12022 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
12023 SvCUR_set(utf16_buffer, 1);
12025 SvCUR_set(utf16_buffer, 0);
12028 DEBUG_P(PerlIO_printf(Perl_debug_log,
12029 "utf16_textfilter: returns, status=%" IVdf " utf16=%" UVuf " utf8=%" UVuf "\n",
12031 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12032 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
12037 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
12039 SV *filter = filter_add(S_utf16_textfilter, NULL);
12041 PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
12043 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
12045 IoLINES(filter) = reversed;
12046 IoPAGE(filter) = 1; /* Not EOF */
12048 /* Sadly, we have to return a valid pointer, come what may, so we have to
12049 ignore any error return from this. */
12050 SvCUR_set(PL_linestr, 0);
12051 if (FILTER_READ(0, PL_linestr, 0)) {
12052 SvUTF8_on(PL_linestr);
12054 SvUTF8_on(PL_linestr);
12056 PL_bufend = SvEND(PL_linestr);
12057 return (U8*)SvPVX(PL_linestr);
12062 Returns a pointer to the next character after the parsed
12063 vstring, as well as updating the passed in sv.
12065 Function must be called like
12067 sv = sv_2mortal(newSV(5));
12068 s = scan_vstring(s,e,sv);
12070 where s and e are the start and end of the string.
12071 The sv should already be large enough to store the vstring
12072 passed in, for performance reasons.
12074 This function may croak if fatal warnings are enabled in the
12075 calling scope, hence the sv_2mortal in the example (to prevent
12076 a leak). Make sure to do SvREFCNT_inc afterwards if you use
12082 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12084 const char *pos = s;
12085 const char *start = s;
12087 PERL_ARGS_ASSERT_SCAN_VSTRING;
12089 if (*pos == 'v') pos++; /* get past 'v' */
12090 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12092 if ( *pos != '.') {
12093 /* this may not be a v-string if followed by => */
12094 const char *next = pos;
12095 while (next < e && isSPACE(*next))
12097 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12098 /* return string not v-string */
12099 sv_setpvn(sv,(char *)s,pos-s);
12100 return (char *)pos;
12104 if (!isALPHA(*pos)) {
12105 U8 tmpbuf[UTF8_MAXBYTES+1];
12108 s++; /* get past 'v' */
12113 /* this is atoi() that tolerates underscores */
12116 const char *end = pos;
12118 while (--end >= s) {
12120 const UV orev = rev;
12121 rev += (*end - '0') * mult;
12124 /* diag_listed_as: Integer overflow in %s number */
12125 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
12126 "Integer overflow in decimal number");
12130 /* Append native character for the rev point */
12131 tmpend = uvchr_to_utf8(tmpbuf, rev);
12132 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12133 if (!UVCHR_IS_INVARIANT(rev))
12135 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12141 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12145 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12152 Perl_keyword_plugin_standard(pTHX_
12153 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
12155 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
12156 PERL_UNUSED_CONTEXT;
12157 PERL_UNUSED_ARG(keyword_ptr);
12158 PERL_UNUSED_ARG(keyword_len);
12159 PERL_UNUSED_ARG(op_ptr);
12160 return KEYWORD_PLUGIN_DECLINE;
12164 =for apidoc Amx|void|wrap_keyword_plugin|Perl_keyword_plugin_t new_plugin|Perl_keyword_plugin_t *old_plugin_p
12166 Puts a C function into the chain of keyword plugins. This is the
12167 preferred way to manipulate the L</PL_keyword_plugin> variable.
12168 C<new_plugin> is a pointer to the C function that is to be added to the
12169 keyword plugin chain, and C<old_plugin_p> points to the storage location
12170 where a pointer to the next function in the chain will be stored. The
12171 value of C<new_plugin> is written into the L</PL_keyword_plugin> variable,
12172 while the value previously stored there is written to C<*old_plugin_p>.
12174 L</PL_keyword_plugin> is global to an entire process, and a module wishing
12175 to hook keyword parsing may find itself invoked more than once per
12176 process, typically in different threads. To handle that situation, this
12177 function is idempotent. The location C<*old_plugin_p> must initially
12178 (once per process) contain a null pointer. A C variable of static
12179 duration (declared at file scope, typically also marked C<static> to give
12180 it internal linkage) will be implicitly initialised appropriately, if it
12181 does not have an explicit initialiser. This function will only actually
12182 modify the plugin chain if it finds C<*old_plugin_p> to be null. This
12183 function is also thread safe on the small scale. It uses appropriate
12184 locking to avoid race conditions in accessing L</PL_keyword_plugin>.
12186 When this function is called, the function referenced by C<new_plugin>
12187 must be ready to be called, except for C<*old_plugin_p> being unfilled.
12188 In a threading situation, C<new_plugin> may be called immediately, even
12189 before this function has returned. C<*old_plugin_p> will always be
12190 appropriately set before C<new_plugin> is called. If C<new_plugin>
12191 decides not to do anything special with the identifier that it is given
12192 (which is the usual case for most calls to a keyword plugin), it must
12193 chain the plugin function referenced by C<*old_plugin_p>.
12195 Taken all together, XS code to install a keyword plugin should typically
12196 look something like this:
12198 static Perl_keyword_plugin_t next_keyword_plugin;
12199 static OP *my_keyword_plugin(pTHX_
12200 char *keyword_plugin, STRLEN keyword_len, OP **op_ptr)
12202 if (memEQs(keyword_ptr, keyword_len,
12203 "my_new_keyword")) {
12206 return next_keyword_plugin(aTHX_
12207 keyword_ptr, keyword_len, op_ptr);
12211 wrap_keyword_plugin(my_keyword_plugin,
12212 &next_keyword_plugin);
12214 Direct access to L</PL_keyword_plugin> should be avoided.
12220 Perl_wrap_keyword_plugin(pTHX_
12221 Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
12225 PERL_UNUSED_CONTEXT;
12226 PERL_ARGS_ASSERT_WRAP_KEYWORD_PLUGIN;
12227 if (*old_plugin_p) return;
12228 KEYWORD_PLUGIN_MUTEX_LOCK;
12229 if (!*old_plugin_p) {
12230 *old_plugin_p = PL_keyword_plugin;
12231 PL_keyword_plugin = new_plugin;
12233 KEYWORD_PLUGIN_MUTEX_UNLOCK;
12236 #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
12238 S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
12240 SAVEI32(PL_lex_brackets);
12241 if (PL_lex_brackets > 100)
12242 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
12243 PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
12244 SAVEI32(PL_lex_allbrackets);
12245 PL_lex_allbrackets = 0;
12246 SAVEI8(PL_lex_fakeeof);
12247 PL_lex_fakeeof = (U8)fakeeof;
12248 if(yyparse(gramtype) && !PL_parser->error_count)
12249 qerror(Perl_mess(aTHX_ "Parse error"));
12252 #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
12254 S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
12258 SAVEVPTR(PL_eval_root);
12259 PL_eval_root = NULL;
12260 parse_recdescent(gramtype, fakeeof);
12266 #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
12268 S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
12271 if (flags & ~PARSE_OPTIONAL)
12272 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
12273 exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
12274 if (!exprop && !(flags & PARSE_OPTIONAL)) {
12275 if (!PL_parser->error_count)
12276 qerror(Perl_mess(aTHX_ "Parse error"));
12277 exprop = newOP(OP_NULL, 0);
12283 =for apidoc Amx|OP *|parse_arithexpr|U32 flags
12285 Parse a Perl arithmetic expression. This may contain operators of precedence
12286 down to the bit shift operators. The expression must be followed (and thus
12287 terminated) either by a comparison or lower-precedence operator or by
12288 something that would normally terminate an expression such as semicolon.
12289 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12290 otherwise it is mandatory. It is up to the caller to ensure that the
12291 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12292 the source of the code to be parsed and the lexical context for the
12295 The op tree representing the expression is returned. If an optional
12296 expression is absent, a null pointer is returned, otherwise the pointer
12299 If an error occurs in parsing or compilation, in most cases a valid op
12300 tree is returned anyway. The error is reflected in the parser state,
12301 normally resulting in a single exception at the top level of parsing
12302 which covers all the compilation errors that occurred. Some compilation
12303 errors, however, will throw an exception immediately.
12309 Perl_parse_arithexpr(pTHX_ U32 flags)
12311 return parse_expr(LEX_FAKEEOF_COMPARE, flags);
12315 =for apidoc Amx|OP *|parse_termexpr|U32 flags
12317 Parse a Perl term expression. This may contain operators of precedence
12318 down to the assignment operators. The expression must be followed (and thus
12319 terminated) either by a comma or lower-precedence operator or by
12320 something that would normally terminate an expression such as semicolon.
12321 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12322 otherwise it is mandatory. It is up to the caller to ensure that the
12323 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12324 the source of the code to be parsed and the lexical context for the
12327 The op tree representing the expression is returned. If an optional
12328 expression is absent, a null pointer is returned, otherwise the pointer
12331 If an error occurs in parsing or compilation, in most cases a valid op
12332 tree is returned anyway. The error is reflected in the parser state,
12333 normally resulting in a single exception at the top level of parsing
12334 which covers all the compilation errors that occurred. Some compilation
12335 errors, however, will throw an exception immediately.
12341 Perl_parse_termexpr(pTHX_ U32 flags)
12343 return parse_expr(LEX_FAKEEOF_COMMA, flags);
12347 =for apidoc Amx|OP *|parse_listexpr|U32 flags
12349 Parse a Perl list expression. This may contain operators of precedence
12350 down to the comma operator. The expression must be followed (and thus
12351 terminated) either by a low-precedence logic operator such as C<or> or by
12352 something that would normally terminate an expression such as semicolon.
12353 If C<flags> has the C<PARSE_OPTIONAL> bit set, then the expression is optional,
12354 otherwise it is mandatory. It is up to the caller to ensure that the
12355 dynamic parser state (L</PL_parser> et al) is correctly set to reflect
12356 the source of the code to be parsed and the lexical context for the
12359 The op tree representing the expression is returned. If an optional
12360 expression is absent, a null pointer is returned, otherwise the pointer
12363 If an error occurs in parsing or compilation, in most cases a valid op
12364 tree is returned anyway. The error is reflected in the parser state,
12365 normally resulting in a single exception at the top level of parsing
12366 which covers all the compilation errors that occurred. Some compilation
12367 errors, however, will throw an exception immediately.
12373 Perl_parse_listexpr(pTHX_ U32 flags)
12375 return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12379 =for apidoc Amx|OP *|parse_fullexpr|U32 flags
12381 Parse a single complete Perl expression. This allows the full
12382 expression grammar, including the lowest-precedence operators such
12383 as C<or>. The expression must be followed (and thus terminated) by a
12384 token that an expression would normally be terminated by: end-of-file,
12385 closing bracketing punctuation, semicolon, or one of the keywords that
12386 signals a postfix expression-statement modifier. If C<flags> has the
12387 C<PARSE_OPTIONAL> bit set, then the expression is optional, otherwise it is
12388 mandatory. It is up to the caller to ensure that the dynamic parser
12389 state (L</PL_parser> et al) is correctly set to reflect the source of
12390 the code to be parsed and the lexical context for the expression.
12392 The op tree representing the expression is returned. If an optional
12393 expression is absent, a null pointer is returned, otherwise the pointer
12396 If an error occurs in parsing or compilation, in most cases a valid op
12397 tree is returned anyway. The error is reflected in the parser state,
12398 normally resulting in a single exception at the top level of parsing
12399 which covers all the compilation errors that occurred. Some compilation
12400 errors, however, will throw an exception immediately.
12406 Perl_parse_fullexpr(pTHX_ U32 flags)
12408 return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12412 =for apidoc Amx|OP *|parse_block|U32 flags
12414 Parse a single complete Perl code block. This consists of an opening
12415 brace, a sequence of statements, and a closing brace. The block
12416 constitutes a lexical scope, so C<my> variables and various compile-time
12417 effects can be contained within it. It is up to the caller to ensure
12418 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12419 reflect the source of the code to be parsed and the lexical context for
12422 The op tree representing the code block is returned. This is always a
12423 real op, never a null pointer. It will normally be a C<lineseq> list,
12424 including C<nextstate> or equivalent ops. No ops to construct any kind
12425 of runtime scope are included by virtue of it being a block.
12427 If an error occurs in parsing or compilation, in most cases a valid op
12428 tree (most likely null) is returned anyway. The error is reflected in
12429 the parser state, normally resulting in a single exception at the top
12430 level of parsing which covers all the compilation errors that occurred.
12431 Some compilation errors, however, will throw an exception immediately.
12433 The C<flags> parameter is reserved for future use, and must always
12440 Perl_parse_block(pTHX_ U32 flags)
12443 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12444 return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12448 =for apidoc Amx|OP *|parse_barestmt|U32 flags
12450 Parse a single unadorned Perl statement. This may be a normal imperative
12451 statement or a declaration that has compile-time effect. It does not
12452 include any label or other affixture. It is up to the caller to ensure
12453 that the dynamic parser state (L</PL_parser> et al) is correctly set to
12454 reflect the source of the code to be parsed and the lexical context for
12457 The op tree representing the statement is returned. This may be a
12458 null pointer if the statement is null, for example if it was actually
12459 a subroutine definition (which has compile-time side effects). If not
12460 null, it will be ops directly implementing the statement, suitable to
12461 pass to L</newSTATEOP>. It will not normally include a C<nextstate> or
12462 equivalent op (except for those embedded in a scope contained entirely
12463 within the statement).
12465 If an error occurs in parsing or compilation, in most cases a valid op
12466 tree (most likely null) is returned anyway. The error is reflected in
12467 the parser state, normally resulting in a single exception at the top
12468 level of parsing which covers all the compilation errors that occurred.
12469 Some compilation errors, however, will throw an exception immediately.
12471 The C<flags> parameter is reserved for future use, and must always
12478 Perl_parse_barestmt(pTHX_ U32 flags)
12481 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12482 return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12486 =for apidoc Amx|SV *|parse_label|U32 flags
12488 Parse a single label, possibly optional, of the type that may prefix a
12489 Perl statement. It is up to the caller to ensure that the dynamic parser
12490 state (L</PL_parser> et al) is correctly set to reflect the source of
12491 the code to be parsed. If C<flags> has the C<PARSE_OPTIONAL> bit set, then the
12492 label is optional, otherwise it is mandatory.
12494 The name of the label is returned in the form of a fresh scalar. If an
12495 optional label is absent, a null pointer is returned.
12497 If an error occurs in parsing, which can only occur if the label is
12498 mandatory, a valid label is returned anyway. The error is reflected in
12499 the parser state, normally resulting in a single exception at the top
12500 level of parsing which covers all the compilation errors that occurred.
12506 Perl_parse_label(pTHX_ U32 flags)
12508 if (flags & ~PARSE_OPTIONAL)
12509 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12511 PL_parser->yychar = yylex();
12512 if (PL_parser->yychar == LABEL) {
12513 char * const lpv = pl_yylval.pval;
12514 STRLEN llen = strlen(lpv);
12515 PL_parser->yychar = YYEMPTY;
12516 return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12523 STRLEN wlen, bufptr_pos;
12526 if (!isIDFIRST_lazy_if_safe(s, PL_bufend, UTF))
12528 t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12529 if (word_takes_any_delimiter(s, wlen))
12531 bufptr_pos = s - SvPVX(PL_linestr);
12533 lex_read_space(LEX_KEEP_PREVIOUS);
12535 s = SvPVX(PL_linestr) + bufptr_pos;
12536 if (t[0] == ':' && t[1] != ':') {
12537 PL_oldoldbufptr = PL_oldbufptr;
12540 return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
12544 if (flags & PARSE_OPTIONAL) {
12547 qerror(Perl_mess(aTHX_ "Parse error"));
12548 return newSVpvs("x");
12555 =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12557 Parse a single complete Perl statement. This may be a normal imperative
12558 statement or a declaration that has compile-time effect, and may include
12559 optional labels. It is up to the caller to ensure that the dynamic
12560 parser state (L</PL_parser> et al) is correctly set to reflect the source
12561 of the code to be parsed and the lexical context for the statement.
12563 The op tree representing the statement is returned. This may be a
12564 null pointer if the statement is null, for example if it was actually
12565 a subroutine definition (which has compile-time side effects). If not
12566 null, it will be the result of a L</newSTATEOP> call, normally including
12567 a C<nextstate> or equivalent op.
12569 If an error occurs in parsing or compilation, in most cases a valid op
12570 tree (most likely null) is returned anyway. The error is reflected in
12571 the parser state, normally resulting in a single exception at the top
12572 level of parsing which covers all the compilation errors that occurred.
12573 Some compilation errors, however, will throw an exception immediately.
12575 The C<flags> parameter is reserved for future use, and must always
12582 Perl_parse_fullstmt(pTHX_ U32 flags)
12585 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12586 return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12590 =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12592 Parse a sequence of zero or more Perl statements. These may be normal
12593 imperative statements, including optional labels, or declarations
12594 that have compile-time effect, or any mixture thereof. The statement
12595 sequence ends when a closing brace or end-of-file is encountered in a
12596 place where a new statement could have validly started. It is up to
12597 the caller to ensure that the dynamic parser state (L</PL_parser> et al)
12598 is correctly set to reflect the source of the code to be parsed and the
12599 lexical context for the statements.
12601 The op tree representing the statement sequence is returned. This may
12602 be a null pointer if the statements were all null, for example if there
12603 were no statements or if there were only subroutine definitions (which
12604 have compile-time side effects). If not null, it will be a C<lineseq>
12605 list, normally including C<nextstate> or equivalent ops.
12607 If an error occurs in parsing or compilation, in most cases a valid op
12608 tree is returned anyway. The error is reflected in the parser state,
12609 normally resulting in a single exception at the top level of parsing
12610 which covers all the compilation errors that occurred. Some compilation
12611 errors, however, will throw an exception immediately.
12613 The C<flags> parameter is reserved for future use, and must always
12620 Perl_parse_stmtseq(pTHX_ U32 flags)
12625 Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12626 stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12627 c = lex_peek_unichar(0);
12628 if (c != -1 && c != /*{*/'}')
12629 qerror(Perl_mess(aTHX_ "Parse error"));
12634 * ex: set ts=8 sts=4 sw=4 et: