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)
100 S_pending_ident(pTHX);
102 static const char ident_too_long[] = "Identifier too long";
103 static const char commaless_variable_list[] = "comma-less variable list";
105 #ifndef PERL_NO_UTF16_FILTER
106 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
107 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
111 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
112 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
114 # define CURMAD(slot,sv)
115 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
118 #define XFAKEBRACK 128
119 #define XENUMMASK 127
121 #ifdef USE_UTF8_SCRIPTS
122 # define UTF (!IN_BYTES)
124 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
127 /* The maximum number of characters preceding the unrecognized one to display */
128 #define UNRECOGNIZED_PRECEDE_COUNT 10
130 /* In variables named $^X, these are the legal values for X.
131 * 1999-02-27 mjd-perl-patch@plover.com */
132 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
134 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
136 /* LEX_* are values for PL_lex_state, the state of the lexer.
137 * They are arranged oddly so that the guard on the switch statement
138 * can get by with a single comparison (if the compiler is smart enough).
141 /* #define LEX_NOTPARSING 11 is done in perl.h. */
143 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
144 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
145 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
146 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
147 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
149 /* at end of code, eg "$x" followed by: */
150 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
151 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
153 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
154 string or after \E, $foo, etc */
155 #define LEX_INTERPCONST 2 /* NOT USED */
156 #define LEX_FORMLINE 1 /* expecting a format line */
157 #define LEX_KNOWNEXT 0 /* next token known; just return it */
161 static const char* const lex_state_names[] = {
180 #include "keywords.h"
182 /* CLINE is a macro that ensures PL_copline has a sane value */
187 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
190 # define SKIPSPACE0(s) skipspace0(s)
191 # define SKIPSPACE1(s) skipspace1(s)
192 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
193 # define PEEKSPACE(s) skipspace2(s,0)
195 # define SKIPSPACE0(s) skipspace(s)
196 # define SKIPSPACE1(s) skipspace(s)
197 # define SKIPSPACE2(s,tsv) skipspace(s)
198 # define PEEKSPACE(s) skipspace(s)
202 * Convenience functions to return different tokens and prime the
203 * lexer for the next token. They all take an argument.
205 * TOKEN : generic token (used for '(', DOLSHARP, etc)
206 * OPERATOR : generic operator
207 * AOPERATOR : assignment operator
208 * PREBLOCK : beginning the block after an if, while, foreach, ...
209 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
210 * PREREF : *EXPR where EXPR is not a simple identifier
211 * TERM : expression term
212 * LOOPX : loop exiting command (goto, last, dump, etc)
213 * FTST : file test operator
214 * FUN0 : zero-argument function
215 * FUN1 : not used, except for not, which isn't a UNIOP
216 * BOop : bitwise or or xor
218 * SHop : shift operator
219 * PWop : power operator
220 * PMop : pattern-matching operator
221 * Aop : addition-level operator
222 * Mop : multiplication-level operator
223 * Eop : equality-testing operator
224 * Rop : relational operator <= != gt
226 * Also see LOP and lop() below.
229 #ifdef DEBUGGING /* Serve -DT. */
230 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
232 # define REPORT(retval) (retval)
235 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
236 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
237 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
238 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
239 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
240 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
241 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
242 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
243 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
244 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
245 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
246 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
247 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
248 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
249 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
250 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
251 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
252 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
253 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
254 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
256 /* This bit of chicanery makes a unary function followed by
257 * a parenthesis into a function with one argument, highest precedence.
258 * The UNIDOR macro is for unary functions that can be followed by the //
259 * operator (such as C<shift // 0>).
261 #define UNI2(f,x) { \
262 pl_yylval.ival = f; \
265 PL_last_uni = PL_oldbufptr; \
266 PL_last_lop_op = f; \
268 return REPORT( (int)FUNC1 ); \
270 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
272 #define UNI(f) UNI2(f,XTERM)
273 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
275 #define UNIBRACK(f) { \
276 pl_yylval.ival = f; \
278 PL_last_uni = PL_oldbufptr; \
280 return REPORT( (int)FUNC1 ); \
282 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
285 /* grandfather return to old style */
286 #define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
290 /* how to interpret the pl_yylval associated with the token */
294 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
300 static struct debug_tokens {
302 enum token_type type;
304 } const debug_tokens[] =
306 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
307 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
308 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
309 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
310 { ARROW, TOKENTYPE_NONE, "ARROW" },
311 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
312 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
313 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
314 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
315 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
316 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
317 { DO, TOKENTYPE_NONE, "DO" },
318 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
319 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
320 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
321 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
322 { ELSE, TOKENTYPE_NONE, "ELSE" },
323 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
324 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
325 { FOR, TOKENTYPE_IVAL, "FOR" },
326 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
327 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
328 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
329 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
330 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
331 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
332 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
333 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
334 { IF, TOKENTYPE_IVAL, "IF" },
335 { LABEL, TOKENTYPE_PVAL, "LABEL" },
336 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
337 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
338 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
339 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
340 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
341 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
342 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
343 { MY, TOKENTYPE_IVAL, "MY" },
344 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
345 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
346 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
347 { OROP, TOKENTYPE_IVAL, "OROP" },
348 { OROR, TOKENTYPE_NONE, "OROR" },
349 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
350 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
351 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
352 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
353 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
354 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
355 { PREINC, TOKENTYPE_NONE, "PREINC" },
356 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
357 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
358 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
359 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
360 { SUB, TOKENTYPE_NONE, "SUB" },
361 { THING, TOKENTYPE_OPVAL, "THING" },
362 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
363 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
364 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
365 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
366 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
367 { USE, TOKENTYPE_IVAL, "USE" },
368 { WHEN, TOKENTYPE_IVAL, "WHEN" },
369 { WHILE, TOKENTYPE_IVAL, "WHILE" },
370 { WORD, TOKENTYPE_OPVAL, "WORD" },
371 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
372 { 0, TOKENTYPE_NONE, NULL }
375 /* dump the returned token in rv, plus any optional arg in pl_yylval */
378 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
382 PERL_ARGS_ASSERT_TOKEREPORT;
385 const char *name = NULL;
386 enum token_type type = TOKENTYPE_NONE;
387 const struct debug_tokens *p;
388 SV* const report = newSVpvs("<== ");
390 for (p = debug_tokens; p->token; p++) {
391 if (p->token == (int)rv) {
398 Perl_sv_catpv(aTHX_ report, name);
399 else if ((char)rv > ' ' && (char)rv < '~')
400 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
402 sv_catpvs(report, "EOF");
404 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
407 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
410 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
412 case TOKENTYPE_OPNUM:
413 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
414 PL_op_name[lvalp->ival]);
417 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
419 case TOKENTYPE_OPVAL:
421 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
422 PL_op_name[lvalp->opval->op_type]);
423 if (lvalp->opval->op_type == OP_CONST) {
424 Perl_sv_catpvf(aTHX_ report, " %s",
425 SvPEEK(cSVOPx_sv(lvalp->opval)));
430 sv_catpvs(report, "(opval=null)");
433 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
439 /* print the buffer with suitable escapes */
442 S_printbuf(pTHX_ const char *const fmt, const char *const s)
444 SV* const tmp = newSVpvs("");
446 PERL_ARGS_ASSERT_PRINTBUF;
448 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
457 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
458 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
462 S_ao(pTHX_ int toketype)
465 if (*PL_bufptr == '=') {
467 if (toketype == ANDAND)
468 pl_yylval.ival = OP_ANDASSIGN;
469 else if (toketype == OROR)
470 pl_yylval.ival = OP_ORASSIGN;
471 else if (toketype == DORDOR)
472 pl_yylval.ival = OP_DORASSIGN;
480 * When Perl expects an operator and finds something else, no_op
481 * prints the warning. It always prints "<something> found where
482 * operator expected. It prints "Missing semicolon on previous line?"
483 * if the surprise occurs at the start of the line. "do you need to
484 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
485 * where the compiler doesn't know if foo is a method call or a function.
486 * It prints "Missing operator before end of line" if there's nothing
487 * after the missing operator, or "... before <...>" if there is something
488 * after the missing operator.
492 S_no_op(pTHX_ const char *const what, char *s)
495 char * const oldbp = PL_bufptr;
496 const bool is_first = (PL_oldbufptr == PL_linestart);
498 PERL_ARGS_ASSERT_NO_OP;
504 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
505 if (ckWARN_d(WARN_SYNTAX)) {
507 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
508 "\t(Missing semicolon on previous line?)\n");
509 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
511 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
513 if (t < PL_bufptr && isSPACE(*t))
514 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
515 "\t(Do you need to predeclare %.*s?)\n",
516 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
520 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
521 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
529 * Complain about missing quote/regexp/heredoc terminator.
530 * If it's called with NULL then it cauterizes the line buffer.
531 * If we're in a delimited string and the delimiter is a control
532 * character, it's reformatted into a two-char sequence like ^C.
537 S_missingterm(pTHX_ char *s)
543 char * const nl = strrchr(s,'\n');
547 else if (isCNTRL(PL_multi_close)) {
549 tmpbuf[1] = (char)toCTRL(PL_multi_close);
554 *tmpbuf = (char)PL_multi_close;
558 q = strchr(s,'"') ? '\'' : '"';
559 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
562 #define FEATURE_IS_ENABLED(name) \
563 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
564 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
565 /* The longest string we pass in. */
566 #define MAX_FEATURE_LEN (sizeof("switch")-1)
569 * S_feature_is_enabled
570 * Check whether the named feature is enabled.
573 S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
576 HV * const hinthv = GvHV(PL_hintgv);
577 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
579 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
581 assert(namelen <= MAX_FEATURE_LEN);
582 memcpy(&he_name[8], name, namelen);
584 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
592 Perl_deprecate(pTHX_ const char *const s)
594 PERL_ARGS_ASSERT_DEPRECATE;
596 if (ckWARN(WARN_DEPRECATED))
597 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
601 Perl_deprecate_old(pTHX_ const char *const s)
603 /* This function should NOT be called for any new deprecated warnings */
604 /* Use Perl_deprecate instead */
606 /* It is here to maintain backward compatibility with the pre-5.8 */
607 /* warnings category hierarchy. The "deprecated" category used to */
608 /* live under the "syntax" category. It is now a top-level category */
609 /* in its own right. */
611 PERL_ARGS_ASSERT_DEPRECATE_OLD;
613 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
614 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
615 "Use of %s is deprecated", s);
619 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
620 * utf16-to-utf8-reversed.
623 #ifdef PERL_CR_FILTER
627 register const char *s = SvPVX_const(sv);
628 register const char * const e = s + SvCUR(sv);
630 PERL_ARGS_ASSERT_STRIP_RETURN;
632 /* outer loop optimized to do nothing if there are no CR-LFs */
634 if (*s++ == '\r' && *s == '\n') {
635 /* hit a CR-LF, need to copy the rest */
636 register char *d = s - 1;
639 if (*s == '\r' && s[1] == '\n')
650 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
652 const I32 count = FILTER_READ(idx+1, sv, maxlen);
653 if (count > 0 && !maxlen)
664 * Create a parser object and initialise its parser and lexer fields
666 * rsfp is the opened file handle to read from (if any),
668 * line holds any initial content already read from the file (or in
669 * the case of no file, such as an eval, the whole contents);
671 * new_filter indicates that this is a new file and it shouldn't inherit
672 * the filters from the current parser (ie require).
676 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
679 const char *s = NULL;
681 yy_parser *parser, *oparser;
683 /* create and initialise a parser */
685 Newxz(parser, 1, yy_parser);
686 parser->old_parser = oparser = PL_parser;
689 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
690 parser->ps = parser->stack;
691 parser->stack_size = YYINITDEPTH;
693 parser->stack->state = 0;
694 parser->yyerrstatus = 0;
695 parser->yychar = YYEMPTY; /* Cause a token to be read. */
697 /* on scope exit, free this parser and restore any outer one */
699 parser->saved_curcop = PL_curcop;
701 /* initialise lexer state */
704 parser->curforce = -1;
706 parser->nexttoke = 0;
708 parser->error_count = oparser ? oparser->error_count : 0;
709 parser->copline = NOLINE;
710 parser->lex_state = LEX_NORMAL;
711 parser->expect = XSTATE;
713 parser->rsfp_filters = (new_filter || !oparser) ? newAV()
714 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
716 Newx(parser->lex_brackstack, 120, char);
717 Newx(parser->lex_casestack, 12, char);
718 *parser->lex_casestack = '\0';
721 s = SvPV_const(line, len);
727 parser->linestr = newSVpvs("\n;");
728 } else if (SvREADONLY(line) || s[len-1] != ';') {
729 parser->linestr = newSVsv(line);
731 sv_catpvs(parser->linestr, "\n;");
734 SvREFCNT_inc_simple_void_NN(line);
735 parser->linestr = line;
737 parser->oldoldbufptr =
740 parser->linestart = SvPVX(parser->linestr);
741 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
742 parser->last_lop = parser->last_uni = NULL;
746 /* delete a parser object */
749 Perl_parser_free(pTHX_ const yy_parser *parser)
751 PERL_ARGS_ASSERT_PARSER_FREE;
753 PL_curcop = parser->saved_curcop;
754 SvREFCNT_dec(parser->linestr);
756 if (parser->rsfp == PerlIO_stdin())
757 PerlIO_clearerr(parser->rsfp);
758 else if (parser->rsfp && (!parser->old_parser ||
759 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
760 PerlIO_close(parser->rsfp);
761 SvREFCNT_dec(parser->rsfp_filters);
763 Safefree(parser->stack);
764 Safefree(parser->lex_brackstack);
765 Safefree(parser->lex_casestack);
766 PL_parser = parser->old_parser;
773 * Finalizer for lexing operations. Must be called when the parser is
774 * done with the lexer.
781 PL_doextract = FALSE;
786 * This subroutine has nothing to do with tilting, whether at windmills
787 * or pinball tables. Its name is short for "increment line". It
788 * increments the current line number in CopLINE(PL_curcop) and checks
789 * to see whether the line starts with a comment of the form
790 * # line 500 "foo.pm"
791 * If so, it sets the current line number and file to the values in the comment.
795 S_incline(pTHX_ const char *s)
802 PERL_ARGS_ASSERT_INCLINE;
804 CopLINE_inc(PL_curcop);
807 while (SPACE_OR_TAB(*s))
809 if (strnEQ(s, "line", 4))
813 if (SPACE_OR_TAB(*s))
817 while (SPACE_OR_TAB(*s))
825 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
827 while (SPACE_OR_TAB(*s))
829 if (*s == '"' && (t = strchr(s+1, '"'))) {
839 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
841 if (*e != '\n' && *e != '\0')
842 return; /* false alarm */
845 const STRLEN len = t - s;
847 SV *const temp_sv = CopFILESV(PL_curcop);
853 tmplen = SvCUR(temp_sv);
859 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
860 /* must copy *{"::_<(eval N)[oldfilename:L]"}
861 * to *{"::_<newfilename"} */
862 /* However, the long form of evals is only turned on by the
863 debugger - usually they're "(eval %lu)" */
867 STRLEN tmplen2 = len;
868 if (tmplen + 2 <= sizeof smallbuf)
871 Newx(tmpbuf, tmplen + 2, char);
874 memcpy(tmpbuf + 2, cf, tmplen);
876 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
881 if (tmplen2 + 2 <= sizeof smallbuf)
884 Newx(tmpbuf2, tmplen2 + 2, char);
886 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
887 /* Either they malloc'd it, or we malloc'd it,
888 so no prefix is present in ours. */
893 memcpy(tmpbuf2 + 2, s, tmplen2);
896 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
898 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
899 /* adjust ${"::_<newfilename"} to store the new file name */
900 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
901 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
902 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
905 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
907 if (tmpbuf != smallbuf) Safefree(tmpbuf);
910 CopFILE_free(PL_curcop);
911 CopFILE_setn(PL_curcop, s, len);
913 CopLINE_set(PL_curcop, atoi(n)-1);
917 /* skip space before PL_thistoken */
920 S_skipspace0(pTHX_ register char *s)
922 PERL_ARGS_ASSERT_SKIPSPACE0;
929 PL_thiswhite = newSVpvs("");
930 sv_catsv(PL_thiswhite, PL_skipwhite);
931 sv_free(PL_skipwhite);
934 PL_realtokenstart = s - SvPVX(PL_linestr);
938 /* skip space after PL_thistoken */
941 S_skipspace1(pTHX_ register char *s)
943 const char *start = s;
944 I32 startoff = start - SvPVX(PL_linestr);
946 PERL_ARGS_ASSERT_SKIPSPACE1;
951 start = SvPVX(PL_linestr) + startoff;
952 if (!PL_thistoken && PL_realtokenstart >= 0) {
953 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
954 PL_thistoken = newSVpvn(tstart, start - tstart);
956 PL_realtokenstart = -1;
959 PL_nextwhite = newSVpvs("");
960 sv_catsv(PL_nextwhite, PL_skipwhite);
961 sv_free(PL_skipwhite);
968 S_skipspace2(pTHX_ register char *s, SV **svp)
971 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
972 const I32 startoff = s - SvPVX(PL_linestr);
974 PERL_ARGS_ASSERT_SKIPSPACE2;
977 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
978 if (!PL_madskills || !svp)
980 start = SvPVX(PL_linestr) + startoff;
981 if (!PL_thistoken && PL_realtokenstart >= 0) {
982 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
983 PL_thistoken = newSVpvn(tstart, start - tstart);
984 PL_realtokenstart = -1;
989 sv_setsv(*svp, PL_skipwhite);
990 sv_free(PL_skipwhite);
999 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1001 AV *av = CopFILEAVx(PL_curcop);
1003 SV * const sv = newSV_type(SVt_PVMG);
1005 sv_setsv(sv, orig_sv);
1007 sv_setpvn(sv, buf, len);
1010 av_store(av, (I32)CopLINE(PL_curcop), sv);
1016 * Called to gobble the appropriate amount and type of whitespace.
1017 * Skips comments as well.
1021 S_skipspace(pTHX_ register char *s)
1026 int startoff = s - SvPVX(PL_linestr);
1028 PERL_ARGS_ASSERT_SKIPSPACE;
1031 sv_free(PL_skipwhite);
1035 PERL_ARGS_ASSERT_SKIPSPACE;
1037 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1038 while (s < PL_bufend && SPACE_OR_TAB(*s))
1048 SSize_t oldprevlen, oldoldprevlen;
1049 SSize_t oldloplen = 0, oldunilen = 0;
1050 while (s < PL_bufend && isSPACE(*s)) {
1051 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1056 if (s < PL_bufend && *s == '#') {
1057 while (s < PL_bufend && *s != '\n')
1059 if (s < PL_bufend) {
1061 if (PL_in_eval && !PL_rsfp) {
1068 /* only continue to recharge the buffer if we're at the end
1069 * of the buffer, we're not reading from a source filter, and
1070 * we're in normal lexing mode
1072 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1073 PL_lex_state == LEX_FORMLINE)
1080 /* try to recharge the buffer */
1082 curoff = s - SvPVX(PL_linestr);
1085 if ((s = filter_gets(PL_linestr, PL_rsfp,
1086 (prevlen = SvCUR(PL_linestr)))) == NULL)
1089 if (PL_madskills && curoff != startoff) {
1091 PL_skipwhite = newSVpvs("");
1092 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1096 /* mustn't throw out old stuff yet if madpropping */
1097 SvCUR(PL_linestr) = curoff;
1098 s = SvPVX(PL_linestr) + curoff;
1100 if (curoff && s[-1] == '\n')
1104 /* end of file. Add on the -p or -n magic */
1105 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1108 sv_catpvs(PL_linestr,
1109 ";}continue{print or die qq(-p destination: $!\\n);}");
1111 sv_setpvs(PL_linestr,
1112 ";}continue{print or die qq(-p destination: $!\\n);}");
1114 PL_minus_n = PL_minus_p = 0;
1116 else if (PL_minus_n) {
1118 sv_catpvs(PL_linestr, ";}");
1120 sv_setpvs(PL_linestr, ";}");
1126 sv_catpvs(PL_linestr,";");
1128 sv_setpvs(PL_linestr,";");
1131 /* reset variables for next time we lex */
1132 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1138 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1139 PL_last_lop = PL_last_uni = NULL;
1141 /* Close the filehandle. Could be from
1142 * STDIN, or a regular file. If we were reading code from
1143 * STDIN (because the commandline held no -e or filename)
1144 * then we don't close it, we reset it so the code can
1145 * read from STDIN too.
1148 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1149 PerlIO_clearerr(PL_rsfp);
1151 (void)PerlIO_close(PL_rsfp);
1156 /* not at end of file, so we only read another line */
1157 /* make corresponding updates to old pointers, for yyerror() */
1158 oldprevlen = PL_oldbufptr - PL_bufend;
1159 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1161 oldunilen = PL_last_uni - PL_bufend;
1163 oldloplen = PL_last_lop - PL_bufend;
1164 PL_linestart = PL_bufptr = s + prevlen;
1165 PL_bufend = s + SvCUR(PL_linestr);
1167 PL_oldbufptr = s + oldprevlen;
1168 PL_oldoldbufptr = s + oldoldprevlen;
1170 PL_last_uni = s + oldunilen;
1172 PL_last_lop = s + oldloplen;
1175 /* debugger active and we're not compiling the debugger code,
1176 * so store the line into the debugger's array of lines
1178 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
1179 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1186 PL_skipwhite = newSVpvs("");
1187 curoff = s - SvPVX(PL_linestr);
1188 if (curoff - startoff)
1189 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1198 * Check the unary operators to ensure there's no ambiguity in how they're
1199 * used. An ambiguous piece of code would be:
1201 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1202 * the +5 is its argument.
1212 if (PL_oldoldbufptr != PL_last_uni)
1214 while (isSPACE(*PL_last_uni))
1217 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1219 if ((t = strchr(s, '(')) && t < PL_bufptr)
1222 if (ckWARN_d(WARN_AMBIGUOUS)){
1223 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1224 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1225 (int)(s - PL_last_uni), PL_last_uni);
1230 * LOP : macro to build a list operator. Its behaviour has been replaced
1231 * with a subroutine, S_lop() for which LOP is just another name.
1234 #define LOP(f,x) return lop(f,x,s)
1238 * Build a list operator (or something that might be one). The rules:
1239 * - if we have a next token, then it's a list operator [why?]
1240 * - if the next thing is an opening paren, then it's a function
1241 * - else it's a list operator
1245 S_lop(pTHX_ I32 f, int x, char *s)
1249 PERL_ARGS_ASSERT_LOP;
1255 PL_last_lop = PL_oldbufptr;
1256 PL_last_lop_op = (OPCODE)f;
1259 return REPORT(LSTOP);
1262 return REPORT(LSTOP);
1265 return REPORT(FUNC);
1268 return REPORT(FUNC);
1270 return REPORT(LSTOP);
1276 * Sets up for an eventual force_next(). start_force(0) basically does
1277 * an unshift, while start_force(-1) does a push. yylex removes items
1282 S_start_force(pTHX_ int where)
1286 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1287 where = PL_lasttoke;
1288 assert(PL_curforce < 0 || PL_curforce == where);
1289 if (PL_curforce != where) {
1290 for (i = PL_lasttoke; i > where; --i) {
1291 PL_nexttoke[i] = PL_nexttoke[i-1];
1295 if (PL_curforce < 0) /* in case of duplicate start_force() */
1296 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1297 PL_curforce = where;
1300 curmad('^', newSVpvs(""));
1301 CURMAD('_', PL_nextwhite);
1306 S_curmad(pTHX_ char slot, SV *sv)
1312 if (PL_curforce < 0)
1313 where = &PL_thismad;
1315 where = &PL_nexttoke[PL_curforce].next_mad;
1321 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1323 else if (PL_encoding) {
1324 sv_recode_to_utf8(sv, PL_encoding);
1329 /* keep a slot open for the head of the list? */
1330 if (slot != '_' && *where && (*where)->mad_key == '^') {
1331 (*where)->mad_key = slot;
1332 sv_free(MUTABLE_SV(((*where)->mad_val)));
1333 (*where)->mad_val = (void*)sv;
1336 addmad(newMADsv(slot, sv), where, 0);
1339 # define start_force(where) NOOP
1340 # define curmad(slot, sv) NOOP
1345 * When the lexer realizes it knows the next token (for instance,
1346 * it is reordering tokens for the parser) then it can call S_force_next
1347 * to know what token to return the next time the lexer is called. Caller
1348 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1349 * and possibly PL_expect to ensure the lexer handles the token correctly.
1353 S_force_next(pTHX_ I32 type)
1358 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1359 tokereport(type, &NEXTVAL_NEXTTOKE);
1363 if (PL_curforce < 0)
1364 start_force(PL_lasttoke);
1365 PL_nexttoke[PL_curforce].next_type = type;
1366 if (PL_lex_state != LEX_KNOWNEXT)
1367 PL_lex_defer = PL_lex_state;
1368 PL_lex_state = LEX_KNOWNEXT;
1369 PL_lex_expect = PL_expect;
1372 PL_nexttype[PL_nexttoke] = type;
1374 if (PL_lex_state != LEX_KNOWNEXT) {
1375 PL_lex_defer = PL_lex_state;
1376 PL_lex_expect = PL_expect;
1377 PL_lex_state = LEX_KNOWNEXT;
1383 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1386 SV * const sv = newSVpvn_utf8(start, len,
1388 && is_utf8_string((const U8*)start, len));
1394 * When the lexer knows the next thing is a word (for instance, it has
1395 * just seen -> and it knows that the next char is a word char, then
1396 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1400 * char *start : buffer position (must be within PL_linestr)
1401 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1402 * int check_keyword : if true, Perl checks to make sure the word isn't
1403 * a keyword (do this if the word is a label, e.g. goto FOO)
1404 * int allow_pack : if true, : characters will also be allowed (require,
1405 * use, etc. do this)
1406 * int allow_initial_tick : used by the "sub" lexer only.
1410 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1416 PERL_ARGS_ASSERT_FORCE_WORD;
1418 start = SKIPSPACE1(start);
1420 if (isIDFIRST_lazy_if(s,UTF) ||
1421 (allow_pack && *s == ':') ||
1422 (allow_initial_tick && *s == '\'') )
1424 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1425 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1427 start_force(PL_curforce);
1429 curmad('X', newSVpvn(start,s-start));
1430 if (token == METHOD) {
1435 PL_expect = XOPERATOR;
1439 curmad('g', newSVpvs( "forced" ));
1440 NEXTVAL_NEXTTOKE.opval
1441 = (OP*)newSVOP(OP_CONST,0,
1442 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1443 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1451 * Called when the lexer wants $foo *foo &foo etc, but the program
1452 * text only contains the "foo" portion. The first argument is a pointer
1453 * to the "foo", and the second argument is the type symbol to prefix.
1454 * Forces the next token to be a "WORD".
1455 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1459 S_force_ident(pTHX_ register const char *s, int kind)
1463 PERL_ARGS_ASSERT_FORCE_IDENT;
1466 const STRLEN len = strlen(s);
1467 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1468 start_force(PL_curforce);
1469 NEXTVAL_NEXTTOKE.opval = o;
1472 o->op_private = OPpCONST_ENTERED;
1473 /* XXX see note in pp_entereval() for why we forgo typo
1474 warnings if the symbol must be introduced in an eval.
1476 gv_fetchpvn_flags(s, len,
1477 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1479 kind == '$' ? SVt_PV :
1480 kind == '@' ? SVt_PVAV :
1481 kind == '%' ? SVt_PVHV :
1489 Perl_str_to_version(pTHX_ SV *sv)
1494 const char *start = SvPV_const(sv,len);
1495 const char * const end = start + len;
1496 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1498 PERL_ARGS_ASSERT_STR_TO_VERSION;
1500 while (start < end) {
1504 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1509 retval += ((NV)n)/nshift;
1518 * Forces the next token to be a version number.
1519 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1520 * and if "guessing" is TRUE, then no new token is created (and the caller
1521 * must use an alternative parsing method).
1525 S_force_version(pTHX_ char *s, int guessing)
1531 I32 startoff = s - SvPVX(PL_linestr);
1534 PERL_ARGS_ASSERT_FORCE_VERSION;
1542 while (isDIGIT(*d) || *d == '_' || *d == '.')
1546 start_force(PL_curforce);
1547 curmad('X', newSVpvn(s,d-s));
1550 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1552 s = scan_num(s, &pl_yylval);
1553 version = pl_yylval.opval;
1554 ver = cSVOPx(version)->op_sv;
1555 if (SvPOK(ver) && !SvNIOK(ver)) {
1556 SvUPGRADE(ver, SVt_PVNV);
1557 SvNV_set(ver, str_to_version(ver));
1558 SvNOK_on(ver); /* hint that it is a version */
1561 else if (guessing) {
1564 sv_free(PL_nextwhite); /* let next token collect whitespace */
1566 s = SvPVX(PL_linestr) + startoff;
1574 if (PL_madskills && !version) {
1575 sv_free(PL_nextwhite); /* let next token collect whitespace */
1577 s = SvPVX(PL_linestr) + startoff;
1580 /* NOTE: The parser sees the package name and the VERSION swapped */
1581 start_force(PL_curforce);
1582 NEXTVAL_NEXTTOKE.opval = version;
1590 * Tokenize a quoted string passed in as an SV. It finds the next
1591 * chunk, up to end of string or a backslash. It may make a new
1592 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1597 S_tokeq(pTHX_ SV *sv)
1601 register char *send;
1606 PERL_ARGS_ASSERT_TOKEQ;
1611 s = SvPV_force(sv, len);
1612 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1615 while (s < send && *s != '\\')
1620 if ( PL_hints & HINT_NEW_STRING ) {
1621 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
1625 if (s + 1 < send && (s[1] == '\\'))
1626 s++; /* all that, just for this */
1631 SvCUR_set(sv, d - SvPVX_const(sv));
1633 if ( PL_hints & HINT_NEW_STRING )
1634 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
1639 * Now come three functions related to double-quote context,
1640 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1641 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1642 * interact with PL_lex_state, and create fake ( ... ) argument lists
1643 * to handle functions and concatenation.
1644 * They assume that whoever calls them will be setting up a fake
1645 * join call, because each subthing puts a ',' after it. This lets
1648 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1650 * (I'm not sure whether the spurious commas at the end of lcfirst's
1651 * arguments and join's arguments are created or not).
1656 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1658 * Pattern matching will set PL_lex_op to the pattern-matching op to
1659 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
1661 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1663 * Everything else becomes a FUNC.
1665 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1666 * had an OP_CONST or OP_READLINE). This just sets us up for a
1667 * call to S_sublex_push().
1671 S_sublex_start(pTHX)
1674 register const I32 op_type = pl_yylval.ival;
1676 if (op_type == OP_NULL) {
1677 pl_yylval.opval = PL_lex_op;
1681 if (op_type == OP_CONST || op_type == OP_READLINE) {
1682 SV *sv = tokeq(PL_lex_stuff);
1684 if (SvTYPE(sv) == SVt_PVIV) {
1685 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1687 const char * const p = SvPV_const(sv, len);
1688 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
1692 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1693 PL_lex_stuff = NULL;
1694 /* Allow <FH> // "foo" */
1695 if (op_type == OP_READLINE)
1696 PL_expect = XTERMORDORDOR;
1699 else if (op_type == OP_BACKTICK && PL_lex_op) {
1700 /* readpipe() vas overriden */
1701 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1702 pl_yylval.opval = PL_lex_op;
1704 PL_lex_stuff = NULL;
1708 PL_sublex_info.super_state = PL_lex_state;
1709 PL_sublex_info.sub_inwhat = (U16)op_type;
1710 PL_sublex_info.sub_op = PL_lex_op;
1711 PL_lex_state = LEX_INTERPPUSH;
1715 pl_yylval.opval = PL_lex_op;
1725 * Create a new scope to save the lexing state. The scope will be
1726 * ended in S_sublex_done. Returns a '(', starting the function arguments
1727 * to the uc, lc, etc. found before.
1728 * Sets PL_lex_state to LEX_INTERPCONCAT.
1737 PL_lex_state = PL_sublex_info.super_state;
1738 SAVEBOOL(PL_lex_dojoin);
1739 SAVEI32(PL_lex_brackets);
1740 SAVEI32(PL_lex_casemods);
1741 SAVEI32(PL_lex_starts);
1742 SAVEI8(PL_lex_state);
1743 SAVEVPTR(PL_lex_inpat);
1744 SAVEI16(PL_lex_inwhat);
1745 SAVECOPLINE(PL_curcop);
1746 SAVEPPTR(PL_bufptr);
1747 SAVEPPTR(PL_bufend);
1748 SAVEPPTR(PL_oldbufptr);
1749 SAVEPPTR(PL_oldoldbufptr);
1750 SAVEPPTR(PL_last_lop);
1751 SAVEPPTR(PL_last_uni);
1752 SAVEPPTR(PL_linestart);
1753 SAVESPTR(PL_linestr);
1754 SAVEGENERICPV(PL_lex_brackstack);
1755 SAVEGENERICPV(PL_lex_casestack);
1757 PL_linestr = PL_lex_stuff;
1758 PL_lex_stuff = NULL;
1760 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1761 = SvPVX(PL_linestr);
1762 PL_bufend += SvCUR(PL_linestr);
1763 PL_last_lop = PL_last_uni = NULL;
1764 SAVEFREESV(PL_linestr);
1766 PL_lex_dojoin = FALSE;
1767 PL_lex_brackets = 0;
1768 Newx(PL_lex_brackstack, 120, char);
1769 Newx(PL_lex_casestack, 12, char);
1770 PL_lex_casemods = 0;
1771 *PL_lex_casestack = '\0';
1773 PL_lex_state = LEX_INTERPCONCAT;
1774 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1776 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1777 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1778 PL_lex_inpat = PL_sublex_info.sub_op;
1780 PL_lex_inpat = NULL;
1787 * Restores lexer state after a S_sublex_push.
1794 if (!PL_lex_starts++) {
1795 SV * const sv = newSVpvs("");
1796 if (SvUTF8(PL_linestr))
1798 PL_expect = XOPERATOR;
1799 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1803 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1804 PL_lex_state = LEX_INTERPCASEMOD;
1808 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1809 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1810 PL_linestr = PL_lex_repl;
1812 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1813 PL_bufend += SvCUR(PL_linestr);
1814 PL_last_lop = PL_last_uni = NULL;
1815 SAVEFREESV(PL_linestr);
1816 PL_lex_dojoin = FALSE;
1817 PL_lex_brackets = 0;
1818 PL_lex_casemods = 0;
1819 *PL_lex_casestack = '\0';
1821 if (SvEVALED(PL_lex_repl)) {
1822 PL_lex_state = LEX_INTERPNORMAL;
1824 /* we don't clear PL_lex_repl here, so that we can check later
1825 whether this is an evalled subst; that means we rely on the
1826 logic to ensure sublex_done() is called again only via the
1827 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1830 PL_lex_state = LEX_INTERPCONCAT;
1840 PL_endwhite = newSVpvs("");
1841 sv_catsv(PL_endwhite, PL_thiswhite);
1845 sv_setpvs(PL_thistoken,"");
1847 PL_realtokenstart = -1;
1851 PL_bufend = SvPVX(PL_linestr);
1852 PL_bufend += SvCUR(PL_linestr);
1853 PL_expect = XOPERATOR;
1854 PL_sublex_info.sub_inwhat = 0;
1862 Extracts a pattern, double-quoted string, or transliteration. This
1865 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1866 processing a pattern (PL_lex_inpat is true), a transliteration
1867 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1869 Returns a pointer to the character scanned up to. If this is
1870 advanced from the start pointer supplied (i.e. if anything was
1871 successfully parsed), will leave an OP for the substring scanned
1872 in pl_yylval. Caller must intuit reason for not parsing further
1873 by looking at the next characters herself.
1877 double-quoted style: \r and \n
1878 regexp special ones: \D \s
1881 case and quoting: \U \Q \E
1882 stops on @ and $, but not for $ as tail anchor
1884 In transliterations:
1885 characters are VERY literal, except for - not at the start or end
1886 of the string, which indicates a range. If the range is in bytes,
1887 scan_const expands the range to the full set of intermediate
1888 characters. If the range is in utf8, the hyphen is replaced with
1889 a certain range mark which will be handled by pmtrans() in op.c.
1891 In double-quoted strings:
1893 double-quoted style: \r and \n
1895 deprecated backrefs: \1 (in substitution replacements)
1896 case and quoting: \U \Q \E
1899 scan_const does *not* construct ops to handle interpolated strings.
1900 It stops processing as soon as it finds an embedded $ or @ variable
1901 and leaves it to the caller to work out what's going on.
1903 embedded arrays (whether in pattern or not) could be:
1904 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1906 $ in double-quoted strings must be the symbol of an embedded scalar.
1908 $ in pattern could be $foo or could be tail anchor. Assumption:
1909 it's a tail anchor if $ is the last thing in the string, or if it's
1910 followed by one of "()| \r\n\t"
1912 \1 (backreferences) are turned into $1
1914 The structure of the code is
1915 while (there's a character to process) {
1916 handle transliteration ranges
1917 skip regexp comments /(?#comment)/ and codes /(?{code})/
1918 skip #-initiated comments in //x patterns
1919 check for embedded arrays
1920 check for embedded scalars
1922 leave intact backslashes from leaveit (below)
1923 deprecate \1 in substitution replacements
1924 handle string-changing backslashes \l \U \Q \E, etc.
1925 switch (what was escaped) {
1926 handle \- in a transliteration (becomes a literal -)
1927 handle \132 (octal characters)
1928 handle \x15 and \x{1234} (hex characters)
1929 handle \N{name} (named characters)
1930 handle \cV (control characters)
1931 handle printf-style backslashes (\f, \r, \n, etc)
1934 } (end if backslash)
1935 handle regular character
1936 } (end while character to read)
1941 S_scan_const(pTHX_ char *start)
1944 register char *send = PL_bufend; /* end of the constant */
1945 SV *sv = newSV(send - start); /* sv for the constant. See
1946 note below on sizing. */
1947 register char *s = start; /* start of the constant */
1948 register char *d = SvPVX(sv); /* destination for copies */
1949 bool dorange = FALSE; /* are we in a translit range? */
1950 bool didrange = FALSE; /* did we just finish a range? */
1951 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1952 I32 this_utf8 = UTF; /* Is the source string assumed
1953 to be UTF8? But, this can
1954 show as true when the source
1955 isn't utf8, as for example
1956 when it is entirely composed
1959 /* Note on sizing: The scanned constant is placed into sv, which is
1960 * initialized by newSV() assuming one byte of output for every byte of
1961 * input. This routine expects newSV() to allocate an extra byte for a
1962 * trailing NUL, which this routine will append if it gets to the end of
1963 * the input. There may be more bytes of input than output (eg., \N{LATIN
1964 * CAPITAL LETTER A}), or more output than input if the constant ends up
1965 * recoded to utf8, but each time a construct is found that might increase
1966 * the needed size, SvGROW() is called. Its size parameter each time is
1967 * based on the best guess estimate at the time, namely the length used so
1968 * far, plus the length the current construct will occupy, plus room for
1969 * the trailing NUL, plus one byte for every input byte still unscanned */
1973 UV literal_endpoint = 0;
1974 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1977 PERL_ARGS_ASSERT_SCAN_CONST;
1979 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1980 /* If we are doing a trans and we know we want UTF8 set expectation */
1981 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1982 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1986 while (s < send || dorange) {
1987 /* get transliterations out of the way (they're most literal) */
1988 if (PL_lex_inwhat == OP_TRANS) {
1989 /* expand a range A-Z to the full set of characters. AIE! */
1991 I32 i; /* current expanded character */
1992 I32 min; /* first character in range */
1993 I32 max; /* last character in range */
2004 char * const c = (char*)utf8_hop((U8*)d, -1);
2008 *c = (char)UTF_TO_NATIVE(0xff);
2009 /* mark the range as done, and continue */
2015 i = d - SvPVX_const(sv); /* remember current offset */
2018 SvLEN(sv) + (has_utf8 ?
2019 (512 - UTF_CONTINUATION_MARK +
2022 /* How many two-byte within 0..255: 128 in UTF-8,
2023 * 96 in UTF-8-mod. */
2025 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2027 d = SvPVX(sv) + i; /* refresh d after realloc */
2031 for (j = 0; j <= 1; j++) {
2032 char * const c = (char*)utf8_hop((U8*)d, -1);
2033 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2039 max = (U8)0xff; /* only to \xff */
2040 uvmax = uv; /* \x{100} to uvmax */
2042 d = c; /* eat endpoint chars */
2047 d -= 2; /* eat the first char and the - */
2048 min = (U8)*d; /* first char in range */
2049 max = (U8)d[1]; /* last char in range */
2056 "Invalid range \"%c-%c\" in transliteration operator",
2057 (char)min, (char)max);
2061 if (literal_endpoint == 2 &&
2062 ((isLOWER(min) && isLOWER(max)) ||
2063 (isUPPER(min) && isUPPER(max)))) {
2065 for (i = min; i <= max; i++)
2067 *d++ = NATIVE_TO_NEED(has_utf8,i);
2069 for (i = min; i <= max; i++)
2071 *d++ = NATIVE_TO_NEED(has_utf8,i);
2076 for (i = min; i <= max; i++)
2079 const U8 ch = (U8)NATIVE_TO_UTF(i);
2080 if (UNI_IS_INVARIANT(ch))
2083 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2084 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2093 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2095 *d++ = (char)UTF_TO_NATIVE(0xff);
2097 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2101 /* mark the range as done, and continue */
2105 literal_endpoint = 0;
2110 /* range begins (ignore - as first or last char) */
2111 else if (*s == '-' && s+1 < send && s != start) {
2113 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2120 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2130 literal_endpoint = 0;
2131 native_range = TRUE;
2136 /* if we get here, we're not doing a transliteration */
2138 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2139 except for the last char, which will be done separately. */
2140 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2142 while (s+1 < send && *s != ')')
2143 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2145 else if (s[2] == '{' /* This should match regcomp.c */
2146 || (s[2] == '?' && s[3] == '{'))
2149 char *regparse = s + (s[2] == '{' ? 3 : 4);
2152 while (count && (c = *regparse)) {
2153 if (c == '\\' && regparse[1])
2161 if (*regparse != ')')
2162 regparse--; /* Leave one char for continuation. */
2163 while (s < regparse)
2164 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2168 /* likewise skip #-initiated comments in //x patterns */
2169 else if (*s == '#' && PL_lex_inpat &&
2170 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2171 while (s+1 < send && *s != '\n')
2172 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2175 /* check for embedded arrays
2176 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2178 else if (*s == '@' && s[1]) {
2179 if (isALNUM_lazy_if(s+1,UTF))
2181 if (strchr(":'{$", s[1]))
2183 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2184 break; /* in regexp, neither @+ nor @- are interpolated */
2187 /* check for embedded scalars. only stop if we're sure it's a
2190 else if (*s == '$') {
2191 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2193 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2194 if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) {
2195 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2196 "Possible unintended interpolation of $\\ in regex");
2198 break; /* in regexp, $ might be tail anchor */
2202 /* End of else if chain - OP_TRANS rejoin rest */
2205 if (*s == '\\' && s+1 < send) {
2208 /* deprecate \1 in strings and substitution replacements */
2209 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2210 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2212 if (ckWARN(WARN_SYNTAX))
2213 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2218 /* string-change backslash escapes */
2219 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2223 /* skip any other backslash escapes in a pattern */
2224 else if (PL_lex_inpat) {
2225 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2226 goto default_action;
2229 /* if we get here, it's either a quoted -, or a digit */
2232 /* quoted - in transliterations */
2234 if (PL_lex_inwhat == OP_TRANS) {
2241 if ((isALPHA(*s) || isDIGIT(*s)) &&
2243 Perl_warner(aTHX_ packWARN(WARN_MISC),
2244 "Unrecognized escape \\%c passed through",
2246 /* default action is to copy the quoted character */
2247 goto default_action;
2250 /* eg. \132 indicates the octal constant 0x132 */
2251 case '0': case '1': case '2': case '3':
2252 case '4': case '5': case '6': case '7':
2256 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2259 goto NUM_ESCAPE_INSERT;
2261 /* eg. \x24 indicates the hex constant 0x24 */
2265 char* const e = strchr(s, '}');
2266 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2267 PERL_SCAN_DISALLOW_PREFIX;
2272 yyerror("Missing right brace on \\x{}");
2276 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2282 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2283 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2289 /* Insert oct, hex, or \N{U+...} escaped character. There will
2290 * always be enough room in sv since such escapes will be
2291 * longer than any UTF-8 sequence they can end up as, except if
2292 * they force us to recode the rest of the string into utf8 */
2294 /* Here uv is the ordinal of the next character being added in
2295 * unicode (converted from native). (It has to be done before
2296 * here because \N is interpreted as unicode, and oct and hex
2298 if (!UNI_IS_INVARIANT(uv)) {
2299 if (!has_utf8 && uv > 255) {
2300 /* Might need to recode whatever we have accumulated so
2301 * far if it contains any chars variant in utf8 or
2304 SvCUR_set(sv, d - SvPVX_const(sv));
2307 /* See Note on sizing above. */
2308 sv_utf8_upgrade_flags_grow(sv,
2309 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2310 UNISKIP(uv) + (STRLEN)(send - s) + 1);
2311 d = SvPVX(sv) + SvCUR(sv);
2316 d = (char*)uvuni_to_utf8((U8*)d, uv);
2317 if (PL_lex_inwhat == OP_TRANS &&
2318 PL_sublex_info.sub_op) {
2319 PL_sublex_info.sub_op->op_private |=
2320 (PL_lex_repl ? OPpTRANS_FROM_UTF
2324 if (uv > 255 && !dorange)
2325 native_range = FALSE;
2337 /* \N{LATIN SMALL LETTER A} is a named character, and so is
2342 char* e = strchr(s, '}');
2348 yyerror("Missing right brace on \\N{}");
2352 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2353 /* \N{U+...} The ... is a unicode value even on EBCDIC
2355 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2356 PERL_SCAN_DISALLOW_PREFIX;
2359 uv = grok_hex(s, &len, &flags, NULL);
2360 if ( e > s && len != (STRLEN)(e - s) ) {
2364 goto NUM_ESCAPE_INSERT;
2366 res = newSVpvn(s + 1, e - s - 1);
2367 res = new_constant( NULL, 0, "charnames",
2368 res, NULL, s - 2, e - s + 3 );
2370 sv_utf8_upgrade(res);
2371 str = SvPV_const(res,len);
2372 #ifdef EBCDIC_NEVER_MIND
2373 /* charnames uses pack U and that has been
2374 * recently changed to do the below uni->native
2375 * mapping, so this would be redundant (and wrong,
2376 * the code point would be doubly converted).
2377 * But leave this in just in case the pack U change
2378 * gets revoked, but the semantics is still
2379 * desireable for charnames. --jhi */
2381 UV uv = utf8_to_uvchr((const U8*)str, 0);
2384 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2386 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2387 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2388 str = SvPV_const(res, len);
2392 /* If destination is not in utf8 but this new character is,
2393 * recode the dest to utf8 */
2394 if (!has_utf8 && SvUTF8(res)) {
2395 SvCUR_set(sv, d - SvPVX_const(sv));
2398 /* See Note on sizing above. */
2399 sv_utf8_upgrade_flags_grow(sv,
2400 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2401 len + (STRLEN)(send - s) + 1);
2402 d = SvPVX(sv) + SvCUR(sv);
2404 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2406 /* See Note on sizing above. (NOTE: SvCUR() is not set
2407 * correctly here). */
2408 const STRLEN off = d - SvPVX_const(sv);
2409 d = SvGROW(sv, off + len + (STRLEN)(send - s) + 1) + off;
2413 native_range = FALSE; /* \N{} is guessed to be Unicode */
2415 Copy(str, d, len, char);
2422 yyerror("Missing braces on \\N{}");
2425 /* \c is a control character */
2434 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2437 yyerror("Missing control char name in \\c");
2441 /* printf-style backslashes, formfeeds, newlines, etc */
2443 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2446 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2449 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2452 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2455 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2458 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2461 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2467 } /* end if (backslash) */
2474 /* If we started with encoded form, or already know we want it,
2475 then encode the next character */
2476 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
2480 /* One might think that it is wasted effort in the case of the
2481 * source being utf8 (this_utf8 == TRUE) to take the next character
2482 * in the source, convert it to an unsigned value, and then convert
2483 * it back again. But the source has not been validated here. The
2484 * routine that does the conversion checks for errors like
2487 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2488 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2490 SvCUR_set(sv, d - SvPVX_const(sv));
2493 /* See Note on sizing above. */
2494 sv_utf8_upgrade_flags_grow(sv,
2495 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2496 need + (STRLEN)(send - s) + 1);
2497 d = SvPVX(sv) + SvCUR(sv);
2499 } else if (need > len) {
2500 /* encoded value larger than old, may need extra space (NOTE:
2501 * SvCUR() is not set correctly here). See Note on sizing
2503 const STRLEN off = d - SvPVX_const(sv);
2504 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
2508 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2510 if (uv > 255 && !dorange)
2511 native_range = FALSE;
2515 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2517 } /* while loop to process each character */
2519 /* terminate the string and set up the sv */
2521 SvCUR_set(sv, d - SvPVX_const(sv));
2522 if (SvCUR(sv) >= SvLEN(sv))
2523 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2526 if (PL_encoding && !has_utf8) {
2527 sv_recode_to_utf8(sv, PL_encoding);
2533 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2534 PL_sublex_info.sub_op->op_private |=
2535 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2539 /* shrink the sv if we allocated more than we used */
2540 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2541 SvPV_shrink_to_cur(sv);
2544 /* return the substring (via pl_yylval) only if we parsed anything */
2545 if (s > PL_bufptr) {
2546 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
2547 const char *const key = PL_lex_inpat ? "qr" : "q";
2548 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
2552 if (PL_lex_inwhat == OP_TRANS) {
2555 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
2563 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
2566 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2573 * Returns TRUE if there's more to the expression (e.g., a subscript),
2576 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2578 * ->[ and ->{ return TRUE
2579 * { and [ outside a pattern are always subscripts, so return TRUE
2580 * if we're outside a pattern and it's not { or [, then return FALSE
2581 * if we're in a pattern and the first char is a {
2582 * {4,5} (any digits around the comma) returns FALSE
2583 * if we're in a pattern and the first char is a [
2585 * [SOMETHING] has a funky algorithm to decide whether it's a
2586 * character class or not. It has to deal with things like
2587 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2588 * anything else returns TRUE
2591 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2594 S_intuit_more(pTHX_ register char *s)
2598 PERL_ARGS_ASSERT_INTUIT_MORE;
2600 if (PL_lex_brackets)
2602 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2604 if (*s != '{' && *s != '[')
2609 /* In a pattern, so maybe we have {n,m}. */
2626 /* On the other hand, maybe we have a character class */
2629 if (*s == ']' || *s == '^')
2632 /* this is terrifying, and it works */
2633 int weight = 2; /* let's weigh the evidence */
2635 unsigned char un_char = 255, last_un_char;
2636 const char * const send = strchr(s,']');
2637 char tmpbuf[sizeof PL_tokenbuf * 4];
2639 if (!send) /* has to be an expression */
2642 Zero(seen,256,char);
2645 else if (isDIGIT(*s)) {
2647 if (isDIGIT(s[1]) && s[2] == ']')
2653 for (; s < send; s++) {
2654 last_un_char = un_char;
2655 un_char = (unsigned char)*s;
2660 weight -= seen[un_char] * 10;
2661 if (isALNUM_lazy_if(s+1,UTF)) {
2663 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2664 len = (int)strlen(tmpbuf);
2665 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2670 else if (*s == '$' && s[1] &&
2671 strchr("[#!%*<>()-=",s[1])) {
2672 if (/*{*/ strchr("])} =",s[2]))
2681 if (strchr("wds]",s[1]))
2683 else if (seen[(U8)'\''] || seen[(U8)'"'])
2685 else if (strchr("rnftbxcav",s[1]))
2687 else if (isDIGIT(s[1])) {
2689 while (s[1] && isDIGIT(s[1]))
2699 if (strchr("aA01! ",last_un_char))
2701 if (strchr("zZ79~",s[1]))
2703 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2704 weight -= 5; /* cope with negative subscript */
2707 if (!isALNUM(last_un_char)
2708 && !(last_un_char == '$' || last_un_char == '@'
2709 || last_un_char == '&')
2710 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2715 if (keyword(tmpbuf, d - tmpbuf, 0))
2718 if (un_char == last_un_char + 1)
2720 weight -= seen[un_char];
2725 if (weight >= 0) /* probably a character class */
2735 * Does all the checking to disambiguate
2737 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2738 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2740 * First argument is the stuff after the first token, e.g. "bar".
2742 * Not a method if bar is a filehandle.
2743 * Not a method if foo is a subroutine prototyped to take a filehandle.
2744 * Not a method if it's really "Foo $bar"
2745 * Method if it's "foo $bar"
2746 * Not a method if it's really "print foo $bar"
2747 * Method if it's really "foo package::" (interpreted as package->foo)
2748 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2749 * Not a method if bar is a filehandle or package, but is quoted with
2754 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2757 char *s = start + (*start == '$');
2758 char tmpbuf[sizeof PL_tokenbuf];
2765 PERL_ARGS_ASSERT_INTUIT_METHOD;
2768 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2772 const char *proto = SvPVX_const(cv);
2783 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2784 /* start is the beginning of the possible filehandle/object,
2785 * and s is the end of it
2786 * tmpbuf is a copy of it
2789 if (*start == '$') {
2790 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2791 isUPPER(*PL_tokenbuf))
2794 len = start - SvPVX(PL_linestr);
2798 start = SvPVX(PL_linestr) + len;
2802 return *s == '(' ? FUNCMETH : METHOD;
2804 if (!keyword(tmpbuf, len, 0)) {
2805 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2809 soff = s - SvPVX(PL_linestr);
2813 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2814 if (indirgv && GvCVu(indirgv))
2816 /* filehandle or package name makes it a method */
2817 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2819 soff = s - SvPVX(PL_linestr);
2822 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2823 return 0; /* no assumptions -- "=>" quotes bearword */
2825 start_force(PL_curforce);
2826 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2827 newSVpvn(tmpbuf,len));
2828 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2830 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2835 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2837 return *s == '(' ? FUNCMETH : METHOD;
2843 /* Encoded script support. filter_add() effectively inserts a
2844 * 'pre-processing' function into the current source input stream.
2845 * Note that the filter function only applies to the current source file
2846 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2848 * The datasv parameter (which may be NULL) can be used to pass
2849 * private data to this instance of the filter. The filter function
2850 * can recover the SV using the FILTER_DATA macro and use it to
2851 * store private buffers and state information.
2853 * The supplied datasv parameter is upgraded to a PVIO type
2854 * and the IoDIRP/IoANY field is used to store the function pointer,
2855 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2856 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2857 * private use must be set using malloc'd pointers.
2861 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2870 if (!PL_rsfp_filters)
2871 PL_rsfp_filters = newAV();
2874 SvUPGRADE(datasv, SVt_PVIO);
2875 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2876 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2877 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2878 FPTR2DPTR(void *, IoANY(datasv)),
2879 SvPV_nolen(datasv)));
2880 av_unshift(PL_rsfp_filters, 1);
2881 av_store(PL_rsfp_filters, 0, datasv) ;
2886 /* Delete most recently added instance of this filter function. */
2888 Perl_filter_del(pTHX_ filter_t funcp)
2893 PERL_ARGS_ASSERT_FILTER_DEL;
2896 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2897 FPTR2DPTR(void*, funcp)));
2899 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2901 /* if filter is on top of stack (usual case) just pop it off */
2902 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2903 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2904 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2905 IoANY(datasv) = (void *)NULL;
2906 sv_free(av_pop(PL_rsfp_filters));
2910 /* we need to search for the correct entry and clear it */
2911 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2915 /* Invoke the idxth filter function for the current rsfp. */
2916 /* maxlen 0 = read one text line */
2918 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2923 /* This API is bad. It should have been using unsigned int for maxlen.
2924 Not sure if we want to change the API, but if not we should sanity
2925 check the value here. */
2926 const unsigned int correct_length
2935 PERL_ARGS_ASSERT_FILTER_READ;
2937 if (!PL_parser || !PL_rsfp_filters)
2939 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2940 /* Provide a default input filter to make life easy. */
2941 /* Note that we append to the line. This is handy. */
2942 DEBUG_P(PerlIO_printf(Perl_debug_log,
2943 "filter_read %d: from rsfp\n", idx));
2944 if (correct_length) {
2947 const int old_len = SvCUR(buf_sv);
2949 /* ensure buf_sv is large enough */
2950 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2951 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2952 correct_length)) <= 0) {
2953 if (PerlIO_error(PL_rsfp))
2954 return -1; /* error */
2956 return 0 ; /* end of file */
2958 SvCUR_set(buf_sv, old_len + len) ;
2961 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2962 if (PerlIO_error(PL_rsfp))
2963 return -1; /* error */
2965 return 0 ; /* end of file */
2968 return SvCUR(buf_sv);
2970 /* Skip this filter slot if filter has been deleted */
2971 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2972 DEBUG_P(PerlIO_printf(Perl_debug_log,
2973 "filter_read %d: skipped (filter deleted)\n",
2975 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2977 /* Get function pointer hidden within datasv */
2978 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2979 DEBUG_P(PerlIO_printf(Perl_debug_log,
2980 "filter_read %d: via function %p (%s)\n",
2981 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2982 /* Call function. The function is expected to */
2983 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2984 /* Return: <0:error, =0:eof, >0:not eof */
2985 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2989 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2993 PERL_ARGS_ASSERT_FILTER_GETS;
2995 #ifdef PERL_CR_FILTER
2996 if (!PL_rsfp_filters) {
2997 filter_add(S_cr_textfilter,NULL);
3000 if (PL_rsfp_filters) {
3002 SvCUR_set(sv, 0); /* start with empty line */
3003 if (FILTER_READ(0, sv, 0) > 0)
3004 return ( SvPVX(sv) ) ;
3009 return (sv_gets(sv, fp, append));
3013 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
3018 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
3020 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3024 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3025 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3027 return GvHV(gv); /* Foo:: */
3030 /* use constant CLASS => 'MyClass' */
3031 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3032 if (gv && GvCV(gv)) {
3033 SV * const sv = cv_const_sv(GvCV(gv));
3035 pkgname = SvPV_const(sv, len);
3038 return gv_stashpvn(pkgname, len, 0);
3042 * S_readpipe_override
3043 * Check whether readpipe() is overriden, and generates the appropriate
3044 * optree, provided sublex_start() is called afterwards.
3047 S_readpipe_override(pTHX)
3050 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
3051 pl_yylval.ival = OP_BACKTICK;
3053 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
3055 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
3056 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
3057 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
3059 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
3060 append_elem(OP_LIST,
3061 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
3062 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
3069 * The intent of this yylex wrapper is to minimize the changes to the
3070 * tokener when we aren't interested in collecting madprops. It remains
3071 * to be seen how successful this strategy will be...
3078 char *s = PL_bufptr;
3080 /* make sure PL_thiswhite is initialized */
3084 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
3085 if (PL_pending_ident)
3086 return S_pending_ident(aTHX);
3088 /* previous token ate up our whitespace? */
3089 if (!PL_lasttoke && PL_nextwhite) {
3090 PL_thiswhite = PL_nextwhite;
3094 /* isolate the token, and figure out where it is without whitespace */
3095 PL_realtokenstart = -1;
3099 assert(PL_curforce < 0);
3101 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
3102 if (!PL_thistoken) {
3103 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3104 PL_thistoken = newSVpvs("");
3106 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3107 PL_thistoken = newSVpvn(tstart, s - tstart);
3110 if (PL_thismad) /* install head */
3111 CURMAD('X', PL_thistoken);
3114 /* last whitespace of a sublex? */
3115 if (optype == ')' && PL_endwhite) {
3116 CURMAD('X', PL_endwhite);
3121 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
3122 if (!PL_thiswhite && !PL_endwhite && !optype) {
3123 sv_free(PL_thistoken);
3128 /* put off final whitespace till peg */
3129 if (optype == ';' && !PL_rsfp) {
3130 PL_nextwhite = PL_thiswhite;
3133 else if (PL_thisopen) {
3134 CURMAD('q', PL_thisopen);
3136 sv_free(PL_thistoken);
3140 /* Store actual token text as madprop X */
3141 CURMAD('X', PL_thistoken);
3145 /* add preceding whitespace as madprop _ */
3146 CURMAD('_', PL_thiswhite);
3150 /* add quoted material as madprop = */
3151 CURMAD('=', PL_thisstuff);
3155 /* add terminating quote as madprop Q */
3156 CURMAD('Q', PL_thisclose);
3160 /* special processing based on optype */
3164 /* opval doesn't need a TOKEN since it can already store mp */
3174 if (pl_yylval.opval)
3175 append_madprops(PL_thismad, pl_yylval.opval, 0);
3183 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3192 /* remember any fake bracket that lexer is about to discard */
3193 if (PL_lex_brackets == 1 &&
3194 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3197 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3200 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3201 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3204 break; /* don't bother looking for trailing comment */
3213 /* attach a trailing comment to its statement instead of next token */
3217 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3219 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3221 if (*s == '\n' || *s == '#') {
3222 while (s < PL_bufend && *s != '\n')
3226 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3227 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3244 /* Create new token struct. Note: opvals return early above. */
3245 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
3252 S_tokenize_use(pTHX_ int is_use, char *s) {
3255 PERL_ARGS_ASSERT_TOKENIZE_USE;
3257 if (PL_expect != XSTATE)
3258 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3259 is_use ? "use" : "no"));
3261 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3262 s = force_version(s, TRUE);
3263 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3264 start_force(PL_curforce);
3265 NEXTVAL_NEXTTOKE.opval = NULL;
3268 else if (*s == 'v') {
3269 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3270 s = force_version(s, FALSE);
3274 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3275 s = force_version(s, FALSE);
3277 pl_yylval.ival = is_use;
3281 static const char* const exp_name[] =
3282 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3283 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3290 Works out what to call the token just pulled out of the input
3291 stream. The yacc parser takes care of taking the ops we return and
3292 stitching them into a tree.
3298 if read an identifier
3299 if we're in a my declaration
3300 croak if they tried to say my($foo::bar)
3301 build the ops for a my() declaration
3302 if it's an access to a my() variable
3303 are we in a sort block?
3304 croak if my($a); $a <=> $b
3305 build ops for access to a my() variable
3306 if in a dq string, and they've said @foo and we can't find @foo
3308 build ops for a bareword
3309 if we already built the token before, use it.
3314 #pragma segment Perl_yylex
3320 register char *s = PL_bufptr;
3325 /* orig_keyword, gvp, and gv are initialized here because
3326 * jump to the label just_a_word_zero can bypass their
3327 * initialization later. */
3328 I32 orig_keyword = 0;
3333 SV* tmp = newSVpvs("");
3334 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3335 (IV)CopLINE(PL_curcop),
3336 lex_state_names[PL_lex_state],
3337 exp_name[PL_expect],
3338 pv_display(tmp, s, strlen(s), 0, 60));
3341 /* check if there's an identifier for us to look at */
3342 if (PL_pending_ident)
3343 return REPORT(S_pending_ident(aTHX));
3345 /* no identifier pending identification */
3347 switch (PL_lex_state) {
3349 case LEX_NORMAL: /* Some compilers will produce faster */
3350 case LEX_INTERPNORMAL: /* code if we comment these out. */
3354 /* when we've already built the next token, just pull it out of the queue */
3358 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
3360 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3361 PL_nexttoke[PL_lasttoke].next_mad = 0;
3362 if (PL_thismad && PL_thismad->mad_key == '_') {
3363 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
3364 PL_thismad->mad_val = 0;
3365 mad_free(PL_thismad);
3370 PL_lex_state = PL_lex_defer;
3371 PL_expect = PL_lex_expect;
3372 PL_lex_defer = LEX_NORMAL;
3373 if (!PL_nexttoke[PL_lasttoke].next_type)
3378 pl_yylval = PL_nextval[PL_nexttoke];
3380 PL_lex_state = PL_lex_defer;
3381 PL_expect = PL_lex_expect;
3382 PL_lex_defer = LEX_NORMAL;
3386 /* FIXME - can these be merged? */
3387 return(PL_nexttoke[PL_lasttoke].next_type);
3389 return REPORT(PL_nexttype[PL_nexttoke]);
3392 /* interpolated case modifiers like \L \U, including \Q and \E.
3393 when we get here, PL_bufptr is at the \
3395 case LEX_INTERPCASEMOD:
3397 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3398 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3400 /* handle \E or end of string */
3401 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3403 if (PL_lex_casemods) {
3404 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3405 PL_lex_casestack[PL_lex_casemods] = '\0';
3407 if (PL_bufptr != PL_bufend
3408 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3410 PL_lex_state = LEX_INTERPCONCAT;
3413 PL_thistoken = newSVpvs("\\E");
3419 while (PL_bufptr != PL_bufend &&
3420 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3422 PL_thiswhite = newSVpvs("");
3423 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3427 if (PL_bufptr != PL_bufend)
3430 PL_lex_state = LEX_INTERPCONCAT;
3434 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3435 "### Saw case modifier\n"); });
3437 if (s[1] == '\\' && s[2] == 'E') {
3440 PL_thiswhite = newSVpvs("");
3441 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3444 PL_lex_state = LEX_INTERPCONCAT;
3449 if (!PL_madskills) /* when just compiling don't need correct */
3450 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3451 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3452 if ((*s == 'L' || *s == 'U') &&
3453 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3454 PL_lex_casestack[--PL_lex_casemods] = '\0';
3457 if (PL_lex_casemods > 10)
3458 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3459 PL_lex_casestack[PL_lex_casemods++] = *s;
3460 PL_lex_casestack[PL_lex_casemods] = '\0';
3461 PL_lex_state = LEX_INTERPCONCAT;
3462 start_force(PL_curforce);
3463 NEXTVAL_NEXTTOKE.ival = 0;
3465 start_force(PL_curforce);
3467 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3469 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3471 NEXTVAL_NEXTTOKE.ival = OP_LC;
3473 NEXTVAL_NEXTTOKE.ival = OP_UC;
3475 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3477 Perl_croak(aTHX_ "panic: yylex");
3479 SV* const tmpsv = newSVpvs("\\ ");
3480 /* replace the space with the character we want to escape
3482 SvPVX(tmpsv)[1] = *s;
3488 if (PL_lex_starts) {
3494 sv_free(PL_thistoken);
3495 PL_thistoken = newSVpvs("");
3498 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3499 if (PL_lex_casemods == 1 && PL_lex_inpat)
3508 case LEX_INTERPPUSH:
3509 return REPORT(sublex_push());
3511 case LEX_INTERPSTART:
3512 if (PL_bufptr == PL_bufend)
3513 return REPORT(sublex_done());
3514 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3515 "### Interpolated variable\n"); });
3517 PL_lex_dojoin = (*PL_bufptr == '@');
3518 PL_lex_state = LEX_INTERPNORMAL;
3519 if (PL_lex_dojoin) {
3520 start_force(PL_curforce);
3521 NEXTVAL_NEXTTOKE.ival = 0;
3523 start_force(PL_curforce);
3524 force_ident("\"", '$');
3525 start_force(PL_curforce);
3526 NEXTVAL_NEXTTOKE.ival = 0;
3528 start_force(PL_curforce);
3529 NEXTVAL_NEXTTOKE.ival = 0;
3531 start_force(PL_curforce);
3532 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3535 if (PL_lex_starts++) {
3540 sv_free(PL_thistoken);
3541 PL_thistoken = newSVpvs("");
3544 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3545 if (!PL_lex_casemods && PL_lex_inpat)
3552 case LEX_INTERPENDMAYBE:
3553 if (intuit_more(PL_bufptr)) {
3554 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3560 if (PL_lex_dojoin) {
3561 PL_lex_dojoin = FALSE;
3562 PL_lex_state = LEX_INTERPCONCAT;
3566 sv_free(PL_thistoken);
3567 PL_thistoken = newSVpvs("");
3572 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3573 && SvEVALED(PL_lex_repl))
3575 if (PL_bufptr != PL_bufend)
3576 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3580 case LEX_INTERPCONCAT:
3582 if (PL_lex_brackets)
3583 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3585 if (PL_bufptr == PL_bufend)
3586 return REPORT(sublex_done());
3588 if (SvIVX(PL_linestr) == '\'') {
3589 SV *sv = newSVsv(PL_linestr);
3592 else if ( PL_hints & HINT_NEW_RE )
3593 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
3594 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3598 s = scan_const(PL_bufptr);
3600 PL_lex_state = LEX_INTERPCASEMOD;
3602 PL_lex_state = LEX_INTERPSTART;
3605 if (s != PL_bufptr) {
3606 start_force(PL_curforce);
3608 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3610 NEXTVAL_NEXTTOKE = pl_yylval;
3613 if (PL_lex_starts++) {
3617 sv_free(PL_thistoken);
3618 PL_thistoken = newSVpvs("");
3621 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3622 if (!PL_lex_casemods && PL_lex_inpat)
3635 PL_lex_state = LEX_NORMAL;
3636 s = scan_formline(PL_bufptr);
3637 if (!PL_lex_formbrack)
3643 PL_oldoldbufptr = PL_oldbufptr;
3649 sv_free(PL_thistoken);
3652 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3656 if (isIDFIRST_lazy_if(s,UTF))
3659 unsigned char c = *s;
3660 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
3661 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
3662 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
3667 Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
3671 goto fake_eof; /* emulate EOF on ^D or ^Z */
3680 if (PL_lex_brackets) {
3681 yyerror((const char *)
3683 ? "Format not terminated"
3684 : "Missing right curly or square bracket"));
3686 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3687 "### Tokener got EOF\n");
3691 if (s++ < PL_bufend)
3692 goto retry; /* ignore stray nulls */
3695 if (!PL_in_eval && !PL_preambled) {
3696 PL_preambled = TRUE;
3702 /* Generate a string of Perl code to load the debugger.
3703 * If PERL5DB is set, it will return the contents of that,
3704 * otherwise a compile-time require of perl5db.pl. */
3706 const char * const pdb = PerlEnv_getenv("PERL5DB");
3709 sv_setpv(PL_linestr, pdb);
3710 sv_catpvs(PL_linestr,";");
3712 SETERRNO(0,SS_NORMAL);
3713 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
3716 sv_setpvs(PL_linestr,"");
3717 if (PL_preambleav) {
3718 SV **svp = AvARRAY(PL_preambleav);
3719 SV **const end = svp + AvFILLp(PL_preambleav);
3721 sv_catsv(PL_linestr, *svp);
3723 sv_catpvs(PL_linestr, ";");
3725 sv_free(MUTABLE_SV(PL_preambleav));
3726 PL_preambleav = NULL;
3729 sv_catpvs(PL_linestr,
3730 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
3731 if (PL_minus_n || PL_minus_p) {
3732 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3734 sv_catpvs(PL_linestr,"chomp;");
3737 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3738 || *PL_splitstr == '"')
3739 && strchr(PL_splitstr + 1, *PL_splitstr))
3740 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3742 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3743 bytes can be used as quoting characters. :-) */
3744 const char *splits = PL_splitstr;
3745 sv_catpvs(PL_linestr, "our @F=split(q\0");
3748 if (*splits == '\\')
3749 sv_catpvn(PL_linestr, splits, 1);
3750 sv_catpvn(PL_linestr, splits, 1);
3751 } while (*splits++);
3752 /* This loop will embed the trailing NUL of
3753 PL_linestr as the last thing it does before
3755 sv_catpvs(PL_linestr, ");");
3759 sv_catpvs(PL_linestr,"our @F=split(' ');");
3762 sv_catpvs(PL_linestr, "\n");
3763 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3764 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3765 PL_last_lop = PL_last_uni = NULL;
3766 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3767 update_debugger_info(PL_linestr, NULL, 0);
3771 bof = PL_rsfp ? TRUE : FALSE;
3772 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3775 PL_realtokenstart = -1;
3778 if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3779 PerlIO_clearerr(PL_rsfp);
3781 (void)PerlIO_close(PL_rsfp);
3783 PL_doextract = FALSE;
3785 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3791 sv_setpvs(PL_linestr, ";}continue{print;}");
3793 sv_setpvs(PL_linestr, ";}");
3794 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3795 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3796 PL_last_lop = PL_last_uni = NULL;
3797 PL_minus_n = PL_minus_p = 0;
3800 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3801 PL_last_lop = PL_last_uni = NULL;
3802 sv_setpvs(PL_linestr,"");
3803 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3805 /* If it looks like the start of a BOM or raw UTF-16,
3806 * check if it in fact is. */
3812 #ifdef PERLIO_IS_STDIO
3813 # ifdef __GNU_LIBRARY__
3814 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3815 # define FTELL_FOR_PIPE_IS_BROKEN
3819 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3820 # define FTELL_FOR_PIPE_IS_BROKEN
3825 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3827 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3828 s = swallow_bom((U8*)s);
3832 /* Incest with pod. */
3835 sv_catsv(PL_thiswhite, PL_linestr);
3837 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3838 sv_setpvs(PL_linestr, "");
3839 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3840 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3841 PL_last_lop = PL_last_uni = NULL;
3842 PL_doextract = FALSE;
3846 } while (PL_doextract);
3847 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3848 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3849 update_debugger_info(PL_linestr, NULL, 0);
3850 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3851 PL_last_lop = PL_last_uni = NULL;
3852 if (CopLINE(PL_curcop) == 1) {
3853 while (s < PL_bufend && isSPACE(*s))
3855 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3859 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3863 if (*s == '#' && *(s+1) == '!')
3865 #ifdef ALTERNATE_SHEBANG
3867 static char const as[] = ALTERNATE_SHEBANG;
3868 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3869 d = s + (sizeof(as) - 1);
3871 #endif /* ALTERNATE_SHEBANG */
3880 while (*d && !isSPACE(*d))
3884 #ifdef ARG_ZERO_IS_SCRIPT
3885 if (ipathend > ipath) {
3887 * HP-UX (at least) sets argv[0] to the script name,
3888 * which makes $^X incorrect. And Digital UNIX and Linux,
3889 * at least, set argv[0] to the basename of the Perl
3890 * interpreter. So, having found "#!", we'll set it right.
3892 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3894 assert(SvPOK(x) || SvGMAGICAL(x));
3895 if (sv_eq(x, CopFILESV(PL_curcop))) {
3896 sv_setpvn(x, ipath, ipathend - ipath);
3902 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3903 const char * const lstart = SvPV_const(x,llen);
3905 bstart += blen - llen;
3906 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3907 sv_setpvn(x, ipath, ipathend - ipath);
3912 TAINT_NOT; /* $^X is always tainted, but that's OK */
3914 #endif /* ARG_ZERO_IS_SCRIPT */
3919 d = instr(s,"perl -");
3921 d = instr(s,"perl");
3923 /* avoid getting into infinite loops when shebang
3924 * line contains "Perl" rather than "perl" */
3926 for (d = ipathend-4; d >= ipath; --d) {
3927 if ((*d == 'p' || *d == 'P')
3928 && !ibcmp(d, "perl", 4))
3938 #ifdef ALTERNATE_SHEBANG
3940 * If the ALTERNATE_SHEBANG on this system starts with a
3941 * character that can be part of a Perl expression, then if
3942 * we see it but not "perl", we're probably looking at the
3943 * start of Perl code, not a request to hand off to some
3944 * other interpreter. Similarly, if "perl" is there, but
3945 * not in the first 'word' of the line, we assume the line
3946 * contains the start of the Perl program.
3948 if (d && *s != '#') {
3949 const char *c = ipath;
3950 while (*c && !strchr("; \t\r\n\f\v#", *c))
3953 d = NULL; /* "perl" not in first word; ignore */
3955 *s = '#'; /* Don't try to parse shebang line */
3957 #endif /* ALTERNATE_SHEBANG */
3962 !instr(s,"indir") &&
3963 instr(PL_origargv[0],"perl"))
3970 while (s < PL_bufend && isSPACE(*s))
3972 if (s < PL_bufend) {
3973 Newx(newargv,PL_origargc+3,char*);
3975 while (s < PL_bufend && !isSPACE(*s))
3978 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3981 newargv = PL_origargv;
3984 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3986 Perl_croak(aTHX_ "Can't exec %s", ipath);
3989 while (*d && !isSPACE(*d))
3991 while (SPACE_OR_TAB(*d))
3995 const bool switches_done = PL_doswitches;
3996 const U32 oldpdb = PL_perldb;
3997 const bool oldn = PL_minus_n;
3998 const bool oldp = PL_minus_p;
4002 bool baduni = FALSE;
4004 const char *d2 = d1 + 1;
4005 if (parse_unicode_opts((const char **)&d2)
4009 if (baduni || *d1 == 'M' || *d1 == 'm') {
4010 const char * const m = d1;
4011 while (*d1 && !isSPACE(*d1))
4013 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4016 d1 = moreswitches(d1);
4018 if (PL_doswitches && !switches_done) {
4019 int argc = PL_origargc;
4020 char **argv = PL_origargv;
4023 } while (argc && argv[0][0] == '-' && argv[0][1]);
4024 init_argv_symbols(argc,argv);
4026 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4027 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4028 /* if we have already added "LINE: while (<>) {",
4029 we must not do it again */
4031 sv_setpvs(PL_linestr, "");
4032 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4033 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4034 PL_last_lop = PL_last_uni = NULL;
4035 PL_preambled = FALSE;
4036 if (PERLDB_LINE || PERLDB_SAVESRC)
4037 (void)gv_fetchfile(PL_origfilename);
4044 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4046 PL_lex_state = LEX_FORMLINE;
4051 #ifdef PERL_STRICT_CR
4052 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4054 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4056 case ' ': case '\t': case '\f': case 013:
4058 PL_realtokenstart = -1;
4060 PL_thiswhite = newSVpvs("");
4061 sv_catpvn(PL_thiswhite, s, 1);
4068 PL_realtokenstart = -1;
4072 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
4073 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
4074 /* handle eval qq[#line 1 "foo"\n ...] */
4075 CopLINE_dec(PL_curcop);
4078 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
4080 if (!PL_in_eval || PL_rsfp)
4085 while (d < PL_bufend && *d != '\n')
4089 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4090 Perl_croak(aTHX_ "panic: input overflow");
4093 PL_thiswhite = newSVpvn(s, d - s);
4098 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4100 PL_lex_state = LEX_FORMLINE;
4106 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
4107 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
4110 TOKEN(PEG); /* make sure any #! line is accessible */
4115 /* if (PL_madskills && PL_lex_formbrack) { */
4117 while (d < PL_bufend && *d != '\n')
4121 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4122 Perl_croak(aTHX_ "panic: input overflow");
4123 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4125 PL_thiswhite = newSVpvs("");
4126 if (CopLINE(PL_curcop) == 1) {
4127 sv_setpvs(PL_thiswhite, "");
4130 sv_catpvn(PL_thiswhite, s, d - s);
4144 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4152 while (s < PL_bufend && SPACE_OR_TAB(*s))
4155 if (strnEQ(s,"=>",2)) {
4156 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4157 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4158 OPERATOR('-'); /* unary minus */
4160 PL_last_uni = PL_oldbufptr;
4162 case 'r': ftst = OP_FTEREAD; break;
4163 case 'w': ftst = OP_FTEWRITE; break;
4164 case 'x': ftst = OP_FTEEXEC; break;
4165 case 'o': ftst = OP_FTEOWNED; break;
4166 case 'R': ftst = OP_FTRREAD; break;
4167 case 'W': ftst = OP_FTRWRITE; break;
4168 case 'X': ftst = OP_FTREXEC; break;
4169 case 'O': ftst = OP_FTROWNED; break;
4170 case 'e': ftst = OP_FTIS; break;
4171 case 'z': ftst = OP_FTZERO; break;
4172 case 's': ftst = OP_FTSIZE; break;
4173 case 'f': ftst = OP_FTFILE; break;
4174 case 'd': ftst = OP_FTDIR; break;
4175 case 'l': ftst = OP_FTLINK; break;
4176 case 'p': ftst = OP_FTPIPE; break;
4177 case 'S': ftst = OP_FTSOCK; break;
4178 case 'u': ftst = OP_FTSUID; break;
4179 case 'g': ftst = OP_FTSGID; break;
4180 case 'k': ftst = OP_FTSVTX; break;
4181 case 'b': ftst = OP_FTBLK; break;
4182 case 'c': ftst = OP_FTCHR; break;
4183 case 't': ftst = OP_FTTTY; break;
4184 case 'T': ftst = OP_FTTEXT; break;
4185 case 'B': ftst = OP_FTBINARY; break;
4186 case 'M': case 'A': case 'C':
4187 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4189 case 'M': ftst = OP_FTMTIME; break;
4190 case 'A': ftst = OP_FTATIME; break;
4191 case 'C': ftst = OP_FTCTIME; break;
4199 PL_last_lop_op = (OPCODE)ftst;
4200 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4201 "### Saw file test %c\n", (int)tmp);
4206 /* Assume it was a minus followed by a one-letter named
4207 * subroutine call (or a -bareword), then. */
4208 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4209 "### '-%c' looked like a file test but was not\n",
4216 const char tmp = *s++;
4219 if (PL_expect == XOPERATOR)
4224 else if (*s == '>') {
4227 if (isIDFIRST_lazy_if(s,UTF)) {
4228 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4236 if (PL_expect == XOPERATOR)
4239 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4241 OPERATOR('-'); /* unary minus */
4247 const char tmp = *s++;
4250 if (PL_expect == XOPERATOR)
4255 if (PL_expect == XOPERATOR)
4258 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4265 if (PL_expect != XOPERATOR) {
4266 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4267 PL_expect = XOPERATOR;
4268 force_ident(PL_tokenbuf, '*');
4281 if (PL_expect == XOPERATOR) {
4285 PL_tokenbuf[0] = '%';
4286 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4287 sizeof PL_tokenbuf - 1, FALSE);
4288 if (!PL_tokenbuf[1]) {
4291 PL_pending_ident = '%';
4300 const char tmp = *s++;
4305 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4312 const char tmp = *s++;
4318 goto just_a_word_zero_gv;
4321 switch (PL_expect) {
4327 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4329 PL_bufptr = s; /* update in case we back off */
4335 PL_expect = XTERMBLOCK;
4338 stuffstart = s - SvPVX(PL_linestr) - 1;
4342 while (isIDFIRST_lazy_if(s,UTF)) {
4345 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4346 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4347 if (tmp < 0) tmp = -tmp;
4362 sv = newSVpvn(s, len);
4364 d = scan_str(d,TRUE,TRUE);
4366 /* MUST advance bufptr here to avoid bogus
4367 "at end of line" context messages from yyerror().
4369 PL_bufptr = s + len;
4370 yyerror("Unterminated attribute parameter in attribute list");
4374 return REPORT(0); /* EOF indicator */
4378 sv_catsv(sv, PL_lex_stuff);
4379 attrs = append_elem(OP_LIST, attrs,
4380 newSVOP(OP_CONST, 0, sv));
4381 SvREFCNT_dec(PL_lex_stuff);
4382 PL_lex_stuff = NULL;
4385 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4387 if (PL_in_my == KEY_our) {
4388 deprecate(":unique");
4391 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4394 /* NOTE: any CV attrs applied here need to be part of
4395 the CVf_BUILTIN_ATTRS define in cv.h! */
4396 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4398 CvLVALUE_on(PL_compcv);
4400 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4402 deprecate(":locked");
4404 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4406 CvMETHOD_on(PL_compcv);
4408 /* After we've set the flags, it could be argued that
4409 we don't need to do the attributes.pm-based setting
4410 process, and shouldn't bother appending recognized
4411 flags. To experiment with that, uncomment the
4412 following "else". (Note that's already been
4413 uncommented. That keeps the above-applied built-in
4414 attributes from being intercepted (and possibly
4415 rejected) by a package's attribute routines, but is
4416 justified by the performance win for the common case
4417 of applying only built-in attributes.) */
4419 attrs = append_elem(OP_LIST, attrs,
4420 newSVOP(OP_CONST, 0,
4424 if (*s == ':' && s[1] != ':')
4427 break; /* require real whitespace or :'s */
4428 /* XXX losing whitespace on sequential attributes here */
4432 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4433 if (*s != ';' && *s != '}' && *s != tmp
4434 && (tmp != '=' || *s != ')')) {
4435 const char q = ((*s == '\'') ? '"' : '\'');
4436 /* If here for an expression, and parsed no attrs, back
4438 if (tmp == '=' && !attrs) {
4442 /* MUST advance bufptr here to avoid bogus "at end of line"
4443 context messages from yyerror().
4446 yyerror( (const char *)
4448 ? Perl_form(aTHX_ "Invalid separator character "
4449 "%c%c%c in attribute list", q, *s, q)
4450 : "Unterminated attribute list" ) );
4458 start_force(PL_curforce);
4459 NEXTVAL_NEXTTOKE.opval = attrs;
4460 CURMAD('_', PL_nextwhite);
4465 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4466 (s - SvPVX(PL_linestr)) - stuffstart);
4474 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4475 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4483 const char tmp = *s++;
4488 const char tmp = *s++;
4496 if (PL_lex_brackets <= 0)
4497 yyerror("Unmatched right square bracket");
4500 if (PL_lex_state == LEX_INTERPNORMAL) {
4501 if (PL_lex_brackets == 0) {
4502 if (*s == '-' && s[1] == '>')
4503 PL_lex_state = LEX_INTERPENDMAYBE;
4504 else if (*s != '[' && *s != '{')
4505 PL_lex_state = LEX_INTERPEND;
4512 if (PL_lex_brackets > 100) {
4513 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4515 switch (PL_expect) {
4517 if (PL_lex_formbrack) {
4521 if (PL_oldoldbufptr == PL_last_lop)
4522 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4524 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4525 OPERATOR(HASHBRACK);
4527 while (s < PL_bufend && SPACE_OR_TAB(*s))
4530 PL_tokenbuf[0] = '\0';
4531 if (d < PL_bufend && *d == '-') {
4532 PL_tokenbuf[0] = '-';
4534 while (d < PL_bufend && SPACE_OR_TAB(*d))
4537 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4538 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4540 while (d < PL_bufend && SPACE_OR_TAB(*d))
4543 const char minus = (PL_tokenbuf[0] == '-');
4544 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4552 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4557 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4562 if (PL_oldoldbufptr == PL_last_lop)
4563 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4565 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4568 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4570 /* This hack is to get the ${} in the message. */
4572 yyerror("syntax error");
4575 OPERATOR(HASHBRACK);
4577 /* This hack serves to disambiguate a pair of curlies
4578 * as being a block or an anon hash. Normally, expectation
4579 * determines that, but in cases where we're not in a
4580 * position to expect anything in particular (like inside
4581 * eval"") we have to resolve the ambiguity. This code
4582 * covers the case where the first term in the curlies is a
4583 * quoted string. Most other cases need to be explicitly
4584 * disambiguated by prepending a "+" before the opening
4585 * curly in order to force resolution as an anon hash.
4587 * XXX should probably propagate the outer expectation
4588 * into eval"" to rely less on this hack, but that could
4589 * potentially break current behavior of eval"".
4593 if (*s == '\'' || *s == '"' || *s == '`') {
4594 /* common case: get past first string, handling escapes */
4595 for (t++; t < PL_bufend && *t != *s;)
4596 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4600 else if (*s == 'q') {
4603 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4606 /* skip q//-like construct */
4608 char open, close, term;
4611 while (t < PL_bufend && isSPACE(*t))
4613 /* check for q => */
4614 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4615 OPERATOR(HASHBRACK);
4619 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4623 for (t++; t < PL_bufend; t++) {
4624 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4626 else if (*t == open)
4630 for (t++; t < PL_bufend; t++) {
4631 if (*t == '\\' && t+1 < PL_bufend)
4633 else if (*t == close && --brackets <= 0)
4635 else if (*t == open)
4642 /* skip plain q word */
4643 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4646 else if (isALNUM_lazy_if(t,UTF)) {
4648 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4651 while (t < PL_bufend && isSPACE(*t))
4653 /* if comma follows first term, call it an anon hash */
4654 /* XXX it could be a comma expression with loop modifiers */
4655 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4656 || (*t == '=' && t[1] == '>')))
4657 OPERATOR(HASHBRACK);
4658 if (PL_expect == XREF)
4661 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4667 pl_yylval.ival = CopLINE(PL_curcop);
4668 if (isSPACE(*s) || *s == '#')
4669 PL_copline = NOLINE; /* invalidate current command line number */
4674 if (PL_lex_brackets <= 0)
4675 yyerror("Unmatched right curly bracket");
4677 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4678 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4679 PL_lex_formbrack = 0;
4680 if (PL_lex_state == LEX_INTERPNORMAL) {
4681 if (PL_lex_brackets == 0) {
4682 if (PL_expect & XFAKEBRACK) {
4683 PL_expect &= XENUMMASK;
4684 PL_lex_state = LEX_INTERPEND;
4689 PL_thiswhite = newSVpvs("");
4690 sv_catpvs(PL_thiswhite,"}");
4693 return yylex(); /* ignore fake brackets */
4695 if (*s == '-' && s[1] == '>')
4696 PL_lex_state = LEX_INTERPENDMAYBE;
4697 else if (*s != '[' && *s != '{')
4698 PL_lex_state = LEX_INTERPEND;
4701 if (PL_expect & XFAKEBRACK) {
4702 PL_expect &= XENUMMASK;
4704 return yylex(); /* ignore fake brackets */
4706 start_force(PL_curforce);
4708 curmad('X', newSVpvn(s-1,1));
4709 CURMAD('_', PL_thiswhite);
4714 PL_thistoken = newSVpvs("");
4722 if (PL_expect == XOPERATOR) {
4723 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4724 && isIDFIRST_lazy_if(s,UTF))
4726 CopLINE_dec(PL_curcop);
4727 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
4728 CopLINE_inc(PL_curcop);
4733 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4735 PL_expect = XOPERATOR;
4736 force_ident(PL_tokenbuf, '&');
4740 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
4752 const char tmp = *s++;
4759 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4760 && strchr("+-*/%.^&|<",tmp))
4761 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4762 "Reversed %c= operator",(int)tmp);
4764 if (PL_expect == XSTATE && isALPHA(tmp) &&
4765 (s == PL_linestart+1 || s[-2] == '\n') )
4767 if (PL_in_eval && !PL_rsfp) {
4772 if (strnEQ(s,"=cut",4)) {
4788 PL_thiswhite = newSVpvs("");
4789 sv_catpvn(PL_thiswhite, PL_linestart,
4790 PL_bufend - PL_linestart);
4794 PL_doextract = TRUE;
4798 if (PL_lex_brackets < PL_lex_formbrack) {
4800 #ifdef PERL_STRICT_CR
4801 while (SPACE_OR_TAB(*t))
4803 while (SPACE_OR_TAB(*t) || *t == '\r')
4806 if (*t == '\n' || *t == '#') {
4817 const char tmp = *s++;
4819 /* was this !=~ where !~ was meant?
4820 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4822 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4823 const char *t = s+1;
4825 while (t < PL_bufend && isSPACE(*t))
4828 if (*t == '/' || *t == '?' ||
4829 ((*t == 'm' || *t == 's' || *t == 'y')
4830 && !isALNUM(t[1])) ||
4831 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4832 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4833 "!=~ should be !~");
4843 if (PL_expect != XOPERATOR) {
4844 if (s[1] != '<' && !strchr(s,'>'))
4847 s = scan_heredoc(s);
4849 s = scan_inputsymbol(s);
4850 TERM(sublex_start());
4856 SHop(OP_LEFT_SHIFT);
4870 const char tmp = *s++;
4872 SHop(OP_RIGHT_SHIFT);
4873 else if (tmp == '=')
4882 if (PL_expect == XOPERATOR) {
4883 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4885 deprecate_old(commaless_variable_list);
4886 return REPORT(','); /* grandfather non-comma-format format */
4890 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4891 PL_tokenbuf[0] = '@';
4892 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4893 sizeof PL_tokenbuf - 1, FALSE);
4894 if (PL_expect == XOPERATOR)
4895 no_op("Array length", s);
4896 if (!PL_tokenbuf[1])
4898 PL_expect = XOPERATOR;
4899 PL_pending_ident = '#';
4903 PL_tokenbuf[0] = '$';
4904 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4905 sizeof PL_tokenbuf - 1, FALSE);
4906 if (PL_expect == XOPERATOR)
4908 if (!PL_tokenbuf[1]) {
4910 yyerror("Final $ should be \\$ or $name");
4914 /* This kludge not intended to be bulletproof. */
4915 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4916 pl_yylval.opval = newSVOP(OP_CONST, 0,
4917 newSViv(CopARYBASE_get(&PL_compiling)));
4918 pl_yylval.opval->op_private = OPpCONST_ARYBASE;
4924 const char tmp = *s;
4925 if (PL_lex_state == LEX_NORMAL)
4928 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4929 && intuit_more(s)) {
4931 PL_tokenbuf[0] = '@';
4932 if (ckWARN(WARN_SYNTAX)) {
4935 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4938 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4939 while (t < PL_bufend && *t != ']')
4941 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4942 "Multidimensional syntax %.*s not supported",
4943 (int)((t - PL_bufptr) + 1), PL_bufptr);
4947 else if (*s == '{') {
4949 PL_tokenbuf[0] = '%';
4950 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4951 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4953 char tmpbuf[sizeof PL_tokenbuf];
4956 } while (isSPACE(*t));
4957 if (isIDFIRST_lazy_if(t,UTF)) {
4959 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4963 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4964 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4965 "You need to quote \"%s\"",
4972 PL_expect = XOPERATOR;
4973 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4974 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4975 if (!islop || PL_last_lop_op == OP_GREPSTART)
4976 PL_expect = XOPERATOR;
4977 else if (strchr("$@\"'`q", *s))
4978 PL_expect = XTERM; /* e.g. print $fh "foo" */
4979 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4980 PL_expect = XTERM; /* e.g. print $fh &sub */
4981 else if (isIDFIRST_lazy_if(s,UTF)) {
4982 char tmpbuf[sizeof PL_tokenbuf];
4984 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4985 if ((t2 = keyword(tmpbuf, len, 0))) {
4986 /* binary operators exclude handle interpretations */
4998 PL_expect = XTERM; /* e.g. print $fh length() */
5003 PL_expect = XTERM; /* e.g. print $fh subr() */
5006 else if (isDIGIT(*s))
5007 PL_expect = XTERM; /* e.g. print $fh 3 */
5008 else if (*s == '.' && isDIGIT(s[1]))
5009 PL_expect = XTERM; /* e.g. print $fh .3 */
5010 else if ((*s == '?' || *s == '-' || *s == '+')
5011 && !isSPACE(s[1]) && s[1] != '=')
5012 PL_expect = XTERM; /* e.g. print $fh -1 */
5013 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
5015 PL_expect = XTERM; /* e.g. print $fh /.../
5016 XXX except DORDOR operator
5018 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
5020 PL_expect = XTERM; /* print $fh <<"EOF" */
5023 PL_pending_ident = '$';
5027 if (PL_expect == XOPERATOR)
5029 PL_tokenbuf[0] = '@';
5030 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5031 if (!PL_tokenbuf[1]) {
5034 if (PL_lex_state == LEX_NORMAL)
5036 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5038 PL_tokenbuf[0] = '%';
5040 /* Warn about @ where they meant $. */
5041 if (*s == '[' || *s == '{') {
5042 if (ckWARN(WARN_SYNTAX)) {
5043 const char *t = s + 1;
5044 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
5046 if (*t == '}' || *t == ']') {
5048 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
5049 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5050 "Scalar value %.*s better written as $%.*s",
5051 (int)(t-PL_bufptr), PL_bufptr,
5052 (int)(t-PL_bufptr-1), PL_bufptr+1);
5057 PL_pending_ident = '@';
5060 case '/': /* may be division, defined-or, or pattern */
5061 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
5065 case '?': /* may either be conditional or pattern */
5066 if (PL_expect == XOPERATOR) {
5074 /* A // operator. */
5084 /* Disable warning on "study /blah/" */
5085 if (PL_oldoldbufptr == PL_last_uni
5086 && (*PL_last_uni != 's' || s - PL_last_uni < 5
5087 || memNE(PL_last_uni, "study", 5)
5088 || isALNUM_lazy_if(PL_last_uni+5,UTF)
5091 s = scan_pat(s,OP_MATCH);
5092 TERM(sublex_start());
5096 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
5097 #ifdef PERL_STRICT_CR
5100 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
5102 && (s == PL_linestart || s[-1] == '\n') )
5104 PL_lex_formbrack = 0;
5108 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
5112 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
5118 pl_yylval.ival = OPf_SPECIAL;
5124 if (PL_expect != XOPERATOR)
5129 case '0': case '1': case '2': case '3': case '4':
5130 case '5': case '6': case '7': case '8': case '9':
5131 s = scan_num(s, &pl_yylval);
5132 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
5133 if (PL_expect == XOPERATOR)
5138 s = scan_str(s,!!PL_madskills,FALSE);
5139 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5140 if (PL_expect == XOPERATOR) {
5141 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5143 deprecate_old(commaless_variable_list);
5144 return REPORT(','); /* grandfather non-comma-format format */
5151 pl_yylval.ival = OP_CONST;
5152 TERM(sublex_start());
5155 s = scan_str(s,!!PL_madskills,FALSE);
5156 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5157 if (PL_expect == XOPERATOR) {
5158 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5160 deprecate_old(commaless_variable_list);
5161 return REPORT(','); /* grandfather non-comma-format format */
5168 pl_yylval.ival = OP_CONST;
5169 /* FIXME. I think that this can be const if char *d is replaced by
5170 more localised variables. */
5171 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5172 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5173 pl_yylval.ival = OP_STRINGIFY;
5177 TERM(sublex_start());
5180 s = scan_str(s,!!PL_madskills,FALSE);
5181 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5182 if (PL_expect == XOPERATOR)
5183 no_op("Backticks",s);
5186 readpipe_override();
5187 TERM(sublex_start());
5191 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5192 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5194 if (PL_expect == XOPERATOR)
5195 no_op("Backslash",s);
5199 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5200 char *start = s + 2;
5201 while (isDIGIT(*start) || *start == '_')
5203 if (*start == '.' && isDIGIT(start[1])) {
5204 s = scan_num(s, &pl_yylval);
5207 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5208 else if (!isALPHA(*start) && (PL_expect == XTERM
5209 || PL_expect == XREF || PL_expect == XSTATE
5210 || PL_expect == XTERMORDORDOR)) {
5211 GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
5213 s = scan_num(s, &pl_yylval);
5220 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5262 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5264 /* Some keywords can be followed by any delimiter, including ':' */
5265 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5266 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5267 (PL_tokenbuf[0] == 'q' &&
5268 strchr("qwxr", PL_tokenbuf[1])))));
5270 /* x::* is just a word, unless x is "CORE" */
5271 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5275 while (d < PL_bufend && isSPACE(*d))
5276 d++; /* no comments skipped here, or s### is misparsed */
5278 /* Is this a label? */
5279 if (!tmp && PL_expect == XSTATE
5280 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5281 tmp = keyword(PL_tokenbuf, len, 0);
5283 Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
5285 pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5290 /* Check for keywords */
5291 tmp = keyword(PL_tokenbuf, len, 0);
5293 /* Is this a word before a => operator? */
5294 if (*d == '=' && d[1] == '>') {
5297 = (OP*)newSVOP(OP_CONST, 0,
5298 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5299 pl_yylval.opval->op_private = OPpCONST_BARE;
5303 if (tmp < 0) { /* second-class keyword? */
5304 GV *ogv = NULL; /* override (winner) */
5305 GV *hgv = NULL; /* hidden (loser) */
5306 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5308 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5311 if (GvIMPORTED_CV(gv))
5313 else if (! CvMETHOD(cv))
5317 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5318 (gv = *gvp) && isGV_with_GP(gv) &&
5319 GvCVu(gv) && GvIMPORTED_CV(gv))
5326 tmp = 0; /* overridden by import or by GLOBAL */
5329 && -tmp==KEY_lock /* XXX generalizable kludge */
5332 tmp = 0; /* any sub overrides "weak" keyword */
5334 else { /* no override */
5336 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5337 Perl_warner(aTHX_ packWARN(WARN_MISC),
5338 "dump() better written as CORE::dump()");
5342 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5343 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
5344 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5345 "Ambiguous call resolved as CORE::%s(), %s",
5346 GvENAME(hgv), "qualify as such or use &");
5353 default: /* not a keyword */
5354 /* Trade off - by using this evil construction we can pull the
5355 variable gv into the block labelled keylookup. If not, then
5356 we have to give it function scope so that the goto from the
5357 earlier ':' case doesn't bypass the initialisation. */
5359 just_a_word_zero_gv:
5367 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5370 SV *nextPL_nextwhite = 0;
5374 /* Get the rest if it looks like a package qualifier */
5376 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5378 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5381 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5382 *s == '\'' ? "'" : "::");
5387 if (PL_expect == XOPERATOR) {
5388 if (PL_bufptr == PL_linestart) {
5389 CopLINE_dec(PL_curcop);
5390 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5391 CopLINE_inc(PL_curcop);
5394 no_op("Bareword",s);
5397 /* Look for a subroutine with this name in current package,
5398 unless name is "Foo::", in which case Foo is a bearword
5399 (and a package name). */
5401 if (len > 2 && !PL_madskills &&
5402 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5404 if (ckWARN(WARN_BAREWORD)
5405 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5406 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5407 "Bareword \"%s\" refers to nonexistent package",
5410 PL_tokenbuf[len] = '\0';
5416 /* Mustn't actually add anything to a symbol table.
5417 But also don't want to "initialise" any placeholder
5418 constants that might already be there into full
5419 blown PVGVs with attached PVCV. */
5420 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5421 GV_NOADD_NOINIT, SVt_PVCV);
5426 /* if we saw a global override before, get the right name */
5429 sv = newSVpvs("CORE::GLOBAL::");
5430 sv_catpv(sv,PL_tokenbuf);
5433 /* If len is 0, newSVpv does strlen(), which is correct.
5434 If len is non-zero, then it will be the true length,
5435 and so the scalar will be created correctly. */
5436 sv = newSVpv(PL_tokenbuf,len);
5439 if (PL_madskills && !PL_thistoken) {
5440 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5441 PL_thistoken = newSVpvn(start,s - start);
5442 PL_realtokenstart = s - SvPVX(PL_linestr);
5446 /* Presume this is going to be a bareword of some sort. */
5449 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5450 pl_yylval.opval->op_private = OPpCONST_BARE;
5451 /* UTF-8 package name? */
5452 if (UTF && !IN_BYTES &&
5453 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5456 /* And if "Foo::", then that's what it certainly is. */
5461 /* Do the explicit type check so that we don't need to force
5462 the initialisation of the symbol table to have a real GV.
5463 Beware - gv may not really be a PVGV, cv may not really be
5464 a PVCV, (because of the space optimisations that gv_init
5465 understands) But they're true if for this symbol there is
5466 respectively a typeglob and a subroutine.
5468 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5469 /* Real typeglob, so get the real subroutine: */
5471 /* A proxy for a subroutine in this package? */
5472 : SvOK(gv) ? MUTABLE_CV(gv) : NULL)
5475 /* See if it's the indirect object for a list operator. */
5477 if (PL_oldoldbufptr &&
5478 PL_oldoldbufptr < PL_bufptr &&
5479 (PL_oldoldbufptr == PL_last_lop
5480 || PL_oldoldbufptr == PL_last_uni) &&
5481 /* NO SKIPSPACE BEFORE HERE! */
5482 (PL_expect == XREF ||
5483 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5485 bool immediate_paren = *s == '(';
5487 /* (Now we can afford to cross potential line boundary.) */
5488 s = SKIPSPACE2(s,nextPL_nextwhite);
5490 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5493 /* Two barewords in a row may indicate method call. */
5495 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5496 (tmp = intuit_method(s, gv, cv)))
5499 /* If not a declared subroutine, it's an indirect object. */
5500 /* (But it's an indir obj regardless for sort.) */
5501 /* Also, if "_" follows a filetest operator, it's a bareword */
5504 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5506 (PL_last_lop_op != OP_MAPSTART &&
5507 PL_last_lop_op != OP_GREPSTART))))
5508 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5509 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5512 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5517 PL_expect = XOPERATOR;
5520 s = SKIPSPACE2(s,nextPL_nextwhite);
5521 PL_nextwhite = nextPL_nextwhite;
5526 /* Is this a word before a => operator? */
5527 if (*s == '=' && s[1] == '>' && !pkgname) {
5529 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
5530 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5531 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
5535 /* If followed by a paren, it's certainly a subroutine. */
5540 while (SPACE_OR_TAB(*d))
5542 if (*d == ')' && (sv = gv_const_sv(gv))) {
5549 PL_nextwhite = PL_thiswhite;
5552 start_force(PL_curforce);
5554 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5555 PL_expect = XOPERATOR;
5558 PL_nextwhite = nextPL_nextwhite;
5559 curmad('X', PL_thistoken);
5560 PL_thistoken = newSVpvs("");
5568 /* If followed by var or block, call it a method (unless sub) */
5570 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5571 PL_last_lop = PL_oldbufptr;
5572 PL_last_lop_op = OP_METHOD;
5576 /* If followed by a bareword, see if it looks like indir obj. */
5579 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5580 && (tmp = intuit_method(s, gv, cv)))
5583 /* Not a method, so call it a subroutine (if defined) */
5586 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5587 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5588 "Ambiguous use of -%s resolved as -&%s()",
5589 PL_tokenbuf, PL_tokenbuf);
5590 /* Check for a constant sub */
5591 if ((sv = gv_const_sv(gv))) {
5593 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
5594 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5595 pl_yylval.opval->op_private = 0;
5599 /* Resolve to GV now. */
5600 if (SvTYPE(gv) != SVt_PVGV) {
5601 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5602 assert (SvTYPE(gv) == SVt_PVGV);
5603 /* cv must have been some sort of placeholder, so
5604 now needs replacing with a real code reference. */
5608 op_free(pl_yylval.opval);
5609 pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5610 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5611 PL_last_lop = PL_oldbufptr;
5612 PL_last_lop_op = OP_ENTERSUB;
5613 /* Is there a prototype? */
5621 const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
5624 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5626 while (*proto == ';')
5628 if (*proto == '&' && *s == '{') {
5630 sv_setpvs(PL_subname, "__ANON__");
5632 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5639 PL_nextwhite = PL_thiswhite;
5642 start_force(PL_curforce);
5643 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5646 PL_nextwhite = nextPL_nextwhite;
5647 curmad('X', PL_thistoken);
5648 PL_thistoken = newSVpvs("");
5655 /* Guess harder when madskills require "best effort". */
5656 if (PL_madskills && (!gv || !GvCVu(gv))) {
5657 int probable_sub = 0;
5658 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5660 else if (isALPHA(*s)) {
5664 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5665 if (!keyword(tmpbuf, tmplen, 0))
5668 while (d < PL_bufend && isSPACE(*d))
5670 if (*d == '=' && d[1] == '>')
5675 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5676 op_free(pl_yylval.opval);
5677 pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5678 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5679 PL_last_lop = PL_oldbufptr;
5680 PL_last_lop_op = OP_ENTERSUB;
5681 PL_nextwhite = PL_thiswhite;
5683 start_force(PL_curforce);
5684 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5686 PL_nextwhite = nextPL_nextwhite;
5687 curmad('X', PL_thistoken);
5688 PL_thistoken = newSVpvs("");
5693 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5700 /* Call it a bare word */
5702 if (PL_hints & HINT_STRICT_SUBS)
5703 pl_yylval.opval->op_private |= OPpCONST_STRICT;
5706 /* after "print" and similar functions (corresponding to
5707 * "F? L" in opcode.pl), whatever wasn't already parsed as
5708 * a filehandle should be subject to "strict subs".
5709 * Likewise for the optional indirect-object argument to system
5710 * or exec, which can't be a bareword */
5711 if ((PL_last_lop_op == OP_PRINT
5712 || PL_last_lop_op == OP_PRTF
5713 || PL_last_lop_op == OP_SAY
5714 || PL_last_lop_op == OP_SYSTEM
5715 || PL_last_lop_op == OP_EXEC)
5716 && (PL_hints & HINT_STRICT_SUBS))
5717 pl_yylval.opval->op_private |= OPpCONST_STRICT;
5718 if (lastchar != '-') {
5719 if (ckWARN(WARN_RESERVED)) {
5723 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5724 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5731 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5732 && ckWARN_d(WARN_AMBIGUOUS)) {
5733 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5734 "Operator or semicolon missing before %c%s",
5735 lastchar, PL_tokenbuf);
5736 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5737 "Ambiguous use of %c resolved as operator %c",
5738 lastchar, lastchar);
5744 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5745 newSVpv(CopFILE(PL_curcop),0));
5749 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5750 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5753 case KEY___PACKAGE__:
5754 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5756 ? newSVhek(HvNAME_HEK(PL_curstash))
5763 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5764 const char *pname = "main";
5765 if (PL_tokenbuf[2] == 'D')
5766 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5767 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5771 GvIOp(gv) = newIO();
5772 IoIFP(GvIOp(gv)) = PL_rsfp;
5773 #if defined(HAS_FCNTL) && defined(F_SETFD)
5775 const int fd = PerlIO_fileno(PL_rsfp);
5776 fcntl(fd,F_SETFD,fd >= 3);
5779 /* Mark this internal pseudo-handle as clean */
5780 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5781 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5782 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5784 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5785 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5786 /* if the script was opened in binmode, we need to revert
5787 * it to text mode for compatibility; but only iff it has CRs
5788 * XXX this is a questionable hack at best. */
5789 if (PL_bufend-PL_bufptr > 2
5790 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5793 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5794 loc = PerlIO_tell(PL_rsfp);
5795 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5798 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5800 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5801 #endif /* NETWARE */
5802 #ifdef PERLIO_IS_STDIO /* really? */
5803 # if defined(__BORLANDC__)
5804 /* XXX see note in do_binmode() */
5805 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5809 PerlIO_seek(PL_rsfp, loc, 0);
5813 #ifdef PERLIO_LAYERS
5816 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5817 else if (PL_encoding) {
5824 XPUSHs(PL_encoding);
5826 call_method("name", G_SCALAR);
5830 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5831 Perl_form(aTHX_ ":encoding(%"SVf")",
5840 if (PL_realtokenstart >= 0) {
5841 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5843 PL_endwhite = newSVpvs("");
5844 sv_catsv(PL_endwhite, PL_thiswhite);
5846 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5847 PL_realtokenstart = -1;
5849 while ((s = filter_gets(PL_endwhite, PL_rsfp,
5850 SvCUR(PL_endwhite))) != NULL) ;
5865 if (PL_expect == XSTATE) {
5872 if (*s == ':' && s[1] == ':') {
5875 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5876 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5877 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5880 else if (tmp == KEY_require || tmp == KEY_do)
5881 /* that's a way to remember we saw "CORE::" */
5894 LOP(OP_ACCEPT,XTERM);
5900 LOP(OP_ATAN2,XTERM);
5906 LOP(OP_BINMODE,XTERM);
5909 LOP(OP_BLESS,XTERM);
5918 /* When 'use switch' is in effect, continue has a dual
5919 life as a control operator. */
5921 if (!FEATURE_IS_ENABLED("switch"))
5924 /* We have to disambiguate the two senses of
5925 "continue". If the next token is a '{' then
5926 treat it as the start of a continue block;
5927 otherwise treat it as a control operator.
5939 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5956 if (!PL_cryptseen) {
5957 PL_cryptseen = TRUE;
5961 LOP(OP_CRYPT,XTERM);
5964 LOP(OP_CHMOD,XTERM);
5967 LOP(OP_CHOWN,XTERM);
5970 LOP(OP_CONNECT,XTERM);
5989 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5990 if (orig_keyword == KEY_do) {
5999 PL_hints |= HINT_BLOCK_SCOPE;
6009 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
6010 LOP(OP_DBMOPEN,XTERM);
6016 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6023 pl_yylval.ival = CopLINE(PL_curcop);
6039 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
6040 UNIBRACK(OP_ENTEREVAL);
6054 case KEY_endhostent:
6060 case KEY_endservent:
6063 case KEY_endprotoent:
6074 pl_yylval.ival = CopLINE(PL_curcop);
6076 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
6079 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
6082 if ((PL_bufend - p) >= 3 &&
6083 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
6085 else if ((PL_bufend - p) >= 4 &&
6086 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
6089 if (isIDFIRST_lazy_if(p,UTF)) {
6090 p = scan_ident(p, PL_bufend,
6091 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
6095 Perl_croak(aTHX_ "Missing $ on loop variable");
6097 s = SvPVX(PL_linestr) + soff;
6103 LOP(OP_FORMLINE,XTERM);
6109 LOP(OP_FCNTL,XTERM);
6115 LOP(OP_FLOCK,XTERM);
6124 LOP(OP_GREPSTART, XREF);
6127 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6142 case KEY_getpriority:
6143 LOP(OP_GETPRIORITY,XTERM);
6145 case KEY_getprotobyname:
6148 case KEY_getprotobynumber:
6149 LOP(OP_GPBYNUMBER,XTERM);
6151 case KEY_getprotoent:
6163 case KEY_getpeername:
6164 UNI(OP_GETPEERNAME);
6166 case KEY_gethostbyname:
6169 case KEY_gethostbyaddr:
6170 LOP(OP_GHBYADDR,XTERM);
6172 case KEY_gethostent:
6175 case KEY_getnetbyname:
6178 case KEY_getnetbyaddr:
6179 LOP(OP_GNBYADDR,XTERM);
6184 case KEY_getservbyname:
6185 LOP(OP_GSBYNAME,XTERM);
6187 case KEY_getservbyport:
6188 LOP(OP_GSBYPORT,XTERM);
6190 case KEY_getservent:
6193 case KEY_getsockname:
6194 UNI(OP_GETSOCKNAME);
6196 case KEY_getsockopt:
6197 LOP(OP_GSOCKOPT,XTERM);
6212 pl_yylval.ival = CopLINE(PL_curcop);
6222 pl_yylval.ival = CopLINE(PL_curcop);
6226 LOP(OP_INDEX,XTERM);
6232 LOP(OP_IOCTL,XTERM);
6244 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6276 LOP(OP_LISTEN,XTERM);
6285 s = scan_pat(s,OP_MATCH);
6286 TERM(sublex_start());
6289 LOP(OP_MAPSTART, XREF);
6292 LOP(OP_MKDIR,XTERM);
6295 LOP(OP_MSGCTL,XTERM);
6298 LOP(OP_MSGGET,XTERM);
6301 LOP(OP_MSGRCV,XTERM);
6304 LOP(OP_MSGSND,XTERM);
6309 PL_in_my = (U16)tmp;
6311 if (isIDFIRST_lazy_if(s,UTF)) {
6315 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6316 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6318 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6319 if (!PL_in_my_stash) {
6322 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6326 if (PL_madskills) { /* just add type to declarator token */
6327 sv_catsv(PL_thistoken, PL_nextwhite);
6329 sv_catpvn(PL_thistoken, start, s - start);
6337 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6344 s = tokenize_use(0, s);
6348 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6355 if (isIDFIRST_lazy_if(s,UTF)) {
6357 for (d = s; isALNUM_lazy_if(d,UTF);)
6359 for (t=d; isSPACE(*t);)
6361 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6363 && !(t[0] == '=' && t[1] == '>')
6365 int parms_len = (int)(d-s);
6366 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6367 "Precedence problem: open %.*s should be open(%.*s)",
6368 parms_len, s, parms_len, s);
6374 pl_yylval.ival = OP_OR;
6384 LOP(OP_OPEN_DIR,XTERM);
6387 checkcomma(s,PL_tokenbuf,"filehandle");
6391 checkcomma(s,PL_tokenbuf,"filehandle");
6410 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6414 LOP(OP_PIPE_OP,XTERM);
6417 s = scan_str(s,!!PL_madskills,FALSE);
6420 pl_yylval.ival = OP_CONST;
6421 TERM(sublex_start());
6427 s = scan_str(s,!!PL_madskills,FALSE);
6430 PL_expect = XOPERATOR;
6432 if (SvCUR(PL_lex_stuff)) {
6435 d = SvPV_force(PL_lex_stuff, len);
6437 for (; isSPACE(*d) && len; --len, ++d)
6442 if (!warned && ckWARN(WARN_QW)) {
6443 for (; !isSPACE(*d) && len; --len, ++d) {
6445 Perl_warner(aTHX_ packWARN(WARN_QW),
6446 "Possible attempt to separate words with commas");
6449 else if (*d == '#') {
6450 Perl_warner(aTHX_ packWARN(WARN_QW),
6451 "Possible attempt to put comments in qw() list");
6457 for (; !isSPACE(*d) && len; --len, ++d)
6460 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
6461 words = append_elem(OP_LIST, words,
6462 newSVOP(OP_CONST, 0, tokeq(sv)));
6466 start_force(PL_curforce);
6467 NEXTVAL_NEXTTOKE.opval = words;
6472 SvREFCNT_dec(PL_lex_stuff);
6473 PL_lex_stuff = NULL;
6479 s = scan_str(s,!!PL_madskills,FALSE);
6482 pl_yylval.ival = OP_STRINGIFY;
6483 if (SvIVX(PL_lex_stuff) == '\'')
6484 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6485 TERM(sublex_start());
6488 s = scan_pat(s,OP_QR);
6489 TERM(sublex_start());
6492 s = scan_str(s,!!PL_madskills,FALSE);
6495 readpipe_override();
6496 TERM(sublex_start());
6504 s = force_version(s, FALSE);
6506 else if (*s != 'v' || !isDIGIT(s[1])
6507 || (s = force_version(s, TRUE), *s == 'v'))
6509 *PL_tokenbuf = '\0';
6510 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6511 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6512 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6514 yyerror("<> should be quotes");
6516 if (orig_keyword == KEY_require) {
6524 PL_last_uni = PL_oldbufptr;
6525 PL_last_lop_op = OP_REQUIRE;
6527 return REPORT( (int)REQUIRE );
6533 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6537 LOP(OP_RENAME,XTERM);
6546 LOP(OP_RINDEX,XTERM);
6555 UNIDOR(OP_READLINE);
6558 UNIDOR(OP_BACKTICK);
6567 LOP(OP_REVERSE,XTERM);
6570 UNIDOR(OP_READLINK);
6577 if (pl_yylval.opval)
6578 TERM(sublex_start());
6580 TOKEN(1); /* force error */
6583 checkcomma(s,PL_tokenbuf,"filehandle");
6593 LOP(OP_SELECT,XTERM);
6599 LOP(OP_SEMCTL,XTERM);
6602 LOP(OP_SEMGET,XTERM);
6605 LOP(OP_SEMOP,XTERM);
6611 LOP(OP_SETPGRP,XTERM);
6613 case KEY_setpriority:
6614 LOP(OP_SETPRIORITY,XTERM);
6616 case KEY_sethostent:
6622 case KEY_setservent:
6625 case KEY_setprotoent:
6635 LOP(OP_SEEKDIR,XTERM);
6637 case KEY_setsockopt:
6638 LOP(OP_SSOCKOPT,XTERM);
6644 LOP(OP_SHMCTL,XTERM);
6647 LOP(OP_SHMGET,XTERM);
6650 LOP(OP_SHMREAD,XTERM);
6653 LOP(OP_SHMWRITE,XTERM);
6656 LOP(OP_SHUTDOWN,XTERM);
6665 LOP(OP_SOCKET,XTERM);
6667 case KEY_socketpair:
6668 LOP(OP_SOCKPAIR,XTERM);
6671 checkcomma(s,PL_tokenbuf,"subroutine name");
6673 if (*s == ';' || *s == ')') /* probably a close */
6674 Perl_croak(aTHX_ "sort is now a reserved word");
6676 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6680 LOP(OP_SPLIT,XTERM);
6683 LOP(OP_SPRINTF,XTERM);
6686 LOP(OP_SPLICE,XTERM);
6701 LOP(OP_SUBSTR,XTERM);
6707 char tmpbuf[sizeof PL_tokenbuf];
6708 SSize_t tboffset = 0;
6709 expectation attrful;
6710 bool have_name, have_proto;
6711 const int key = tmp;
6716 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6717 SV *subtoken = newSVpvn(tstart, s - tstart);
6721 s = SKIPSPACE2(s,tmpwhite);
6726 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6727 (*s == ':' && s[1] == ':'))
6730 SV *nametoke = NULL;
6734 attrful = XATTRBLOCK;
6735 /* remember buffer pos'n for later force_word */
6736 tboffset = s - PL_oldbufptr;
6737 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6740 nametoke = newSVpvn(s, d - s);
6742 if (memchr(tmpbuf, ':', len))
6743 sv_setpvn(PL_subname, tmpbuf, len);
6745 sv_setsv(PL_subname,PL_curstname);
6746 sv_catpvs(PL_subname,"::");
6747 sv_catpvn(PL_subname,tmpbuf,len);
6754 CURMAD('X', nametoke);
6755 CURMAD('_', tmpwhite);
6756 (void) force_word(PL_oldbufptr + tboffset, WORD,
6759 s = SKIPSPACE2(d,tmpwhite);
6766 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6767 PL_expect = XTERMBLOCK;
6768 attrful = XATTRTERM;
6769 sv_setpvs(PL_subname,"?");
6773 if (key == KEY_format) {
6775 PL_lex_formbrack = PL_lex_brackets + 1;
6777 PL_thistoken = subtoken;
6781 (void) force_word(PL_oldbufptr + tboffset, WORD,
6787 /* Look for a prototype */
6790 bool bad_proto = FALSE;
6791 bool in_brackets = FALSE;
6792 char greedy_proto = ' ';
6793 bool proto_after_greedy_proto = FALSE;
6794 bool must_be_last = FALSE;
6795 bool underscore = FALSE;
6796 bool seen_underscore = FALSE;
6797 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6799 s = scan_str(s,!!PL_madskills,FALSE);
6801 Perl_croak(aTHX_ "Prototype not terminated");
6802 /* strip spaces and check for bad characters */
6803 d = SvPVX(PL_lex_stuff);
6805 for (p = d; *p; ++p) {
6811 proto_after_greedy_proto = TRUE;
6812 if (!strchr("$@%*;[]&\\_", *p)) {
6824 else if ( *p == ']' ) {
6825 in_brackets = FALSE;
6827 else if ( (*p == '@' || *p == '%') &&
6828 ( tmp < 2 || d[tmp-2] != '\\' ) &&
6830 must_be_last = TRUE;
6833 else if ( *p == '_' ) {
6834 underscore = seen_underscore = TRUE;
6841 if (proto_after_greedy_proto)
6842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6843 "Prototype after '%c' for %"SVf" : %s",
6844 greedy_proto, SVfARG(PL_subname), d);
6846 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6847 "Illegal character %sin prototype for %"SVf" : %s",
6848 seen_underscore ? "after '_' " : "",
6849 SVfARG(PL_subname), d);
6850 SvCUR_set(PL_lex_stuff, tmp);
6855 CURMAD('q', PL_thisopen);
6856 CURMAD('_', tmpwhite);
6857 CURMAD('=', PL_thisstuff);
6858 CURMAD('Q', PL_thisclose);
6859 NEXTVAL_NEXTTOKE.opval =
6860 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6861 PL_lex_stuff = NULL;
6864 s = SKIPSPACE2(s,tmpwhite);
6872 if (*s == ':' && s[1] != ':')
6873 PL_expect = attrful;
6874 else if (*s != '{' && key == KEY_sub) {
6876 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6878 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6885 curmad('^', newSVpvs(""));
6886 CURMAD('_', tmpwhite);
6890 PL_thistoken = subtoken;
6893 NEXTVAL_NEXTTOKE.opval =
6894 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6895 PL_lex_stuff = NULL;
6901 sv_setpvs(PL_subname, "__ANON__");
6903 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6907 (void) force_word(PL_oldbufptr + tboffset, WORD,
6916 LOP(OP_SYSTEM,XREF);
6919 LOP(OP_SYMLINK,XTERM);
6922 LOP(OP_SYSCALL,XTERM);
6925 LOP(OP_SYSOPEN,XTERM);
6928 LOP(OP_SYSSEEK,XTERM);
6931 LOP(OP_SYSREAD,XTERM);
6934 LOP(OP_SYSWRITE,XTERM);
6938 TERM(sublex_start());
6959 LOP(OP_TRUNCATE,XTERM);
6971 pl_yylval.ival = CopLINE(PL_curcop);
6975 pl_yylval.ival = CopLINE(PL_curcop);
6979 LOP(OP_UNLINK,XTERM);
6985 LOP(OP_UNPACK,XTERM);
6988 LOP(OP_UTIME,XTERM);
6994 LOP(OP_UNSHIFT,XTERM);
6997 s = tokenize_use(1, s);
7007 pl_yylval.ival = CopLINE(PL_curcop);
7011 pl_yylval.ival = CopLINE(PL_curcop);
7015 PL_hints |= HINT_BLOCK_SCOPE;
7022 LOP(OP_WAITPID,XTERM);
7031 ctl_l[0] = toCTRL('L');
7033 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
7036 /* Make sure $^L is defined */
7037 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
7042 if (PL_expect == XOPERATOR)
7048 pl_yylval.ival = OP_XOR;
7053 TERM(sublex_start());
7058 #pragma segment Main
7062 S_pending_ident(pTHX)
7067 /* pit holds the identifier we read and pending_ident is reset */
7068 char pit = PL_pending_ident;
7069 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
7070 /* All routes through this function want to know if there is a colon. */
7071 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
7072 PL_pending_ident = 0;
7074 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
7075 DEBUG_T({ PerlIO_printf(Perl_debug_log,
7076 "### Pending identifier '%s'\n", PL_tokenbuf); });
7078 /* if we're in a my(), we can't allow dynamics here.
7079 $foo'bar has already been turned into $foo::bar, so
7080 just check for colons.
7082 if it's a legal name, the OP is a PADANY.
7085 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
7087 yyerror(Perl_form(aTHX_ "No package name allowed for "
7088 "variable %s in \"our\"",
7090 tmp = allocmy(PL_tokenbuf);
7094 yyerror(Perl_form(aTHX_ PL_no_myglob,
7095 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
7097 pl_yylval.opval = newOP(OP_PADANY, 0);
7098 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf);
7104 build the ops for accesses to a my() variable.
7106 Deny my($a) or my($b) in a sort block, *if* $a or $b is
7107 then used in a comparison. This catches most, but not
7108 all cases. For instance, it catches
7109 sort { my($a); $a <=> $b }
7111 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
7112 (although why you'd do that is anyone's guess).
7117 tmp = pad_findmy(PL_tokenbuf);
7118 if (tmp != NOT_IN_PAD) {
7119 /* might be an "our" variable" */
7120 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
7121 /* build ops for a bareword */
7122 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
7123 HEK * const stashname = HvNAME_HEK(stash);
7124 SV * const sym = newSVhek(stashname);
7125 sv_catpvs(sym, "::");
7126 sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
7127 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
7128 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7131 ? (GV_ADDMULTI | GV_ADDINEVAL)
7134 ((PL_tokenbuf[0] == '$') ? SVt_PV
7135 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7140 /* if it's a sort block and they're naming $a or $b */
7141 if (PL_last_lop_op == OP_SORT &&
7142 PL_tokenbuf[0] == '$' &&
7143 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
7146 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
7147 d < PL_bufend && *d != '\n';
7150 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
7151 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
7157 pl_yylval.opval = newOP(OP_PADANY, 0);
7158 pl_yylval.opval->op_targ = tmp;
7164 Whine if they've said @foo in a doublequoted string,
7165 and @foo isn't a variable we can find in the symbol
7168 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
7169 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
7171 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
7172 && ckWARN(WARN_AMBIGUOUS)
7173 /* DO NOT warn for @- and @+ */
7174 && !( PL_tokenbuf[2] == '\0' &&
7175 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
7178 /* Downgraded from fatal to warning 20000522 mjd */
7179 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7180 "Possible unintended interpolation of %s in string",
7185 /* build ops for a bareword */
7186 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
7188 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7190 PL_tokenbuf + 1, tokenbuf_len - 1,
7191 /* If the identifier refers to a stash, don't autovivify it.
7192 * Change 24660 had the side effect of causing symbol table
7193 * hashes to always be defined, even if they were freshly
7194 * created and the only reference in the entire program was
7195 * the single statement with the defined %foo::bar:: test.
7196 * It appears that all code in the wild doing this actually
7197 * wants to know whether sub-packages have been loaded, so
7198 * by avoiding auto-vivifying symbol tables, we ensure that
7199 * defined %foo::bar:: continues to be false, and the existing
7200 * tests still give the expected answers, even though what
7201 * they're actually testing has now changed subtly.
7203 (*PL_tokenbuf == '%'
7204 && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
7207 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7208 ((PL_tokenbuf[0] == '$') ? SVt_PV
7209 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7215 * The following code was generated by perl_keyword.pl.
7219 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7223 PERL_ARGS_ASSERT_KEYWORD;
7227 case 1: /* 5 tokens of length 1 */
7259 case 2: /* 18 tokens of length 2 */
7405 case 3: /* 29 tokens of length 3 */
7409 if (name[1] == 'N' &&
7472 if (name[1] == 'i' &&
7504 if (name[1] == 'o' &&
7513 if (name[1] == 'e' &&
7522 if (name[1] == 'n' &&
7531 if (name[1] == 'o' &&
7540 if (name[1] == 'a' &&
7549 if (name[1] == 'o' &&
7611 if (name[1] == 'e' &&
7625 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7651 if (name[1] == 'i' &&
7660 if (name[1] == 's' &&
7669 if (name[1] == 'e' &&
7678 if (name[1] == 'o' &&
7690 case 4: /* 41 tokens of length 4 */
7694 if (name[1] == 'O' &&
7704 if (name[1] == 'N' &&
7714 if (name[1] == 'i' &&
7724 if (name[1] == 'h' &&
7734 if (name[1] == 'u' &&
7747 if (name[2] == 'c' &&
7756 if (name[2] == 's' &&
7765 if (name[2] == 'a' &&
7801 if (name[1] == 'o' &&
7814 if (name[2] == 't' &&
7823 if (name[2] == 'o' &&
7832 if (name[2] == 't' &&
7841 if (name[2] == 'e' &&
7854 if (name[1] == 'o' &&
7867 if (name[2] == 'y' &&
7876 if (name[2] == 'l' &&
7892 if (name[2] == 's' &&
7901 if (name[2] == 'n' &&
7910 if (name[2] == 'c' &&
7923 if (name[1] == 'e' &&
7933 if (name[1] == 'p' &&
7946 if (name[2] == 'c' &&
7955 if (name[2] == 'p' &&
7964 if (name[2] == 's' &&
7980 if (name[2] == 'n' &&
8050 if (name[2] == 'r' &&
8059 if (name[2] == 'r' &&
8068 if (name[2] == 'a' &&
8084 if (name[2] == 'l' &&
8146 if (name[2] == 'e' &&
8149 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
8162 case 5: /* 39 tokens of length 5 */
8166 if (name[1] == 'E' &&
8177 if (name[1] == 'H' &&
8191 if (name[2] == 'a' &&
8201 if (name[2] == 'a' &&
8218 if (name[2] == 'e' &&
8228 if (name[2] == 'e' &&
8232 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8248 if (name[3] == 'i' &&
8257 if (name[3] == 'o' &&
8293 if (name[2] == 'o' &&
8303 if (name[2] == 'y' &&
8317 if (name[1] == 'l' &&
8331 if (name[2] == 'n' &&
8341 if (name[2] == 'o' &&
8355 if (name[1] == 'i' &&
8360 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8369 if (name[2] == 'd' &&
8379 if (name[2] == 'c' &&
8396 if (name[2] == 'c' &&
8406 if (name[2] == 't' &&
8420 if (name[1] == 'k' &&
8431 if (name[1] == 'r' &&
8445 if (name[2] == 's' &&
8455 if (name[2] == 'd' &&
8472 if (name[2] == 'm' &&
8482 if (name[2] == 'i' &&
8492 if (name[2] == 'e' &&
8502 if (name[2] == 'l' &&
8512 if (name[2] == 'a' &&
8525 if (name[3] == 't' &&
8528 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8534 if (name[3] == 'd' &&
8551 if (name[1] == 'i' &&
8565 if (name[2] == 'a' &&
8578 if (name[3] == 'e' &&
8613 if (name[2] == 'i' &&
8630 if (name[2] == 'i' &&
8640 if (name[2] == 'i' &&
8657 case 6: /* 33 tokens of length 6 */
8661 if (name[1] == 'c' &&
8676 if (name[2] == 'l' &&
8687 if (name[2] == 'r' &&
8702 if (name[1] == 'e' &&
8717 if (name[2] == 's' &&
8722 if(ckWARN_d(WARN_SYNTAX))
8723 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8729 if (name[2] == 'i' &&
8747 if (name[2] == 'l' &&
8758 if (name[2] == 'r' &&
8773 if (name[1] == 'm' &&
8788 if (name[2] == 'n' &&
8799 if (name[2] == 's' &&
8814 if (name[1] == 's' &&
8820 if (name[4] == 't' &&
8829 if (name[4] == 'e' &&
8838 if (name[4] == 'c' &&
8847 if (name[4] == 'n' &&
8863 if (name[1] == 'r' &&
8881 if (name[3] == 'a' &&
8891 if (name[3] == 'u' &&
8905 if (name[2] == 'n' &&
8923 if (name[2] == 'a' &&
8937 if (name[3] == 'e' &&
8950 if (name[4] == 't' &&
8959 if (name[4] == 'e' &&
8981 if (name[4] == 't' &&
8990 if (name[4] == 'e' &&
9006 if (name[2] == 'c' &&
9017 if (name[2] == 'l' &&
9028 if (name[2] == 'b' &&
9039 if (name[2] == 's' &&
9062 if (name[4] == 's' &&
9071 if (name[4] == 'n' &&
9084 if (name[3] == 'a' &&
9101 if (name[1] == 'a' &&
9116 case 7: /* 29 tokens of length 7 */
9120 if (name[1] == 'E' &&
9133 if (name[1] == '_' &&
9146 if (name[1] == 'i' &&
9153 return -KEY_binmode;
9159 if (name[1] == 'o' &&
9166 return -KEY_connect;
9175 if (name[2] == 'm' &&
9181 return -KEY_dbmopen;
9192 if (name[4] == 'u' &&
9196 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9202 if (name[4] == 'n' &&
9223 if (name[1] == 'o' &&
9236 if (name[1] == 'e' &&
9243 if (name[5] == 'r' &&
9246 return -KEY_getpgrp;
9252 if (name[5] == 'i' &&
9255 return -KEY_getppid;
9268 if (name[1] == 'c' &&
9275 return -KEY_lcfirst;
9281 if (name[1] == 'p' &&
9288 return -KEY_opendir;
9294 if (name[1] == 'a' &&
9312 if (name[3] == 'd' &&
9317 return -KEY_readdir;
9323 if (name[3] == 'u' &&
9334 if (name[3] == 'e' &&
9339 return -KEY_reverse;
9358 if (name[3] == 'k' &&
9363 return -KEY_seekdir;
9369 if (name[3] == 'p' &&
9374 return -KEY_setpgrp;
9384 if (name[2] == 'm' &&
9390 return -KEY_shmread;
9396 if (name[2] == 'r' &&
9402 return -KEY_sprintf;
9411 if (name[3] == 'l' &&
9416 return -KEY_symlink;
9425 if (name[4] == 'a' &&
9429 return -KEY_syscall;
9435 if (name[4] == 'p' &&
9439 return -KEY_sysopen;
9445 if (name[4] == 'e' &&
9449 return -KEY_sysread;
9455 if (name[4] == 'e' &&
9459 return -KEY_sysseek;
9477 if (name[1] == 'e' &&
9484 return -KEY_telldir;
9493 if (name[2] == 'f' &&
9499 return -KEY_ucfirst;
9505 if (name[2] == 's' &&
9511 return -KEY_unshift;
9521 if (name[1] == 'a' &&
9528 return -KEY_waitpid;
9537 case 8: /* 26 tokens of length 8 */
9541 if (name[1] == 'U' &&
9549 return KEY_AUTOLOAD;
9560 if (name[3] == 'A' &&
9566 return KEY___DATA__;
9572 if (name[3] == 'I' &&
9578 return -KEY___FILE__;
9584 if (name[3] == 'I' &&
9590 return -KEY___LINE__;
9606 if (name[2] == 'o' &&
9613 return -KEY_closedir;
9619 if (name[2] == 'n' &&
9626 return -KEY_continue;
9636 if (name[1] == 'b' &&
9644 return -KEY_dbmclose;
9650 if (name[1] == 'n' &&
9656 if (name[4] == 'r' &&
9661 return -KEY_endgrent;
9667 if (name[4] == 'w' &&
9672 return -KEY_endpwent;
9685 if (name[1] == 'o' &&
9693 return -KEY_formline;
9699 if (name[1] == 'e' &&
9710 if (name[6] == 'n' &&
9713 return -KEY_getgrent;
9719 if (name[6] == 'i' &&
9722 return -KEY_getgrgid;
9728 if (name[6] == 'a' &&
9731 return -KEY_getgrnam;
9744 if (name[4] == 'o' &&
9749 return -KEY_getlogin;
9760 if (name[6] == 'n' &&
9763 return -KEY_getpwent;
9769 if (name[6] == 'a' &&
9772 return -KEY_getpwnam;
9778 if (name[6] == 'i' &&
9781 return -KEY_getpwuid;
9801 if (name[1] == 'e' &&
9808 if (name[5] == 'i' &&
9815 return -KEY_readline;
9820 return -KEY_readlink;
9831 if (name[5] == 'i' &&
9835 return -KEY_readpipe;
9856 if (name[4] == 'r' &&
9861 return -KEY_setgrent;
9867 if (name[4] == 'w' &&
9872 return -KEY_setpwent;
9888 if (name[3] == 'w' &&
9894 return -KEY_shmwrite;
9900 if (name[3] == 't' &&
9906 return -KEY_shutdown;
9916 if (name[2] == 's' &&
9923 return -KEY_syswrite;
9933 if (name[1] == 'r' &&
9941 return -KEY_truncate;
9950 case 9: /* 9 tokens of length 9 */
9954 if (name[1] == 'N' &&
9963 return KEY_UNITCHECK;
9969 if (name[1] == 'n' &&
9978 return -KEY_endnetent;
9984 if (name[1] == 'e' &&
9993 return -KEY_getnetent;
9999 if (name[1] == 'o' &&
10008 return -KEY_localtime;
10014 if (name[1] == 'r' &&
10023 return KEY_prototype;
10029 if (name[1] == 'u' &&
10038 return -KEY_quotemeta;
10044 if (name[1] == 'e' &&
10053 return -KEY_rewinddir;
10059 if (name[1] == 'e' &&
10068 return -KEY_setnetent;
10074 if (name[1] == 'a' &&
10083 return -KEY_wantarray;
10092 case 10: /* 9 tokens of length 10 */
10096 if (name[1] == 'n' &&
10102 if (name[4] == 'o' &&
10109 return -KEY_endhostent;
10115 if (name[4] == 'e' &&
10122 return -KEY_endservent;
10135 if (name[1] == 'e' &&
10141 if (name[4] == 'o' &&
10148 return -KEY_gethostent;
10157 if (name[5] == 'r' &&
10163 return -KEY_getservent;
10169 if (name[5] == 'c' &&
10175 return -KEY_getsockopt;
10195 if (name[2] == 't')
10200 if (name[4] == 'o' &&
10207 return -KEY_sethostent;
10216 if (name[5] == 'r' &&
10222 return -KEY_setservent;
10228 if (name[5] == 'c' &&
10234 return -KEY_setsockopt;
10251 if (name[2] == 'c' &&
10260 return -KEY_socketpair;
10273 case 11: /* 8 tokens of length 11 */
10277 if (name[1] == '_' &&
10287 { /* __PACKAGE__ */
10288 return -KEY___PACKAGE__;
10294 if (name[1] == 'n' &&
10304 { /* endprotoent */
10305 return -KEY_endprotoent;
10311 if (name[1] == 'e' &&
10320 if (name[5] == 'e' &&
10326 { /* getpeername */
10327 return -KEY_getpeername;
10336 if (name[6] == 'o' &&
10341 { /* getpriority */
10342 return -KEY_getpriority;
10348 if (name[6] == 't' &&
10353 { /* getprotoent */
10354 return -KEY_getprotoent;
10368 if (name[4] == 'o' &&
10375 { /* getsockname */
10376 return -KEY_getsockname;
10389 if (name[1] == 'e' &&
10397 if (name[6] == 'o' &&
10402 { /* setpriority */
10403 return -KEY_setpriority;
10409 if (name[6] == 't' &&
10414 { /* setprotoent */
10415 return -KEY_setprotoent;
10431 case 12: /* 2 tokens of length 12 */
10432 if (name[0] == 'g' &&
10444 if (name[9] == 'd' &&
10447 { /* getnetbyaddr */
10448 return -KEY_getnetbyaddr;
10454 if (name[9] == 'a' &&
10457 { /* getnetbyname */
10458 return -KEY_getnetbyname;
10470 case 13: /* 4 tokens of length 13 */
10471 if (name[0] == 'g' &&
10478 if (name[4] == 'o' &&
10487 if (name[10] == 'd' &&
10490 { /* gethostbyaddr */
10491 return -KEY_gethostbyaddr;
10497 if (name[10] == 'a' &&
10500 { /* gethostbyname */
10501 return -KEY_gethostbyname;
10514 if (name[4] == 'e' &&
10523 if (name[10] == 'a' &&
10526 { /* getservbyname */
10527 return -KEY_getservbyname;
10533 if (name[10] == 'o' &&
10536 { /* getservbyport */
10537 return -KEY_getservbyport;
10556 case 14: /* 1 tokens of length 14 */
10557 if (name[0] == 'g' &&
10571 { /* getprotobyname */
10572 return -KEY_getprotobyname;
10577 case 16: /* 1 tokens of length 16 */
10578 if (name[0] == 'g' &&
10594 { /* getprotobynumber */
10595 return -KEY_getprotobynumber;
10609 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10613 PERL_ARGS_ASSERT_CHECKCOMMA;
10615 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10616 if (ckWARN(WARN_SYNTAX)) {
10619 for (w = s+2; *w && level; w++) {
10622 else if (*w == ')')
10625 while (isSPACE(*w))
10627 /* the list of chars below is for end of statements or
10628 * block / parens, boolean operators (&&, ||, //) and branch
10629 * constructs (or, and, if, until, unless, while, err, for).
10630 * Not a very solid hack... */
10631 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
10632 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10633 "%s (...) interpreted as function",name);
10636 while (s < PL_bufend && isSPACE(*s))
10640 while (s < PL_bufend && isSPACE(*s))
10642 if (isIDFIRST_lazy_if(s,UTF)) {
10643 const char * const w = s++;
10644 while (isALNUM_lazy_if(s,UTF))
10646 while (s < PL_bufend && isSPACE(*s))
10650 if (keyword(w, s - w, 0))
10653 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10654 if (gv && GvCVu(gv))
10656 Perl_croak(aTHX_ "No comma allowed after %s", what);
10661 /* Either returns sv, or mortalizes sv and returns a new SV*.
10662 Best used as sv=new_constant(..., sv, ...).
10663 If s, pv are NULL, calls subroutine with one argument,
10664 and type is used with error messages only. */
10667 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
10668 SV *sv, SV *pv, const char *type, STRLEN typelen)
10671 HV * const table = GvHV(PL_hintgv); /* ^H */
10675 const char *why1 = "", *why2 = "", *why3 = "";
10677 PERL_ARGS_ASSERT_NEW_CONSTANT;
10679 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10682 why2 = (const char *)
10683 (strEQ(key,"charnames")
10684 ? "(possibly a missing \"use charnames ...\")"
10686 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10687 (type ? type: "undef"), why2);
10689 /* This is convoluted and evil ("goto considered harmful")
10690 * but I do not understand the intricacies of all the different
10691 * failure modes of %^H in here. The goal here is to make
10692 * the most probable error message user-friendly. --jhi */
10697 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10698 (type ? type: "undef"), why1, why2, why3);
10700 yyerror(SvPVX_const(msg));
10704 cvp = hv_fetch(table, key, keylen, FALSE);
10705 if (!cvp || !SvOK(*cvp)) {
10708 why3 = "} is not defined";
10711 sv_2mortal(sv); /* Parent created it permanently */
10714 pv = newSVpvn_flags(s, len, SVs_TEMP);
10716 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
10718 typesv = &PL_sv_undef;
10720 PUSHSTACKi(PERLSI_OVERLOAD);
10732 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10736 /* Check the eval first */
10737 if (!PL_in_eval && SvTRUE(ERRSV)) {
10738 sv_catpvs(ERRSV, "Propagated");
10739 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10741 res = SvREFCNT_inc_simple(sv);
10745 SvREFCNT_inc_simple_void(res);
10754 why1 = "Call to &{$^H{";
10756 why3 = "}} did not return a defined value";
10764 /* Returns a NUL terminated string, with the length of the string written to
10768 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10771 register char *d = dest;
10772 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10774 PERL_ARGS_ASSERT_SCAN_WORD;
10778 Perl_croak(aTHX_ ident_too_long);
10779 if (isALNUM(*s)) /* UTF handled below */
10781 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10786 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10790 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10791 char *t = s + UTF8SKIP(s);
10793 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10797 Perl_croak(aTHX_ ident_too_long);
10798 Copy(s, d, len, char);
10811 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10814 char *bracket = NULL;
10816 register char *d = dest;
10817 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10819 PERL_ARGS_ASSERT_SCAN_IDENT;
10824 while (isDIGIT(*s)) {
10826 Perl_croak(aTHX_ ident_too_long);
10833 Perl_croak(aTHX_ ident_too_long);
10834 if (isALNUM(*s)) /* UTF handled below */
10836 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10841 else if (*s == ':' && s[1] == ':') {
10845 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10846 char *t = s + UTF8SKIP(s);
10847 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10849 if (d + (t - s) > e)
10850 Perl_croak(aTHX_ ident_too_long);
10851 Copy(s, d, t - s, char);
10862 if (PL_lex_state != LEX_NORMAL)
10863 PL_lex_state = LEX_INTERPENDMAYBE;
10866 if (*s == '$' && s[1] &&
10867 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10880 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10885 if (isSPACE(s[-1])) {
10887 const char ch = *s++;
10888 if (!SPACE_OR_TAB(ch)) {
10894 if (isIDFIRST_lazy_if(d,UTF)) {
10898 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10899 end += UTF8SKIP(end);
10900 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10901 end += UTF8SKIP(end);
10903 Copy(s, d, end - s, char);
10908 while ((isALNUM(*s) || *s == ':') && d < e)
10911 Perl_croak(aTHX_ ident_too_long);
10914 while (s < send && SPACE_OR_TAB(*s))
10916 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10917 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10918 const char * const brack =
10920 ((*s == '[') ? "[...]" : "{...}");
10921 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10922 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10923 funny, dest, brack, funny, dest, brack);
10926 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10930 /* Handle extended ${^Foo} variables
10931 * 1999-02-27 mjd-perl-patch@plover.com */
10932 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10936 while (isALNUM(*s) && d < e) {
10940 Perl_croak(aTHX_ ident_too_long);
10945 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10946 PL_lex_state = LEX_INTERPEND;
10949 if (PL_lex_state == LEX_NORMAL) {
10950 if (ckWARN(WARN_AMBIGUOUS) &&
10951 (keyword(dest, d - dest, 0)
10952 || get_cvn_flags(dest, d - dest, 0)))
10956 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10957 "Ambiguous use of %c{%s} resolved to %c%s",
10958 funny, dest, funny, dest);
10963 s = bracket; /* let the parser handle it */
10967 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10968 PL_lex_state = LEX_INTERPEND;
10973 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10975 PERL_ARGS_ASSERT_PMFLAG;
10977 PERL_UNUSED_CONTEXT;
10979 const char c = (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 S_scan_pat(pTHX_ char *start, I32 type)
10995 char *s = scan_str(start,!!PL_madskills,FALSE);
10996 const char * const valid_flags =
10997 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
11002 PERL_ARGS_ASSERT_SCAN_PAT;
11005 const char * const delimiter = skipspace(start);
11009 ? "Search pattern not terminated or ternary operator parsed as search pattern"
11010 : "Search pattern not terminated" ));
11013 pm = (PMOP*)newPMOP(type, 0);
11014 if (PL_multi_open == '?') {
11015 /* This is the only point in the code that sets PMf_ONCE: */
11016 pm->op_pmflags |= PMf_ONCE;
11018 /* Hence it's safe to do this bit of PMOP book-keeping here, which
11019 allows us to restrict the list needed by reset to just the ??
11021 assert(type != OP_TRANS);
11023 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
11026 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
11029 elements = mg->mg_len / sizeof(PMOP**);
11030 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
11031 ((PMOP**)mg->mg_ptr) [elements++] = pm;
11032 mg->mg_len = elements * sizeof(PMOP**);
11033 PmopSTASH_set(pm,PL_curstash);
11039 while (*s && strchr(valid_flags, *s))
11040 pmflag(&pm->op_pmflags,*s++);
11042 if (PL_madskills && modstart != s) {
11043 SV* tmptoken = newSVpvn(modstart, s - modstart);
11044 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
11047 /* issue a warning if /c is specified,but /g is not */
11048 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
11049 && ckWARN(WARN_REGEXP))
11051 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
11052 "Use of /c modifier is meaningless without /g" );
11055 PL_lex_op = (OP*)pm;
11056 pl_yylval.ival = OP_MATCH;
11061 S_scan_subst(pTHX_ char *start)
11072 PERL_ARGS_ASSERT_SCAN_SUBST;
11074 pl_yylval.ival = OP_NULL;
11076 s = scan_str(start,!!PL_madskills,FALSE);
11079 Perl_croak(aTHX_ "Substitution pattern not terminated");
11081 if (s[-1] == PL_multi_open)
11084 if (PL_madskills) {
11085 CURMAD('q', PL_thisopen);
11086 CURMAD('_', PL_thiswhite);
11087 CURMAD('E', PL_thisstuff);
11088 CURMAD('Q', PL_thisclose);
11089 PL_realtokenstart = s - SvPVX(PL_linestr);
11093 first_start = PL_multi_start;
11094 s = scan_str(s,!!PL_madskills,FALSE);
11096 if (PL_lex_stuff) {
11097 SvREFCNT_dec(PL_lex_stuff);
11098 PL_lex_stuff = NULL;
11100 Perl_croak(aTHX_ "Substitution replacement not terminated");
11102 PL_multi_start = first_start; /* so whole substitution is taken together */
11104 pm = (PMOP*)newPMOP(OP_SUBST, 0);
11107 if (PL_madskills) {
11108 CURMAD('z', PL_thisopen);
11109 CURMAD('R', PL_thisstuff);
11110 CURMAD('Z', PL_thisclose);
11116 if (*s == EXEC_PAT_MOD) {
11120 else if (strchr(S_PAT_MODS, *s))
11121 pmflag(&pm->op_pmflags,*s++);
11127 if (PL_madskills) {
11129 curmad('m', newSVpvn(modstart, s - modstart));
11130 append_madprops(PL_thismad, (OP*)pm, 0);
11134 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
11135 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
11139 SV * const repl = newSVpvs("");
11141 PL_sublex_info.super_bufptr = s;
11142 PL_sublex_info.super_bufend = PL_bufend;
11144 pm->op_pmflags |= PMf_EVAL;
11147 sv_catpvs(repl, "eval ");
11149 sv_catpvs(repl, "do ");
11151 sv_catpvs(repl, "{");
11152 sv_catsv(repl, PL_lex_repl);
11153 if (strchr(SvPVX(PL_lex_repl), '#'))
11154 sv_catpvs(repl, "\n");
11155 sv_catpvs(repl, "}");
11157 SvREFCNT_dec(PL_lex_repl);
11158 PL_lex_repl = repl;
11161 PL_lex_op = (OP*)pm;
11162 pl_yylval.ival = OP_SUBST;
11167 S_scan_trans(pTHX_ char *start)
11180 PERL_ARGS_ASSERT_SCAN_TRANS;
11182 pl_yylval.ival = OP_NULL;
11184 s = scan_str(start,!!PL_madskills,FALSE);
11186 Perl_croak(aTHX_ "Transliteration pattern not terminated");
11188 if (s[-1] == PL_multi_open)
11191 if (PL_madskills) {
11192 CURMAD('q', PL_thisopen);
11193 CURMAD('_', PL_thiswhite);
11194 CURMAD('E', PL_thisstuff);
11195 CURMAD('Q', PL_thisclose);
11196 PL_realtokenstart = s - SvPVX(PL_linestr);
11200 s = scan_str(s,!!PL_madskills,FALSE);
11202 if (PL_lex_stuff) {
11203 SvREFCNT_dec(PL_lex_stuff);
11204 PL_lex_stuff = NULL;
11206 Perl_croak(aTHX_ "Transliteration replacement not terminated");
11208 if (PL_madskills) {
11209 CURMAD('z', PL_thisopen);
11210 CURMAD('R', PL_thisstuff);
11211 CURMAD('Z', PL_thisclose);
11214 complement = del = squash = 0;
11221 complement = OPpTRANS_COMPLEMENT;
11224 del = OPpTRANS_DELETE;
11227 squash = OPpTRANS_SQUASH;
11236 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11237 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11238 o->op_private &= ~OPpTRANS_ALL;
11239 o->op_private |= del|squash|complement|
11240 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11241 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11244 pl_yylval.ival = OP_TRANS;
11247 if (PL_madskills) {
11249 curmad('m', newSVpvn(modstart, s - modstart));
11250 append_madprops(PL_thismad, o, 0);
11259 S_scan_heredoc(pTHX_ register char *s)
11263 I32 op_type = OP_SCALAR;
11267 const char *found_newline;
11271 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11273 I32 stuffstart = s - SvPVX(PL_linestr);
11276 PL_realtokenstart = -1;
11279 PERL_ARGS_ASSERT_SCAN_HEREDOC;
11283 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11287 while (SPACE_OR_TAB(*peek))
11289 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11292 s = delimcpy(d, e, s, PL_bufend, term, &len);
11302 if (!isALNUM_lazy_if(s,UTF))
11303 deprecate_old("bare << to mean <<\"\"");
11304 for (; isALNUM_lazy_if(s,UTF); s++) {
11309 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11310 Perl_croak(aTHX_ "Delimiter for here document is too long");
11313 len = d - PL_tokenbuf;
11316 if (PL_madskills) {
11317 tstart = PL_tokenbuf + !outer;
11318 PL_thisclose = newSVpvn(tstart, len - !outer);
11319 tstart = SvPVX(PL_linestr) + stuffstart;
11320 PL_thisopen = newSVpvn(tstart, s - tstart);
11321 stuffstart = s - SvPVX(PL_linestr);
11324 #ifndef PERL_STRICT_CR
11325 d = strchr(s, '\r');
11327 char * const olds = s;
11329 while (s < PL_bufend) {
11335 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11344 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11351 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11352 herewas = newSVpvn(s,PL_bufend-s);
11356 herewas = newSVpvn(s-1,found_newline-s+1);
11359 herewas = newSVpvn(s,found_newline-s);
11363 if (PL_madskills) {
11364 tstart = SvPVX(PL_linestr) + stuffstart;
11366 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11368 PL_thisstuff = newSVpvn(tstart, s - tstart);
11371 s += SvCUR(herewas);
11374 stuffstart = s - SvPVX(PL_linestr);
11380 tmpstr = newSV_type(SVt_PVIV);
11381 SvGROW(tmpstr, 80);
11382 if (term == '\'') {
11383 op_type = OP_CONST;
11384 SvIV_set(tmpstr, -1);
11386 else if (term == '`') {
11387 op_type = OP_BACKTICK;
11388 SvIV_set(tmpstr, '\\');
11392 PL_multi_start = CopLINE(PL_curcop);
11393 PL_multi_open = PL_multi_close = '<';
11394 term = *PL_tokenbuf;
11395 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11396 char * const bufptr = PL_sublex_info.super_bufptr;
11397 char * const bufend = PL_sublex_info.super_bufend;
11398 char * const olds = s - SvCUR(herewas);
11399 s = strchr(bufptr, '\n');
11403 while (s < bufend &&
11404 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11406 CopLINE_inc(PL_curcop);
11409 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11410 missingterm(PL_tokenbuf);
11412 sv_setpvn(herewas,bufptr,d-bufptr+1);
11413 sv_setpvn(tmpstr,d+1,s-d);
11415 sv_catpvn(herewas,s,bufend-s);
11416 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11423 while (s < PL_bufend &&
11424 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11426 CopLINE_inc(PL_curcop);
11428 if (s >= PL_bufend) {
11429 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11430 missingterm(PL_tokenbuf);
11432 sv_setpvn(tmpstr,d+1,s-d);
11434 if (PL_madskills) {
11436 sv_catpvn(PL_thisstuff, d + 1, s - d);
11438 PL_thisstuff = newSVpvn(d + 1, s - d);
11439 stuffstart = s - SvPVX(PL_linestr);
11443 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11445 sv_catpvn(herewas,s,PL_bufend-s);
11446 sv_setsv(PL_linestr,herewas);
11447 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11448 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11449 PL_last_lop = PL_last_uni = NULL;
11452 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
11453 while (s >= PL_bufend) { /* multiple line string? */
11455 if (PL_madskills) {
11456 tstart = SvPVX(PL_linestr) + stuffstart;
11458 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11460 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11464 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11465 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11466 missingterm(PL_tokenbuf);
11469 stuffstart = s - SvPVX(PL_linestr);
11471 CopLINE_inc(PL_curcop);
11472 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11473 PL_last_lop = PL_last_uni = NULL;
11474 #ifndef PERL_STRICT_CR
11475 if (PL_bufend - PL_linestart >= 2) {
11476 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11477 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11479 PL_bufend[-2] = '\n';
11481 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11483 else if (PL_bufend[-1] == '\r')
11484 PL_bufend[-1] = '\n';
11486 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11487 PL_bufend[-1] = '\n';
11489 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11490 update_debugger_info(PL_linestr, NULL, 0);
11491 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11492 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11493 *(SvPVX(PL_linestr) + off ) = ' ';
11494 sv_catsv(PL_linestr,herewas);
11495 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11496 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11500 sv_catsv(tmpstr,PL_linestr);
11505 PL_multi_end = CopLINE(PL_curcop);
11506 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11507 SvPV_shrink_to_cur(tmpstr);
11509 SvREFCNT_dec(herewas);
11511 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11513 else if (PL_encoding)
11514 sv_recode_to_utf8(tmpstr, PL_encoding);
11516 PL_lex_stuff = tmpstr;
11517 pl_yylval.ival = op_type;
11521 /* scan_inputsymbol
11522 takes: current position in input buffer
11523 returns: new position in input buffer
11524 side-effects: pl_yylval and lex_op are set.
11529 <FH> read from filehandle
11530 <pkg::FH> read from package qualified filehandle
11531 <pkg'FH> read from package qualified filehandle
11532 <$fh> read from filehandle in $fh
11533 <*.h> filename glob
11538 S_scan_inputsymbol(pTHX_ char *start)
11541 register char *s = start; /* current position in buffer */
11544 char *d = PL_tokenbuf; /* start of temp holding space */
11545 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11547 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
11549 end = strchr(s, '\n');
11552 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11554 /* die if we didn't have space for the contents of the <>,
11555 or if it didn't end, or if we see a newline
11558 if (len >= (I32)sizeof PL_tokenbuf)
11559 Perl_croak(aTHX_ "Excessively long <> operator");
11561 Perl_croak(aTHX_ "Unterminated <> operator");
11566 Remember, only scalar variables are interpreted as filehandles by
11567 this code. Anything more complex (e.g., <$fh{$num}>) will be
11568 treated as a glob() call.
11569 This code makes use of the fact that except for the $ at the front,
11570 a scalar variable and a filehandle look the same.
11572 if (*d == '$' && d[1]) d++;
11574 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11575 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11578 /* If we've tried to read what we allow filehandles to look like, and
11579 there's still text left, then it must be a glob() and not a getline.
11580 Use scan_str to pull out the stuff between the <> and treat it
11581 as nothing more than a string.
11584 if (d - PL_tokenbuf != len) {
11585 pl_yylval.ival = OP_GLOB;
11586 s = scan_str(start,!!PL_madskills,FALSE);
11588 Perl_croak(aTHX_ "Glob not terminated");
11592 bool readline_overriden = FALSE;
11595 /* we're in a filehandle read situation */
11598 /* turn <> into <ARGV> */
11600 Copy("ARGV",d,5,char);
11602 /* Check whether readline() is overriden */
11603 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11605 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11607 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11608 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11609 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11610 readline_overriden = TRUE;
11612 /* if <$fh>, create the ops to turn the variable into a
11616 /* try to find it in the pad for this block, otherwise find
11617 add symbol table ops
11619 const PADOFFSET tmp = pad_findmy(d);
11620 if (tmp != NOT_IN_PAD) {
11621 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11622 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11623 HEK * const stashname = HvNAME_HEK(stash);
11624 SV * const sym = sv_2mortal(newSVhek(stashname));
11625 sv_catpvs(sym, "::");
11626 sv_catpv(sym, d+1);
11631 OP * const o = newOP(OP_PADSV, 0);
11633 PL_lex_op = readline_overriden
11634 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11635 append_elem(OP_LIST, o,
11636 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11637 : (OP*)newUNOP(OP_READLINE, 0, o);
11646 ? (GV_ADDMULTI | GV_ADDINEVAL)
11649 PL_lex_op = readline_overriden
11650 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11651 append_elem(OP_LIST,
11652 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11653 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11654 : (OP*)newUNOP(OP_READLINE, 0,
11655 newUNOP(OP_RV2SV, 0,
11656 newGVOP(OP_GV, 0, gv)));
11658 if (!readline_overriden)
11659 PL_lex_op->op_flags |= OPf_SPECIAL;
11660 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
11661 pl_yylval.ival = OP_NULL;
11664 /* If it's none of the above, it must be a literal filehandle
11665 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11667 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11668 PL_lex_op = readline_overriden
11669 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11670 append_elem(OP_LIST,
11671 newGVOP(OP_GV, 0, gv),
11672 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11673 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11674 pl_yylval.ival = OP_NULL;
11683 takes: start position in buffer
11684 keep_quoted preserve \ on the embedded delimiter(s)
11685 keep_delims preserve the delimiters around the string
11686 returns: position to continue reading from buffer
11687 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11688 updates the read buffer.
11690 This subroutine pulls a string out of the input. It is called for:
11691 q single quotes q(literal text)
11692 ' single quotes 'literal text'
11693 qq double quotes qq(interpolate $here please)
11694 " double quotes "interpolate $here please"
11695 qx backticks qx(/bin/ls -l)
11696 ` backticks `/bin/ls -l`
11697 qw quote words @EXPORT_OK = qw( func() $spam )
11698 m// regexp match m/this/
11699 s/// regexp substitute s/this/that/
11700 tr/// string transliterate tr/this/that/
11701 y/// string transliterate y/this/that/
11702 ($*@) sub prototypes sub foo ($)
11703 (stuff) sub attr parameters sub foo : attr(stuff)
11704 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11706 In most of these cases (all but <>, patterns and transliterate)
11707 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11708 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11709 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11712 It skips whitespace before the string starts, and treats the first
11713 character as the delimiter. If the delimiter is one of ([{< then
11714 the corresponding "close" character )]}> is used as the closing
11715 delimiter. It allows quoting of delimiters, and if the string has
11716 balanced delimiters ([{<>}]) it allows nesting.
11718 On success, the SV with the resulting string is put into lex_stuff or,
11719 if that is already non-NULL, into lex_repl. The second case occurs only
11720 when parsing the RHS of the special constructs s/// and tr/// (y///).
11721 For convenience, the terminating delimiter character is stuffed into
11726 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11729 SV *sv; /* scalar value: string */
11730 const char *tmps; /* temp string, used for delimiter matching */
11731 register char *s = start; /* current position in the buffer */
11732 register char term; /* terminating character */
11733 register char *to; /* current position in the sv's data */
11734 I32 brackets = 1; /* bracket nesting level */
11735 bool has_utf8 = FALSE; /* is there any utf8 content? */
11736 I32 termcode; /* terminating char. code */
11737 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11738 STRLEN termlen; /* length of terminating string */
11739 int last_off = 0; /* last position for nesting bracket */
11745 PERL_ARGS_ASSERT_SCAN_STR;
11747 /* skip space before the delimiter */
11753 if (PL_realtokenstart >= 0) {
11754 stuffstart = PL_realtokenstart;
11755 PL_realtokenstart = -1;
11758 stuffstart = start - SvPVX(PL_linestr);
11760 /* mark where we are, in case we need to report errors */
11763 /* after skipping whitespace, the next character is the terminator */
11766 termcode = termstr[0] = term;
11770 termcode = utf8_to_uvchr((U8*)s, &termlen);
11771 Copy(s, termstr, termlen, U8);
11772 if (!UTF8_IS_INVARIANT(term))
11776 /* mark where we are */
11777 PL_multi_start = CopLINE(PL_curcop);
11778 PL_multi_open = term;
11780 /* find corresponding closing delimiter */
11781 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11782 termcode = termstr[0] = term = tmps[5];
11784 PL_multi_close = term;
11786 /* create a new SV to hold the contents. 79 is the SV's initial length.
11787 What a random number. */
11788 sv = newSV_type(SVt_PVIV);
11790 SvIV_set(sv, termcode);
11791 (void)SvPOK_only(sv); /* validate pointer */
11793 /* move past delimiter and try to read a complete string */
11795 sv_catpvn(sv, s, termlen);
11798 tstart = SvPVX(PL_linestr) + stuffstart;
11799 if (!PL_thisopen && !keep_delims) {
11800 PL_thisopen = newSVpvn(tstart, s - tstart);
11801 stuffstart = s - SvPVX(PL_linestr);
11805 if (PL_encoding && !UTF) {
11809 int offset = s - SvPVX_const(PL_linestr);
11810 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11811 &offset, (char*)termstr, termlen);
11812 const char * const ns = SvPVX_const(PL_linestr) + offset;
11813 char * const svlast = SvEND(sv) - 1;
11815 for (; s < ns; s++) {
11816 if (*s == '\n' && !PL_rsfp)
11817 CopLINE_inc(PL_curcop);
11820 goto read_more_line;
11822 /* handle quoted delimiters */
11823 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11825 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11827 if ((svlast-1 - t) % 2) {
11828 if (!keep_quoted) {
11829 *(svlast-1) = term;
11831 SvCUR_set(sv, SvCUR(sv) - 1);
11836 if (PL_multi_open == PL_multi_close) {
11842 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11843 /* At here, all closes are "was quoted" one,
11844 so we don't check PL_multi_close. */
11846 if (!keep_quoted && *(t+1) == PL_multi_open)
11851 else if (*t == PL_multi_open)
11859 SvCUR_set(sv, w - SvPVX_const(sv));
11861 last_off = w - SvPVX(sv);
11862 if (--brackets <= 0)
11867 if (!keep_delims) {
11868 SvCUR_set(sv, SvCUR(sv) - 1);
11874 /* extend sv if need be */
11875 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11876 /* set 'to' to the next character in the sv's string */
11877 to = SvPVX(sv)+SvCUR(sv);
11879 /* if open delimiter is the close delimiter read unbridle */
11880 if (PL_multi_open == PL_multi_close) {
11881 for (; s < PL_bufend; s++,to++) {
11882 /* embedded newlines increment the current line number */
11883 if (*s == '\n' && !PL_rsfp)
11884 CopLINE_inc(PL_curcop);
11885 /* handle quoted delimiters */
11886 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11887 if (!keep_quoted && s[1] == term)
11889 /* any other quotes are simply copied straight through */
11893 /* terminate when run out of buffer (the for() condition), or
11894 have found the terminator */
11895 else if (*s == term) {
11898 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11901 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11907 /* if the terminator isn't the same as the start character (e.g.,
11908 matched brackets), we have to allow more in the quoting, and
11909 be prepared for nested brackets.
11912 /* read until we run out of string, or we find the terminator */
11913 for (; s < PL_bufend; s++,to++) {
11914 /* embedded newlines increment the line count */
11915 if (*s == '\n' && !PL_rsfp)
11916 CopLINE_inc(PL_curcop);
11917 /* backslashes can escape the open or closing characters */
11918 if (*s == '\\' && s+1 < PL_bufend) {
11919 if (!keep_quoted &&
11920 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11925 /* allow nested opens and closes */
11926 else if (*s == PL_multi_close && --brackets <= 0)
11928 else if (*s == PL_multi_open)
11930 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11935 /* terminate the copied string and update the sv's end-of-string */
11937 SvCUR_set(sv, to - SvPVX_const(sv));
11940 * this next chunk reads more into the buffer if we're not done yet
11944 break; /* handle case where we are done yet :-) */
11946 #ifndef PERL_STRICT_CR
11947 if (to - SvPVX_const(sv) >= 2) {
11948 if ((to[-2] == '\r' && to[-1] == '\n') ||
11949 (to[-2] == '\n' && to[-1] == '\r'))
11953 SvCUR_set(sv, to - SvPVX_const(sv));
11955 else if (to[-1] == '\r')
11958 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11963 /* if we're out of file, or a read fails, bail and reset the current
11964 line marker so we can report where the unterminated string began
11967 if (PL_madskills) {
11968 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11970 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11972 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11976 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11978 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11984 /* we read a line, so increment our line counter */
11985 CopLINE_inc(PL_curcop);
11987 /* update debugger info */
11988 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11989 update_debugger_info(PL_linestr, NULL, 0);
11991 /* having changed the buffer, we must update PL_bufend */
11992 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11993 PL_last_lop = PL_last_uni = NULL;
11996 /* at this point, we have successfully read the delimited string */
11998 if (!PL_encoding || UTF) {
12000 if (PL_madskills) {
12001 char * const tstart = SvPVX(PL_linestr) + stuffstart;
12002 const int len = s - tstart;
12004 sv_catpvn(PL_thisstuff, tstart, len);
12006 PL_thisstuff = newSVpvn(tstart, len);
12007 if (!PL_thisclose && !keep_delims)
12008 PL_thisclose = newSVpvn(s,termlen);
12013 sv_catpvn(sv, s, termlen);
12018 if (PL_madskills) {
12019 char * const tstart = SvPVX(PL_linestr) + stuffstart;
12020 const int len = s - tstart - termlen;
12022 sv_catpvn(PL_thisstuff, tstart, len);
12024 PL_thisstuff = newSVpvn(tstart, len);
12025 if (!PL_thisclose && !keep_delims)
12026 PL_thisclose = newSVpvn(s - termlen,termlen);
12030 if (has_utf8 || PL_encoding)
12033 PL_multi_end = CopLINE(PL_curcop);
12035 /* if we allocated too much space, give some back */
12036 if (SvCUR(sv) + 5 < SvLEN(sv)) {
12037 SvLEN_set(sv, SvCUR(sv) + 1);
12038 SvPV_renew(sv, SvLEN(sv));
12041 /* decide whether this is the first or second quoted string we've read
12054 takes: pointer to position in buffer
12055 returns: pointer to new position in buffer
12056 side-effects: builds ops for the constant in pl_yylval.op
12058 Read a number in any of the formats that Perl accepts:
12060 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
12061 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
12064 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
12066 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
12069 If it reads a number without a decimal point or an exponent, it will
12070 try converting the number to an integer and see if it can do so
12071 without loss of precision.
12075 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
12078 register const char *s = start; /* current position in buffer */
12079 register char *d; /* destination in temp buffer */
12080 register char *e; /* end of temp buffer */
12081 NV nv; /* number read, as a double */
12082 SV *sv = NULL; /* place to put the converted number */
12083 bool floatit; /* boolean: int or float? */
12084 const char *lastub = NULL; /* position of last underbar */
12085 static char const number_too_long[] = "Number too long";
12087 PERL_ARGS_ASSERT_SCAN_NUM;
12089 /* We use the first character to decide what type of number this is */
12093 Perl_croak(aTHX_ "panic: scan_num");
12095 /* if it starts with a 0, it could be an octal number, a decimal in
12096 0.13 disguise, or a hexadecimal number, or a binary number. */
12100 u holds the "number so far"
12101 shift the power of 2 of the base
12102 (hex == 4, octal == 3, binary == 1)
12103 overflowed was the number more than we can hold?
12105 Shift is used when we add a digit. It also serves as an "are
12106 we in octal/hex/binary?" indicator to disallow hex characters
12107 when in octal mode.
12112 bool overflowed = FALSE;
12113 bool just_zero = TRUE; /* just plain 0 or binary number? */
12114 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
12115 static const char* const bases[5] =
12116 { "", "binary", "", "octal", "hexadecimal" };
12117 static const char* const Bases[5] =
12118 { "", "Binary", "", "Octal", "Hexadecimal" };
12119 static const char* const maxima[5] =
12121 "0b11111111111111111111111111111111",
12125 const char *base, *Base, *max;
12127 /* check for hex */
12132 } else if (s[1] == 'b') {
12137 /* check for a decimal in disguise */
12138 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
12140 /* so it must be octal */
12147 if (ckWARN(WARN_SYNTAX))
12148 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12149 "Misplaced _ in number");
12153 base = bases[shift];
12154 Base = Bases[shift];
12155 max = maxima[shift];
12157 /* read the rest of the number */
12159 /* x is used in the overflow test,
12160 b is the digit we're adding on. */
12165 /* if we don't mention it, we're done */
12169 /* _ are ignored -- but warned about if consecutive */
12171 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12172 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12173 "Misplaced _ in number");
12177 /* 8 and 9 are not octal */
12178 case '8': case '9':
12180 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
12184 case '2': case '3': case '4':
12185 case '5': case '6': case '7':
12187 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
12190 case '0': case '1':
12191 b = *s++ & 15; /* ASCII digit -> value of digit */
12195 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
12196 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
12197 /* make sure they said 0x */
12200 b = (*s++ & 7) + 9;
12202 /* Prepare to put the digit we have onto the end
12203 of the number so far. We check for overflows.
12209 x = u << shift; /* make room for the digit */
12211 if ((x >> shift) != u
12212 && !(PL_hints & HINT_NEW_BINARY)) {
12215 if (ckWARN_d(WARN_OVERFLOW))
12216 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12217 "Integer overflow in %s number",
12220 u = x | b; /* add the digit to the end */
12223 n *= nvshift[shift];
12224 /* If an NV has not enough bits in its
12225 * mantissa to represent an UV this summing of
12226 * small low-order numbers is a waste of time
12227 * (because the NV cannot preserve the
12228 * low-order bits anyway): we could just
12229 * remember when did we overflow and in the
12230 * end just multiply n by the right
12238 /* if we get here, we had success: make a scalar value from
12243 /* final misplaced underbar check */
12244 if (s[-1] == '_') {
12245 if (ckWARN(WARN_SYNTAX))
12246 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12251 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12252 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12253 "%s number > %s non-portable",
12259 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12260 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12261 "%s number > %s non-portable",
12266 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12267 sv = new_constant(start, s - start, "integer",
12268 sv, NULL, NULL, 0);
12269 else if (PL_hints & HINT_NEW_BINARY)
12270 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
12275 handle decimal numbers.
12276 we're also sent here when we read a 0 as the first digit
12278 case '1': case '2': case '3': case '4': case '5':
12279 case '6': case '7': case '8': case '9': case '.':
12282 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12285 /* read next group of digits and _ and copy into d */
12286 while (isDIGIT(*s) || *s == '_') {
12287 /* skip underscores, checking for misplaced ones
12291 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12292 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12293 "Misplaced _ in number");
12297 /* check for end of fixed-length buffer */
12299 Perl_croak(aTHX_ number_too_long);
12300 /* if we're ok, copy the character */
12305 /* final misplaced underbar check */
12306 if (lastub && s == lastub + 1) {
12307 if (ckWARN(WARN_SYNTAX))
12308 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12311 /* read a decimal portion if there is one. avoid
12312 3..5 being interpreted as the number 3. followed
12315 if (*s == '.' && s[1] != '.') {
12320 if (ckWARN(WARN_SYNTAX))
12321 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12322 "Misplaced _ in number");
12326 /* copy, ignoring underbars, until we run out of digits.
12328 for (; isDIGIT(*s) || *s == '_'; s++) {
12329 /* fixed length buffer check */
12331 Perl_croak(aTHX_ number_too_long);
12333 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12334 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12335 "Misplaced _ in number");
12341 /* fractional part ending in underbar? */
12342 if (s[-1] == '_') {
12343 if (ckWARN(WARN_SYNTAX))
12344 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12345 "Misplaced _ in number");
12347 if (*s == '.' && isDIGIT(s[1])) {
12348 /* oops, it's really a v-string, but without the "v" */
12354 /* read exponent part, if present */
12355 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12359 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12360 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12362 /* stray preinitial _ */
12364 if (ckWARN(WARN_SYNTAX))
12365 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12366 "Misplaced _ in number");
12370 /* allow positive or negative exponent */
12371 if (*s == '+' || *s == '-')
12374 /* stray initial _ */
12376 if (ckWARN(WARN_SYNTAX))
12377 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12378 "Misplaced _ in number");
12382 /* read digits of exponent */
12383 while (isDIGIT(*s) || *s == '_') {
12386 Perl_croak(aTHX_ number_too_long);
12390 if (((lastub && s == lastub + 1) ||
12391 (!isDIGIT(s[1]) && s[1] != '_'))
12392 && ckWARN(WARN_SYNTAX))
12393 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12394 "Misplaced _ in number");
12401 /* make an sv from the string */
12405 We try to do an integer conversion first if no characters
12406 indicating "float" have been found.
12411 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12413 if (flags == IS_NUMBER_IN_UV) {
12415 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12418 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12419 if (uv <= (UV) IV_MIN)
12420 sv_setiv(sv, -(IV)uv);
12427 /* terminate the string */
12429 nv = Atof(PL_tokenbuf);
12434 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
12435 const char *const key = floatit ? "float" : "integer";
12436 const STRLEN keylen = floatit ? 5 : 7;
12437 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
12438 key, keylen, sv, NULL, NULL, 0);
12442 /* if it starts with a v, it could be a v-string */
12445 sv = newSV(5); /* preallocate storage space */
12446 s = scan_vstring(s, PL_bufend, sv);
12450 /* make the op for the constant and return */
12453 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12455 lvalp->opval = NULL;
12461 S_scan_formline(pTHX_ register char *s)
12464 register char *eol;
12466 SV * const stuff = newSVpvs("");
12467 bool needargs = FALSE;
12468 bool eofmt = FALSE;
12470 char *tokenstart = s;
12471 SV* savewhite = NULL;
12473 if (PL_madskills) {
12474 savewhite = PL_thiswhite;
12479 PERL_ARGS_ASSERT_SCAN_FORMLINE;
12481 while (!needargs) {
12484 #ifdef PERL_STRICT_CR
12485 while (SPACE_OR_TAB(*t))
12488 while (SPACE_OR_TAB(*t) || *t == '\r')
12491 if (*t == '\n' || t == PL_bufend) {
12496 if (PL_in_eval && !PL_rsfp) {
12497 eol = (char *) memchr(s,'\n',PL_bufend-s);
12502 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12504 for (t = s; t < eol; t++) {
12505 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12507 goto enough; /* ~~ must be first line in formline */
12509 if (*t == '@' || *t == '^')
12513 sv_catpvn(stuff, s, eol-s);
12514 #ifndef PERL_STRICT_CR
12515 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12516 char *end = SvPVX(stuff) + SvCUR(stuff);
12519 SvCUR_set(stuff, SvCUR(stuff) - 1);
12529 if (PL_madskills) {
12531 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12533 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12536 s = filter_gets(PL_linestr, PL_rsfp, 0);
12538 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12540 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12542 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12543 PL_last_lop = PL_last_uni = NULL;
12552 if (SvCUR(stuff)) {
12555 PL_lex_state = LEX_NORMAL;
12556 start_force(PL_curforce);
12557 NEXTVAL_NEXTTOKE.ival = 0;
12561 PL_lex_state = LEX_FORMLINE;
12563 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12565 else if (PL_encoding)
12566 sv_recode_to_utf8(stuff, PL_encoding);
12568 start_force(PL_curforce);
12569 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12571 start_force(PL_curforce);
12572 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12576 SvREFCNT_dec(stuff);
12578 PL_lex_formbrack = 0;
12582 if (PL_madskills) {
12584 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12586 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12587 PL_thiswhite = savewhite;
12594 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12597 const I32 oldsavestack_ix = PL_savestack_ix;
12598 CV* const outsidecv = PL_compcv;
12601 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12603 SAVEI32(PL_subline);
12604 save_item(PL_subname);
12605 SAVESPTR(PL_compcv);
12607 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
12608 CvFLAGS(PL_compcv) |= flags;
12610 PL_subline = CopLINE(PL_curcop);
12611 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12612 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
12613 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12615 return oldsavestack_ix;
12619 #pragma segment Perl_yylex
12622 S_yywarn(pTHX_ const char *const s)
12626 PERL_ARGS_ASSERT_YYWARN;
12628 PL_in_eval |= EVAL_WARNONLY;
12630 PL_in_eval &= ~EVAL_WARNONLY;
12635 Perl_yyerror(pTHX_ const char *const s)
12638 const char *where = NULL;
12639 const char *context = NULL;
12642 int yychar = PL_parser->yychar;
12644 PERL_ARGS_ASSERT_YYERROR;
12646 if (!yychar || (yychar == ';' && !PL_rsfp))
12648 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12649 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12650 PL_oldbufptr != PL_bufptr) {
12653 The code below is removed for NetWare because it abends/crashes on NetWare
12654 when the script has error such as not having the closing quotes like:
12655 if ($var eq "value)
12656 Checking of white spaces is anyway done in NetWare code.
12659 while (isSPACE(*PL_oldoldbufptr))
12662 context = PL_oldoldbufptr;
12663 contlen = PL_bufptr - PL_oldoldbufptr;
12665 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12666 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12669 The code below is removed for NetWare because it abends/crashes on NetWare
12670 when the script has error such as not having the closing quotes like:
12671 if ($var eq "value)
12672 Checking of white spaces is anyway done in NetWare code.
12675 while (isSPACE(*PL_oldbufptr))
12678 context = PL_oldbufptr;
12679 contlen = PL_bufptr - PL_oldbufptr;
12681 else if (yychar > 255)
12682 where = "next token ???";
12683 else if (yychar == -2) { /* YYEMPTY */
12684 if (PL_lex_state == LEX_NORMAL ||
12685 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12686 where = "at end of line";
12687 else if (PL_lex_inpat)
12688 where = "within pattern";
12690 where = "within string";
12693 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
12695 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12696 else if (isPRINT_LC(yychar)) {
12697 const char string = yychar;
12698 sv_catpvn(where_sv, &string, 1);
12701 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12702 where = SvPVX_const(where_sv);
12704 msg = sv_2mortal(newSVpv(s, 0));
12705 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12706 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12708 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12710 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12711 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12712 Perl_sv_catpvf(aTHX_ msg,
12713 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12714 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12717 if (PL_in_eval & EVAL_WARNONLY) {
12718 if (ckWARN_d(WARN_SYNTAX))
12719 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12723 if (PL_error_count >= 10) {
12724 if (PL_in_eval && SvCUR(ERRSV))
12725 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12726 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12728 Perl_croak(aTHX_ "%s has too many errors.\n",
12729 OutCopFILE(PL_curcop));
12732 PL_in_my_stash = NULL;
12736 #pragma segment Main
12740 S_swallow_bom(pTHX_ U8 *s)
12743 const STRLEN slen = SvCUR(PL_linestr);
12745 PERL_ARGS_ASSERT_SWALLOW_BOM;
12749 if (s[1] == 0xFE) {
12750 /* UTF-16 little-endian? (or UTF32-LE?) */
12751 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12752 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12753 #ifndef PERL_NO_UTF16_FILTER
12754 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12757 if (PL_bufend > (char*)s) {
12761 filter_add(utf16rev_textfilter, NULL);
12762 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12763 utf16_to_utf8_reversed(s, news,
12764 PL_bufend - (char*)s - 1,
12766 sv_setpvn(PL_linestr, (const char*)news, newlen);
12768 s = (U8*)SvPVX(PL_linestr);
12769 Copy(news, s, newlen, U8);
12773 SvUTF8_on(PL_linestr);
12774 s = (U8*)SvPVX(PL_linestr);
12776 /* FIXME - is this a general bug fix? */
12779 PL_bufend = SvPVX(PL_linestr) + newlen;
12782 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12787 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12788 #ifndef PERL_NO_UTF16_FILTER
12789 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12792 if (PL_bufend > (char *)s) {
12796 filter_add(utf16_textfilter, NULL);
12797 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12798 utf16_to_utf8(s, news,
12799 PL_bufend - (char*)s,
12801 sv_setpvn(PL_linestr, (const char*)news, newlen);
12803 SvUTF8_on(PL_linestr);
12804 s = (U8*)SvPVX(PL_linestr);
12805 PL_bufend = SvPVX(PL_linestr) + newlen;
12808 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12813 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12814 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12815 s += 3; /* UTF-8 */
12821 if (s[2] == 0xFE && s[3] == 0xFF) {
12822 /* UTF-32 big-endian */
12823 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12826 else if (s[2] == 0 && s[3] != 0) {
12829 * are a good indicator of UTF-16BE. */
12830 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12836 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12837 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12838 s += 4; /* UTF-8 */
12844 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12847 * are a good indicator of UTF-16LE. */
12848 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12856 #ifndef PERL_NO_UTF16_FILTER
12858 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12861 const STRLEN old = SvCUR(sv);
12862 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12863 DEBUG_P(PerlIO_printf(Perl_debug_log,
12864 "utf16_textfilter(%p): %d %d (%d)\n",
12865 FPTR2DPTR(void *, utf16_textfilter),
12866 idx, maxlen, (int) count));
12870 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12871 Copy(SvPVX_const(sv), tmps, old, char);
12872 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12873 SvCUR(sv) - old, &newlen);
12874 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12876 DEBUG_P({sv_dump(sv);});
12881 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12884 const STRLEN old = SvCUR(sv);
12885 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12886 DEBUG_P(PerlIO_printf(Perl_debug_log,
12887 "utf16rev_textfilter(%p): %d %d (%d)\n",
12888 FPTR2DPTR(void *, utf16rev_textfilter),
12889 idx, maxlen, (int) count));
12893 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12894 Copy(SvPVX_const(sv), tmps, old, char);
12895 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12896 SvCUR(sv) - old, &newlen);
12897 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12899 DEBUG_P({ sv_dump(sv); });
12905 Returns a pointer to the next character after the parsed
12906 vstring, as well as updating the passed in sv.
12908 Function must be called like
12911 s = scan_vstring(s,e,sv);
12913 where s and e are the start and end of the string.
12914 The sv should already be large enough to store the vstring
12915 passed in, for performance reasons.
12920 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12923 const char *pos = s;
12924 const char *start = s;
12926 PERL_ARGS_ASSERT_SCAN_VSTRING;
12928 if (*pos == 'v') pos++; /* get past 'v' */
12929 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12931 if ( *pos != '.') {
12932 /* this may not be a v-string if followed by => */
12933 const char *next = pos;
12934 while (next < e && isSPACE(*next))
12936 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12937 /* return string not v-string */
12938 sv_setpvn(sv,(char *)s,pos-s);
12939 return (char *)pos;
12943 if (!isALPHA(*pos)) {
12944 U8 tmpbuf[UTF8_MAXBYTES+1];
12947 s++; /* get past 'v' */
12952 /* this is atoi() that tolerates underscores */
12955 const char *end = pos;
12957 while (--end >= s) {
12959 const UV orev = rev;
12960 rev += (*end - '0') * mult;
12962 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12963 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12964 "Integer overflow in decimal number");
12968 if (rev > 0x7FFFFFFF)
12969 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12971 /* Append native character for the rev point */
12972 tmpend = uvchr_to_utf8(tmpbuf, rev);
12973 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12974 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12976 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12982 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12986 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12994 * c-indentation-style: bsd
12995 * c-basic-offset: 4
12996 * indent-tabs-mode: t
12999 * ex: set ts=8 sts=4 sw=4 noet: