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 #define PERL_IN_TOKE_C
28 #define new_constant(a,b,c,d,e,f,g) \
29 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
31 #define pl_yylval (PL_parser->yylval)
33 /* YYINITDEPTH -- initial size of the parser's stacks. */
34 #define YYINITDEPTH 200
36 /* XXX temporary backwards compatibility */
37 #define PL_lex_brackets (PL_parser->lex_brackets)
38 #define PL_lex_brackstack (PL_parser->lex_brackstack)
39 #define PL_lex_casemods (PL_parser->lex_casemods)
40 #define PL_lex_casestack (PL_parser->lex_casestack)
41 #define PL_lex_defer (PL_parser->lex_defer)
42 #define PL_lex_dojoin (PL_parser->lex_dojoin)
43 #define PL_lex_expect (PL_parser->lex_expect)
44 #define PL_lex_formbrack (PL_parser->lex_formbrack)
45 #define PL_lex_inpat (PL_parser->lex_inpat)
46 #define PL_lex_inwhat (PL_parser->lex_inwhat)
47 #define PL_lex_op (PL_parser->lex_op)
48 #define PL_lex_repl (PL_parser->lex_repl)
49 #define PL_lex_starts (PL_parser->lex_starts)
50 #define PL_lex_stuff (PL_parser->lex_stuff)
51 #define PL_multi_start (PL_parser->multi_start)
52 #define PL_multi_open (PL_parser->multi_open)
53 #define PL_multi_close (PL_parser->multi_close)
54 #define PL_pending_ident (PL_parser->pending_ident)
55 #define PL_preambled (PL_parser->preambled)
56 #define PL_sublex_info (PL_parser->sublex_info)
57 #define PL_linestr (PL_parser->linestr)
58 #define PL_expect (PL_parser->expect)
59 #define PL_copline (PL_parser->copline)
60 #define PL_bufptr (PL_parser->bufptr)
61 #define PL_oldbufptr (PL_parser->oldbufptr)
62 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
63 #define PL_linestart (PL_parser->linestart)
64 #define PL_bufend (PL_parser->bufend)
65 #define PL_last_uni (PL_parser->last_uni)
66 #define PL_last_lop (PL_parser->last_lop)
67 #define PL_last_lop_op (PL_parser->last_lop_op)
68 #define PL_lex_state (PL_parser->lex_state)
69 #define PL_rsfp (PL_parser->rsfp)
70 #define PL_rsfp_filters (PL_parser->rsfp_filters)
71 #define PL_in_my (PL_parser->in_my)
72 #define PL_in_my_stash (PL_parser->in_my_stash)
73 #define PL_tokenbuf (PL_parser->tokenbuf)
74 #define PL_multi_end (PL_parser->multi_end)
75 #define PL_error_count (PL_parser->error_count)
78 # define PL_endwhite (PL_parser->endwhite)
79 # define PL_faketokens (PL_parser->faketokens)
80 # define PL_lasttoke (PL_parser->lasttoke)
81 # define PL_nextwhite (PL_parser->nextwhite)
82 # define PL_realtokenstart (PL_parser->realtokenstart)
83 # define PL_skipwhite (PL_parser->skipwhite)
84 # define PL_thisclose (PL_parser->thisclose)
85 # define PL_thismad (PL_parser->thismad)
86 # define PL_thisopen (PL_parser->thisopen)
87 # define PL_thisstuff (PL_parser->thisstuff)
88 # define PL_thistoken (PL_parser->thistoken)
89 # define PL_thiswhite (PL_parser->thiswhite)
90 # define PL_thiswhite (PL_parser->thiswhite)
91 # define PL_nexttoke (PL_parser->nexttoke)
92 # define PL_curforce (PL_parser->curforce)
94 # define PL_nexttoke (PL_parser->nexttoke)
95 # define PL_nexttype (PL_parser->nexttype)
96 # define PL_nextval (PL_parser->nextval)
99 /* This can't be done with embed.fnc, because struct yy_parser contains a
100 member named pending_ident, which clashes with the generated #define */
102 S_pending_ident(pTHX);
104 static const char ident_too_long[] = "Identifier too long";
107 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
108 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
110 # define CURMAD(slot,sv)
111 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
114 #define XFAKEBRACK 128
115 #define XENUMMASK 127
117 #ifdef USE_UTF8_SCRIPTS
118 # define UTF (!IN_BYTES)
120 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
123 /* The maximum number of characters preceding the unrecognized one to display */
124 #define UNRECOGNIZED_PRECEDE_COUNT 10
126 /* In variables named $^X, these are the legal values for X.
127 * 1999-02-27 mjd-perl-patch@plover.com */
128 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
130 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
132 /* LEX_* are values for PL_lex_state, the state of the lexer.
133 * They are arranged oddly so that the guard on the switch statement
134 * can get by with a single comparison (if the compiler is smart enough).
137 /* #define LEX_NOTPARSING 11 is done in perl.h. */
139 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
140 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
141 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
142 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
143 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
145 /* at end of code, eg "$x" followed by: */
146 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
147 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
149 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
150 string or after \E, $foo, etc */
151 #define LEX_INTERPCONST 2 /* NOT USED */
152 #define LEX_FORMLINE 1 /* expecting a format line */
153 #define LEX_KNOWNEXT 0 /* next token known; just return it */
157 static const char* const lex_state_names[] = {
176 #include "keywords.h"
178 /* CLINE is a macro that ensures PL_copline has a sane value */
183 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
186 # define SKIPSPACE0(s) skipspace0(s)
187 # define SKIPSPACE1(s) skipspace1(s)
188 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
189 # define PEEKSPACE(s) skipspace2(s,0)
191 # define SKIPSPACE0(s) skipspace(s)
192 # define SKIPSPACE1(s) skipspace(s)
193 # define SKIPSPACE2(s,tsv) skipspace(s)
194 # define PEEKSPACE(s) skipspace(s)
198 * Convenience functions to return different tokens and prime the
199 * lexer for the next token. They all take an argument.
201 * TOKEN : generic token (used for '(', DOLSHARP, etc)
202 * OPERATOR : generic operator
203 * AOPERATOR : assignment operator
204 * PREBLOCK : beginning the block after an if, while, foreach, ...
205 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
206 * PREREF : *EXPR where EXPR is not a simple identifier
207 * TERM : expression term
208 * LOOPX : loop exiting command (goto, last, dump, etc)
209 * FTST : file test operator
210 * FUN0 : zero-argument function
211 * FUN1 : not used, except for not, which isn't a UNIOP
212 * BOop : bitwise or or xor
214 * SHop : shift operator
215 * PWop : power operator
216 * PMop : pattern-matching operator
217 * Aop : addition-level operator
218 * Mop : multiplication-level operator
219 * Eop : equality-testing operator
220 * Rop : relational operator <= != gt
222 * Also see LOP and lop() below.
225 #ifdef DEBUGGING /* Serve -DT. */
226 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
228 # define REPORT(retval) (retval)
231 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
232 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
233 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
234 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
235 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
236 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
237 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
238 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
239 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
240 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
241 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
242 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
243 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
244 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
245 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
246 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
247 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
248 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
249 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
250 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
252 /* This bit of chicanery makes a unary function followed by
253 * a parenthesis into a function with one argument, highest precedence.
254 * The UNIDOR macro is for unary functions that can be followed by the //
255 * operator (such as C<shift // 0>).
257 #define UNI2(f,x) { \
258 pl_yylval.ival = f; \
261 PL_last_uni = PL_oldbufptr; \
262 PL_last_lop_op = f; \
264 return REPORT( (int)FUNC1 ); \
266 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
268 #define UNI(f) UNI2(f,XTERM)
269 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
271 #define UNIBRACK(f) { \
272 pl_yylval.ival = f; \
274 PL_last_uni = PL_oldbufptr; \
276 return REPORT( (int)FUNC1 ); \
278 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
281 /* grandfather return to old style */
282 #define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
286 /* how to interpret the pl_yylval associated with the token */
290 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
296 static struct debug_tokens {
298 enum token_type type;
300 } const debug_tokens[] =
302 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
303 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
304 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
305 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
306 { ARROW, TOKENTYPE_NONE, "ARROW" },
307 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
308 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
309 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
310 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
311 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
312 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
313 { DO, TOKENTYPE_NONE, "DO" },
314 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
315 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
316 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
317 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
318 { ELSE, TOKENTYPE_NONE, "ELSE" },
319 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
320 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
321 { FOR, TOKENTYPE_IVAL, "FOR" },
322 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
323 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
324 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
325 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
326 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
327 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
328 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
329 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
330 { IF, TOKENTYPE_IVAL, "IF" },
331 { LABEL, TOKENTYPE_PVAL, "LABEL" },
332 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
333 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
334 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
335 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
336 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
337 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
338 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
339 { MY, TOKENTYPE_IVAL, "MY" },
340 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
341 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
342 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
343 { OROP, TOKENTYPE_IVAL, "OROP" },
344 { OROR, TOKENTYPE_NONE, "OROR" },
345 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
346 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
347 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
348 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
349 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
350 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
351 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
352 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
353 { PREINC, TOKENTYPE_NONE, "PREINC" },
354 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
355 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
356 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
357 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
358 { SUB, TOKENTYPE_NONE, "SUB" },
359 { THING, TOKENTYPE_OPVAL, "THING" },
360 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
361 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
362 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
363 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
364 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
365 { USE, TOKENTYPE_IVAL, "USE" },
366 { WHEN, TOKENTYPE_IVAL, "WHEN" },
367 { WHILE, TOKENTYPE_IVAL, "WHILE" },
368 { WORD, TOKENTYPE_OPVAL, "WORD" },
369 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
370 { 0, TOKENTYPE_NONE, NULL }
373 /* dump the returned token in rv, plus any optional arg in pl_yylval */
376 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
380 PERL_ARGS_ASSERT_TOKEREPORT;
383 const char *name = NULL;
384 enum token_type type = TOKENTYPE_NONE;
385 const struct debug_tokens *p;
386 SV* const report = newSVpvs("<== ");
388 for (p = debug_tokens; p->token; p++) {
389 if (p->token == (int)rv) {
396 Perl_sv_catpv(aTHX_ report, name);
397 else if ((char)rv > ' ' && (char)rv < '~')
398 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
400 sv_catpvs(report, "EOF");
402 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
405 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
408 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
410 case TOKENTYPE_OPNUM:
411 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
412 PL_op_name[lvalp->ival]);
415 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
417 case TOKENTYPE_OPVAL:
419 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
420 PL_op_name[lvalp->opval->op_type]);
421 if (lvalp->opval->op_type == OP_CONST) {
422 Perl_sv_catpvf(aTHX_ report, " %s",
423 SvPEEK(cSVOPx_sv(lvalp->opval)));
428 sv_catpvs(report, "(opval=null)");
431 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
437 /* print the buffer with suitable escapes */
440 S_printbuf(pTHX_ const char *const fmt, const char *const s)
442 SV* const tmp = newSVpvs("");
444 PERL_ARGS_ASSERT_PRINTBUF;
446 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
453 S_deprecate_commaless_var_list(pTHX) {
455 deprecate("comma-less variable list");
456 return REPORT(','); /* grandfather non-comma-format format */
462 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
463 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
467 S_ao(pTHX_ int toketype)
470 if (*PL_bufptr == '=') {
472 if (toketype == ANDAND)
473 pl_yylval.ival = OP_ANDASSIGN;
474 else if (toketype == OROR)
475 pl_yylval.ival = OP_ORASSIGN;
476 else if (toketype == DORDOR)
477 pl_yylval.ival = OP_DORASSIGN;
485 * When Perl expects an operator and finds something else, no_op
486 * prints the warning. It always prints "<something> found where
487 * operator expected. It prints "Missing semicolon on previous line?"
488 * if the surprise occurs at the start of the line. "do you need to
489 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
490 * where the compiler doesn't know if foo is a method call or a function.
491 * It prints "Missing operator before end of line" if there's nothing
492 * after the missing operator, or "... before <...>" if there is something
493 * after the missing operator.
497 S_no_op(pTHX_ const char *const what, char *s)
500 char * const oldbp = PL_bufptr;
501 const bool is_first = (PL_oldbufptr == PL_linestart);
503 PERL_ARGS_ASSERT_NO_OP;
509 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
510 if (ckWARN_d(WARN_SYNTAX)) {
512 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
513 "\t(Missing semicolon on previous line?)\n");
514 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
516 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
518 if (t < PL_bufptr && isSPACE(*t))
519 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
520 "\t(Do you need to predeclare %.*s?)\n",
521 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
525 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
526 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
534 * Complain about missing quote/regexp/heredoc terminator.
535 * If it's called with NULL then it cauterizes the line buffer.
536 * If we're in a delimited string and the delimiter is a control
537 * character, it's reformatted into a two-char sequence like ^C.
542 S_missingterm(pTHX_ char *s)
548 char * const nl = strrchr(s,'\n');
552 else if (isCNTRL(PL_multi_close)) {
554 tmpbuf[1] = (char)toCTRL(PL_multi_close);
559 *tmpbuf = (char)PL_multi_close;
563 q = strchr(s,'"') ? '\'' : '"';
564 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
567 #define FEATURE_IS_ENABLED(name) \
568 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
569 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
570 /* The longest string we pass in. */
571 #define MAX_FEATURE_LEN (sizeof("switch")-1)
574 * S_feature_is_enabled
575 * Check whether the named feature is enabled.
578 S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
581 HV * const hinthv = GvHV(PL_hintgv);
582 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
584 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
586 assert(namelen <= MAX_FEATURE_LEN);
587 memcpy(&he_name[8], name, namelen);
589 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
593 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
594 * utf16-to-utf8-reversed.
597 #ifdef PERL_CR_FILTER
601 register const char *s = SvPVX_const(sv);
602 register const char * const e = s + SvCUR(sv);
604 PERL_ARGS_ASSERT_STRIP_RETURN;
606 /* outer loop optimized to do nothing if there are no CR-LFs */
608 if (*s++ == '\r' && *s == '\n') {
609 /* hit a CR-LF, need to copy the rest */
610 register char *d = s - 1;
613 if (*s == '\r' && s[1] == '\n')
624 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
626 const I32 count = FILTER_READ(idx+1, sv, maxlen);
627 if (count > 0 && !maxlen)
638 * Create a parser object and initialise its parser and lexer fields
640 * rsfp is the opened file handle to read from (if any),
642 * line holds any initial content already read from the file (or in
643 * the case of no file, such as an eval, the whole contents);
645 * new_filter indicates that this is a new file and it shouldn't inherit
646 * the filters from the current parser (ie require).
650 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
653 const char *s = NULL;
655 yy_parser *parser, *oparser;
657 /* create and initialise a parser */
659 Newxz(parser, 1, yy_parser);
660 parser->old_parser = oparser = PL_parser;
663 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
664 parser->ps = parser->stack;
665 parser->stack_size = YYINITDEPTH;
667 parser->stack->state = 0;
668 parser->yyerrstatus = 0;
669 parser->yychar = YYEMPTY; /* Cause a token to be read. */
671 /* on scope exit, free this parser and restore any outer one */
673 parser->saved_curcop = PL_curcop;
675 /* initialise lexer state */
678 parser->curforce = -1;
680 parser->nexttoke = 0;
682 parser->error_count = oparser ? oparser->error_count : 0;
683 parser->copline = NOLINE;
684 parser->lex_state = LEX_NORMAL;
685 parser->expect = XSTATE;
687 parser->rsfp_filters = (new_filter || !oparser) ? newAV()
688 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
690 Newx(parser->lex_brackstack, 120, char);
691 Newx(parser->lex_casestack, 12, char);
692 *parser->lex_casestack = '\0';
695 s = SvPV_const(line, len);
701 parser->linestr = newSVpvs("\n;");
702 } else if (SvREADONLY(line) || s[len-1] != ';') {
703 parser->linestr = newSVsv(line);
705 sv_catpvs(parser->linestr, "\n;");
708 SvREFCNT_inc_simple_void_NN(line);
709 parser->linestr = line;
711 parser->oldoldbufptr =
714 parser->linestart = SvPVX(parser->linestr);
715 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
716 parser->last_lop = parser->last_uni = NULL;
720 /* delete a parser object */
723 Perl_parser_free(pTHX_ const yy_parser *parser)
725 PERL_ARGS_ASSERT_PARSER_FREE;
727 PL_curcop = parser->saved_curcop;
728 SvREFCNT_dec(parser->linestr);
730 if (parser->rsfp == PerlIO_stdin())
731 PerlIO_clearerr(parser->rsfp);
732 else if (parser->rsfp && (!parser->old_parser ||
733 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
734 PerlIO_close(parser->rsfp);
735 SvREFCNT_dec(parser->rsfp_filters);
737 Safefree(parser->stack);
738 Safefree(parser->lex_brackstack);
739 Safefree(parser->lex_casestack);
740 PL_parser = parser->old_parser;
747 * Finalizer for lexing operations. Must be called when the parser is
748 * done with the lexer.
755 PL_doextract = FALSE;
760 * This subroutine has nothing to do with tilting, whether at windmills
761 * or pinball tables. Its name is short for "increment line". It
762 * increments the current line number in CopLINE(PL_curcop) and checks
763 * to see whether the line starts with a comment of the form
764 * # line 500 "foo.pm"
765 * If so, it sets the current line number and file to the values in the comment.
769 S_incline(pTHX_ const char *s)
776 PERL_ARGS_ASSERT_INCLINE;
778 CopLINE_inc(PL_curcop);
781 while (SPACE_OR_TAB(*s))
783 if (strnEQ(s, "line", 4))
787 if (SPACE_OR_TAB(*s))
791 while (SPACE_OR_TAB(*s))
799 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
801 while (SPACE_OR_TAB(*s))
803 if (*s == '"' && (t = strchr(s+1, '"'))) {
813 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
815 if (*e != '\n' && *e != '\0')
816 return; /* false alarm */
819 const STRLEN len = t - s;
821 SV *const temp_sv = CopFILESV(PL_curcop);
827 tmplen = SvCUR(temp_sv);
833 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
834 /* must copy *{"::_<(eval N)[oldfilename:L]"}
835 * to *{"::_<newfilename"} */
836 /* However, the long form of evals is only turned on by the
837 debugger - usually they're "(eval %lu)" */
841 STRLEN tmplen2 = len;
842 if (tmplen + 2 <= sizeof smallbuf)
845 Newx(tmpbuf, tmplen + 2, char);
848 memcpy(tmpbuf + 2, cf, tmplen);
850 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
855 if (tmplen2 + 2 <= sizeof smallbuf)
858 Newx(tmpbuf2, tmplen2 + 2, char);
860 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
861 /* Either they malloc'd it, or we malloc'd it,
862 so no prefix is present in ours. */
867 memcpy(tmpbuf2 + 2, s, tmplen2);
870 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
872 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
873 /* adjust ${"::_<newfilename"} to store the new file name */
874 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
875 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
876 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
879 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
881 if (tmpbuf != smallbuf) Safefree(tmpbuf);
884 CopFILE_free(PL_curcop);
885 CopFILE_setn(PL_curcop, s, len);
887 CopLINE_set(PL_curcop, atoi(n)-1);
891 /* skip space before PL_thistoken */
894 S_skipspace0(pTHX_ register char *s)
896 PERL_ARGS_ASSERT_SKIPSPACE0;
903 PL_thiswhite = newSVpvs("");
904 sv_catsv(PL_thiswhite, PL_skipwhite);
905 sv_free(PL_skipwhite);
908 PL_realtokenstart = s - SvPVX(PL_linestr);
912 /* skip space after PL_thistoken */
915 S_skipspace1(pTHX_ register char *s)
917 const char *start = s;
918 I32 startoff = start - SvPVX(PL_linestr);
920 PERL_ARGS_ASSERT_SKIPSPACE1;
925 start = SvPVX(PL_linestr) + startoff;
926 if (!PL_thistoken && PL_realtokenstart >= 0) {
927 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
928 PL_thistoken = newSVpvn(tstart, start - tstart);
930 PL_realtokenstart = -1;
933 PL_nextwhite = newSVpvs("");
934 sv_catsv(PL_nextwhite, PL_skipwhite);
935 sv_free(PL_skipwhite);
942 S_skipspace2(pTHX_ register char *s, SV **svp)
945 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
946 const I32 startoff = s - SvPVX(PL_linestr);
948 PERL_ARGS_ASSERT_SKIPSPACE2;
951 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
952 if (!PL_madskills || !svp)
954 start = SvPVX(PL_linestr) + startoff;
955 if (!PL_thistoken && PL_realtokenstart >= 0) {
956 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
957 PL_thistoken = newSVpvn(tstart, start - tstart);
958 PL_realtokenstart = -1;
963 sv_setsv(*svp, PL_skipwhite);
964 sv_free(PL_skipwhite);
973 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
975 AV *av = CopFILEAVx(PL_curcop);
977 SV * const sv = newSV_type(SVt_PVMG);
979 sv_setsv(sv, orig_sv);
981 sv_setpvn(sv, buf, len);
984 av_store(av, (I32)CopLINE(PL_curcop), sv);
990 * Called to gobble the appropriate amount and type of whitespace.
991 * Skips comments as well.
995 S_skipspace(pTHX_ register char *s)
1000 int startoff = s - SvPVX(PL_linestr);
1002 PERL_ARGS_ASSERT_SKIPSPACE;
1005 sv_free(PL_skipwhite);
1009 PERL_ARGS_ASSERT_SKIPSPACE;
1011 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1012 while (s < PL_bufend && SPACE_OR_TAB(*s))
1022 SSize_t oldprevlen, oldoldprevlen;
1023 SSize_t oldloplen = 0, oldunilen = 0;
1024 while (s < PL_bufend && isSPACE(*s)) {
1025 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1030 if (s < PL_bufend && *s == '#') {
1031 while (s < PL_bufend && *s != '\n')
1033 if (s < PL_bufend) {
1035 if (PL_in_eval && !PL_rsfp) {
1042 /* only continue to recharge the buffer if we're at the end
1043 * of the buffer, we're not reading from a source filter, and
1044 * we're in normal lexing mode
1046 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1047 PL_lex_state == LEX_FORMLINE)
1054 /* try to recharge the buffer */
1056 curoff = s - SvPVX(PL_linestr);
1059 if ((s = filter_gets(PL_linestr, (prevlen = SvCUR(PL_linestr))))
1063 if (PL_madskills && curoff != startoff) {
1065 PL_skipwhite = newSVpvs("");
1066 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1070 /* mustn't throw out old stuff yet if madpropping */
1071 SvCUR(PL_linestr) = curoff;
1072 s = SvPVX(PL_linestr) + curoff;
1074 if (curoff && s[-1] == '\n')
1078 /* end of file. Add on the -p or -n magic */
1079 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1082 sv_catpvs(PL_linestr,
1083 ";}continue{print or die qq(-p destination: $!\\n);}");
1085 sv_setpvs(PL_linestr,
1086 ";}continue{print or die qq(-p destination: $!\\n);}");
1088 PL_minus_n = PL_minus_p = 0;
1090 else if (PL_minus_n) {
1092 sv_catpvs(PL_linestr, ";}");
1094 sv_setpvs(PL_linestr, ";}");
1100 sv_catpvs(PL_linestr,";");
1102 sv_setpvs(PL_linestr,";");
1105 /* reset variables for next time we lex */
1106 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1112 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1113 PL_last_lop = PL_last_uni = NULL;
1115 /* Close the filehandle. Could be from
1116 * STDIN, or a regular file. If we were reading code from
1117 * STDIN (because the commandline held no -e or filename)
1118 * then we don't close it, we reset it so the code can
1119 * read from STDIN too.
1122 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1123 PerlIO_clearerr(PL_rsfp);
1125 (void)PerlIO_close(PL_rsfp);
1130 /* not at end of file, so we only read another line */
1131 /* make corresponding updates to old pointers, for yyerror() */
1132 oldprevlen = PL_oldbufptr - PL_bufend;
1133 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1135 oldunilen = PL_last_uni - PL_bufend;
1137 oldloplen = PL_last_lop - PL_bufend;
1138 PL_linestart = PL_bufptr = s + prevlen;
1139 PL_bufend = s + SvCUR(PL_linestr);
1141 PL_oldbufptr = s + oldprevlen;
1142 PL_oldoldbufptr = s + oldoldprevlen;
1144 PL_last_uni = s + oldunilen;
1146 PL_last_lop = s + oldloplen;
1149 /* debugger active and we're not compiling the debugger code,
1150 * so store the line into the debugger's array of lines
1152 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
1153 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1160 PL_skipwhite = newSVpvs("");
1161 curoff = s - SvPVX(PL_linestr);
1162 if (curoff - startoff)
1163 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1172 * Check the unary operators to ensure there's no ambiguity in how they're
1173 * used. An ambiguous piece of code would be:
1175 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1176 * the +5 is its argument.
1186 if (PL_oldoldbufptr != PL_last_uni)
1188 while (isSPACE(*PL_last_uni))
1191 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1193 if ((t = strchr(s, '(')) && t < PL_bufptr)
1196 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1197 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1198 (int)(s - PL_last_uni), PL_last_uni);
1202 * LOP : macro to build a list operator. Its behaviour has been replaced
1203 * with a subroutine, S_lop() for which LOP is just another name.
1206 #define LOP(f,x) return lop(f,x,s)
1210 * Build a list operator (or something that might be one). The rules:
1211 * - if we have a next token, then it's a list operator [why?]
1212 * - if the next thing is an opening paren, then it's a function
1213 * - else it's a list operator
1217 S_lop(pTHX_ I32 f, int x, char *s)
1221 PERL_ARGS_ASSERT_LOP;
1227 PL_last_lop = PL_oldbufptr;
1228 PL_last_lop_op = (OPCODE)f;
1231 return REPORT(LSTOP);
1234 return REPORT(LSTOP);
1237 return REPORT(FUNC);
1240 return REPORT(FUNC);
1242 return REPORT(LSTOP);
1248 * Sets up for an eventual force_next(). start_force(0) basically does
1249 * an unshift, while start_force(-1) does a push. yylex removes items
1254 S_start_force(pTHX_ int where)
1258 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1259 where = PL_lasttoke;
1260 assert(PL_curforce < 0 || PL_curforce == where);
1261 if (PL_curforce != where) {
1262 for (i = PL_lasttoke; i > where; --i) {
1263 PL_nexttoke[i] = PL_nexttoke[i-1];
1267 if (PL_curforce < 0) /* in case of duplicate start_force() */
1268 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1269 PL_curforce = where;
1272 curmad('^', newSVpvs(""));
1273 CURMAD('_', PL_nextwhite);
1278 S_curmad(pTHX_ char slot, SV *sv)
1284 if (PL_curforce < 0)
1285 where = &PL_thismad;
1287 where = &PL_nexttoke[PL_curforce].next_mad;
1293 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1295 else if (PL_encoding) {
1296 sv_recode_to_utf8(sv, PL_encoding);
1301 /* keep a slot open for the head of the list? */
1302 if (slot != '_' && *where && (*where)->mad_key == '^') {
1303 (*where)->mad_key = slot;
1304 sv_free(MUTABLE_SV(((*where)->mad_val)));
1305 (*where)->mad_val = (void*)sv;
1308 addmad(newMADsv(slot, sv), where, 0);
1311 # define start_force(where) NOOP
1312 # define curmad(slot, sv) NOOP
1317 * When the lexer realizes it knows the next token (for instance,
1318 * it is reordering tokens for the parser) then it can call S_force_next
1319 * to know what token to return the next time the lexer is called. Caller
1320 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1321 * and possibly PL_expect to ensure the lexer handles the token correctly.
1325 S_force_next(pTHX_ I32 type)
1330 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1331 tokereport(type, &NEXTVAL_NEXTTOKE);
1335 if (PL_curforce < 0)
1336 start_force(PL_lasttoke);
1337 PL_nexttoke[PL_curforce].next_type = type;
1338 if (PL_lex_state != LEX_KNOWNEXT)
1339 PL_lex_defer = PL_lex_state;
1340 PL_lex_state = LEX_KNOWNEXT;
1341 PL_lex_expect = PL_expect;
1344 PL_nexttype[PL_nexttoke] = type;
1346 if (PL_lex_state != LEX_KNOWNEXT) {
1347 PL_lex_defer = PL_lex_state;
1348 PL_lex_expect = PL_expect;
1349 PL_lex_state = LEX_KNOWNEXT;
1355 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1358 SV * const sv = newSVpvn_utf8(start, len,
1361 && !is_ascii_string((const U8*)start, len)
1362 && is_utf8_string((const U8*)start, len));
1368 * When the lexer knows the next thing is a word (for instance, it has
1369 * just seen -> and it knows that the next char is a word char, then
1370 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1374 * char *start : buffer position (must be within PL_linestr)
1375 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1376 * int check_keyword : if true, Perl checks to make sure the word isn't
1377 * a keyword (do this if the word is a label, e.g. goto FOO)
1378 * int allow_pack : if true, : characters will also be allowed (require,
1379 * use, etc. do this)
1380 * int allow_initial_tick : used by the "sub" lexer only.
1384 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1390 PERL_ARGS_ASSERT_FORCE_WORD;
1392 start = SKIPSPACE1(start);
1394 if (isIDFIRST_lazy_if(s,UTF) ||
1395 (allow_pack && *s == ':') ||
1396 (allow_initial_tick && *s == '\'') )
1398 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1399 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1401 start_force(PL_curforce);
1403 curmad('X', newSVpvn(start,s-start));
1404 if (token == METHOD) {
1409 PL_expect = XOPERATOR;
1413 curmad('g', newSVpvs( "forced" ));
1414 NEXTVAL_NEXTTOKE.opval
1415 = (OP*)newSVOP(OP_CONST,0,
1416 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1417 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1425 * Called when the lexer wants $foo *foo &foo etc, but the program
1426 * text only contains the "foo" portion. The first argument is a pointer
1427 * to the "foo", and the second argument is the type symbol to prefix.
1428 * Forces the next token to be a "WORD".
1429 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1433 S_force_ident(pTHX_ register const char *s, int kind)
1437 PERL_ARGS_ASSERT_FORCE_IDENT;
1440 const STRLEN len = strlen(s);
1441 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1442 start_force(PL_curforce);
1443 NEXTVAL_NEXTTOKE.opval = o;
1446 o->op_private = OPpCONST_ENTERED;
1447 /* XXX see note in pp_entereval() for why we forgo typo
1448 warnings if the symbol must be introduced in an eval.
1450 gv_fetchpvn_flags(s, len,
1451 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1453 kind == '$' ? SVt_PV :
1454 kind == '@' ? SVt_PVAV :
1455 kind == '%' ? SVt_PVHV :
1463 Perl_str_to_version(pTHX_ SV *sv)
1468 const char *start = SvPV_const(sv,len);
1469 const char * const end = start + len;
1470 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1472 PERL_ARGS_ASSERT_STR_TO_VERSION;
1474 while (start < end) {
1478 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1483 retval += ((NV)n)/nshift;
1492 * Forces the next token to be a version number.
1493 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1494 * and if "guessing" is TRUE, then no new token is created (and the caller
1495 * must use an alternative parsing method).
1499 S_force_version(pTHX_ char *s, int guessing)
1505 I32 startoff = s - SvPVX(PL_linestr);
1508 PERL_ARGS_ASSERT_FORCE_VERSION;
1516 while (isDIGIT(*d) || *d == '_' || *d == '.')
1520 start_force(PL_curforce);
1521 curmad('X', newSVpvn(s,d-s));
1524 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1526 s = scan_num(s, &pl_yylval);
1527 version = pl_yylval.opval;
1528 ver = cSVOPx(version)->op_sv;
1529 if (SvPOK(ver) && !SvNIOK(ver)) {
1530 SvUPGRADE(ver, SVt_PVNV);
1531 SvNV_set(ver, str_to_version(ver));
1532 SvNOK_on(ver); /* hint that it is a version */
1535 else if (guessing) {
1538 sv_free(PL_nextwhite); /* let next token collect whitespace */
1540 s = SvPVX(PL_linestr) + startoff;
1548 if (PL_madskills && !version) {
1549 sv_free(PL_nextwhite); /* let next token collect whitespace */
1551 s = SvPVX(PL_linestr) + startoff;
1554 /* NOTE: The parser sees the package name and the VERSION swapped */
1555 start_force(PL_curforce);
1556 NEXTVAL_NEXTTOKE.opval = version;
1564 * Tokenize a quoted string passed in as an SV. It finds the next
1565 * chunk, up to end of string or a backslash. It may make a new
1566 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1571 S_tokeq(pTHX_ SV *sv)
1575 register char *send;
1580 PERL_ARGS_ASSERT_TOKEQ;
1585 s = SvPV_force(sv, len);
1586 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1589 while (s < send && *s != '\\')
1594 if ( PL_hints & HINT_NEW_STRING ) {
1595 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
1599 if (s + 1 < send && (s[1] == '\\'))
1600 s++; /* all that, just for this */
1605 SvCUR_set(sv, d - SvPVX_const(sv));
1607 if ( PL_hints & HINT_NEW_STRING )
1608 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
1613 * Now come three functions related to double-quote context,
1614 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1615 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1616 * interact with PL_lex_state, and create fake ( ... ) argument lists
1617 * to handle functions and concatenation.
1618 * They assume that whoever calls them will be setting up a fake
1619 * join call, because each subthing puts a ',' after it. This lets
1622 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1624 * (I'm not sure whether the spurious commas at the end of lcfirst's
1625 * arguments and join's arguments are created or not).
1630 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1632 * Pattern matching will set PL_lex_op to the pattern-matching op to
1633 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
1635 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1637 * Everything else becomes a FUNC.
1639 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1640 * had an OP_CONST or OP_READLINE). This just sets us up for a
1641 * call to S_sublex_push().
1645 S_sublex_start(pTHX)
1648 register const I32 op_type = pl_yylval.ival;
1650 if (op_type == OP_NULL) {
1651 pl_yylval.opval = PL_lex_op;
1655 if (op_type == OP_CONST || op_type == OP_READLINE) {
1656 SV *sv = tokeq(PL_lex_stuff);
1658 if (SvTYPE(sv) == SVt_PVIV) {
1659 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1661 const char * const p = SvPV_const(sv, len);
1662 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
1666 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1667 PL_lex_stuff = NULL;
1668 /* Allow <FH> // "foo" */
1669 if (op_type == OP_READLINE)
1670 PL_expect = XTERMORDORDOR;
1673 else if (op_type == OP_BACKTICK && PL_lex_op) {
1674 /* readpipe() vas overriden */
1675 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1676 pl_yylval.opval = PL_lex_op;
1678 PL_lex_stuff = NULL;
1682 PL_sublex_info.super_state = PL_lex_state;
1683 PL_sublex_info.sub_inwhat = (U16)op_type;
1684 PL_sublex_info.sub_op = PL_lex_op;
1685 PL_lex_state = LEX_INTERPPUSH;
1689 pl_yylval.opval = PL_lex_op;
1699 * Create a new scope to save the lexing state. The scope will be
1700 * ended in S_sublex_done. Returns a '(', starting the function arguments
1701 * to the uc, lc, etc. found before.
1702 * Sets PL_lex_state to LEX_INTERPCONCAT.
1711 PL_lex_state = PL_sublex_info.super_state;
1712 SAVEBOOL(PL_lex_dojoin);
1713 SAVEI32(PL_lex_brackets);
1714 SAVEI32(PL_lex_casemods);
1715 SAVEI32(PL_lex_starts);
1716 SAVEI8(PL_lex_state);
1717 SAVEVPTR(PL_lex_inpat);
1718 SAVEI16(PL_lex_inwhat);
1719 SAVECOPLINE(PL_curcop);
1720 SAVEPPTR(PL_bufptr);
1721 SAVEPPTR(PL_bufend);
1722 SAVEPPTR(PL_oldbufptr);
1723 SAVEPPTR(PL_oldoldbufptr);
1724 SAVEPPTR(PL_last_lop);
1725 SAVEPPTR(PL_last_uni);
1726 SAVEPPTR(PL_linestart);
1727 SAVESPTR(PL_linestr);
1728 SAVEGENERICPV(PL_lex_brackstack);
1729 SAVEGENERICPV(PL_lex_casestack);
1731 PL_linestr = PL_lex_stuff;
1732 PL_lex_stuff = NULL;
1734 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1735 = SvPVX(PL_linestr);
1736 PL_bufend += SvCUR(PL_linestr);
1737 PL_last_lop = PL_last_uni = NULL;
1738 SAVEFREESV(PL_linestr);
1740 PL_lex_dojoin = FALSE;
1741 PL_lex_brackets = 0;
1742 Newx(PL_lex_brackstack, 120, char);
1743 Newx(PL_lex_casestack, 12, char);
1744 PL_lex_casemods = 0;
1745 *PL_lex_casestack = '\0';
1747 PL_lex_state = LEX_INTERPCONCAT;
1748 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1750 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1751 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1752 PL_lex_inpat = PL_sublex_info.sub_op;
1754 PL_lex_inpat = NULL;
1761 * Restores lexer state after a S_sublex_push.
1768 if (!PL_lex_starts++) {
1769 SV * const sv = newSVpvs("");
1770 if (SvUTF8(PL_linestr))
1772 PL_expect = XOPERATOR;
1773 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1777 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1778 PL_lex_state = LEX_INTERPCASEMOD;
1782 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1783 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1784 PL_linestr = PL_lex_repl;
1786 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1787 PL_bufend += SvCUR(PL_linestr);
1788 PL_last_lop = PL_last_uni = NULL;
1789 SAVEFREESV(PL_linestr);
1790 PL_lex_dojoin = FALSE;
1791 PL_lex_brackets = 0;
1792 PL_lex_casemods = 0;
1793 *PL_lex_casestack = '\0';
1795 if (SvEVALED(PL_lex_repl)) {
1796 PL_lex_state = LEX_INTERPNORMAL;
1798 /* we don't clear PL_lex_repl here, so that we can check later
1799 whether this is an evalled subst; that means we rely on the
1800 logic to ensure sublex_done() is called again only via the
1801 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1804 PL_lex_state = LEX_INTERPCONCAT;
1814 PL_endwhite = newSVpvs("");
1815 sv_catsv(PL_endwhite, PL_thiswhite);
1819 sv_setpvs(PL_thistoken,"");
1821 PL_realtokenstart = -1;
1825 PL_bufend = SvPVX(PL_linestr);
1826 PL_bufend += SvCUR(PL_linestr);
1827 PL_expect = XOPERATOR;
1828 PL_sublex_info.sub_inwhat = 0;
1836 Extracts a pattern, double-quoted string, or transliteration. This
1839 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1840 processing a pattern (PL_lex_inpat is true), a transliteration
1841 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1843 Returns a pointer to the character scanned up to. If this is
1844 advanced from the start pointer supplied (i.e. if anything was
1845 successfully parsed), will leave an OP for the substring scanned
1846 in pl_yylval. Caller must intuit reason for not parsing further
1847 by looking at the next characters herself.
1851 double-quoted style: \r and \n
1852 regexp special ones: \D \s
1855 case and quoting: \U \Q \E
1856 stops on @ and $, but not for $ as tail anchor
1858 In transliterations:
1859 characters are VERY literal, except for - not at the start or end
1860 of the string, which indicates a range. If the range is in bytes,
1861 scan_const expands the range to the full set of intermediate
1862 characters. If the range is in utf8, the hyphen is replaced with
1863 a certain range mark which will be handled by pmtrans() in op.c.
1865 In double-quoted strings:
1867 double-quoted style: \r and \n
1869 deprecated backrefs: \1 (in substitution replacements)
1870 case and quoting: \U \Q \E
1873 scan_const does *not* construct ops to handle interpolated strings.
1874 It stops processing as soon as it finds an embedded $ or @ variable
1875 and leaves it to the caller to work out what's going on.
1877 embedded arrays (whether in pattern or not) could be:
1878 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1880 $ in double-quoted strings must be the symbol of an embedded scalar.
1882 $ in pattern could be $foo or could be tail anchor. Assumption:
1883 it's a tail anchor if $ is the last thing in the string, or if it's
1884 followed by one of "()| \r\n\t"
1886 \1 (backreferences) are turned into $1
1888 The structure of the code is
1889 while (there's a character to process) {
1890 handle transliteration ranges
1891 skip regexp comments /(?#comment)/ and codes /(?{code})/
1892 skip #-initiated comments in //x patterns
1893 check for embedded arrays
1894 check for embedded scalars
1896 leave intact backslashes from leaveit (below)
1897 deprecate \1 in substitution replacements
1898 handle string-changing backslashes \l \U \Q \E, etc.
1899 switch (what was escaped) {
1900 handle \- in a transliteration (becomes a literal -)
1901 handle \132 (octal characters)
1902 handle \x15 and \x{1234} (hex characters)
1903 handle \N{name} (named characters)
1904 handle \cV (control characters)
1905 handle printf-style backslashes (\f, \r, \n, etc)
1908 } (end if backslash)
1909 handle regular character
1910 } (end while character to read)
1915 S_scan_const(pTHX_ char *start)
1918 register char *send = PL_bufend; /* end of the constant */
1919 SV *sv = newSV(send - start); /* sv for the constant. See
1920 note below on sizing. */
1921 register char *s = start; /* start of the constant */
1922 register char *d = SvPVX(sv); /* destination for copies */
1923 bool dorange = FALSE; /* are we in a translit range? */
1924 bool didrange = FALSE; /* did we just finish a range? */
1925 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1926 I32 this_utf8 = UTF; /* Is the source string assumed
1927 to be UTF8? But, this can
1928 show as true when the source
1929 isn't utf8, as for example
1930 when it is entirely composed
1933 /* Note on sizing: The scanned constant is placed into sv, which is
1934 * initialized by newSV() assuming one byte of output for every byte of
1935 * input. This routine expects newSV() to allocate an extra byte for a
1936 * trailing NUL, which this routine will append if it gets to the end of
1937 * the input. There may be more bytes of input than output (eg., \N{LATIN
1938 * CAPITAL LETTER A}), or more output than input if the constant ends up
1939 * recoded to utf8, but each time a construct is found that might increase
1940 * the needed size, SvGROW() is called. Its size parameter each time is
1941 * based on the best guess estimate at the time, namely the length used so
1942 * far, plus the length the current construct will occupy, plus room for
1943 * the trailing NUL, plus one byte for every input byte still unscanned */
1947 UV literal_endpoint = 0;
1948 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1951 PERL_ARGS_ASSERT_SCAN_CONST;
1953 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1954 /* If we are doing a trans and we know we want UTF8 set expectation */
1955 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1956 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1960 while (s < send || dorange) {
1961 /* get transliterations out of the way (they're most literal) */
1962 if (PL_lex_inwhat == OP_TRANS) {
1963 /* expand a range A-Z to the full set of characters. AIE! */
1965 I32 i; /* current expanded character */
1966 I32 min; /* first character in range */
1967 I32 max; /* last character in range */
1978 char * const c = (char*)utf8_hop((U8*)d, -1);
1982 *c = (char)UTF_TO_NATIVE(0xff);
1983 /* mark the range as done, and continue */
1989 i = d - SvPVX_const(sv); /* remember current offset */
1992 SvLEN(sv) + (has_utf8 ?
1993 (512 - UTF_CONTINUATION_MARK +
1996 /* How many two-byte within 0..255: 128 in UTF-8,
1997 * 96 in UTF-8-mod. */
1999 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2001 d = SvPVX(sv) + i; /* refresh d after realloc */
2005 for (j = 0; j <= 1; j++) {
2006 char * const c = (char*)utf8_hop((U8*)d, -1);
2007 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2013 max = (U8)0xff; /* only to \xff */
2014 uvmax = uv; /* \x{100} to uvmax */
2016 d = c; /* eat endpoint chars */
2021 d -= 2; /* eat the first char and the - */
2022 min = (U8)*d; /* first char in range */
2023 max = (U8)d[1]; /* last char in range */
2030 "Invalid range \"%c-%c\" in transliteration operator",
2031 (char)min, (char)max);
2035 if (literal_endpoint == 2 &&
2036 ((isLOWER(min) && isLOWER(max)) ||
2037 (isUPPER(min) && isUPPER(max)))) {
2039 for (i = min; i <= max; i++)
2041 *d++ = NATIVE_TO_NEED(has_utf8,i);
2043 for (i = min; i <= max; i++)
2045 *d++ = NATIVE_TO_NEED(has_utf8,i);
2050 for (i = min; i <= max; i++)
2053 const U8 ch = (U8)NATIVE_TO_UTF(i);
2054 if (UNI_IS_INVARIANT(ch))
2057 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2058 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2067 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2069 *d++ = (char)UTF_TO_NATIVE(0xff);
2071 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2075 /* mark the range as done, and continue */
2079 literal_endpoint = 0;
2084 /* range begins (ignore - as first or last char) */
2085 else if (*s == '-' && s+1 < send && s != start) {
2087 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2094 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2104 literal_endpoint = 0;
2105 native_range = TRUE;
2110 /* if we get here, we're not doing a transliteration */
2112 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2113 except for the last char, which will be done separately. */
2114 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2116 while (s+1 < send && *s != ')')
2117 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2119 else if (s[2] == '{' /* This should match regcomp.c */
2120 || (s[2] == '?' && s[3] == '{'))
2123 char *regparse = s + (s[2] == '{' ? 3 : 4);
2126 while (count && (c = *regparse)) {
2127 if (c == '\\' && regparse[1])
2135 if (*regparse != ')')
2136 regparse--; /* Leave one char for continuation. */
2137 while (s < regparse)
2138 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2142 /* likewise skip #-initiated comments in //x patterns */
2143 else if (*s == '#' && PL_lex_inpat &&
2144 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2145 while (s+1 < send && *s != '\n')
2146 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2149 /* check for embedded arrays
2150 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2152 else if (*s == '@' && s[1]) {
2153 if (isALNUM_lazy_if(s+1,UTF))
2155 if (strchr(":'{$", s[1]))
2157 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2158 break; /* in regexp, neither @+ nor @- are interpolated */
2161 /* check for embedded scalars. only stop if we're sure it's a
2164 else if (*s == '$') {
2165 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2167 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2169 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2170 "Possible unintended interpolation of $\\ in regex");
2172 break; /* in regexp, $ might be tail anchor */
2176 /* End of else if chain - OP_TRANS rejoin rest */
2179 if (*s == '\\' && s+1 < send) {
2182 /* deprecate \1 in strings and substitution replacements */
2183 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2184 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2186 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2191 /* string-change backslash escapes */
2192 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2196 /* skip any other backslash escapes in a pattern */
2197 else if (PL_lex_inpat) {
2198 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2199 goto default_action;
2202 /* if we get here, it's either a quoted -, or a digit */
2205 /* quoted - in transliterations */
2207 if (PL_lex_inwhat == OP_TRANS) {
2214 if ((isALPHA(*s) || isDIGIT(*s)))
2215 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2216 "Unrecognized escape \\%c passed through",
2218 /* default action is to copy the quoted character */
2219 goto default_action;
2222 /* eg. \132 indicates the octal constant 0x132 */
2223 case '0': case '1': case '2': case '3':
2224 case '4': case '5': case '6': case '7':
2228 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2231 goto NUM_ESCAPE_INSERT;
2233 /* eg. \x24 indicates the hex constant 0x24 */
2237 char* const e = strchr(s, '}');
2238 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2239 PERL_SCAN_DISALLOW_PREFIX;
2244 yyerror("Missing right brace on \\x{}");
2248 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2254 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2255 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2261 /* Insert oct, hex, or \N{U+...} escaped character. There will
2262 * always be enough room in sv since such escapes will be
2263 * longer than any UTF-8 sequence they can end up as, except if
2264 * they force us to recode the rest of the string into utf8 */
2266 /* Here uv is the ordinal of the next character being added in
2267 * unicode (converted from native). (It has to be done before
2268 * here because \N is interpreted as unicode, and oct and hex
2270 if (!UNI_IS_INVARIANT(uv)) {
2271 if (!has_utf8 && uv > 255) {
2272 /* Might need to recode whatever we have accumulated so
2273 * far if it contains any chars variant in utf8 or
2276 SvCUR_set(sv, d - SvPVX_const(sv));
2279 /* See Note on sizing above. */
2280 sv_utf8_upgrade_flags_grow(sv,
2281 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2282 UNISKIP(uv) + (STRLEN)(send - s) + 1);
2283 d = SvPVX(sv) + SvCUR(sv);
2288 d = (char*)uvuni_to_utf8((U8*)d, uv);
2289 if (PL_lex_inwhat == OP_TRANS &&
2290 PL_sublex_info.sub_op) {
2291 PL_sublex_info.sub_op->op_private |=
2292 (PL_lex_repl ? OPpTRANS_FROM_UTF
2296 if (uv > 255 && !dorange)
2297 native_range = FALSE;
2309 /* \N{LATIN SMALL LETTER A} is a named character, and so is
2314 char* e = strchr(s, '}');
2320 yyerror("Missing right brace on \\N{}");
2324 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2325 /* \N{U+...} The ... is a unicode value even on EBCDIC
2327 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2328 PERL_SCAN_DISALLOW_PREFIX;
2331 uv = grok_hex(s, &len, &flags, NULL);
2332 if ( e > s && len != (STRLEN)(e - s) ) {
2336 goto NUM_ESCAPE_INSERT;
2338 res = newSVpvn(s + 1, e - s - 1);
2339 res = new_constant( NULL, 0, "charnames",
2340 res, NULL, s - 2, e - s + 3 );
2342 sv_utf8_upgrade(res);
2343 str = SvPV_const(res,len);
2344 #ifdef EBCDIC_NEVER_MIND
2345 /* charnames uses pack U and that has been
2346 * recently changed to do the below uni->native
2347 * mapping, so this would be redundant (and wrong,
2348 * the code point would be doubly converted).
2349 * But leave this in just in case the pack U change
2350 * gets revoked, but the semantics is still
2351 * desireable for charnames. --jhi */
2353 UV uv = utf8_to_uvchr((const U8*)str, 0);
2356 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2358 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2359 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2360 str = SvPV_const(res, len);
2364 /* If destination is not in utf8 but this new character is,
2365 * recode the dest to utf8 */
2366 if (!has_utf8 && SvUTF8(res)) {
2367 SvCUR_set(sv, d - SvPVX_const(sv));
2370 /* See Note on sizing above. */
2371 sv_utf8_upgrade_flags_grow(sv,
2372 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2373 len + (STRLEN)(send - s) + 1);
2374 d = SvPVX(sv) + SvCUR(sv);
2376 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2378 /* See Note on sizing above. (NOTE: SvCUR() is not set
2379 * correctly here). */
2380 const STRLEN off = d - SvPVX_const(sv);
2381 d = SvGROW(sv, off + len + (STRLEN)(send - s) + 1) + off;
2385 native_range = FALSE; /* \N{} is guessed to be Unicode */
2387 Copy(str, d, len, char);
2394 yyerror("Missing braces on \\N{}");
2397 /* \c is a control character */
2406 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2409 yyerror("Missing control char name in \\c");
2413 /* printf-style backslashes, formfeeds, newlines, etc */
2415 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2418 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2421 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2424 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2427 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2430 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2433 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2439 } /* end if (backslash) */
2446 /* If we started with encoded form, or already know we want it,
2447 then encode the next character */
2448 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
2452 /* One might think that it is wasted effort in the case of the
2453 * source being utf8 (this_utf8 == TRUE) to take the next character
2454 * in the source, convert it to an unsigned value, and then convert
2455 * it back again. But the source has not been validated here. The
2456 * routine that does the conversion checks for errors like
2459 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2460 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2462 SvCUR_set(sv, d - SvPVX_const(sv));
2465 /* See Note on sizing above. */
2466 sv_utf8_upgrade_flags_grow(sv,
2467 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2468 need + (STRLEN)(send - s) + 1);
2469 d = SvPVX(sv) + SvCUR(sv);
2471 } else if (need > len) {
2472 /* encoded value larger than old, may need extra space (NOTE:
2473 * SvCUR() is not set correctly here). See Note on sizing
2475 const STRLEN off = d - SvPVX_const(sv);
2476 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
2480 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2482 if (uv > 255 && !dorange)
2483 native_range = FALSE;
2487 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2489 } /* while loop to process each character */
2491 /* terminate the string and set up the sv */
2493 SvCUR_set(sv, d - SvPVX_const(sv));
2494 if (SvCUR(sv) >= SvLEN(sv))
2495 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2498 if (PL_encoding && !has_utf8) {
2499 sv_recode_to_utf8(sv, PL_encoding);
2505 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2506 PL_sublex_info.sub_op->op_private |=
2507 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2511 /* shrink the sv if we allocated more than we used */
2512 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2513 SvPV_shrink_to_cur(sv);
2516 /* return the substring (via pl_yylval) only if we parsed anything */
2517 if (s > PL_bufptr) {
2518 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
2519 const char *const key = PL_lex_inpat ? "qr" : "q";
2520 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
2524 if (PL_lex_inwhat == OP_TRANS) {
2527 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
2535 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
2538 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2545 * Returns TRUE if there's more to the expression (e.g., a subscript),
2548 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2550 * ->[ and ->{ return TRUE
2551 * { and [ outside a pattern are always subscripts, so return TRUE
2552 * if we're outside a pattern and it's not { or [, then return FALSE
2553 * if we're in a pattern and the first char is a {
2554 * {4,5} (any digits around the comma) returns FALSE
2555 * if we're in a pattern and the first char is a [
2557 * [SOMETHING] has a funky algorithm to decide whether it's a
2558 * character class or not. It has to deal with things like
2559 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2560 * anything else returns TRUE
2563 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2566 S_intuit_more(pTHX_ register char *s)
2570 PERL_ARGS_ASSERT_INTUIT_MORE;
2572 if (PL_lex_brackets)
2574 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2576 if (*s != '{' && *s != '[')
2581 /* In a pattern, so maybe we have {n,m}. */
2598 /* On the other hand, maybe we have a character class */
2601 if (*s == ']' || *s == '^')
2604 /* this is terrifying, and it works */
2605 int weight = 2; /* let's weigh the evidence */
2607 unsigned char un_char = 255, last_un_char;
2608 const char * const send = strchr(s,']');
2609 char tmpbuf[sizeof PL_tokenbuf * 4];
2611 if (!send) /* has to be an expression */
2614 Zero(seen,256,char);
2617 else if (isDIGIT(*s)) {
2619 if (isDIGIT(s[1]) && s[2] == ']')
2625 for (; s < send; s++) {
2626 last_un_char = un_char;
2627 un_char = (unsigned char)*s;
2632 weight -= seen[un_char] * 10;
2633 if (isALNUM_lazy_if(s+1,UTF)) {
2635 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2636 len = (int)strlen(tmpbuf);
2637 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2642 else if (*s == '$' && s[1] &&
2643 strchr("[#!%*<>()-=",s[1])) {
2644 if (/*{*/ strchr("])} =",s[2]))
2653 if (strchr("wds]",s[1]))
2655 else if (seen[(U8)'\''] || seen[(U8)'"'])
2657 else if (strchr("rnftbxcav",s[1]))
2659 else if (isDIGIT(s[1])) {
2661 while (s[1] && isDIGIT(s[1]))
2671 if (strchr("aA01! ",last_un_char))
2673 if (strchr("zZ79~",s[1]))
2675 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2676 weight -= 5; /* cope with negative subscript */
2679 if (!isALNUM(last_un_char)
2680 && !(last_un_char == '$' || last_un_char == '@'
2681 || last_un_char == '&')
2682 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2687 if (keyword(tmpbuf, d - tmpbuf, 0))
2690 if (un_char == last_un_char + 1)
2692 weight -= seen[un_char];
2697 if (weight >= 0) /* probably a character class */
2707 * Does all the checking to disambiguate
2709 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2710 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2712 * First argument is the stuff after the first token, e.g. "bar".
2714 * Not a method if bar is a filehandle.
2715 * Not a method if foo is a subroutine prototyped to take a filehandle.
2716 * Not a method if it's really "Foo $bar"
2717 * Method if it's "foo $bar"
2718 * Not a method if it's really "print foo $bar"
2719 * Method if it's really "foo package::" (interpreted as package->foo)
2720 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2721 * Not a method if bar is a filehandle or package, but is quoted with
2726 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2729 char *s = start + (*start == '$');
2730 char tmpbuf[sizeof PL_tokenbuf];
2737 PERL_ARGS_ASSERT_INTUIT_METHOD;
2740 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2744 const char *proto = SvPVX_const(cv);
2755 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2756 /* start is the beginning of the possible filehandle/object,
2757 * and s is the end of it
2758 * tmpbuf is a copy of it
2761 if (*start == '$') {
2762 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2763 isUPPER(*PL_tokenbuf))
2766 len = start - SvPVX(PL_linestr);
2770 start = SvPVX(PL_linestr) + len;
2774 return *s == '(' ? FUNCMETH : METHOD;
2776 if (!keyword(tmpbuf, len, 0)) {
2777 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2781 soff = s - SvPVX(PL_linestr);
2785 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2786 if (indirgv && GvCVu(indirgv))
2788 /* filehandle or package name makes it a method */
2789 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2791 soff = s - SvPVX(PL_linestr);
2794 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2795 return 0; /* no assumptions -- "=>" quotes bearword */
2797 start_force(PL_curforce);
2798 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2799 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
2800 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2802 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2807 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2809 return *s == '(' ? FUNCMETH : METHOD;
2815 /* Encoded script support. filter_add() effectively inserts a
2816 * 'pre-processing' function into the current source input stream.
2817 * Note that the filter function only applies to the current source file
2818 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2820 * The datasv parameter (which may be NULL) can be used to pass
2821 * private data to this instance of the filter. The filter function
2822 * can recover the SV using the FILTER_DATA macro and use it to
2823 * store private buffers and state information.
2825 * The supplied datasv parameter is upgraded to a PVIO type
2826 * and the IoDIRP/IoANY field is used to store the function pointer,
2827 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2828 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2829 * private use must be set using malloc'd pointers.
2833 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2842 if (!PL_rsfp_filters)
2843 PL_rsfp_filters = newAV();
2846 SvUPGRADE(datasv, SVt_PVIO);
2847 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2848 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2849 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2850 FPTR2DPTR(void *, IoANY(datasv)),
2851 SvPV_nolen(datasv)));
2852 av_unshift(PL_rsfp_filters, 1);
2853 av_store(PL_rsfp_filters, 0, datasv) ;
2858 /* Delete most recently added instance of this filter function. */
2860 Perl_filter_del(pTHX_ filter_t funcp)
2865 PERL_ARGS_ASSERT_FILTER_DEL;
2868 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2869 FPTR2DPTR(void*, funcp)));
2871 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2873 /* if filter is on top of stack (usual case) just pop it off */
2874 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2875 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2876 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2877 IoANY(datasv) = (void *)NULL;
2878 sv_free(av_pop(PL_rsfp_filters));
2882 /* we need to search for the correct entry and clear it */
2883 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2887 /* Invoke the idxth filter function for the current rsfp. */
2888 /* maxlen 0 = read one text line */
2890 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2895 /* This API is bad. It should have been using unsigned int for maxlen.
2896 Not sure if we want to change the API, but if not we should sanity
2897 check the value here. */
2898 const unsigned int correct_length
2907 PERL_ARGS_ASSERT_FILTER_READ;
2909 if (!PL_parser || !PL_rsfp_filters)
2911 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2912 /* Provide a default input filter to make life easy. */
2913 /* Note that we append to the line. This is handy. */
2914 DEBUG_P(PerlIO_printf(Perl_debug_log,
2915 "filter_read %d: from rsfp\n", idx));
2916 if (correct_length) {
2919 const int old_len = SvCUR(buf_sv);
2921 /* ensure buf_sv is large enough */
2922 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
2923 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2924 correct_length)) <= 0) {
2925 if (PerlIO_error(PL_rsfp))
2926 return -1; /* error */
2928 return 0 ; /* end of file */
2930 SvCUR_set(buf_sv, old_len + len) ;
2931 SvPVX(buf_sv)[old_len + len] = '\0';
2934 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2935 if (PerlIO_error(PL_rsfp))
2936 return -1; /* error */
2938 return 0 ; /* end of file */
2941 return SvCUR(buf_sv);
2943 /* Skip this filter slot if filter has been deleted */
2944 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2945 DEBUG_P(PerlIO_printf(Perl_debug_log,
2946 "filter_read %d: skipped (filter deleted)\n",
2948 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2950 /* Get function pointer hidden within datasv */
2951 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2952 DEBUG_P(PerlIO_printf(Perl_debug_log,
2953 "filter_read %d: via function %p (%s)\n",
2954 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2955 /* Call function. The function is expected to */
2956 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2957 /* Return: <0:error, =0:eof, >0:not eof */
2958 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2962 S_filter_gets(pTHX_ register SV *sv, STRLEN append)
2966 PERL_ARGS_ASSERT_FILTER_GETS;
2968 #ifdef PERL_CR_FILTER
2969 if (!PL_rsfp_filters) {
2970 filter_add(S_cr_textfilter,NULL);
2973 if (PL_rsfp_filters) {
2975 SvCUR_set(sv, 0); /* start with empty line */
2976 if (FILTER_READ(0, sv, 0) > 0)
2977 return ( SvPVX(sv) ) ;
2982 return (sv_gets(sv, PL_rsfp, append));
2986 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
2991 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
2993 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2997 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2998 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3000 return GvHV(gv); /* Foo:: */
3003 /* use constant CLASS => 'MyClass' */
3004 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3005 if (gv && GvCV(gv)) {
3006 SV * const sv = cv_const_sv(GvCV(gv));
3008 pkgname = SvPV_const(sv, len);
3011 return gv_stashpvn(pkgname, len, 0);
3015 * S_readpipe_override
3016 * Check whether readpipe() is overriden, and generates the appropriate
3017 * optree, provided sublex_start() is called afterwards.
3020 S_readpipe_override(pTHX)
3023 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
3024 pl_yylval.ival = OP_BACKTICK;
3026 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
3028 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
3029 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
3030 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
3032 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
3033 append_elem(OP_LIST,
3034 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
3035 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
3042 * The intent of this yylex wrapper is to minimize the changes to the
3043 * tokener when we aren't interested in collecting madprops. It remains
3044 * to be seen how successful this strategy will be...
3051 char *s = PL_bufptr;
3053 /* make sure PL_thiswhite is initialized */
3057 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
3058 if (PL_pending_ident)
3059 return S_pending_ident(aTHX);
3061 /* previous token ate up our whitespace? */
3062 if (!PL_lasttoke && PL_nextwhite) {
3063 PL_thiswhite = PL_nextwhite;
3067 /* isolate the token, and figure out where it is without whitespace */
3068 PL_realtokenstart = -1;
3072 assert(PL_curforce < 0);
3074 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
3075 if (!PL_thistoken) {
3076 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3077 PL_thistoken = newSVpvs("");
3079 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3080 PL_thistoken = newSVpvn(tstart, s - tstart);
3083 if (PL_thismad) /* install head */
3084 CURMAD('X', PL_thistoken);
3087 /* last whitespace of a sublex? */
3088 if (optype == ')' && PL_endwhite) {
3089 CURMAD('X', PL_endwhite);
3094 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
3095 if (!PL_thiswhite && !PL_endwhite && !optype) {
3096 sv_free(PL_thistoken);
3101 /* put off final whitespace till peg */
3102 if (optype == ';' && !PL_rsfp) {
3103 PL_nextwhite = PL_thiswhite;
3106 else if (PL_thisopen) {
3107 CURMAD('q', PL_thisopen);
3109 sv_free(PL_thistoken);
3113 /* Store actual token text as madprop X */
3114 CURMAD('X', PL_thistoken);
3118 /* add preceding whitespace as madprop _ */
3119 CURMAD('_', PL_thiswhite);
3123 /* add quoted material as madprop = */
3124 CURMAD('=', PL_thisstuff);
3128 /* add terminating quote as madprop Q */
3129 CURMAD('Q', PL_thisclose);
3133 /* special processing based on optype */
3137 /* opval doesn't need a TOKEN since it can already store mp */
3147 if (pl_yylval.opval)
3148 append_madprops(PL_thismad, pl_yylval.opval, 0);
3156 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3165 /* remember any fake bracket that lexer is about to discard */
3166 if (PL_lex_brackets == 1 &&
3167 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3170 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3173 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3174 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3177 break; /* don't bother looking for trailing comment */
3186 /* attach a trailing comment to its statement instead of next token */
3190 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3192 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3194 if (*s == '\n' || *s == '#') {
3195 while (s < PL_bufend && *s != '\n')
3199 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3200 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3217 /* Create new token struct. Note: opvals return early above. */
3218 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
3225 S_tokenize_use(pTHX_ int is_use, char *s) {
3228 PERL_ARGS_ASSERT_TOKENIZE_USE;
3230 if (PL_expect != XSTATE)
3231 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3232 is_use ? "use" : "no"));
3234 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3235 s = force_version(s, TRUE);
3236 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3237 start_force(PL_curforce);
3238 NEXTVAL_NEXTTOKE.opval = NULL;
3241 else if (*s == 'v') {
3242 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3243 s = force_version(s, FALSE);
3247 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3248 s = force_version(s, FALSE);
3250 pl_yylval.ival = is_use;
3254 static const char* const exp_name[] =
3255 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3256 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3263 Works out what to call the token just pulled out of the input
3264 stream. The yacc parser takes care of taking the ops we return and
3265 stitching them into a tree.
3271 if read an identifier
3272 if we're in a my declaration
3273 croak if they tried to say my($foo::bar)
3274 build the ops for a my() declaration
3275 if it's an access to a my() variable
3276 are we in a sort block?
3277 croak if my($a); $a <=> $b
3278 build ops for access to a my() variable
3279 if in a dq string, and they've said @foo and we can't find @foo
3281 build ops for a bareword
3282 if we already built the token before, use it.
3287 #pragma segment Perl_yylex
3293 register char *s = PL_bufptr;
3298 /* orig_keyword, gvp, and gv are initialized here because
3299 * jump to the label just_a_word_zero can bypass their
3300 * initialization later. */
3301 I32 orig_keyword = 0;
3306 SV* tmp = newSVpvs("");
3307 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3308 (IV)CopLINE(PL_curcop),
3309 lex_state_names[PL_lex_state],
3310 exp_name[PL_expect],
3311 pv_display(tmp, s, strlen(s), 0, 60));
3314 /* check if there's an identifier for us to look at */
3315 if (PL_pending_ident)
3316 return REPORT(S_pending_ident(aTHX));
3318 /* no identifier pending identification */
3320 switch (PL_lex_state) {
3322 case LEX_NORMAL: /* Some compilers will produce faster */
3323 case LEX_INTERPNORMAL: /* code if we comment these out. */
3327 /* when we've already built the next token, just pull it out of the queue */
3331 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
3333 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3334 PL_nexttoke[PL_lasttoke].next_mad = 0;
3335 if (PL_thismad && PL_thismad->mad_key == '_') {
3336 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
3337 PL_thismad->mad_val = 0;
3338 mad_free(PL_thismad);
3343 PL_lex_state = PL_lex_defer;
3344 PL_expect = PL_lex_expect;
3345 PL_lex_defer = LEX_NORMAL;
3346 if (!PL_nexttoke[PL_lasttoke].next_type)
3351 pl_yylval = PL_nextval[PL_nexttoke];
3353 PL_lex_state = PL_lex_defer;
3354 PL_expect = PL_lex_expect;
3355 PL_lex_defer = LEX_NORMAL;
3359 /* FIXME - can these be merged? */
3360 return(PL_nexttoke[PL_lasttoke].next_type);
3362 return REPORT(PL_nexttype[PL_nexttoke]);
3365 /* interpolated case modifiers like \L \U, including \Q and \E.
3366 when we get here, PL_bufptr is at the \
3368 case LEX_INTERPCASEMOD:
3370 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3371 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3373 /* handle \E or end of string */
3374 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3376 if (PL_lex_casemods) {
3377 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3378 PL_lex_casestack[PL_lex_casemods] = '\0';
3380 if (PL_bufptr != PL_bufend
3381 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3383 PL_lex_state = LEX_INTERPCONCAT;
3386 PL_thistoken = newSVpvs("\\E");
3392 while (PL_bufptr != PL_bufend &&
3393 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3395 PL_thiswhite = newSVpvs("");
3396 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3400 if (PL_bufptr != PL_bufend)
3403 PL_lex_state = LEX_INTERPCONCAT;
3407 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3408 "### Saw case modifier\n"); });
3410 if (s[1] == '\\' && s[2] == 'E') {
3413 PL_thiswhite = newSVpvs("");
3414 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3417 PL_lex_state = LEX_INTERPCONCAT;
3422 if (!PL_madskills) /* when just compiling don't need correct */
3423 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3424 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3425 if ((*s == 'L' || *s == 'U') &&
3426 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3427 PL_lex_casestack[--PL_lex_casemods] = '\0';
3430 if (PL_lex_casemods > 10)
3431 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3432 PL_lex_casestack[PL_lex_casemods++] = *s;
3433 PL_lex_casestack[PL_lex_casemods] = '\0';
3434 PL_lex_state = LEX_INTERPCONCAT;
3435 start_force(PL_curforce);
3436 NEXTVAL_NEXTTOKE.ival = 0;
3438 start_force(PL_curforce);
3440 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3442 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3444 NEXTVAL_NEXTTOKE.ival = OP_LC;
3446 NEXTVAL_NEXTTOKE.ival = OP_UC;
3448 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3450 Perl_croak(aTHX_ "panic: yylex");
3452 SV* const tmpsv = newSVpvs("\\ ");
3453 /* replace the space with the character we want to escape
3455 SvPVX(tmpsv)[1] = *s;
3461 if (PL_lex_starts) {
3467 sv_free(PL_thistoken);
3468 PL_thistoken = newSVpvs("");
3471 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3472 if (PL_lex_casemods == 1 && PL_lex_inpat)
3481 case LEX_INTERPPUSH:
3482 return REPORT(sublex_push());
3484 case LEX_INTERPSTART:
3485 if (PL_bufptr == PL_bufend)
3486 return REPORT(sublex_done());
3487 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3488 "### Interpolated variable\n"); });
3490 PL_lex_dojoin = (*PL_bufptr == '@');
3491 PL_lex_state = LEX_INTERPNORMAL;
3492 if (PL_lex_dojoin) {
3493 start_force(PL_curforce);
3494 NEXTVAL_NEXTTOKE.ival = 0;
3496 start_force(PL_curforce);
3497 force_ident("\"", '$');
3498 start_force(PL_curforce);
3499 NEXTVAL_NEXTTOKE.ival = 0;
3501 start_force(PL_curforce);
3502 NEXTVAL_NEXTTOKE.ival = 0;
3504 start_force(PL_curforce);
3505 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3508 if (PL_lex_starts++) {
3513 sv_free(PL_thistoken);
3514 PL_thistoken = newSVpvs("");
3517 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3518 if (!PL_lex_casemods && PL_lex_inpat)
3525 case LEX_INTERPENDMAYBE:
3526 if (intuit_more(PL_bufptr)) {
3527 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3533 if (PL_lex_dojoin) {
3534 PL_lex_dojoin = FALSE;
3535 PL_lex_state = LEX_INTERPCONCAT;
3539 sv_free(PL_thistoken);
3540 PL_thistoken = newSVpvs("");
3545 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3546 && SvEVALED(PL_lex_repl))
3548 if (PL_bufptr != PL_bufend)
3549 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3553 case LEX_INTERPCONCAT:
3555 if (PL_lex_brackets)
3556 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3558 if (PL_bufptr == PL_bufend)
3559 return REPORT(sublex_done());
3561 if (SvIVX(PL_linestr) == '\'') {
3562 SV *sv = newSVsv(PL_linestr);
3565 else if ( PL_hints & HINT_NEW_RE )
3566 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
3567 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3571 s = scan_const(PL_bufptr);
3573 PL_lex_state = LEX_INTERPCASEMOD;
3575 PL_lex_state = LEX_INTERPSTART;
3578 if (s != PL_bufptr) {
3579 start_force(PL_curforce);
3581 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3583 NEXTVAL_NEXTTOKE = pl_yylval;
3586 if (PL_lex_starts++) {
3590 sv_free(PL_thistoken);
3591 PL_thistoken = newSVpvs("");
3594 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3595 if (!PL_lex_casemods && PL_lex_inpat)
3608 PL_lex_state = LEX_NORMAL;
3609 s = scan_formline(PL_bufptr);
3610 if (!PL_lex_formbrack)
3616 PL_oldoldbufptr = PL_oldbufptr;
3622 sv_free(PL_thistoken);
3625 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3629 if (isIDFIRST_lazy_if(s,UTF))
3632 unsigned char c = *s;
3633 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
3634 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
3635 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
3640 Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
3644 goto fake_eof; /* emulate EOF on ^D or ^Z */
3653 if (PL_lex_brackets) {
3654 yyerror((const char *)
3656 ? "Format not terminated"
3657 : "Missing right curly or square bracket"));
3659 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3660 "### Tokener got EOF\n");
3664 if (s++ < PL_bufend)
3665 goto retry; /* ignore stray nulls */
3668 if (!PL_in_eval && !PL_preambled) {
3669 PL_preambled = TRUE;
3675 /* Generate a string of Perl code to load the debugger.
3676 * If PERL5DB is set, it will return the contents of that,
3677 * otherwise a compile-time require of perl5db.pl. */
3679 const char * const pdb = PerlEnv_getenv("PERL5DB");
3682 sv_setpv(PL_linestr, pdb);
3683 sv_catpvs(PL_linestr,";");
3685 SETERRNO(0,SS_NORMAL);
3686 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
3689 sv_setpvs(PL_linestr,"");
3690 if (PL_preambleav) {
3691 SV **svp = AvARRAY(PL_preambleav);
3692 SV **const end = svp + AvFILLp(PL_preambleav);
3694 sv_catsv(PL_linestr, *svp);
3696 sv_catpvs(PL_linestr, ";");
3698 sv_free(MUTABLE_SV(PL_preambleav));
3699 PL_preambleav = NULL;
3702 sv_catpvs(PL_linestr,
3703 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
3704 if (PL_minus_n || PL_minus_p) {
3705 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3707 sv_catpvs(PL_linestr,"chomp;");
3710 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3711 || *PL_splitstr == '"')
3712 && strchr(PL_splitstr + 1, *PL_splitstr))
3713 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3715 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3716 bytes can be used as quoting characters. :-) */
3717 const char *splits = PL_splitstr;
3718 sv_catpvs(PL_linestr, "our @F=split(q\0");
3721 if (*splits == '\\')
3722 sv_catpvn(PL_linestr, splits, 1);
3723 sv_catpvn(PL_linestr, splits, 1);
3724 } while (*splits++);
3725 /* This loop will embed the trailing NUL of
3726 PL_linestr as the last thing it does before
3728 sv_catpvs(PL_linestr, ");");
3732 sv_catpvs(PL_linestr,"our @F=split(' ');");
3735 sv_catpvs(PL_linestr, "\n");
3736 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3737 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3738 PL_last_lop = PL_last_uni = NULL;
3739 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3740 update_debugger_info(PL_linestr, NULL, 0);
3744 bof = PL_rsfp ? TRUE : FALSE;
3745 if ((s = filter_gets(PL_linestr, 0)) == NULL) {
3748 PL_realtokenstart = -1;
3751 if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3752 PerlIO_clearerr(PL_rsfp);
3754 (void)PerlIO_close(PL_rsfp);
3756 PL_doextract = FALSE;
3758 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3764 sv_setpvs(PL_linestr, ";}continue{print;}");
3766 sv_setpvs(PL_linestr, ";}");
3767 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3768 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3769 PL_last_lop = PL_last_uni = NULL;
3770 PL_minus_n = PL_minus_p = 0;
3773 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3774 PL_last_lop = PL_last_uni = NULL;
3775 sv_setpvs(PL_linestr,"");
3776 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3778 /* If it looks like the start of a BOM or raw UTF-16,
3779 * check if it in fact is. */
3785 #ifdef PERLIO_IS_STDIO
3786 # ifdef __GNU_LIBRARY__
3787 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3788 # define FTELL_FOR_PIPE_IS_BROKEN
3792 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3793 # define FTELL_FOR_PIPE_IS_BROKEN
3798 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3800 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3801 s = swallow_bom((U8*)s);
3805 /* Incest with pod. */
3808 sv_catsv(PL_thiswhite, PL_linestr);
3810 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3811 sv_setpvs(PL_linestr, "");
3812 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3813 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3814 PL_last_lop = PL_last_uni = NULL;
3815 PL_doextract = FALSE;
3819 } while (PL_doextract);
3820 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3821 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3822 update_debugger_info(PL_linestr, NULL, 0);
3823 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3824 PL_last_lop = PL_last_uni = NULL;
3825 if (CopLINE(PL_curcop) == 1) {
3826 while (s < PL_bufend && isSPACE(*s))
3828 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3832 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3836 if (*s == '#' && *(s+1) == '!')
3838 #ifdef ALTERNATE_SHEBANG
3840 static char const as[] = ALTERNATE_SHEBANG;
3841 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3842 d = s + (sizeof(as) - 1);
3844 #endif /* ALTERNATE_SHEBANG */
3853 while (*d && !isSPACE(*d))
3857 #ifdef ARG_ZERO_IS_SCRIPT
3858 if (ipathend > ipath) {
3860 * HP-UX (at least) sets argv[0] to the script name,
3861 * which makes $^X incorrect. And Digital UNIX and Linux,
3862 * at least, set argv[0] to the basename of the Perl
3863 * interpreter. So, having found "#!", we'll set it right.
3865 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3867 assert(SvPOK(x) || SvGMAGICAL(x));
3868 if (sv_eq(x, CopFILESV(PL_curcop))) {
3869 sv_setpvn(x, ipath, ipathend - ipath);
3875 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3876 const char * const lstart = SvPV_const(x,llen);
3878 bstart += blen - llen;
3879 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3880 sv_setpvn(x, ipath, ipathend - ipath);
3885 TAINT_NOT; /* $^X is always tainted, but that's OK */
3887 #endif /* ARG_ZERO_IS_SCRIPT */
3892 d = instr(s,"perl -");
3894 d = instr(s,"perl");
3896 /* avoid getting into infinite loops when shebang
3897 * line contains "Perl" rather than "perl" */
3899 for (d = ipathend-4; d >= ipath; --d) {
3900 if ((*d == 'p' || *d == 'P')
3901 && !ibcmp(d, "perl", 4))
3911 #ifdef ALTERNATE_SHEBANG
3913 * If the ALTERNATE_SHEBANG on this system starts with a
3914 * character that can be part of a Perl expression, then if
3915 * we see it but not "perl", we're probably looking at the
3916 * start of Perl code, not a request to hand off to some
3917 * other interpreter. Similarly, if "perl" is there, but
3918 * not in the first 'word' of the line, we assume the line
3919 * contains the start of the Perl program.
3921 if (d && *s != '#') {
3922 const char *c = ipath;
3923 while (*c && !strchr("; \t\r\n\f\v#", *c))
3926 d = NULL; /* "perl" not in first word; ignore */
3928 *s = '#'; /* Don't try to parse shebang line */
3930 #endif /* ALTERNATE_SHEBANG */
3935 !instr(s,"indir") &&
3936 instr(PL_origargv[0],"perl"))
3943 while (s < PL_bufend && isSPACE(*s))
3945 if (s < PL_bufend) {
3946 Newx(newargv,PL_origargc+3,char*);
3948 while (s < PL_bufend && !isSPACE(*s))
3951 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3954 newargv = PL_origargv;
3957 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3959 Perl_croak(aTHX_ "Can't exec %s", ipath);
3962 while (*d && !isSPACE(*d))
3964 while (SPACE_OR_TAB(*d))
3968 const bool switches_done = PL_doswitches;
3969 const U32 oldpdb = PL_perldb;
3970 const bool oldn = PL_minus_n;
3971 const bool oldp = PL_minus_p;
3975 bool baduni = FALSE;
3977 const char *d2 = d1 + 1;
3978 if (parse_unicode_opts((const char **)&d2)
3982 if (baduni || *d1 == 'M' || *d1 == 'm') {
3983 const char * const m = d1;
3984 while (*d1 && !isSPACE(*d1))
3986 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3989 d1 = moreswitches(d1);
3991 if (PL_doswitches && !switches_done) {
3992 int argc = PL_origargc;
3993 char **argv = PL_origargv;
3996 } while (argc && argv[0][0] == '-' && argv[0][1]);
3997 init_argv_symbols(argc,argv);
3999 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4000 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4001 /* if we have already added "LINE: while (<>) {",
4002 we must not do it again */
4004 sv_setpvs(PL_linestr, "");
4005 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4006 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4007 PL_last_lop = PL_last_uni = NULL;
4008 PL_preambled = FALSE;
4009 if (PERLDB_LINE || PERLDB_SAVESRC)
4010 (void)gv_fetchfile(PL_origfilename);
4017 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4019 PL_lex_state = LEX_FORMLINE;
4024 #ifdef PERL_STRICT_CR
4025 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4027 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4029 case ' ': case '\t': case '\f': case 013:
4031 PL_realtokenstart = -1;
4033 PL_thiswhite = newSVpvs("");
4034 sv_catpvn(PL_thiswhite, s, 1);
4041 PL_realtokenstart = -1;
4045 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
4046 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
4047 /* handle eval qq[#line 1 "foo"\n ...] */
4048 CopLINE_dec(PL_curcop);
4051 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
4053 if (!PL_in_eval || PL_rsfp)
4058 while (d < PL_bufend && *d != '\n')
4062 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4063 Perl_croak(aTHX_ "panic: input overflow");
4066 PL_thiswhite = newSVpvn(s, d - s);
4071 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4073 PL_lex_state = LEX_FORMLINE;
4079 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
4080 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
4083 TOKEN(PEG); /* make sure any #! line is accessible */
4088 /* if (PL_madskills && PL_lex_formbrack) { */
4090 while (d < PL_bufend && *d != '\n')
4094 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4095 Perl_croak(aTHX_ "panic: input overflow");
4096 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4098 PL_thiswhite = newSVpvs("");
4099 if (CopLINE(PL_curcop) == 1) {
4100 sv_setpvs(PL_thiswhite, "");
4103 sv_catpvn(PL_thiswhite, s, d - s);
4117 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4125 while (s < PL_bufend && SPACE_OR_TAB(*s))
4128 if (strnEQ(s,"=>",2)) {
4129 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4130 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4131 OPERATOR('-'); /* unary minus */
4133 PL_last_uni = PL_oldbufptr;
4135 case 'r': ftst = OP_FTEREAD; break;
4136 case 'w': ftst = OP_FTEWRITE; break;
4137 case 'x': ftst = OP_FTEEXEC; break;
4138 case 'o': ftst = OP_FTEOWNED; break;
4139 case 'R': ftst = OP_FTRREAD; break;
4140 case 'W': ftst = OP_FTRWRITE; break;
4141 case 'X': ftst = OP_FTREXEC; break;
4142 case 'O': ftst = OP_FTROWNED; break;
4143 case 'e': ftst = OP_FTIS; break;
4144 case 'z': ftst = OP_FTZERO; break;
4145 case 's': ftst = OP_FTSIZE; break;
4146 case 'f': ftst = OP_FTFILE; break;
4147 case 'd': ftst = OP_FTDIR; break;
4148 case 'l': ftst = OP_FTLINK; break;
4149 case 'p': ftst = OP_FTPIPE; break;
4150 case 'S': ftst = OP_FTSOCK; break;
4151 case 'u': ftst = OP_FTSUID; break;
4152 case 'g': ftst = OP_FTSGID; break;
4153 case 'k': ftst = OP_FTSVTX; break;
4154 case 'b': ftst = OP_FTBLK; break;
4155 case 'c': ftst = OP_FTCHR; break;
4156 case 't': ftst = OP_FTTTY; break;
4157 case 'T': ftst = OP_FTTEXT; break;
4158 case 'B': ftst = OP_FTBINARY; break;
4159 case 'M': case 'A': case 'C':
4160 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4162 case 'M': ftst = OP_FTMTIME; break;
4163 case 'A': ftst = OP_FTATIME; break;
4164 case 'C': ftst = OP_FTCTIME; break;
4172 PL_last_lop_op = (OPCODE)ftst;
4173 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4174 "### Saw file test %c\n", (int)tmp);
4179 /* Assume it was a minus followed by a one-letter named
4180 * subroutine call (or a -bareword), then. */
4181 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4182 "### '-%c' looked like a file test but was not\n",
4189 const char tmp = *s++;
4192 if (PL_expect == XOPERATOR)
4197 else if (*s == '>') {
4200 if (isIDFIRST_lazy_if(s,UTF)) {
4201 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4209 if (PL_expect == XOPERATOR)
4212 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4214 OPERATOR('-'); /* unary minus */
4220 const char tmp = *s++;
4223 if (PL_expect == XOPERATOR)
4228 if (PL_expect == XOPERATOR)
4231 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4238 if (PL_expect != XOPERATOR) {
4239 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4240 PL_expect = XOPERATOR;
4241 force_ident(PL_tokenbuf, '*');
4254 if (PL_expect == XOPERATOR) {
4258 PL_tokenbuf[0] = '%';
4259 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4260 sizeof PL_tokenbuf - 1, FALSE);
4261 if (!PL_tokenbuf[1]) {
4264 PL_pending_ident = '%';
4273 const char tmp = *s++;
4278 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4285 const char tmp = *s++;
4291 goto just_a_word_zero_gv;
4294 switch (PL_expect) {
4300 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4302 PL_bufptr = s; /* update in case we back off */
4304 deprecate(":= for an empty attribute list");
4311 PL_expect = XTERMBLOCK;
4314 stuffstart = s - SvPVX(PL_linestr) - 1;
4318 while (isIDFIRST_lazy_if(s,UTF)) {
4321 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4322 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4323 if (tmp < 0) tmp = -tmp;
4338 sv = newSVpvn(s, len);
4340 d = scan_str(d,TRUE,TRUE);
4342 /* MUST advance bufptr here to avoid bogus
4343 "at end of line" context messages from yyerror().
4345 PL_bufptr = s + len;
4346 yyerror("Unterminated attribute parameter in attribute list");
4350 return REPORT(0); /* EOF indicator */
4354 sv_catsv(sv, PL_lex_stuff);
4355 attrs = append_elem(OP_LIST, attrs,
4356 newSVOP(OP_CONST, 0, sv));
4357 SvREFCNT_dec(PL_lex_stuff);
4358 PL_lex_stuff = NULL;
4361 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4363 if (PL_in_my == KEY_our) {
4364 deprecate(":unique");
4367 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4370 /* NOTE: any CV attrs applied here need to be part of
4371 the CVf_BUILTIN_ATTRS define in cv.h! */
4372 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4374 CvLVALUE_on(PL_compcv);
4376 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4378 deprecate(":locked");
4380 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4382 CvMETHOD_on(PL_compcv);
4384 /* After we've set the flags, it could be argued that
4385 we don't need to do the attributes.pm-based setting
4386 process, and shouldn't bother appending recognized
4387 flags. To experiment with that, uncomment the
4388 following "else". (Note that's already been
4389 uncommented. That keeps the above-applied built-in
4390 attributes from being intercepted (and possibly
4391 rejected) by a package's attribute routines, but is
4392 justified by the performance win for the common case
4393 of applying only built-in attributes.) */
4395 attrs = append_elem(OP_LIST, attrs,
4396 newSVOP(OP_CONST, 0,
4400 if (*s == ':' && s[1] != ':')
4403 break; /* require real whitespace or :'s */
4404 /* XXX losing whitespace on sequential attributes here */
4408 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4409 if (*s != ';' && *s != '}' && *s != tmp
4410 && (tmp != '=' || *s != ')')) {
4411 const char q = ((*s == '\'') ? '"' : '\'');
4412 /* If here for an expression, and parsed no attrs, back
4414 if (tmp == '=' && !attrs) {
4418 /* MUST advance bufptr here to avoid bogus "at end of line"
4419 context messages from yyerror().
4422 yyerror( (const char *)
4424 ? Perl_form(aTHX_ "Invalid separator character "
4425 "%c%c%c in attribute list", q, *s, q)
4426 : "Unterminated attribute list" ) );
4434 start_force(PL_curforce);
4435 NEXTVAL_NEXTTOKE.opval = attrs;
4436 CURMAD('_', PL_nextwhite);
4441 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4442 (s - SvPVX(PL_linestr)) - stuffstart);
4450 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4451 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4459 const char tmp = *s++;
4464 const char tmp = *s++;
4472 if (PL_lex_brackets <= 0)
4473 yyerror("Unmatched right square bracket");
4476 if (PL_lex_state == LEX_INTERPNORMAL) {
4477 if (PL_lex_brackets == 0) {
4478 if (*s == '-' && s[1] == '>')
4479 PL_lex_state = LEX_INTERPENDMAYBE;
4480 else if (*s != '[' && *s != '{')
4481 PL_lex_state = LEX_INTERPEND;
4488 if (PL_lex_brackets > 100) {
4489 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4491 switch (PL_expect) {
4493 if (PL_lex_formbrack) {
4497 if (PL_oldoldbufptr == PL_last_lop)
4498 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4500 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4501 OPERATOR(HASHBRACK);
4503 while (s < PL_bufend && SPACE_OR_TAB(*s))
4506 PL_tokenbuf[0] = '\0';
4507 if (d < PL_bufend && *d == '-') {
4508 PL_tokenbuf[0] = '-';
4510 while (d < PL_bufend && SPACE_OR_TAB(*d))
4513 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4514 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4516 while (d < PL_bufend && SPACE_OR_TAB(*d))
4519 const char minus = (PL_tokenbuf[0] == '-');
4520 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4528 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4533 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4538 if (PL_oldoldbufptr == PL_last_lop)
4539 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4541 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4544 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4546 /* This hack is to get the ${} in the message. */
4548 yyerror("syntax error");
4551 OPERATOR(HASHBRACK);
4553 /* This hack serves to disambiguate a pair of curlies
4554 * as being a block or an anon hash. Normally, expectation
4555 * determines that, but in cases where we're not in a
4556 * position to expect anything in particular (like inside
4557 * eval"") we have to resolve the ambiguity. This code
4558 * covers the case where the first term in the curlies is a
4559 * quoted string. Most other cases need to be explicitly
4560 * disambiguated by prepending a "+" before the opening
4561 * curly in order to force resolution as an anon hash.
4563 * XXX should probably propagate the outer expectation
4564 * into eval"" to rely less on this hack, but that could
4565 * potentially break current behavior of eval"".
4569 if (*s == '\'' || *s == '"' || *s == '`') {
4570 /* common case: get past first string, handling escapes */
4571 for (t++; t < PL_bufend && *t != *s;)
4572 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4576 else if (*s == 'q') {
4579 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4582 /* skip q//-like construct */
4584 char open, close, term;
4587 while (t < PL_bufend && isSPACE(*t))
4589 /* check for q => */
4590 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4591 OPERATOR(HASHBRACK);
4595 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4599 for (t++; t < PL_bufend; t++) {
4600 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4602 else if (*t == open)
4606 for (t++; t < PL_bufend; t++) {
4607 if (*t == '\\' && t+1 < PL_bufend)
4609 else if (*t == close && --brackets <= 0)
4611 else if (*t == open)
4618 /* skip plain q word */
4619 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4622 else if (isALNUM_lazy_if(t,UTF)) {
4624 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4627 while (t < PL_bufend && isSPACE(*t))
4629 /* if comma follows first term, call it an anon hash */
4630 /* XXX it could be a comma expression with loop modifiers */
4631 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4632 || (*t == '=' && t[1] == '>')))
4633 OPERATOR(HASHBRACK);
4634 if (PL_expect == XREF)
4637 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4643 pl_yylval.ival = CopLINE(PL_curcop);
4644 if (isSPACE(*s) || *s == '#')
4645 PL_copline = NOLINE; /* invalidate current command line number */
4650 if (PL_lex_brackets <= 0)
4651 yyerror("Unmatched right curly bracket");
4653 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4654 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4655 PL_lex_formbrack = 0;
4656 if (PL_lex_state == LEX_INTERPNORMAL) {
4657 if (PL_lex_brackets == 0) {
4658 if (PL_expect & XFAKEBRACK) {
4659 PL_expect &= XENUMMASK;
4660 PL_lex_state = LEX_INTERPEND;
4665 PL_thiswhite = newSVpvs("");
4666 sv_catpvs(PL_thiswhite,"}");
4669 return yylex(); /* ignore fake brackets */
4671 if (*s == '-' && s[1] == '>')
4672 PL_lex_state = LEX_INTERPENDMAYBE;
4673 else if (*s != '[' && *s != '{')
4674 PL_lex_state = LEX_INTERPEND;
4677 if (PL_expect & XFAKEBRACK) {
4678 PL_expect &= XENUMMASK;
4680 return yylex(); /* ignore fake brackets */
4682 start_force(PL_curforce);
4684 curmad('X', newSVpvn(s-1,1));
4685 CURMAD('_', PL_thiswhite);
4690 PL_thistoken = newSVpvs("");
4698 if (PL_expect == XOPERATOR) {
4699 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4700 && isIDFIRST_lazy_if(s,UTF))
4702 CopLINE_dec(PL_curcop);
4703 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
4704 CopLINE_inc(PL_curcop);
4709 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4711 PL_expect = XOPERATOR;
4712 force_ident(PL_tokenbuf, '&');
4716 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
4728 const char tmp = *s++;
4735 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4736 && strchr("+-*/%.^&|<",tmp))
4737 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4738 "Reversed %c= operator",(int)tmp);
4740 if (PL_expect == XSTATE && isALPHA(tmp) &&
4741 (s == PL_linestart+1 || s[-2] == '\n') )
4743 if (PL_in_eval && !PL_rsfp) {
4748 if (strnEQ(s,"=cut",4)) {
4764 PL_thiswhite = newSVpvs("");
4765 sv_catpvn(PL_thiswhite, PL_linestart,
4766 PL_bufend - PL_linestart);
4770 PL_doextract = TRUE;
4774 if (PL_lex_brackets < PL_lex_formbrack) {
4776 #ifdef PERL_STRICT_CR
4777 while (SPACE_OR_TAB(*t))
4779 while (SPACE_OR_TAB(*t) || *t == '\r')
4782 if (*t == '\n' || *t == '#') {
4793 const char tmp = *s++;
4795 /* was this !=~ where !~ was meant?
4796 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4798 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4799 const char *t = s+1;
4801 while (t < PL_bufend && isSPACE(*t))
4804 if (*t == '/' || *t == '?' ||
4805 ((*t == 'm' || *t == 's' || *t == 'y')
4806 && !isALNUM(t[1])) ||
4807 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4808 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4809 "!=~ should be !~");
4819 if (PL_expect != XOPERATOR) {
4820 if (s[1] != '<' && !strchr(s,'>'))
4823 s = scan_heredoc(s);
4825 s = scan_inputsymbol(s);
4826 TERM(sublex_start());
4832 SHop(OP_LEFT_SHIFT);
4846 const char tmp = *s++;
4848 SHop(OP_RIGHT_SHIFT);
4849 else if (tmp == '=')
4858 if (PL_expect == XOPERATOR) {
4859 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4860 return deprecate_commaless_var_list();
4864 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4865 PL_tokenbuf[0] = '@';
4866 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4867 sizeof PL_tokenbuf - 1, FALSE);
4868 if (PL_expect == XOPERATOR)
4869 no_op("Array length", s);
4870 if (!PL_tokenbuf[1])
4872 PL_expect = XOPERATOR;
4873 PL_pending_ident = '#';
4877 PL_tokenbuf[0] = '$';
4878 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4879 sizeof PL_tokenbuf - 1, FALSE);
4880 if (PL_expect == XOPERATOR)
4882 if (!PL_tokenbuf[1]) {
4884 yyerror("Final $ should be \\$ or $name");
4888 /* This kludge not intended to be bulletproof. */
4889 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4890 pl_yylval.opval = newSVOP(OP_CONST, 0,
4891 newSViv(CopARYBASE_get(&PL_compiling)));
4892 pl_yylval.opval->op_private = OPpCONST_ARYBASE;
4898 const char tmp = *s;
4899 if (PL_lex_state == LEX_NORMAL)
4902 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4903 && intuit_more(s)) {
4905 PL_tokenbuf[0] = '@';
4906 if (ckWARN(WARN_SYNTAX)) {
4909 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4912 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4913 while (t < PL_bufend && *t != ']')
4915 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4916 "Multidimensional syntax %.*s not supported",
4917 (int)((t - PL_bufptr) + 1), PL_bufptr);
4921 else if (*s == '{') {
4923 PL_tokenbuf[0] = '%';
4924 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4925 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4927 char tmpbuf[sizeof PL_tokenbuf];
4930 } while (isSPACE(*t));
4931 if (isIDFIRST_lazy_if(t,UTF)) {
4933 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4937 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4938 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4939 "You need to quote \"%s\"",
4946 PL_expect = XOPERATOR;
4947 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4948 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4949 if (!islop || PL_last_lop_op == OP_GREPSTART)
4950 PL_expect = XOPERATOR;
4951 else if (strchr("$@\"'`q", *s))
4952 PL_expect = XTERM; /* e.g. print $fh "foo" */
4953 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4954 PL_expect = XTERM; /* e.g. print $fh &sub */
4955 else if (isIDFIRST_lazy_if(s,UTF)) {
4956 char tmpbuf[sizeof PL_tokenbuf];
4958 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4959 if ((t2 = keyword(tmpbuf, len, 0))) {
4960 /* binary operators exclude handle interpretations */
4972 PL_expect = XTERM; /* e.g. print $fh length() */
4977 PL_expect = XTERM; /* e.g. print $fh subr() */
4980 else if (isDIGIT(*s))
4981 PL_expect = XTERM; /* e.g. print $fh 3 */
4982 else if (*s == '.' && isDIGIT(s[1]))
4983 PL_expect = XTERM; /* e.g. print $fh .3 */
4984 else if ((*s == '?' || *s == '-' || *s == '+')
4985 && !isSPACE(s[1]) && s[1] != '=')
4986 PL_expect = XTERM; /* e.g. print $fh -1 */
4987 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4989 PL_expect = XTERM; /* e.g. print $fh /.../
4990 XXX except DORDOR operator
4992 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4994 PL_expect = XTERM; /* print $fh <<"EOF" */
4997 PL_pending_ident = '$';
5001 if (PL_expect == XOPERATOR)
5003 PL_tokenbuf[0] = '@';
5004 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5005 if (!PL_tokenbuf[1]) {
5008 if (PL_lex_state == LEX_NORMAL)
5010 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5012 PL_tokenbuf[0] = '%';
5014 /* Warn about @ where they meant $. */
5015 if (*s == '[' || *s == '{') {
5016 if (ckWARN(WARN_SYNTAX)) {
5017 const char *t = s + 1;
5018 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
5020 if (*t == '}' || *t == ']') {
5022 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
5023 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5024 "Scalar value %.*s better written as $%.*s",
5025 (int)(t-PL_bufptr), PL_bufptr,
5026 (int)(t-PL_bufptr-1), PL_bufptr+1);
5031 PL_pending_ident = '@';
5034 case '/': /* may be division, defined-or, or pattern */
5035 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
5039 case '?': /* may either be conditional or pattern */
5040 if (PL_expect == XOPERATOR) {
5048 /* A // operator. */
5058 /* Disable warning on "study /blah/" */
5059 if (PL_oldoldbufptr == PL_last_uni
5060 && (*PL_last_uni != 's' || s - PL_last_uni < 5
5061 || memNE(PL_last_uni, "study", 5)
5062 || isALNUM_lazy_if(PL_last_uni+5,UTF)
5065 s = scan_pat(s,OP_MATCH);
5066 TERM(sublex_start());
5070 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
5071 #ifdef PERL_STRICT_CR
5074 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
5076 && (s == PL_linestart || s[-1] == '\n') )
5078 PL_lex_formbrack = 0;
5082 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
5086 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
5092 pl_yylval.ival = OPf_SPECIAL;
5098 if (PL_expect != XOPERATOR)
5103 case '0': case '1': case '2': case '3': case '4':
5104 case '5': case '6': case '7': case '8': case '9':
5105 s = scan_num(s, &pl_yylval);
5106 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
5107 if (PL_expect == XOPERATOR)
5112 s = scan_str(s,!!PL_madskills,FALSE);
5113 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5114 if (PL_expect == XOPERATOR) {
5115 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5116 return deprecate_commaless_var_list();
5123 pl_yylval.ival = OP_CONST;
5124 TERM(sublex_start());
5127 s = scan_str(s,!!PL_madskills,FALSE);
5128 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5129 if (PL_expect == XOPERATOR) {
5130 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5131 return deprecate_commaless_var_list();
5138 pl_yylval.ival = OP_CONST;
5139 /* FIXME. I think that this can be const if char *d is replaced by
5140 more localised variables. */
5141 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5142 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5143 pl_yylval.ival = OP_STRINGIFY;
5147 TERM(sublex_start());
5150 s = scan_str(s,!!PL_madskills,FALSE);
5151 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5152 if (PL_expect == XOPERATOR)
5153 no_op("Backticks",s);
5156 readpipe_override();
5157 TERM(sublex_start());
5161 if (PL_lex_inwhat && isDIGIT(*s))
5162 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5164 if (PL_expect == XOPERATOR)
5165 no_op("Backslash",s);
5169 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5170 char *start = s + 2;
5171 while (isDIGIT(*start) || *start == '_')
5173 if (*start == '.' && isDIGIT(start[1])) {
5174 s = scan_num(s, &pl_yylval);
5177 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5178 else if (!isALPHA(*start) && (PL_expect == XTERM
5179 || PL_expect == XREF || PL_expect == XSTATE
5180 || PL_expect == XTERMORDORDOR)) {
5181 GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
5183 s = scan_num(s, &pl_yylval);
5190 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5233 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5235 /* Some keywords can be followed by any delimiter, including ':' */
5236 anydelim = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5237 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5238 (PL_tokenbuf[0] == 'q' &&
5239 strchr("qwxr", PL_tokenbuf[1])))));
5241 /* x::* is just a word, unless x is "CORE" */
5242 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5246 while (d < PL_bufend && isSPACE(*d))
5247 d++; /* no comments skipped here, or s### is misparsed */
5249 /* Is this a word before a => operator? */
5250 if (*d == '=' && d[1] == '>') {
5253 = (OP*)newSVOP(OP_CONST, 0,
5254 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5255 pl_yylval.opval->op_private = OPpCONST_BARE;
5259 /* Check for plugged-in keyword */
5263 char *saved_bufptr = PL_bufptr;
5265 result = CALL_FPTR(PL_keyword_plugin)(aTHX_ PL_tokenbuf, len, &o);
5267 if (result == KEYWORD_PLUGIN_DECLINE) {
5268 /* not a plugged-in keyword */
5269 PL_bufptr = saved_bufptr;
5270 } else if (result == KEYWORD_PLUGIN_STMT) {
5271 pl_yylval.opval = o;
5274 return REPORT(PLUGSTMT);
5275 } else if (result == KEYWORD_PLUGIN_EXPR) {
5276 pl_yylval.opval = o;
5278 PL_expect = XOPERATOR;
5279 return REPORT(PLUGEXPR);
5281 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
5286 /* Check for built-in keyword */
5287 tmp = keyword(PL_tokenbuf, len, 0);
5289 /* Is this a label? */
5290 if (!anydelim && PL_expect == XSTATE
5291 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5293 Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
5295 pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5300 if (tmp < 0) { /* second-class keyword? */
5301 GV *ogv = NULL; /* override (winner) */
5302 GV *hgv = NULL; /* hidden (loser) */
5303 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5305 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5308 if (GvIMPORTED_CV(gv))
5310 else if (! CvMETHOD(cv))
5314 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5315 (gv = *gvp) && isGV_with_GP(gv) &&
5316 GvCVu(gv) && GvIMPORTED_CV(gv))
5323 tmp = 0; /* overridden by import or by GLOBAL */
5326 && -tmp==KEY_lock /* XXX generalizable kludge */
5329 tmp = 0; /* any sub overrides "weak" keyword */
5331 else { /* no override */
5333 if (tmp == KEY_dump) {
5334 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
5335 "dump() better written as CORE::dump()");
5339 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
5340 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5341 "Ambiguous call resolved as CORE::%s(), %s",
5342 GvENAME(hgv), "qualify as such or use &");
5349 default: /* not a keyword */
5350 /* Trade off - by using this evil construction we can pull the
5351 variable gv into the block labelled keylookup. If not, then
5352 we have to give it function scope so that the goto from the
5353 earlier ':' case doesn't bypass the initialisation. */
5355 just_a_word_zero_gv:
5363 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5367 SV *nextPL_nextwhite = 0;
5371 /* Get the rest if it looks like a package qualifier */
5373 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5375 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5378 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5379 *s == '\'' ? "'" : "::");
5384 if (PL_expect == XOPERATOR) {
5385 if (PL_bufptr == PL_linestart) {
5386 CopLINE_dec(PL_curcop);
5387 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5388 CopLINE_inc(PL_curcop);
5391 no_op("Bareword",s);
5394 /* Look for a subroutine with this name in current package,
5395 unless name is "Foo::", in which case Foo is a bearword
5396 (and a package name). */
5398 if (len > 2 && !PL_madskills &&
5399 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5401 if (ckWARN(WARN_BAREWORD)
5402 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5403 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5404 "Bareword \"%s\" refers to nonexistent package",
5407 PL_tokenbuf[len] = '\0';
5413 /* Mustn't actually add anything to a symbol table.
5414 But also don't want to "initialise" any placeholder
5415 constants that might already be there into full
5416 blown PVGVs with attached PVCV. */
5417 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5418 GV_NOADD_NOINIT, SVt_PVCV);
5423 /* if we saw a global override before, get the right name */
5426 sv = newSVpvs("CORE::GLOBAL::");
5427 sv_catpv(sv,PL_tokenbuf);
5430 /* If len is 0, newSVpv does strlen(), which is correct.
5431 If len is non-zero, then it will be the true length,
5432 and so the scalar will be created correctly. */
5433 sv = newSVpv(PL_tokenbuf,len);
5436 if (PL_madskills && !PL_thistoken) {
5437 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5438 PL_thistoken = newSVpvn(start,s - start);
5439 PL_realtokenstart = s - SvPVX(PL_linestr);
5443 /* Presume this is going to be a bareword of some sort. */
5446 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5447 pl_yylval.opval->op_private = OPpCONST_BARE;
5448 /* UTF-8 package name? */
5449 if (UTF && !IN_BYTES &&
5450 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5453 /* And if "Foo::", then that's what it certainly is. */
5460 OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc(sv));
5461 const_op->op_private = OPpCONST_BARE;
5462 rv2cv_op = newCVREF(0, const_op);
5464 if (rv2cv_op->op_type == OP_RV2CV &&
5465 (rv2cv_op->op_flags & OPf_KIDS)) {
5466 OP *rv_op = cUNOPx(rv2cv_op)->op_first;
5467 switch (rv_op->op_type) {
5469 SV *sv = cSVOPx_sv(rv_op);
5470 if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
5474 GV *gv = cGVOPx_gv(rv_op);
5475 CV *maybe_cv = GvCVu(gv);
5476 if (maybe_cv && SvTYPE((SV*)maybe_cv) == SVt_PVCV)
5482 /* See if it's the indirect object for a list operator. */
5484 if (PL_oldoldbufptr &&
5485 PL_oldoldbufptr < PL_bufptr &&
5486 (PL_oldoldbufptr == PL_last_lop
5487 || PL_oldoldbufptr == PL_last_uni) &&
5488 /* NO SKIPSPACE BEFORE HERE! */
5489 (PL_expect == XREF ||
5490 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5492 bool immediate_paren = *s == '(';
5494 /* (Now we can afford to cross potential line boundary.) */
5495 s = SKIPSPACE2(s,nextPL_nextwhite);
5497 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5500 /* Two barewords in a row may indicate method call. */
5502 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5503 (tmp = intuit_method(s, gv, cv))) {
5508 /* If not a declared subroutine, it's an indirect object. */
5509 /* (But it's an indir obj regardless for sort.) */
5510 /* Also, if "_" follows a filetest operator, it's a bareword */
5513 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5515 (PL_last_lop_op != OP_MAPSTART &&
5516 PL_last_lop_op != OP_GREPSTART))))
5517 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5518 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5521 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5526 PL_expect = XOPERATOR;
5529 s = SKIPSPACE2(s,nextPL_nextwhite);
5530 PL_nextwhite = nextPL_nextwhite;
5535 /* Is this a word before a => operator? */
5536 if (*s == '=' && s[1] == '>' && !pkgname) {
5539 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
5540 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5541 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
5545 /* If followed by a paren, it's certainly a subroutine. */
5550 while (SPACE_OR_TAB(*d))
5552 if (*d == ')' && (sv = cv_const_sv(cv))) {
5559 PL_nextwhite = PL_thiswhite;
5562 start_force(PL_curforce);
5564 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5565 PL_expect = XOPERATOR;
5568 PL_nextwhite = nextPL_nextwhite;
5569 curmad('X', PL_thistoken);
5570 PL_thistoken = newSVpvs("");
5579 /* If followed by var or block, call it a method (unless sub) */
5581 if ((*s == '$' || *s == '{') && !cv) {
5583 PL_last_lop = PL_oldbufptr;
5584 PL_last_lop_op = OP_METHOD;
5588 /* If followed by a bareword, see if it looks like indir obj. */
5591 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5592 && (tmp = intuit_method(s, gv, cv))) {
5597 /* Not a method, so call it a subroutine (if defined) */
5600 if (lastchar == '-')
5601 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
5602 "Ambiguous use of -%s resolved as -&%s()",
5603 PL_tokenbuf, PL_tokenbuf);
5604 /* Check for a constant sub */
5605 if ((sv = cv_const_sv(cv))) {
5608 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
5609 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5610 pl_yylval.opval->op_private = 0;
5614 op_free(pl_yylval.opval);
5615 pl_yylval.opval = rv2cv_op;
5616 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5617 PL_last_lop = PL_oldbufptr;
5618 PL_last_lop_op = OP_ENTERSUB;
5619 /* Is there a prototype? */
5627 const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
5630 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5632 while (*proto == ';')
5634 if (*proto == '&' && *s == '{') {
5636 sv_setpvs(PL_subname, "__ANON__");
5638 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5645 PL_nextwhite = PL_thiswhite;
5648 start_force(PL_curforce);
5649 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5652 PL_nextwhite = nextPL_nextwhite;
5653 curmad('X', PL_thistoken);
5654 PL_thistoken = newSVpvs("");
5661 /* Guess harder when madskills require "best effort". */
5662 if (PL_madskills && (!gv || !GvCVu(gv))) {
5663 int probable_sub = 0;
5664 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5666 else if (isALPHA(*s)) {
5670 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5671 if (!keyword(tmpbuf, tmplen, 0))
5674 while (d < PL_bufend && isSPACE(*d))
5676 if (*d == '=' && d[1] == '>')
5681 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5682 op_free(pl_yylval.opval);
5683 pl_yylval.opval = rv2cv_op;
5684 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5685 PL_last_lop = PL_oldbufptr;
5686 PL_last_lop_op = OP_ENTERSUB;
5687 PL_nextwhite = PL_thiswhite;
5689 start_force(PL_curforce);
5690 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5692 PL_nextwhite = nextPL_nextwhite;
5693 curmad('X', PL_thistoken);
5694 PL_thistoken = newSVpvs("");
5699 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5706 /* Call it a bare word */
5708 if (PL_hints & HINT_STRICT_SUBS)
5709 pl_yylval.opval->op_private |= OPpCONST_STRICT;
5712 /* after "print" and similar functions (corresponding to
5713 * "F? L" in opcode.pl), whatever wasn't already parsed as
5714 * a filehandle should be subject to "strict subs".
5715 * Likewise for the optional indirect-object argument to system
5716 * or exec, which can't be a bareword */
5717 if ((PL_last_lop_op == OP_PRINT
5718 || PL_last_lop_op == OP_PRTF
5719 || PL_last_lop_op == OP_SAY
5720 || PL_last_lop_op == OP_SYSTEM
5721 || PL_last_lop_op == OP_EXEC)
5722 && (PL_hints & HINT_STRICT_SUBS))
5723 pl_yylval.opval->op_private |= OPpCONST_STRICT;
5724 if (lastchar != '-') {
5725 if (ckWARN(WARN_RESERVED)) {
5729 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5730 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5738 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
5739 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
5740 "Operator or semicolon missing before %c%s",
5741 lastchar, PL_tokenbuf);
5742 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
5743 "Ambiguous use of %c resolved as operator %c",
5744 lastchar, lastchar);
5750 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5751 newSVpv(CopFILE(PL_curcop),0));
5755 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5756 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5759 case KEY___PACKAGE__:
5760 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5762 ? newSVhek(HvNAME_HEK(PL_curstash))
5769 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5770 const char *pname = "main";
5771 if (PL_tokenbuf[2] == 'D')
5772 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5773 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5777 GvIOp(gv) = newIO();
5778 IoIFP(GvIOp(gv)) = PL_rsfp;
5779 #if defined(HAS_FCNTL) && defined(F_SETFD)
5781 const int fd = PerlIO_fileno(PL_rsfp);
5782 fcntl(fd,F_SETFD,fd >= 3);
5785 /* Mark this internal pseudo-handle as clean */
5786 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5787 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5788 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5790 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5791 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5792 /* if the script was opened in binmode, we need to revert
5793 * it to text mode for compatibility; but only iff it has CRs
5794 * XXX this is a questionable hack at best. */
5795 if (PL_bufend-PL_bufptr > 2
5796 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5799 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5800 loc = PerlIO_tell(PL_rsfp);
5801 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5804 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5806 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5807 #endif /* NETWARE */
5808 #ifdef PERLIO_IS_STDIO /* really? */
5809 # if defined(__BORLANDC__)
5810 /* XXX see note in do_binmode() */
5811 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5815 PerlIO_seek(PL_rsfp, loc, 0);
5819 #ifdef PERLIO_LAYERS
5822 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5823 else if (PL_encoding) {
5830 XPUSHs(PL_encoding);
5832 call_method("name", G_SCALAR);
5836 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5837 Perl_form(aTHX_ ":encoding(%"SVf")",
5846 if (PL_realtokenstart >= 0) {
5847 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5849 PL_endwhite = newSVpvs("");
5850 sv_catsv(PL_endwhite, PL_thiswhite);
5852 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5853 PL_realtokenstart = -1;
5855 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
5871 if (PL_expect == XSTATE) {
5878 if (*s == ':' && s[1] == ':') {
5881 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5882 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5883 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5886 else if (tmp == KEY_require || tmp == KEY_do)
5887 /* that's a way to remember we saw "CORE::" */
5900 LOP(OP_ACCEPT,XTERM);
5906 LOP(OP_ATAN2,XTERM);
5912 LOP(OP_BINMODE,XTERM);
5915 LOP(OP_BLESS,XTERM);
5924 /* When 'use switch' is in effect, continue has a dual
5925 life as a control operator. */
5927 if (!FEATURE_IS_ENABLED("switch"))
5930 /* We have to disambiguate the two senses of
5931 "continue". If the next token is a '{' then
5932 treat it as the start of a continue block;
5933 otherwise treat it as a control operator.
5945 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5962 if (!PL_cryptseen) {
5963 PL_cryptseen = TRUE;
5967 LOP(OP_CRYPT,XTERM);
5970 LOP(OP_CHMOD,XTERM);
5973 LOP(OP_CHOWN,XTERM);
5976 LOP(OP_CONNECT,XTERM);
5995 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5996 if (orig_keyword == KEY_do) {
6005 PL_hints |= HINT_BLOCK_SCOPE;
6015 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
6016 LOP(OP_DBMOPEN,XTERM);
6022 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6029 pl_yylval.ival = CopLINE(PL_curcop);
6045 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
6046 UNIBRACK(OP_ENTEREVAL);
6060 case KEY_endhostent:
6066 case KEY_endservent:
6069 case KEY_endprotoent:
6080 pl_yylval.ival = CopLINE(PL_curcop);
6082 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
6085 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
6088 if ((PL_bufend - p) >= 3 &&
6089 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
6091 else if ((PL_bufend - p) >= 4 &&
6092 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
6095 if (isIDFIRST_lazy_if(p,UTF)) {
6096 p = scan_ident(p, PL_bufend,
6097 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
6101 Perl_croak(aTHX_ "Missing $ on loop variable");
6103 s = SvPVX(PL_linestr) + soff;
6109 LOP(OP_FORMLINE,XTERM);
6115 LOP(OP_FCNTL,XTERM);
6121 LOP(OP_FLOCK,XTERM);
6130 LOP(OP_GREPSTART, XREF);
6133 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6148 case KEY_getpriority:
6149 LOP(OP_GETPRIORITY,XTERM);
6151 case KEY_getprotobyname:
6154 case KEY_getprotobynumber:
6155 LOP(OP_GPBYNUMBER,XTERM);
6157 case KEY_getprotoent:
6169 case KEY_getpeername:
6170 UNI(OP_GETPEERNAME);
6172 case KEY_gethostbyname:
6175 case KEY_gethostbyaddr:
6176 LOP(OP_GHBYADDR,XTERM);
6178 case KEY_gethostent:
6181 case KEY_getnetbyname:
6184 case KEY_getnetbyaddr:
6185 LOP(OP_GNBYADDR,XTERM);
6190 case KEY_getservbyname:
6191 LOP(OP_GSBYNAME,XTERM);
6193 case KEY_getservbyport:
6194 LOP(OP_GSBYPORT,XTERM);
6196 case KEY_getservent:
6199 case KEY_getsockname:
6200 UNI(OP_GETSOCKNAME);
6202 case KEY_getsockopt:
6203 LOP(OP_GSOCKOPT,XTERM);
6218 pl_yylval.ival = CopLINE(PL_curcop);
6228 pl_yylval.ival = CopLINE(PL_curcop);
6232 LOP(OP_INDEX,XTERM);
6238 LOP(OP_IOCTL,XTERM);
6250 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6282 LOP(OP_LISTEN,XTERM);
6291 s = scan_pat(s,OP_MATCH);
6292 TERM(sublex_start());
6295 LOP(OP_MAPSTART, XREF);
6298 LOP(OP_MKDIR,XTERM);
6301 LOP(OP_MSGCTL,XTERM);
6304 LOP(OP_MSGGET,XTERM);
6307 LOP(OP_MSGRCV,XTERM);
6310 LOP(OP_MSGSND,XTERM);
6315 PL_in_my = (U16)tmp;
6317 if (isIDFIRST_lazy_if(s,UTF)) {
6321 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6322 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6324 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6325 if (!PL_in_my_stash) {
6328 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6332 if (PL_madskills) { /* just add type to declarator token */
6333 sv_catsv(PL_thistoken, PL_nextwhite);
6335 sv_catpvn(PL_thistoken, start, s - start);
6343 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6350 s = tokenize_use(0, s);
6354 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6361 if (isIDFIRST_lazy_if(s,UTF)) {
6363 for (d = s; isALNUM_lazy_if(d,UTF);)
6365 for (t=d; isSPACE(*t);)
6367 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6369 && !(t[0] == '=' && t[1] == '>')
6371 int parms_len = (int)(d-s);
6372 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6373 "Precedence problem: open %.*s should be open(%.*s)",
6374 parms_len, s, parms_len, s);
6380 pl_yylval.ival = OP_OR;
6390 LOP(OP_OPEN_DIR,XTERM);
6393 checkcomma(s,PL_tokenbuf,"filehandle");
6397 checkcomma(s,PL_tokenbuf,"filehandle");
6416 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6417 s = force_version(s, FALSE);
6421 LOP(OP_PIPE_OP,XTERM);
6424 s = scan_str(s,!!PL_madskills,FALSE);
6427 pl_yylval.ival = OP_CONST;
6428 TERM(sublex_start());
6434 s = scan_str(s,!!PL_madskills,FALSE);
6437 PL_expect = XOPERATOR;
6439 if (SvCUR(PL_lex_stuff)) {
6442 d = SvPV_force(PL_lex_stuff, len);
6444 for (; isSPACE(*d) && len; --len, ++d)
6449 if (!warned && ckWARN(WARN_QW)) {
6450 for (; !isSPACE(*d) && len; --len, ++d) {
6452 Perl_warner(aTHX_ packWARN(WARN_QW),
6453 "Possible attempt to separate words with commas");
6456 else if (*d == '#') {
6457 Perl_warner(aTHX_ packWARN(WARN_QW),
6458 "Possible attempt to put comments in qw() list");
6464 for (; !isSPACE(*d) && len; --len, ++d)
6467 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
6468 words = append_elem(OP_LIST, words,
6469 newSVOP(OP_CONST, 0, tokeq(sv)));
6473 start_force(PL_curforce);
6474 NEXTVAL_NEXTTOKE.opval = words;
6479 SvREFCNT_dec(PL_lex_stuff);
6480 PL_lex_stuff = NULL;
6486 s = scan_str(s,!!PL_madskills,FALSE);
6489 pl_yylval.ival = OP_STRINGIFY;
6490 if (SvIVX(PL_lex_stuff) == '\'')
6491 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6492 TERM(sublex_start());
6495 s = scan_pat(s,OP_QR);
6496 TERM(sublex_start());
6499 s = scan_str(s,!!PL_madskills,FALSE);
6502 readpipe_override();
6503 TERM(sublex_start());
6511 s = force_version(s, FALSE);
6513 else if (*s != 'v' || !isDIGIT(s[1])
6514 || (s = force_version(s, TRUE), *s == 'v'))
6516 *PL_tokenbuf = '\0';
6517 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6518 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6519 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6521 yyerror("<> should be quotes");
6523 if (orig_keyword == KEY_require) {
6531 PL_last_uni = PL_oldbufptr;
6532 PL_last_lop_op = OP_REQUIRE;
6534 return REPORT( (int)REQUIRE );
6540 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6544 LOP(OP_RENAME,XTERM);
6553 LOP(OP_RINDEX,XTERM);
6562 UNIDOR(OP_READLINE);
6565 UNIDOR(OP_BACKTICK);
6574 LOP(OP_REVERSE,XTERM);
6577 UNIDOR(OP_READLINK);
6584 if (pl_yylval.opval)
6585 TERM(sublex_start());
6587 TOKEN(1); /* force error */
6590 checkcomma(s,PL_tokenbuf,"filehandle");
6600 LOP(OP_SELECT,XTERM);
6606 LOP(OP_SEMCTL,XTERM);
6609 LOP(OP_SEMGET,XTERM);
6612 LOP(OP_SEMOP,XTERM);
6618 LOP(OP_SETPGRP,XTERM);
6620 case KEY_setpriority:
6621 LOP(OP_SETPRIORITY,XTERM);
6623 case KEY_sethostent:
6629 case KEY_setservent:
6632 case KEY_setprotoent:
6642 LOP(OP_SEEKDIR,XTERM);
6644 case KEY_setsockopt:
6645 LOP(OP_SSOCKOPT,XTERM);
6651 LOP(OP_SHMCTL,XTERM);
6654 LOP(OP_SHMGET,XTERM);
6657 LOP(OP_SHMREAD,XTERM);
6660 LOP(OP_SHMWRITE,XTERM);
6663 LOP(OP_SHUTDOWN,XTERM);
6672 LOP(OP_SOCKET,XTERM);
6674 case KEY_socketpair:
6675 LOP(OP_SOCKPAIR,XTERM);
6678 checkcomma(s,PL_tokenbuf,"subroutine name");
6680 if (*s == ';' || *s == ')') /* probably a close */
6681 Perl_croak(aTHX_ "sort is now a reserved word");
6683 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6687 LOP(OP_SPLIT,XTERM);
6690 LOP(OP_SPRINTF,XTERM);
6693 LOP(OP_SPLICE,XTERM);
6708 LOP(OP_SUBSTR,XTERM);
6714 char tmpbuf[sizeof PL_tokenbuf];
6715 SSize_t tboffset = 0;
6716 expectation attrful;
6717 bool have_name, have_proto;
6718 const int key = tmp;
6723 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6724 SV *subtoken = newSVpvn(tstart, s - tstart);
6728 s = SKIPSPACE2(s,tmpwhite);
6733 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6734 (*s == ':' && s[1] == ':'))
6737 SV *nametoke = NULL;
6741 attrful = XATTRBLOCK;
6742 /* remember buffer pos'n for later force_word */
6743 tboffset = s - PL_oldbufptr;
6744 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6747 nametoke = newSVpvn(s, d - s);
6749 if (memchr(tmpbuf, ':', len))
6750 sv_setpvn(PL_subname, tmpbuf, len);
6752 sv_setsv(PL_subname,PL_curstname);
6753 sv_catpvs(PL_subname,"::");
6754 sv_catpvn(PL_subname,tmpbuf,len);
6761 CURMAD('X', nametoke);
6762 CURMAD('_', tmpwhite);
6763 (void) force_word(PL_oldbufptr + tboffset, WORD,
6766 s = SKIPSPACE2(d,tmpwhite);
6773 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6774 PL_expect = XTERMBLOCK;
6775 attrful = XATTRTERM;
6776 sv_setpvs(PL_subname,"?");
6780 if (key == KEY_format) {
6782 PL_lex_formbrack = PL_lex_brackets + 1;
6784 PL_thistoken = subtoken;
6788 (void) force_word(PL_oldbufptr + tboffset, WORD,
6794 /* Look for a prototype */
6797 bool bad_proto = FALSE;
6798 bool in_brackets = FALSE;
6799 char greedy_proto = ' ';
6800 bool proto_after_greedy_proto = FALSE;
6801 bool must_be_last = FALSE;
6802 bool underscore = FALSE;
6803 bool seen_underscore = FALSE;
6804 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6806 s = scan_str(s,!!PL_madskills,FALSE);
6808 Perl_croak(aTHX_ "Prototype not terminated");
6809 /* strip spaces and check for bad characters */
6810 d = SvPVX(PL_lex_stuff);
6812 for (p = d; *p; ++p) {
6818 proto_after_greedy_proto = TRUE;
6819 if (!strchr("$@%*;[]&\\_", *p)) {
6831 else if ( *p == ']' ) {
6832 in_brackets = FALSE;
6834 else if ( (*p == '@' || *p == '%') &&
6835 ( tmp < 2 || d[tmp-2] != '\\' ) &&
6837 must_be_last = TRUE;
6840 else if ( *p == '_' ) {
6841 underscore = seen_underscore = TRUE;
6848 if (proto_after_greedy_proto)
6849 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6850 "Prototype after '%c' for %"SVf" : %s",
6851 greedy_proto, SVfARG(PL_subname), d);
6853 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6854 "Illegal character %sin prototype for %"SVf" : %s",
6855 seen_underscore ? "after '_' " : "",
6856 SVfARG(PL_subname), d);
6857 SvCUR_set(PL_lex_stuff, tmp);
6862 CURMAD('q', PL_thisopen);
6863 CURMAD('_', tmpwhite);
6864 CURMAD('=', PL_thisstuff);
6865 CURMAD('Q', PL_thisclose);
6866 NEXTVAL_NEXTTOKE.opval =
6867 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6868 PL_lex_stuff = NULL;
6871 s = SKIPSPACE2(s,tmpwhite);
6879 if (*s == ':' && s[1] != ':')
6880 PL_expect = attrful;
6881 else if (*s != '{' && key == KEY_sub) {
6883 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6885 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6892 curmad('^', newSVpvs(""));
6893 CURMAD('_', tmpwhite);
6897 PL_thistoken = subtoken;
6900 NEXTVAL_NEXTTOKE.opval =
6901 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6902 PL_lex_stuff = NULL;
6908 sv_setpvs(PL_subname, "__ANON__");
6910 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6914 (void) force_word(PL_oldbufptr + tboffset, WORD,
6923 LOP(OP_SYSTEM,XREF);
6926 LOP(OP_SYMLINK,XTERM);
6929 LOP(OP_SYSCALL,XTERM);
6932 LOP(OP_SYSOPEN,XTERM);
6935 LOP(OP_SYSSEEK,XTERM);
6938 LOP(OP_SYSREAD,XTERM);
6941 LOP(OP_SYSWRITE,XTERM);
6945 TERM(sublex_start());
6966 LOP(OP_TRUNCATE,XTERM);
6978 pl_yylval.ival = CopLINE(PL_curcop);
6982 pl_yylval.ival = CopLINE(PL_curcop);
6986 LOP(OP_UNLINK,XTERM);
6992 LOP(OP_UNPACK,XTERM);
6995 LOP(OP_UTIME,XTERM);
7001 LOP(OP_UNSHIFT,XTERM);
7004 s = tokenize_use(1, s);
7014 pl_yylval.ival = CopLINE(PL_curcop);
7018 pl_yylval.ival = CopLINE(PL_curcop);
7022 PL_hints |= HINT_BLOCK_SCOPE;
7029 LOP(OP_WAITPID,XTERM);
7038 ctl_l[0] = toCTRL('L');
7040 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
7043 /* Make sure $^L is defined */
7044 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
7049 if (PL_expect == XOPERATOR)
7055 pl_yylval.ival = OP_XOR;
7060 TERM(sublex_start());
7065 #pragma segment Main
7069 S_pending_ident(pTHX)
7074 /* pit holds the identifier we read and pending_ident is reset */
7075 char pit = PL_pending_ident;
7076 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
7077 /* All routes through this function want to know if there is a colon. */
7078 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
7079 PL_pending_ident = 0;
7081 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
7082 DEBUG_T({ PerlIO_printf(Perl_debug_log,
7083 "### Pending identifier '%s'\n", PL_tokenbuf); });
7085 /* if we're in a my(), we can't allow dynamics here.
7086 $foo'bar has already been turned into $foo::bar, so
7087 just check for colons.
7089 if it's a legal name, the OP is a PADANY.
7092 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
7094 yyerror(Perl_form(aTHX_ "No package name allowed for "
7095 "variable %s in \"our\"",
7097 tmp = allocmy(PL_tokenbuf, tokenbuf_len, 0);
7101 yyerror(Perl_form(aTHX_ PL_no_myglob,
7102 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
7104 pl_yylval.opval = newOP(OP_PADANY, 0);
7105 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len, 0);
7111 build the ops for accesses to a my() variable.
7113 Deny my($a) or my($b) in a sort block, *if* $a or $b is
7114 then used in a comparison. This catches most, but not
7115 all cases. For instance, it catches
7116 sort { my($a); $a <=> $b }
7118 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
7119 (although why you'd do that is anyone's guess).
7124 tmp = pad_findmy(PL_tokenbuf, tokenbuf_len, 0);
7125 if (tmp != NOT_IN_PAD) {
7126 /* might be an "our" variable" */
7127 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
7128 /* build ops for a bareword */
7129 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
7130 HEK * const stashname = HvNAME_HEK(stash);
7131 SV * const sym = newSVhek(stashname);
7132 sv_catpvs(sym, "::");
7133 sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
7134 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
7135 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7138 ? (GV_ADDMULTI | GV_ADDINEVAL)
7141 ((PL_tokenbuf[0] == '$') ? SVt_PV
7142 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7147 /* if it's a sort block and they're naming $a or $b */
7148 if (PL_last_lop_op == OP_SORT &&
7149 PL_tokenbuf[0] == '$' &&
7150 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
7153 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
7154 d < PL_bufend && *d != '\n';
7157 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
7158 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
7164 pl_yylval.opval = newOP(OP_PADANY, 0);
7165 pl_yylval.opval->op_targ = tmp;
7171 Whine if they've said @foo in a doublequoted string,
7172 and @foo isn't a variable we can find in the symbol
7175 if (ckWARN(WARN_AMBIGUOUS) &&
7176 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
7177 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
7179 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
7180 /* DO NOT warn for @- and @+ */
7181 && !( PL_tokenbuf[2] == '\0' &&
7182 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
7185 /* Downgraded from fatal to warning 20000522 mjd */
7186 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7187 "Possible unintended interpolation of %s in string",
7192 /* build ops for a bareword */
7193 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
7195 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7197 PL_tokenbuf + 1, tokenbuf_len - 1,
7198 /* If the identifier refers to a stash, don't autovivify it.
7199 * Change 24660 had the side effect of causing symbol table
7200 * hashes to always be defined, even if they were freshly
7201 * created and the only reference in the entire program was
7202 * the single statement with the defined %foo::bar:: test.
7203 * It appears that all code in the wild doing this actually
7204 * wants to know whether sub-packages have been loaded, so
7205 * by avoiding auto-vivifying symbol tables, we ensure that
7206 * defined %foo::bar:: continues to be false, and the existing
7207 * tests still give the expected answers, even though what
7208 * they're actually testing has now changed subtly.
7210 (*PL_tokenbuf == '%'
7211 && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
7214 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7215 ((PL_tokenbuf[0] == '$') ? SVt_PV
7216 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7222 * The following code was generated by perl_keyword.pl.
7226 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7230 PERL_ARGS_ASSERT_KEYWORD;
7234 case 1: /* 5 tokens of length 1 */
7266 case 2: /* 18 tokens of length 2 */
7412 case 3: /* 29 tokens of length 3 */
7416 if (name[1] == 'N' &&
7479 if (name[1] == 'i' &&
7511 if (name[1] == 'o' &&
7520 if (name[1] == 'e' &&
7529 if (name[1] == 'n' &&
7538 if (name[1] == 'o' &&
7547 if (name[1] == 'a' &&
7556 if (name[1] == 'o' &&
7618 if (name[1] == 'e' &&
7632 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7658 if (name[1] == 'i' &&
7667 if (name[1] == 's' &&
7676 if (name[1] == 'e' &&
7685 if (name[1] == 'o' &&
7697 case 4: /* 41 tokens of length 4 */
7701 if (name[1] == 'O' &&
7711 if (name[1] == 'N' &&
7721 if (name[1] == 'i' &&
7731 if (name[1] == 'h' &&
7741 if (name[1] == 'u' &&
7754 if (name[2] == 'c' &&
7763 if (name[2] == 's' &&
7772 if (name[2] == 'a' &&
7808 if (name[1] == 'o' &&
7821 if (name[2] == 't' &&
7830 if (name[2] == 'o' &&
7839 if (name[2] == 't' &&
7848 if (name[2] == 'e' &&
7861 if (name[1] == 'o' &&
7874 if (name[2] == 'y' &&
7883 if (name[2] == 'l' &&
7899 if (name[2] == 's' &&
7908 if (name[2] == 'n' &&
7917 if (name[2] == 'c' &&
7930 if (name[1] == 'e' &&
7940 if (name[1] == 'p' &&
7953 if (name[2] == 'c' &&
7962 if (name[2] == 'p' &&
7971 if (name[2] == 's' &&
7987 if (name[2] == 'n' &&
8057 if (name[2] == 'r' &&
8066 if (name[2] == 'r' &&
8075 if (name[2] == 'a' &&
8091 if (name[2] == 'l' &&
8153 if (name[2] == 'e' &&
8156 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
8169 case 5: /* 39 tokens of length 5 */
8173 if (name[1] == 'E' &&
8184 if (name[1] == 'H' &&
8198 if (name[2] == 'a' &&
8208 if (name[2] == 'a' &&
8225 if (name[2] == 'e' &&
8235 if (name[2] == 'e' &&
8239 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8255 if (name[3] == 'i' &&
8264 if (name[3] == 'o' &&
8300 if (name[2] == 'o' &&
8310 if (name[2] == 'y' &&
8324 if (name[1] == 'l' &&
8338 if (name[2] == 'n' &&
8348 if (name[2] == 'o' &&
8362 if (name[1] == 'i' &&
8367 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8376 if (name[2] == 'd' &&
8386 if (name[2] == 'c' &&
8403 if (name[2] == 'c' &&
8413 if (name[2] == 't' &&
8427 if (name[1] == 'k' &&
8438 if (name[1] == 'r' &&
8452 if (name[2] == 's' &&
8462 if (name[2] == 'd' &&
8479 if (name[2] == 'm' &&
8489 if (name[2] == 'i' &&
8499 if (name[2] == 'e' &&
8509 if (name[2] == 'l' &&
8519 if (name[2] == 'a' &&
8532 if (name[3] == 't' &&
8535 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8541 if (name[3] == 'd' &&
8558 if (name[1] == 'i' &&
8572 if (name[2] == 'a' &&
8585 if (name[3] == 'e' &&
8620 if (name[2] == 'i' &&
8637 if (name[2] == 'i' &&
8647 if (name[2] == 'i' &&
8664 case 6: /* 33 tokens of length 6 */
8668 if (name[1] == 'c' &&
8683 if (name[2] == 'l' &&
8694 if (name[2] == 'r' &&
8709 if (name[1] == 'e' &&
8724 if (name[2] == 's' &&
8729 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8735 if (name[2] == 'i' &&
8753 if (name[2] == 'l' &&
8764 if (name[2] == 'r' &&
8779 if (name[1] == 'm' &&
8794 if (name[2] == 'n' &&
8805 if (name[2] == 's' &&
8820 if (name[1] == 's' &&
8826 if (name[4] == 't' &&
8835 if (name[4] == 'e' &&
8844 if (name[4] == 'c' &&
8853 if (name[4] == 'n' &&
8869 if (name[1] == 'r' &&
8887 if (name[3] == 'a' &&
8897 if (name[3] == 'u' &&
8911 if (name[2] == 'n' &&
8929 if (name[2] == 'a' &&
8943 if (name[3] == 'e' &&
8956 if (name[4] == 't' &&
8965 if (name[4] == 'e' &&
8987 if (name[4] == 't' &&
8996 if (name[4] == 'e' &&
9012 if (name[2] == 'c' &&
9023 if (name[2] == 'l' &&
9034 if (name[2] == 'b' &&
9045 if (name[2] == 's' &&
9068 if (name[4] == 's' &&
9077 if (name[4] == 'n' &&
9090 if (name[3] == 'a' &&
9107 if (name[1] == 'a' &&
9122 case 7: /* 29 tokens of length 7 */
9126 if (name[1] == 'E' &&
9139 if (name[1] == '_' &&
9152 if (name[1] == 'i' &&
9159 return -KEY_binmode;
9165 if (name[1] == 'o' &&
9172 return -KEY_connect;
9181 if (name[2] == 'm' &&
9187 return -KEY_dbmopen;
9198 if (name[4] == 'u' &&
9202 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9208 if (name[4] == 'n' &&
9229 if (name[1] == 'o' &&
9242 if (name[1] == 'e' &&
9249 if (name[5] == 'r' &&
9252 return -KEY_getpgrp;
9258 if (name[5] == 'i' &&
9261 return -KEY_getppid;
9274 if (name[1] == 'c' &&
9281 return -KEY_lcfirst;
9287 if (name[1] == 'p' &&
9294 return -KEY_opendir;
9300 if (name[1] == 'a' &&
9318 if (name[3] == 'd' &&
9323 return -KEY_readdir;
9329 if (name[3] == 'u' &&
9340 if (name[3] == 'e' &&
9345 return -KEY_reverse;
9364 if (name[3] == 'k' &&
9369 return -KEY_seekdir;
9375 if (name[3] == 'p' &&
9380 return -KEY_setpgrp;
9390 if (name[2] == 'm' &&
9396 return -KEY_shmread;
9402 if (name[2] == 'r' &&
9408 return -KEY_sprintf;
9417 if (name[3] == 'l' &&
9422 return -KEY_symlink;
9431 if (name[4] == 'a' &&
9435 return -KEY_syscall;
9441 if (name[4] == 'p' &&
9445 return -KEY_sysopen;
9451 if (name[4] == 'e' &&
9455 return -KEY_sysread;
9461 if (name[4] == 'e' &&
9465 return -KEY_sysseek;
9483 if (name[1] == 'e' &&
9490 return -KEY_telldir;
9499 if (name[2] == 'f' &&
9505 return -KEY_ucfirst;
9511 if (name[2] == 's' &&
9517 return -KEY_unshift;
9527 if (name[1] == 'a' &&
9534 return -KEY_waitpid;
9543 case 8: /* 26 tokens of length 8 */
9547 if (name[1] == 'U' &&
9555 return KEY_AUTOLOAD;
9566 if (name[3] == 'A' &&
9572 return KEY___DATA__;
9578 if (name[3] == 'I' &&
9584 return -KEY___FILE__;
9590 if (name[3] == 'I' &&
9596 return -KEY___LINE__;
9612 if (name[2] == 'o' &&
9619 return -KEY_closedir;
9625 if (name[2] == 'n' &&
9632 return -KEY_continue;
9642 if (name[1] == 'b' &&
9650 return -KEY_dbmclose;
9656 if (name[1] == 'n' &&
9662 if (name[4] == 'r' &&
9667 return -KEY_endgrent;
9673 if (name[4] == 'w' &&
9678 return -KEY_endpwent;
9691 if (name[1] == 'o' &&
9699 return -KEY_formline;
9705 if (name[1] == 'e' &&
9716 if (name[6] == 'n' &&
9719 return -KEY_getgrent;
9725 if (name[6] == 'i' &&
9728 return -KEY_getgrgid;
9734 if (name[6] == 'a' &&
9737 return -KEY_getgrnam;
9750 if (name[4] == 'o' &&
9755 return -KEY_getlogin;
9766 if (name[6] == 'n' &&
9769 return -KEY_getpwent;
9775 if (name[6] == 'a' &&
9778 return -KEY_getpwnam;
9784 if (name[6] == 'i' &&
9787 return -KEY_getpwuid;
9807 if (name[1] == 'e' &&
9814 if (name[5] == 'i' &&
9821 return -KEY_readline;
9826 return -KEY_readlink;
9837 if (name[5] == 'i' &&
9841 return -KEY_readpipe;
9862 if (name[4] == 'r' &&
9867 return -KEY_setgrent;
9873 if (name[4] == 'w' &&
9878 return -KEY_setpwent;
9894 if (name[3] == 'w' &&
9900 return -KEY_shmwrite;
9906 if (name[3] == 't' &&
9912 return -KEY_shutdown;
9922 if (name[2] == 's' &&
9929 return -KEY_syswrite;
9939 if (name[1] == 'r' &&
9947 return -KEY_truncate;
9956 case 9: /* 9 tokens of length 9 */
9960 if (name[1] == 'N' &&
9969 return KEY_UNITCHECK;
9975 if (name[1] == 'n' &&
9984 return -KEY_endnetent;
9990 if (name[1] == 'e' &&
9999 return -KEY_getnetent;
10005 if (name[1] == 'o' &&
10014 return -KEY_localtime;
10020 if (name[1] == 'r' &&
10029 return KEY_prototype;
10035 if (name[1] == 'u' &&
10044 return -KEY_quotemeta;
10050 if (name[1] == 'e' &&
10059 return -KEY_rewinddir;
10065 if (name[1] == 'e' &&
10074 return -KEY_setnetent;
10080 if (name[1] == 'a' &&
10089 return -KEY_wantarray;
10098 case 10: /* 9 tokens of length 10 */
10102 if (name[1] == 'n' &&
10108 if (name[4] == 'o' &&
10115 return -KEY_endhostent;
10121 if (name[4] == 'e' &&
10128 return -KEY_endservent;
10141 if (name[1] == 'e' &&
10147 if (name[4] == 'o' &&
10154 return -KEY_gethostent;
10163 if (name[5] == 'r' &&
10169 return -KEY_getservent;
10175 if (name[5] == 'c' &&
10181 return -KEY_getsockopt;
10201 if (name[2] == 't')
10206 if (name[4] == 'o' &&
10213 return -KEY_sethostent;
10222 if (name[5] == 'r' &&
10228 return -KEY_setservent;
10234 if (name[5] == 'c' &&
10240 return -KEY_setsockopt;
10257 if (name[2] == 'c' &&
10266 return -KEY_socketpair;
10279 case 11: /* 8 tokens of length 11 */
10283 if (name[1] == '_' &&
10293 { /* __PACKAGE__ */
10294 return -KEY___PACKAGE__;
10300 if (name[1] == 'n' &&
10310 { /* endprotoent */
10311 return -KEY_endprotoent;
10317 if (name[1] == 'e' &&
10326 if (name[5] == 'e' &&
10332 { /* getpeername */
10333 return -KEY_getpeername;
10342 if (name[6] == 'o' &&
10347 { /* getpriority */
10348 return -KEY_getpriority;
10354 if (name[6] == 't' &&
10359 { /* getprotoent */
10360 return -KEY_getprotoent;
10374 if (name[4] == 'o' &&
10381 { /* getsockname */
10382 return -KEY_getsockname;
10395 if (name[1] == 'e' &&
10403 if (name[6] == 'o' &&
10408 { /* setpriority */
10409 return -KEY_setpriority;
10415 if (name[6] == 't' &&
10420 { /* setprotoent */
10421 return -KEY_setprotoent;
10437 case 12: /* 2 tokens of length 12 */
10438 if (name[0] == 'g' &&
10450 if (name[9] == 'd' &&
10453 { /* getnetbyaddr */
10454 return -KEY_getnetbyaddr;
10460 if (name[9] == 'a' &&
10463 { /* getnetbyname */
10464 return -KEY_getnetbyname;
10476 case 13: /* 4 tokens of length 13 */
10477 if (name[0] == 'g' &&
10484 if (name[4] == 'o' &&
10493 if (name[10] == 'd' &&
10496 { /* gethostbyaddr */
10497 return -KEY_gethostbyaddr;
10503 if (name[10] == 'a' &&
10506 { /* gethostbyname */
10507 return -KEY_gethostbyname;
10520 if (name[4] == 'e' &&
10529 if (name[10] == 'a' &&
10532 { /* getservbyname */
10533 return -KEY_getservbyname;
10539 if (name[10] == 'o' &&
10542 { /* getservbyport */
10543 return -KEY_getservbyport;
10562 case 14: /* 1 tokens of length 14 */
10563 if (name[0] == 'g' &&
10577 { /* getprotobyname */
10578 return -KEY_getprotobyname;
10583 case 16: /* 1 tokens of length 16 */
10584 if (name[0] == 'g' &&
10600 { /* getprotobynumber */
10601 return -KEY_getprotobynumber;
10615 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10619 PERL_ARGS_ASSERT_CHECKCOMMA;
10621 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10622 if (ckWARN(WARN_SYNTAX)) {
10625 for (w = s+2; *w && level; w++) {
10628 else if (*w == ')')
10631 while (isSPACE(*w))
10633 /* the list of chars below is for end of statements or
10634 * block / parens, boolean operators (&&, ||, //) and branch
10635 * constructs (or, and, if, until, unless, while, err, for).
10636 * Not a very solid hack... */
10637 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
10638 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10639 "%s (...) interpreted as function",name);
10642 while (s < PL_bufend && isSPACE(*s))
10646 while (s < PL_bufend && isSPACE(*s))
10648 if (isIDFIRST_lazy_if(s,UTF)) {
10649 const char * const w = s++;
10650 while (isALNUM_lazy_if(s,UTF))
10652 while (s < PL_bufend && isSPACE(*s))
10656 if (keyword(w, s - w, 0))
10659 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10660 if (gv && GvCVu(gv))
10662 Perl_croak(aTHX_ "No comma allowed after %s", what);
10667 /* Either returns sv, or mortalizes sv and returns a new SV*.
10668 Best used as sv=new_constant(..., sv, ...).
10669 If s, pv are NULL, calls subroutine with one argument,
10670 and type is used with error messages only. */
10673 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
10674 SV *sv, SV *pv, const char *type, STRLEN typelen)
10677 HV * const table = GvHV(PL_hintgv); /* ^H */
10681 const char *why1 = "", *why2 = "", *why3 = "";
10683 PERL_ARGS_ASSERT_NEW_CONSTANT;
10685 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10688 why2 = (const char *)
10689 (strEQ(key,"charnames")
10690 ? "(possibly a missing \"use charnames ...\")"
10692 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10693 (type ? type: "undef"), why2);
10695 /* This is convoluted and evil ("goto considered harmful")
10696 * but I do not understand the intricacies of all the different
10697 * failure modes of %^H in here. The goal here is to make
10698 * the most probable error message user-friendly. --jhi */
10703 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10704 (type ? type: "undef"), why1, why2, why3);
10706 yyerror(SvPVX_const(msg));
10710 cvp = hv_fetch(table, key, keylen, FALSE);
10711 if (!cvp || !SvOK(*cvp)) {
10714 why3 = "} is not defined";
10717 sv_2mortal(sv); /* Parent created it permanently */
10720 pv = newSVpvn_flags(s, len, SVs_TEMP);
10722 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
10724 typesv = &PL_sv_undef;
10726 PUSHSTACKi(PERLSI_OVERLOAD);
10738 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10742 /* Check the eval first */
10743 if (!PL_in_eval && SvTRUE(ERRSV)) {
10744 sv_catpvs(ERRSV, "Propagated");
10745 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10747 res = SvREFCNT_inc_simple(sv);
10751 SvREFCNT_inc_simple_void(res);
10760 why1 = "Call to &{$^H{";
10762 why3 = "}} did not return a defined value";
10770 /* Returns a NUL terminated string, with the length of the string written to
10774 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10777 register char *d = dest;
10778 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10780 PERL_ARGS_ASSERT_SCAN_WORD;
10784 Perl_croak(aTHX_ ident_too_long);
10785 if (isALNUM(*s)) /* UTF handled below */
10787 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10792 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10796 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10797 char *t = s + UTF8SKIP(s);
10799 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10803 Perl_croak(aTHX_ ident_too_long);
10804 Copy(s, d, len, char);
10817 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10820 char *bracket = NULL;
10822 register char *d = dest;
10823 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10825 PERL_ARGS_ASSERT_SCAN_IDENT;
10830 while (isDIGIT(*s)) {
10832 Perl_croak(aTHX_ ident_too_long);
10839 Perl_croak(aTHX_ ident_too_long);
10840 if (isALNUM(*s)) /* UTF handled below */
10842 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10847 else if (*s == ':' && s[1] == ':') {
10851 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10852 char *t = s + UTF8SKIP(s);
10853 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10855 if (d + (t - s) > e)
10856 Perl_croak(aTHX_ ident_too_long);
10857 Copy(s, d, t - s, char);
10868 if (PL_lex_state != LEX_NORMAL)
10869 PL_lex_state = LEX_INTERPENDMAYBE;
10872 if (*s == '$' && s[1] &&
10873 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10886 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10891 if (isSPACE(s[-1])) {
10893 const char ch = *s++;
10894 if (!SPACE_OR_TAB(ch)) {
10900 if (isIDFIRST_lazy_if(d,UTF)) {
10904 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10905 end += UTF8SKIP(end);
10906 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10907 end += UTF8SKIP(end);
10909 Copy(s, d, end - s, char);
10914 while ((isALNUM(*s) || *s == ':') && d < e)
10917 Perl_croak(aTHX_ ident_too_long);
10920 while (s < send && SPACE_OR_TAB(*s))
10922 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10923 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10924 const char * const brack =
10926 ((*s == '[') ? "[...]" : "{...}");
10927 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10928 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10929 funny, dest, brack, funny, dest, brack);
10932 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10936 /* Handle extended ${^Foo} variables
10937 * 1999-02-27 mjd-perl-patch@plover.com */
10938 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10942 while (isALNUM(*s) && d < e) {
10946 Perl_croak(aTHX_ ident_too_long);
10951 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10952 PL_lex_state = LEX_INTERPEND;
10955 if (PL_lex_state == LEX_NORMAL) {
10956 if (ckWARN(WARN_AMBIGUOUS) &&
10957 (keyword(dest, d - dest, 0)
10958 || get_cvn_flags(dest, d - dest, 0)))
10962 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10963 "Ambiguous use of %c{%s} resolved to %c%s",
10964 funny, dest, funny, dest);
10969 s = bracket; /* let the parser handle it */
10973 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10974 PL_lex_state = LEX_INTERPEND;
10979 S_pmflag(U32 pmfl, const char ch) {
10981 CASE_STD_PMMOD_FLAGS_PARSE_SET(&pmfl);
10982 case GLOBAL_PAT_MOD: pmfl |= PMf_GLOBAL; break;
10983 case CONTINUE_PAT_MOD: pmfl |= PMf_CONTINUE; break;
10984 case ONCE_PAT_MOD: pmfl |= PMf_KEEP; break;
10985 case KEEPCOPY_PAT_MOD: pmfl |= PMf_KEEPCOPY; break;
10991 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10993 PERL_ARGS_ASSERT_PMFLAG;
10995 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
10996 "Perl_pmflag() is deprecated, and will be removed from the XS API");
10999 *pmfl = S_pmflag(*pmfl, (char)ch);
11004 S_scan_pat(pTHX_ char *start, I32 type)
11008 char *s = scan_str(start,!!PL_madskills,FALSE);
11009 const char * const valid_flags =
11010 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
11015 PERL_ARGS_ASSERT_SCAN_PAT;
11018 const char * const delimiter = skipspace(start);
11022 ? "Search pattern not terminated or ternary operator parsed as search pattern"
11023 : "Search pattern not terminated" ));
11026 pm = (PMOP*)newPMOP(type, 0);
11027 if (PL_multi_open == '?') {
11028 /* This is the only point in the code that sets PMf_ONCE: */
11029 pm->op_pmflags |= PMf_ONCE;
11031 /* Hence it's safe to do this bit of PMOP book-keeping here, which
11032 allows us to restrict the list needed by reset to just the ??
11034 assert(type != OP_TRANS);
11036 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
11039 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
11042 elements = mg->mg_len / sizeof(PMOP**);
11043 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
11044 ((PMOP**)mg->mg_ptr) [elements++] = pm;
11045 mg->mg_len = elements * sizeof(PMOP**);
11046 PmopSTASH_set(pm,PL_curstash);
11052 while (*s && strchr(valid_flags, *s))
11053 pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
11055 if (PL_madskills && modstart != s) {
11056 SV* tmptoken = newSVpvn(modstart, s - modstart);
11057 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
11060 /* issue a warning if /c is specified,but /g is not */
11061 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
11063 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11064 "Use of /c modifier is meaningless without /g" );
11067 PL_lex_op = (OP*)pm;
11068 pl_yylval.ival = OP_MATCH;
11073 S_scan_subst(pTHX_ char *start)
11084 PERL_ARGS_ASSERT_SCAN_SUBST;
11086 pl_yylval.ival = OP_NULL;
11088 s = scan_str(start,!!PL_madskills,FALSE);
11091 Perl_croak(aTHX_ "Substitution pattern not terminated");
11093 if (s[-1] == PL_multi_open)
11096 if (PL_madskills) {
11097 CURMAD('q', PL_thisopen);
11098 CURMAD('_', PL_thiswhite);
11099 CURMAD('E', PL_thisstuff);
11100 CURMAD('Q', PL_thisclose);
11101 PL_realtokenstart = s - SvPVX(PL_linestr);
11105 first_start = PL_multi_start;
11106 s = scan_str(s,!!PL_madskills,FALSE);
11108 if (PL_lex_stuff) {
11109 SvREFCNT_dec(PL_lex_stuff);
11110 PL_lex_stuff = NULL;
11112 Perl_croak(aTHX_ "Substitution replacement not terminated");
11114 PL_multi_start = first_start; /* so whole substitution is taken together */
11116 pm = (PMOP*)newPMOP(OP_SUBST, 0);
11119 if (PL_madskills) {
11120 CURMAD('z', PL_thisopen);
11121 CURMAD('R', PL_thisstuff);
11122 CURMAD('Z', PL_thisclose);
11128 if (*s == EXEC_PAT_MOD) {
11132 else if (strchr(S_PAT_MODS, *s))
11133 pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
11139 if (PL_madskills) {
11141 curmad('m', newSVpvn(modstart, s - modstart));
11142 append_madprops(PL_thismad, (OP*)pm, 0);
11146 if ((pm->op_pmflags & PMf_CONTINUE)) {
11147 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
11151 SV * const repl = newSVpvs("");
11153 PL_sublex_info.super_bufptr = s;
11154 PL_sublex_info.super_bufend = PL_bufend;
11156 pm->op_pmflags |= PMf_EVAL;
11159 sv_catpvs(repl, "eval ");
11161 sv_catpvs(repl, "do ");
11163 sv_catpvs(repl, "{");
11164 sv_catsv(repl, PL_lex_repl);
11165 if (strchr(SvPVX(PL_lex_repl), '#'))
11166 sv_catpvs(repl, "\n");
11167 sv_catpvs(repl, "}");
11169 SvREFCNT_dec(PL_lex_repl);
11170 PL_lex_repl = repl;
11173 PL_lex_op = (OP*)pm;
11174 pl_yylval.ival = OP_SUBST;
11179 S_scan_trans(pTHX_ char *start)
11192 PERL_ARGS_ASSERT_SCAN_TRANS;
11194 pl_yylval.ival = OP_NULL;
11196 s = scan_str(start,!!PL_madskills,FALSE);
11198 Perl_croak(aTHX_ "Transliteration pattern not terminated");
11200 if (s[-1] == PL_multi_open)
11203 if (PL_madskills) {
11204 CURMAD('q', PL_thisopen);
11205 CURMAD('_', PL_thiswhite);
11206 CURMAD('E', PL_thisstuff);
11207 CURMAD('Q', PL_thisclose);
11208 PL_realtokenstart = s - SvPVX(PL_linestr);
11212 s = scan_str(s,!!PL_madskills,FALSE);
11214 if (PL_lex_stuff) {
11215 SvREFCNT_dec(PL_lex_stuff);
11216 PL_lex_stuff = NULL;
11218 Perl_croak(aTHX_ "Transliteration replacement not terminated");
11220 if (PL_madskills) {
11221 CURMAD('z', PL_thisopen);
11222 CURMAD('R', PL_thisstuff);
11223 CURMAD('Z', PL_thisclose);
11226 complement = del = squash = 0;
11233 complement = OPpTRANS_COMPLEMENT;
11236 del = OPpTRANS_DELETE;
11239 squash = OPpTRANS_SQUASH;
11248 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11249 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11250 o->op_private &= ~OPpTRANS_ALL;
11251 o->op_private |= del|squash|complement|
11252 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11253 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11256 pl_yylval.ival = OP_TRANS;
11259 if (PL_madskills) {
11261 curmad('m', newSVpvn(modstart, s - modstart));
11262 append_madprops(PL_thismad, o, 0);
11271 S_scan_heredoc(pTHX_ register char *s)
11275 I32 op_type = OP_SCALAR;
11279 const char *found_newline;
11283 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11285 I32 stuffstart = s - SvPVX(PL_linestr);
11288 PL_realtokenstart = -1;
11291 PERL_ARGS_ASSERT_SCAN_HEREDOC;
11295 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11299 while (SPACE_OR_TAB(*peek))
11301 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11304 s = delimcpy(d, e, s, PL_bufend, term, &len);
11314 if (!isALNUM_lazy_if(s,UTF))
11315 deprecate("bare << to mean <<\"\"");
11316 for (; isALNUM_lazy_if(s,UTF); s++) {
11321 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11322 Perl_croak(aTHX_ "Delimiter for here document is too long");
11325 len = d - PL_tokenbuf;
11328 if (PL_madskills) {
11329 tstart = PL_tokenbuf + !outer;
11330 PL_thisclose = newSVpvn(tstart, len - !outer);
11331 tstart = SvPVX(PL_linestr) + stuffstart;
11332 PL_thisopen = newSVpvn(tstart, s - tstart);
11333 stuffstart = s - SvPVX(PL_linestr);
11336 #ifndef PERL_STRICT_CR
11337 d = strchr(s, '\r');
11339 char * const olds = s;
11341 while (s < PL_bufend) {
11347 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11356 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11363 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11364 herewas = newSVpvn(s,PL_bufend-s);
11368 herewas = newSVpvn(s-1,found_newline-s+1);
11371 herewas = newSVpvn(s,found_newline-s);
11375 if (PL_madskills) {
11376 tstart = SvPVX(PL_linestr) + stuffstart;
11378 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11380 PL_thisstuff = newSVpvn(tstart, s - tstart);
11383 s += SvCUR(herewas);
11386 stuffstart = s - SvPVX(PL_linestr);
11392 tmpstr = newSV_type(SVt_PVIV);
11393 SvGROW(tmpstr, 80);
11394 if (term == '\'') {
11395 op_type = OP_CONST;
11396 SvIV_set(tmpstr, -1);
11398 else if (term == '`') {
11399 op_type = OP_BACKTICK;
11400 SvIV_set(tmpstr, '\\');
11404 PL_multi_start = CopLINE(PL_curcop);
11405 PL_multi_open = PL_multi_close = '<';
11406 term = *PL_tokenbuf;
11407 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11408 char * const bufptr = PL_sublex_info.super_bufptr;
11409 char * const bufend = PL_sublex_info.super_bufend;
11410 char * const olds = s - SvCUR(herewas);
11411 s = strchr(bufptr, '\n');
11415 while (s < bufend &&
11416 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11418 CopLINE_inc(PL_curcop);
11421 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11422 missingterm(PL_tokenbuf);
11424 sv_setpvn(herewas,bufptr,d-bufptr+1);
11425 sv_setpvn(tmpstr,d+1,s-d);
11427 sv_catpvn(herewas,s,bufend-s);
11428 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11435 while (s < PL_bufend &&
11436 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11438 CopLINE_inc(PL_curcop);
11440 if (s >= PL_bufend) {
11441 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11442 missingterm(PL_tokenbuf);
11444 sv_setpvn(tmpstr,d+1,s-d);
11446 if (PL_madskills) {
11448 sv_catpvn(PL_thisstuff, d + 1, s - d);
11450 PL_thisstuff = newSVpvn(d + 1, s - d);
11451 stuffstart = s - SvPVX(PL_linestr);
11455 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11457 sv_catpvn(herewas,s,PL_bufend-s);
11458 sv_setsv(PL_linestr,herewas);
11459 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11460 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11461 PL_last_lop = PL_last_uni = NULL;
11464 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
11465 while (s >= PL_bufend) { /* multiple line string? */
11467 if (PL_madskills) {
11468 tstart = SvPVX(PL_linestr) + stuffstart;
11470 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11472 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11476 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart
11477 = filter_gets(PL_linestr, 0))) {
11478 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11479 missingterm(PL_tokenbuf);
11482 stuffstart = s - SvPVX(PL_linestr);
11484 CopLINE_inc(PL_curcop);
11485 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11486 PL_last_lop = PL_last_uni = NULL;
11487 #ifndef PERL_STRICT_CR
11488 if (PL_bufend - PL_linestart >= 2) {
11489 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11490 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11492 PL_bufend[-2] = '\n';
11494 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11496 else if (PL_bufend[-1] == '\r')
11497 PL_bufend[-1] = '\n';
11499 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11500 PL_bufend[-1] = '\n';
11502 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11503 update_debugger_info(PL_linestr, NULL, 0);
11504 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11505 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11506 *(SvPVX(PL_linestr) + off ) = ' ';
11507 sv_catsv(PL_linestr,herewas);
11508 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11509 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11513 sv_catsv(tmpstr,PL_linestr);
11518 PL_multi_end = CopLINE(PL_curcop);
11519 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11520 SvPV_shrink_to_cur(tmpstr);
11522 SvREFCNT_dec(herewas);
11524 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11526 else if (PL_encoding)
11527 sv_recode_to_utf8(tmpstr, PL_encoding);
11529 PL_lex_stuff = tmpstr;
11530 pl_yylval.ival = op_type;
11534 /* scan_inputsymbol
11535 takes: current position in input buffer
11536 returns: new position in input buffer
11537 side-effects: pl_yylval and lex_op are set.
11542 <FH> read from filehandle
11543 <pkg::FH> read from package qualified filehandle
11544 <pkg'FH> read from package qualified filehandle
11545 <$fh> read from filehandle in $fh
11546 <*.h> filename glob
11551 S_scan_inputsymbol(pTHX_ char *start)
11554 register char *s = start; /* current position in buffer */
11557 char *d = PL_tokenbuf; /* start of temp holding space */
11558 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11560 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
11562 end = strchr(s, '\n');
11565 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11567 /* die if we didn't have space for the contents of the <>,
11568 or if it didn't end, or if we see a newline
11571 if (len >= (I32)sizeof PL_tokenbuf)
11572 Perl_croak(aTHX_ "Excessively long <> operator");
11574 Perl_croak(aTHX_ "Unterminated <> operator");
11579 Remember, only scalar variables are interpreted as filehandles by
11580 this code. Anything more complex (e.g., <$fh{$num}>) will be
11581 treated as a glob() call.
11582 This code makes use of the fact that except for the $ at the front,
11583 a scalar variable and a filehandle look the same.
11585 if (*d == '$' && d[1]) d++;
11587 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11588 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11591 /* If we've tried to read what we allow filehandles to look like, and
11592 there's still text left, then it must be a glob() and not a getline.
11593 Use scan_str to pull out the stuff between the <> and treat it
11594 as nothing more than a string.
11597 if (d - PL_tokenbuf != len) {
11598 pl_yylval.ival = OP_GLOB;
11599 s = scan_str(start,!!PL_madskills,FALSE);
11601 Perl_croak(aTHX_ "Glob not terminated");
11605 bool readline_overriden = FALSE;
11608 /* we're in a filehandle read situation */
11611 /* turn <> into <ARGV> */
11613 Copy("ARGV",d,5,char);
11615 /* Check whether readline() is overriden */
11616 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11618 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11620 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11621 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11622 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11623 readline_overriden = TRUE;
11625 /* if <$fh>, create the ops to turn the variable into a
11629 /* try to find it in the pad for this block, otherwise find
11630 add symbol table ops
11632 const PADOFFSET tmp = pad_findmy(d, len, 0);
11633 if (tmp != NOT_IN_PAD) {
11634 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11635 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11636 HEK * const stashname = HvNAME_HEK(stash);
11637 SV * const sym = sv_2mortal(newSVhek(stashname));
11638 sv_catpvs(sym, "::");
11639 sv_catpv(sym, d+1);
11644 OP * const o = newOP(OP_PADSV, 0);
11646 PL_lex_op = readline_overriden
11647 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11648 append_elem(OP_LIST, o,
11649 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11650 : (OP*)newUNOP(OP_READLINE, 0, o);
11659 ? (GV_ADDMULTI | GV_ADDINEVAL)
11662 PL_lex_op = readline_overriden
11663 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11664 append_elem(OP_LIST,
11665 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11666 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11667 : (OP*)newUNOP(OP_READLINE, 0,
11668 newUNOP(OP_RV2SV, 0,
11669 newGVOP(OP_GV, 0, gv)));
11671 if (!readline_overriden)
11672 PL_lex_op->op_flags |= OPf_SPECIAL;
11673 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
11674 pl_yylval.ival = OP_NULL;
11677 /* If it's none of the above, it must be a literal filehandle
11678 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11680 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11681 PL_lex_op = readline_overriden
11682 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11683 append_elem(OP_LIST,
11684 newGVOP(OP_GV, 0, gv),
11685 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11686 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11687 pl_yylval.ival = OP_NULL;
11696 takes: start position in buffer
11697 keep_quoted preserve \ on the embedded delimiter(s)
11698 keep_delims preserve the delimiters around the string
11699 returns: position to continue reading from buffer
11700 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11701 updates the read buffer.
11703 This subroutine pulls a string out of the input. It is called for:
11704 q single quotes q(literal text)
11705 ' single quotes 'literal text'
11706 qq double quotes qq(interpolate $here please)
11707 " double quotes "interpolate $here please"
11708 qx backticks qx(/bin/ls -l)
11709 ` backticks `/bin/ls -l`
11710 qw quote words @EXPORT_OK = qw( func() $spam )
11711 m// regexp match m/this/
11712 s/// regexp substitute s/this/that/
11713 tr/// string transliterate tr/this/that/
11714 y/// string transliterate y/this/that/
11715 ($*@) sub prototypes sub foo ($)
11716 (stuff) sub attr parameters sub foo : attr(stuff)
11717 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11719 In most of these cases (all but <>, patterns and transliterate)
11720 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11721 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11722 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11725 It skips whitespace before the string starts, and treats the first
11726 character as the delimiter. If the delimiter is one of ([{< then
11727 the corresponding "close" character )]}> is used as the closing
11728 delimiter. It allows quoting of delimiters, and if the string has
11729 balanced delimiters ([{<>}]) it allows nesting.
11731 On success, the SV with the resulting string is put into lex_stuff or,
11732 if that is already non-NULL, into lex_repl. The second case occurs only
11733 when parsing the RHS of the special constructs s/// and tr/// (y///).
11734 For convenience, the terminating delimiter character is stuffed into
11739 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11742 SV *sv; /* scalar value: string */
11743 const char *tmps; /* temp string, used for delimiter matching */
11744 register char *s = start; /* current position in the buffer */
11745 register char term; /* terminating character */
11746 register char *to; /* current position in the sv's data */
11747 I32 brackets = 1; /* bracket nesting level */
11748 bool has_utf8 = FALSE; /* is there any utf8 content? */
11749 I32 termcode; /* terminating char. code */
11750 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11751 STRLEN termlen; /* length of terminating string */
11752 int last_off = 0; /* last position for nesting bracket */
11758 PERL_ARGS_ASSERT_SCAN_STR;
11760 /* skip space before the delimiter */
11766 if (PL_realtokenstart >= 0) {
11767 stuffstart = PL_realtokenstart;
11768 PL_realtokenstart = -1;
11771 stuffstart = start - SvPVX(PL_linestr);
11773 /* mark where we are, in case we need to report errors */
11776 /* after skipping whitespace, the next character is the terminator */
11779 termcode = termstr[0] = term;
11783 termcode = utf8_to_uvchr((U8*)s, &termlen);
11784 Copy(s, termstr, termlen, U8);
11785 if (!UTF8_IS_INVARIANT(term))
11789 /* mark where we are */
11790 PL_multi_start = CopLINE(PL_curcop);
11791 PL_multi_open = term;
11793 /* find corresponding closing delimiter */
11794 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11795 termcode = termstr[0] = term = tmps[5];
11797 PL_multi_close = term;
11799 /* create a new SV to hold the contents. 79 is the SV's initial length.
11800 What a random number. */
11801 sv = newSV_type(SVt_PVIV);
11803 SvIV_set(sv, termcode);
11804 (void)SvPOK_only(sv); /* validate pointer */
11806 /* move past delimiter and try to read a complete string */
11808 sv_catpvn(sv, s, termlen);
11811 tstart = SvPVX(PL_linestr) + stuffstart;
11812 if (!PL_thisopen && !keep_delims) {
11813 PL_thisopen = newSVpvn(tstart, s - tstart);
11814 stuffstart = s - SvPVX(PL_linestr);
11818 if (PL_encoding && !UTF) {
11822 int offset = s - SvPVX_const(PL_linestr);
11823 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11824 &offset, (char*)termstr, termlen);
11825 const char * const ns = SvPVX_const(PL_linestr) + offset;
11826 char * const svlast = SvEND(sv) - 1;
11828 for (; s < ns; s++) {
11829 if (*s == '\n' && !PL_rsfp)
11830 CopLINE_inc(PL_curcop);
11833 goto read_more_line;
11835 /* handle quoted delimiters */
11836 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11838 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11840 if ((svlast-1 - t) % 2) {
11841 if (!keep_quoted) {
11842 *(svlast-1) = term;
11844 SvCUR_set(sv, SvCUR(sv) - 1);
11849 if (PL_multi_open == PL_multi_close) {
11855 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11856 /* At here, all closes are "was quoted" one,
11857 so we don't check PL_multi_close. */
11859 if (!keep_quoted && *(t+1) == PL_multi_open)
11864 else if (*t == PL_multi_open)
11872 SvCUR_set(sv, w - SvPVX_const(sv));
11874 last_off = w - SvPVX(sv);
11875 if (--brackets <= 0)
11880 if (!keep_delims) {
11881 SvCUR_set(sv, SvCUR(sv) - 1);
11887 /* extend sv if need be */
11888 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11889 /* set 'to' to the next character in the sv's string */
11890 to = SvPVX(sv)+SvCUR(sv);
11892 /* if open delimiter is the close delimiter read unbridle */
11893 if (PL_multi_open == PL_multi_close) {
11894 for (; s < PL_bufend; s++,to++) {
11895 /* embedded newlines increment the current line number */
11896 if (*s == '\n' && !PL_rsfp)
11897 CopLINE_inc(PL_curcop);
11898 /* handle quoted delimiters */
11899 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11900 if (!keep_quoted && s[1] == term)
11902 /* any other quotes are simply copied straight through */
11906 /* terminate when run out of buffer (the for() condition), or
11907 have found the terminator */
11908 else if (*s == term) {
11911 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11914 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11920 /* if the terminator isn't the same as the start character (e.g.,
11921 matched brackets), we have to allow more in the quoting, and
11922 be prepared for nested brackets.
11925 /* read until we run out of string, or we find the terminator */
11926 for (; s < PL_bufend; s++,to++) {
11927 /* embedded newlines increment the line count */
11928 if (*s == '\n' && !PL_rsfp)
11929 CopLINE_inc(PL_curcop);
11930 /* backslashes can escape the open or closing characters */
11931 if (*s == '\\' && s+1 < PL_bufend) {
11932 if (!keep_quoted &&
11933 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11938 /* allow nested opens and closes */
11939 else if (*s == PL_multi_close && --brackets <= 0)
11941 else if (*s == PL_multi_open)
11943 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11948 /* terminate the copied string and update the sv's end-of-string */
11950 SvCUR_set(sv, to - SvPVX_const(sv));
11953 * this next chunk reads more into the buffer if we're not done yet
11957 break; /* handle case where we are done yet :-) */
11959 #ifndef PERL_STRICT_CR
11960 if (to - SvPVX_const(sv) >= 2) {
11961 if ((to[-2] == '\r' && to[-1] == '\n') ||
11962 (to[-2] == '\n' && to[-1] == '\r'))
11966 SvCUR_set(sv, to - SvPVX_const(sv));
11968 else if (to[-1] == '\r')
11971 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11976 /* if we're out of file, or a read fails, bail and reset the current
11977 line marker so we can report where the unterminated string began
11980 if (PL_madskills) {
11981 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11983 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11985 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11989 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart
11990 = filter_gets(PL_linestr, 0))) {
11992 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11998 /* we read a line, so increment our line counter */
11999 CopLINE_inc(PL_curcop);
12001 /* update debugger info */
12002 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
12003 update_debugger_info(PL_linestr, NULL, 0);
12005 /* having changed the buffer, we must update PL_bufend */
12006 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12007 PL_last_lop = PL_last_uni = NULL;
12010 /* at this point, we have successfully read the delimited string */
12012 if (!PL_encoding || UTF) {
12014 if (PL_madskills) {
12015 char * const tstart = SvPVX(PL_linestr) + stuffstart;
12016 const int len = s - tstart;
12018 sv_catpvn(PL_thisstuff, tstart, len);
12020 PL_thisstuff = newSVpvn(tstart, len);
12021 if (!PL_thisclose && !keep_delims)
12022 PL_thisclose = newSVpvn(s,termlen);
12027 sv_catpvn(sv, s, termlen);
12032 if (PL_madskills) {
12033 char * const tstart = SvPVX(PL_linestr) + stuffstart;
12034 const int len = s - tstart - termlen;
12036 sv_catpvn(PL_thisstuff, tstart, len);
12038 PL_thisstuff = newSVpvn(tstart, len);
12039 if (!PL_thisclose && !keep_delims)
12040 PL_thisclose = newSVpvn(s - termlen,termlen);
12044 if (has_utf8 || PL_encoding)
12047 PL_multi_end = CopLINE(PL_curcop);
12049 /* if we allocated too much space, give some back */
12050 if (SvCUR(sv) + 5 < SvLEN(sv)) {
12051 SvLEN_set(sv, SvCUR(sv) + 1);
12052 SvPV_renew(sv, SvLEN(sv));
12055 /* decide whether this is the first or second quoted string we've read
12068 takes: pointer to position in buffer
12069 returns: pointer to new position in buffer
12070 side-effects: builds ops for the constant in pl_yylval.op
12072 Read a number in any of the formats that Perl accepts:
12074 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
12075 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
12078 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
12080 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
12083 If it reads a number without a decimal point or an exponent, it will
12084 try converting the number to an integer and see if it can do so
12085 without loss of precision.
12089 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
12092 register const char *s = start; /* current position in buffer */
12093 register char *d; /* destination in temp buffer */
12094 register char *e; /* end of temp buffer */
12095 NV nv; /* number read, as a double */
12096 SV *sv = NULL; /* place to put the converted number */
12097 bool floatit; /* boolean: int or float? */
12098 const char *lastub = NULL; /* position of last underbar */
12099 static char const number_too_long[] = "Number too long";
12101 PERL_ARGS_ASSERT_SCAN_NUM;
12103 /* We use the first character to decide what type of number this is */
12107 Perl_croak(aTHX_ "panic: scan_num");
12109 /* if it starts with a 0, it could be an octal number, a decimal in
12110 0.13 disguise, or a hexadecimal number, or a binary number. */
12114 u holds the "number so far"
12115 shift the power of 2 of the base
12116 (hex == 4, octal == 3, binary == 1)
12117 overflowed was the number more than we can hold?
12119 Shift is used when we add a digit. It also serves as an "are
12120 we in octal/hex/binary?" indicator to disallow hex characters
12121 when in octal mode.
12126 bool overflowed = FALSE;
12127 bool just_zero = TRUE; /* just plain 0 or binary number? */
12128 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
12129 static const char* const bases[5] =
12130 { "", "binary", "", "octal", "hexadecimal" };
12131 static const char* const Bases[5] =
12132 { "", "Binary", "", "Octal", "Hexadecimal" };
12133 static const char* const maxima[5] =
12135 "0b11111111111111111111111111111111",
12139 const char *base, *Base, *max;
12141 /* check for hex */
12146 } else if (s[1] == 'b') {
12151 /* check for a decimal in disguise */
12152 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
12154 /* so it must be octal */
12161 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12162 "Misplaced _ in number");
12166 base = bases[shift];
12167 Base = Bases[shift];
12168 max = maxima[shift];
12170 /* read the rest of the number */
12172 /* x is used in the overflow test,
12173 b is the digit we're adding on. */
12178 /* if we don't mention it, we're done */
12182 /* _ are ignored -- but warned about if consecutive */
12184 if (lastub && s == lastub + 1)
12185 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12186 "Misplaced _ in number");
12190 /* 8 and 9 are not octal */
12191 case '8': case '9':
12193 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
12197 case '2': case '3': case '4':
12198 case '5': case '6': case '7':
12200 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
12203 case '0': case '1':
12204 b = *s++ & 15; /* ASCII digit -> value of digit */
12208 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
12209 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
12210 /* make sure they said 0x */
12213 b = (*s++ & 7) + 9;
12215 /* Prepare to put the digit we have onto the end
12216 of the number so far. We check for overflows.
12222 x = u << shift; /* make room for the digit */
12224 if ((x >> shift) != u
12225 && !(PL_hints & HINT_NEW_BINARY)) {
12228 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
12229 "Integer overflow in %s number",
12232 u = x | b; /* add the digit to the end */
12235 n *= nvshift[shift];
12236 /* If an NV has not enough bits in its
12237 * mantissa to represent an UV this summing of
12238 * small low-order numbers is a waste of time
12239 * (because the NV cannot preserve the
12240 * low-order bits anyway): we could just
12241 * remember when did we overflow and in the
12242 * end just multiply n by the right
12250 /* if we get here, we had success: make a scalar value from
12255 /* final misplaced underbar check */
12256 if (s[-1] == '_') {
12257 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12262 if (n > 4294967295.0)
12263 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
12264 "%s number > %s non-portable",
12270 if (u > 0xffffffff)
12271 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
12272 "%s number > %s non-portable",
12277 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12278 sv = new_constant(start, s - start, "integer",
12279 sv, NULL, NULL, 0);
12280 else if (PL_hints & HINT_NEW_BINARY)
12281 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
12286 handle decimal numbers.
12287 we're also sent here when we read a 0 as the first digit
12289 case '1': case '2': case '3': case '4': case '5':
12290 case '6': case '7': case '8': case '9': case '.':
12293 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12296 /* read next group of digits and _ and copy into d */
12297 while (isDIGIT(*s) || *s == '_') {
12298 /* skip underscores, checking for misplaced ones
12302 if (lastub && s == lastub + 1)
12303 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12304 "Misplaced _ in number");
12308 /* check for end of fixed-length buffer */
12310 Perl_croak(aTHX_ number_too_long);
12311 /* if we're ok, copy the character */
12316 /* final misplaced underbar check */
12317 if (lastub && s == lastub + 1) {
12318 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12321 /* read a decimal portion if there is one. avoid
12322 3..5 being interpreted as the number 3. followed
12325 if (*s == '.' && s[1] != '.') {
12330 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12331 "Misplaced _ in number");
12335 /* copy, ignoring underbars, until we run out of digits.
12337 for (; isDIGIT(*s) || *s == '_'; s++) {
12338 /* fixed length buffer check */
12340 Perl_croak(aTHX_ number_too_long);
12342 if (lastub && s == lastub + 1)
12343 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12344 "Misplaced _ in number");
12350 /* fractional part ending in underbar? */
12351 if (s[-1] == '_') {
12352 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12353 "Misplaced _ in number");
12355 if (*s == '.' && isDIGIT(s[1])) {
12356 /* oops, it's really a v-string, but without the "v" */
12362 /* read exponent part, if present */
12363 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12367 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12368 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12370 /* stray preinitial _ */
12372 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12373 "Misplaced _ in number");
12377 /* allow positive or negative exponent */
12378 if (*s == '+' || *s == '-')
12381 /* stray initial _ */
12383 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12384 "Misplaced _ in number");
12388 /* read digits of exponent */
12389 while (isDIGIT(*s) || *s == '_') {
12392 Perl_croak(aTHX_ number_too_long);
12396 if (((lastub && s == lastub + 1) ||
12397 (!isDIGIT(s[1]) && s[1] != '_')))
12398 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12399 "Misplaced _ in number");
12406 /* make an sv from the string */
12410 We try to do an integer conversion first if no characters
12411 indicating "float" have been found.
12416 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12418 if (flags == IS_NUMBER_IN_UV) {
12420 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12423 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12424 if (uv <= (UV) IV_MIN)
12425 sv_setiv(sv, -(IV)uv);
12432 /* terminate the string */
12434 nv = Atof(PL_tokenbuf);
12439 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
12440 const char *const key = floatit ? "float" : "integer";
12441 const STRLEN keylen = floatit ? 5 : 7;
12442 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
12443 key, keylen, sv, NULL, NULL, 0);
12447 /* if it starts with a v, it could be a v-string */
12450 sv = newSV(5); /* preallocate storage space */
12451 s = scan_vstring(s, PL_bufend, sv);
12455 /* make the op for the constant and return */
12458 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12460 lvalp->opval = NULL;
12466 S_scan_formline(pTHX_ register char *s)
12469 register char *eol;
12471 SV * const stuff = newSVpvs("");
12472 bool needargs = FALSE;
12473 bool eofmt = FALSE;
12475 char *tokenstart = s;
12476 SV* savewhite = NULL;
12478 if (PL_madskills) {
12479 savewhite = PL_thiswhite;
12484 PERL_ARGS_ASSERT_SCAN_FORMLINE;
12486 while (!needargs) {
12489 #ifdef PERL_STRICT_CR
12490 while (SPACE_OR_TAB(*t))
12493 while (SPACE_OR_TAB(*t) || *t == '\r')
12496 if (*t == '\n' || t == PL_bufend) {
12501 if (PL_in_eval && !PL_rsfp) {
12502 eol = (char *) memchr(s,'\n',PL_bufend-s);
12507 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12509 for (t = s; t < eol; t++) {
12510 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12512 goto enough; /* ~~ must be first line in formline */
12514 if (*t == '@' || *t == '^')
12518 sv_catpvn(stuff, s, eol-s);
12519 #ifndef PERL_STRICT_CR
12520 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12521 char *end = SvPVX(stuff) + SvCUR(stuff);
12524 SvCUR_set(stuff, SvCUR(stuff) - 1);
12534 if (PL_madskills) {
12536 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12538 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12541 s = filter_gets(PL_linestr, 0);
12543 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12545 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12547 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12548 PL_last_lop = PL_last_uni = NULL;
12557 if (SvCUR(stuff)) {
12560 PL_lex_state = LEX_NORMAL;
12561 start_force(PL_curforce);
12562 NEXTVAL_NEXTTOKE.ival = 0;
12566 PL_lex_state = LEX_FORMLINE;
12568 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12570 else if (PL_encoding)
12571 sv_recode_to_utf8(stuff, PL_encoding);
12573 start_force(PL_curforce);
12574 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12576 start_force(PL_curforce);
12577 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12581 SvREFCNT_dec(stuff);
12583 PL_lex_formbrack = 0;
12587 if (PL_madskills) {
12589 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12591 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12592 PL_thiswhite = savewhite;
12599 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12602 const I32 oldsavestack_ix = PL_savestack_ix;
12603 CV* const outsidecv = PL_compcv;
12606 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12608 SAVEI32(PL_subline);
12609 save_item(PL_subname);
12610 SAVESPTR(PL_compcv);
12612 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
12613 CvFLAGS(PL_compcv) |= flags;
12615 PL_subline = CopLINE(PL_curcop);
12616 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12617 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
12618 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12620 return oldsavestack_ix;
12624 #pragma segment Perl_yylex
12627 S_yywarn(pTHX_ const char *const s)
12631 PERL_ARGS_ASSERT_YYWARN;
12633 PL_in_eval |= EVAL_WARNONLY;
12635 PL_in_eval &= ~EVAL_WARNONLY;
12640 Perl_yyerror(pTHX_ const char *const s)
12643 const char *where = NULL;
12644 const char *context = NULL;
12647 int yychar = PL_parser->yychar;
12649 PERL_ARGS_ASSERT_YYERROR;
12651 if (!yychar || (yychar == ';' && !PL_rsfp))
12653 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12654 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12655 PL_oldbufptr != PL_bufptr) {
12658 The code below is removed for NetWare because it abends/crashes on NetWare
12659 when the script has error such as not having the closing quotes like:
12660 if ($var eq "value)
12661 Checking of white spaces is anyway done in NetWare code.
12664 while (isSPACE(*PL_oldoldbufptr))
12667 context = PL_oldoldbufptr;
12668 contlen = PL_bufptr - PL_oldoldbufptr;
12670 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12671 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12674 The code below is removed for NetWare because it abends/crashes on NetWare
12675 when the script has error such as not having the closing quotes like:
12676 if ($var eq "value)
12677 Checking of white spaces is anyway done in NetWare code.
12680 while (isSPACE(*PL_oldbufptr))
12683 context = PL_oldbufptr;
12684 contlen = PL_bufptr - PL_oldbufptr;
12686 else if (yychar > 255)
12687 where = "next token ???";
12688 else if (yychar == -2) { /* YYEMPTY */
12689 if (PL_lex_state == LEX_NORMAL ||
12690 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12691 where = "at end of line";
12692 else if (PL_lex_inpat)
12693 where = "within pattern";
12695 where = "within string";
12698 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
12700 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12701 else if (isPRINT_LC(yychar)) {
12702 const char string = yychar;
12703 sv_catpvn(where_sv, &string, 1);
12706 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12707 where = SvPVX_const(where_sv);
12709 msg = sv_2mortal(newSVpv(s, 0));
12710 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12711 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12713 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12715 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12716 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12717 Perl_sv_catpvf(aTHX_ msg,
12718 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12719 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12722 if (PL_in_eval & EVAL_WARNONLY) {
12723 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12727 if (PL_error_count >= 10) {
12728 if (PL_in_eval && SvCUR(ERRSV))
12729 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12730 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12732 Perl_croak(aTHX_ "%s has too many errors.\n",
12733 OutCopFILE(PL_curcop));
12736 PL_in_my_stash = NULL;
12740 #pragma segment Main
12744 S_swallow_bom(pTHX_ U8 *s)
12747 const STRLEN slen = SvCUR(PL_linestr);
12749 PERL_ARGS_ASSERT_SWALLOW_BOM;
12753 if (s[1] == 0xFE) {
12754 /* UTF-16 little-endian? (or UTF32-LE?) */
12755 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12756 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12757 #ifndef PERL_NO_UTF16_FILTER
12758 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12760 if (PL_bufend > (char*)s) {
12761 s = add_utf16_textfilter(s, TRUE);
12764 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12769 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12770 #ifndef PERL_NO_UTF16_FILTER
12771 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12773 if (PL_bufend > (char *)s) {
12774 s = add_utf16_textfilter(s, FALSE);
12777 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12782 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12783 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12784 s += 3; /* UTF-8 */
12790 if (s[2] == 0xFE && s[3] == 0xFF) {
12791 /* UTF-32 big-endian */
12792 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12795 else if (s[2] == 0 && s[3] != 0) {
12798 * are a good indicator of UTF-16BE. */
12799 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12800 s = add_utf16_textfilter(s, FALSE);
12805 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12806 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12807 s += 4; /* UTF-8 */
12813 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12816 * are a good indicator of UTF-16LE. */
12817 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12818 s = add_utf16_textfilter(s, TRUE);
12825 #ifndef PERL_NO_UTF16_FILTER
12827 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12830 SV *const filter = FILTER_DATA(idx);
12831 /* We re-use this each time round, throwing the contents away before we
12833 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
12834 SV *const utf8_buffer = filter;
12835 IV status = IoPAGE(filter);
12836 const bool reverse = (bool) IoLINES(filter);
12839 /* As we're automatically added, at the lowest level, and hence only called
12840 from this file, we can be sure that we're not called in block mode. Hence
12841 don't bother writing code to deal with block mode. */
12843 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
12846 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
12848 DEBUG_P(PerlIO_printf(Perl_debug_log,
12849 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
12850 FPTR2DPTR(void *, S_utf16_textfilter),
12851 reverse ? 'l' : 'b', idx, maxlen, status,
12852 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12859 /* First, look in our buffer of existing UTF-8 data: */
12860 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
12864 } else if (status == 0) {
12866 IoPAGE(filter) = 0;
12867 nl = SvEND(utf8_buffer);
12870 STRLEN got = nl - SvPVX(utf8_buffer);
12871 /* Did we have anything to append? */
12873 sv_catpvn(sv, SvPVX(utf8_buffer), got);
12874 /* Everything else in this code works just fine if SVp_POK isn't
12875 set. This, however, needs it, and we need it to work, else
12876 we loop infinitely because the buffer is never consumed. */
12877 sv_chop(utf8_buffer, nl);
12881 /* OK, not a complete line there, so need to read some more UTF-16.
12882 Read an extra octect if the buffer currently has an odd number. */
12886 if (SvCUR(utf16_buffer) >= 2) {
12887 /* Location of the high octet of the last complete code point.
12888 Gosh, UTF-16 is a pain. All the benefits of variable length,
12889 *coupled* with all the benefits of partial reads and
12891 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
12892 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
12894 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
12898 /* We have the first half of a surrogate. Read more. */
12899 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
12902 status = FILTER_READ(idx + 1, utf16_buffer,
12903 160 + (SvCUR(utf16_buffer) & 1));
12904 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
12905 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
12908 IoPAGE(filter) = status;
12913 chars = SvCUR(utf16_buffer) >> 1;
12914 have = SvCUR(utf8_buffer);
12915 SvGROW(utf8_buffer, have + chars * 3 + 1);
12918 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
12919 (U8*)SvPVX_const(utf8_buffer) + have,
12920 chars * 2, &newlen);
12922 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
12923 (U8*)SvPVX_const(utf8_buffer) + have,
12924 chars * 2, &newlen);
12926 SvCUR_set(utf8_buffer, have + newlen);
12929 /* No need to keep this SV "well-formed" with a '\0' after the end, as
12930 it's private to us, and utf16_to_utf8{,reversed} take a
12931 (pointer,length) pair, rather than a NUL-terminated string. */
12932 if(SvCUR(utf16_buffer) & 1) {
12933 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
12934 SvCUR_set(utf16_buffer, 1);
12936 SvCUR_set(utf16_buffer, 0);
12939 DEBUG_P(PerlIO_printf(Perl_debug_log,
12940 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
12942 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12943 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
12948 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
12950 SV *filter = filter_add(S_utf16_textfilter, NULL);
12952 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
12953 sv_setpvs(filter, "");
12954 IoLINES(filter) = reversed;
12955 IoPAGE(filter) = 1; /* Not EOF */
12957 /* Sadly, we have to return a valid pointer, come what may, so we have to
12958 ignore any error return from this. */
12959 SvCUR_set(PL_linestr, 0);
12960 if (FILTER_READ(0, PL_linestr, 0)) {
12961 SvUTF8_on(PL_linestr);
12963 SvUTF8_on(PL_linestr);
12965 PL_bufend = SvEND(PL_linestr);
12966 return (U8*)SvPVX(PL_linestr);
12971 Returns a pointer to the next character after the parsed
12972 vstring, as well as updating the passed in sv.
12974 Function must be called like
12977 s = scan_vstring(s,e,sv);
12979 where s and e are the start and end of the string.
12980 The sv should already be large enough to store the vstring
12981 passed in, for performance reasons.
12986 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12989 const char *pos = s;
12990 const char *start = s;
12992 PERL_ARGS_ASSERT_SCAN_VSTRING;
12994 if (*pos == 'v') pos++; /* get past 'v' */
12995 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12997 if ( *pos != '.') {
12998 /* this may not be a v-string if followed by => */
12999 const char *next = pos;
13000 while (next < e && isSPACE(*next))
13002 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
13003 /* return string not v-string */
13004 sv_setpvn(sv,(char *)s,pos-s);
13005 return (char *)pos;
13009 if (!isALPHA(*pos)) {
13010 U8 tmpbuf[UTF8_MAXBYTES+1];
13013 s++; /* get past 'v' */
13018 /* this is atoi() that tolerates underscores */
13021 const char *end = pos;
13023 while (--end >= s) {
13025 const UV orev = rev;
13026 rev += (*end - '0') * mult;
13029 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
13030 "Integer overflow in decimal number");
13034 if (rev > 0x7FFFFFFF)
13035 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
13037 /* Append native character for the rev point */
13038 tmpend = uvchr_to_utf8(tmpbuf, rev);
13039 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
13040 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
13042 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
13048 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
13052 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
13059 Perl_keyword_plugin_standard(pTHX_
13060 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
13062 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
13063 PERL_UNUSED_CONTEXT;
13064 PERL_UNUSED_ARG(keyword_ptr);
13065 PERL_UNUSED_ARG(keyword_len);
13066 PERL_UNUSED_ARG(op_ptr);
13067 return KEYWORD_PLUGIN_DECLINE;
13072 * c-indentation-style: bsd
13073 * c-basic-offset: 4
13074 * indent-tabs-mode: t
13077 * ex: set ts=8 sts=4 sw=4 noet: