3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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
16 * This file is the lexer for Perl. It's closely linked to the
19 * The main routine is yylex(), which returns the next token.
23 #define PERL_IN_TOKE_C
26 #define yylval (PL_parser->yylval)
28 /* YYINITDEPTH -- initial size of the parser's stacks. */
29 #define YYINITDEPTH 200
31 /* XXX temporary backwards compatibility */
32 #define PL_lex_brackets (PL_parser->lex_brackets)
33 #define PL_lex_brackstack (PL_parser->lex_brackstack)
34 #define PL_lex_casemods (PL_parser->lex_casemods)
35 #define PL_lex_casestack (PL_parser->lex_casestack)
36 #define PL_lex_defer (PL_parser->lex_defer)
37 #define PL_lex_dojoin (PL_parser->lex_dojoin)
38 #define PL_lex_expect (PL_parser->lex_expect)
39 #define PL_lex_formbrack (PL_parser->lex_formbrack)
40 #define PL_lex_inpat (PL_parser->lex_inpat)
41 #define PL_lex_inwhat (PL_parser->lex_inwhat)
42 #define PL_lex_op (PL_parser->lex_op)
43 #define PL_lex_repl (PL_parser->lex_repl)
44 #define PL_lex_starts (PL_parser->lex_starts)
45 #define PL_lex_stuff (PL_parser->lex_stuff)
46 #define PL_multi_start (PL_parser->multi_start)
47 #define PL_multi_open (PL_parser->multi_open)
48 #define PL_multi_close (PL_parser->multi_close)
49 #define PL_pending_ident (PL_parser->pending_ident)
50 #define PL_preambled (PL_parser->preambled)
51 #define PL_sublex_info (PL_parser->sublex_info)
52 #define PL_linestr (PL_parser->linestr)
53 #define PL_expect (PL_parser->expect)
54 #define PL_copline (PL_parser->copline)
55 #define PL_bufptr (PL_parser->bufptr)
56 #define PL_oldbufptr (PL_parser->oldbufptr)
57 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
58 #define PL_linestart (PL_parser->linestart)
59 #define PL_bufend (PL_parser->bufend)
60 #define PL_last_uni (PL_parser->last_uni)
61 #define PL_last_lop (PL_parser->last_lop)
62 #define PL_last_lop_op (PL_parser->last_lop_op)
63 #define PL_lex_state (PL_parser->lex_state)
64 #define PL_rsfp (PL_parser->rsfp)
65 #define PL_rsfp_filters (PL_parser->rsfp_filters)
66 #define PL_in_my (PL_parser->in_my)
67 #define PL_in_my_stash (PL_parser->in_my_stash)
68 #define PL_tokenbuf (PL_parser->tokenbuf)
71 # define PL_endwhite (PL_parser->endwhite)
72 # define PL_faketokens (PL_parser->faketokens)
73 # define PL_lasttoke (PL_parser->lasttoke)
74 # define PL_nextwhite (PL_parser->nextwhite)
75 # define PL_realtokenstart (PL_parser->realtokenstart)
76 # define PL_skipwhite (PL_parser->skipwhite)
77 # define PL_thisclose (PL_parser->thisclose)
78 # define PL_thismad (PL_parser->thismad)
79 # define PL_thisopen (PL_parser->thisopen)
80 # define PL_thisstuff (PL_parser->thisstuff)
81 # define PL_thistoken (PL_parser->thistoken)
82 # define PL_thiswhite (PL_parser->thiswhite)
83 # define PL_thiswhite (PL_parser->thiswhite)
84 # define PL_nexttoke (PL_parser->nexttoke)
85 # define PL_curforce (PL_parser->curforce)
87 # define PL_nexttoke (PL_parser->nexttoke)
88 # define PL_nexttype (PL_parser->nexttype)
89 # define PL_nextval (PL_parser->nextval)
93 S_pending_ident(pTHX);
95 static const char ident_too_long[] = "Identifier too long";
96 static const char commaless_variable_list[] = "comma-less variable list";
98 #ifndef PERL_NO_UTF16_FILTER
99 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
100 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
104 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
105 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
107 # define CURMAD(slot,sv)
108 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
111 #define XFAKEBRACK 128
112 #define XENUMMASK 127
114 #ifdef USE_UTF8_SCRIPTS
115 # define UTF (!IN_BYTES)
117 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
120 /* In variables named $^X, these are the legal values for X.
121 * 1999-02-27 mjd-perl-patch@plover.com */
122 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
124 /* On MacOS, respect nonbreaking spaces */
125 #ifdef MACOS_TRADITIONAL
126 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
128 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
131 /* LEX_* are values for PL_lex_state, the state of the lexer.
132 * They are arranged oddly so that the guard on the switch statement
133 * can get by with a single comparison (if the compiler is smart enough).
136 /* #define LEX_NOTPARSING 11 is done in perl.h. */
138 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
139 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
140 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
141 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
142 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
144 /* at end of code, eg "$x" followed by: */
145 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
146 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
148 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
149 string or after \E, $foo, etc */
150 #define LEX_INTERPCONST 2 /* NOT USED */
151 #define LEX_FORMLINE 1 /* expecting a format line */
152 #define LEX_KNOWNEXT 0 /* next token known; just return it */
156 static const char* const lex_state_names[] = {
175 #include "keywords.h"
177 /* CLINE is a macro that ensures PL_copline has a sane value */
182 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
185 # define SKIPSPACE0(s) skipspace0(s)
186 # define SKIPSPACE1(s) skipspace1(s)
187 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
188 # define PEEKSPACE(s) skipspace2(s,0)
190 # define SKIPSPACE0(s) skipspace(s)
191 # define SKIPSPACE1(s) skipspace(s)
192 # define SKIPSPACE2(s,tsv) skipspace(s)
193 # define PEEKSPACE(s) skipspace(s)
197 * Convenience functions to return different tokens and prime the
198 * lexer for the next token. They all take an argument.
200 * TOKEN : generic token (used for '(', DOLSHARP, etc)
201 * OPERATOR : generic operator
202 * AOPERATOR : assignment operator
203 * PREBLOCK : beginning the block after an if, while, foreach, ...
204 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
205 * PREREF : *EXPR where EXPR is not a simple identifier
206 * TERM : expression term
207 * LOOPX : loop exiting command (goto, last, dump, etc)
208 * FTST : file test operator
209 * FUN0 : zero-argument function
210 * FUN1 : not used, except for not, which isn't a UNIOP
211 * BOop : bitwise or or xor
213 * SHop : shift operator
214 * PWop : power operator
215 * PMop : pattern-matching operator
216 * Aop : addition-level operator
217 * Mop : multiplication-level operator
218 * Eop : equality-testing operator
219 * Rop : relational operator <= != gt
221 * Also see LOP and lop() below.
224 #ifdef DEBUGGING /* Serve -DT. */
225 # define REPORT(retval) tokereport((I32)retval)
227 # define REPORT(retval) (retval)
230 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
231 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
232 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
233 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
234 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
235 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
236 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
237 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
238 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
239 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
240 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
241 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
242 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
243 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
244 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
245 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
246 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
247 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
248 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
249 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
251 /* This bit of chicanery makes a unary function followed by
252 * a parenthesis into a function with one argument, highest precedence.
253 * The UNIDOR macro is for unary functions that can be followed by the //
254 * operator (such as C<shift // 0>).
256 #define UNI2(f,x) { \
260 PL_last_uni = PL_oldbufptr; \
261 PL_last_lop_op = f; \
263 return REPORT( (int)FUNC1 ); \
265 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
267 #define UNI(f) UNI2(f,XTERM)
268 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
270 #define UNIBRACK(f) { \
273 PL_last_uni = PL_oldbufptr; \
275 return REPORT( (int)FUNC1 ); \
277 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
280 /* grandfather return to old style */
281 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
285 /* how to interpret the yylval associated with the token */
289 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
295 static struct debug_tokens {
297 enum token_type type;
299 } const debug_tokens[] =
301 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
302 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
303 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
304 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
305 { ARROW, TOKENTYPE_NONE, "ARROW" },
306 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
307 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
308 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
309 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
310 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
311 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
312 { DO, TOKENTYPE_NONE, "DO" },
313 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
314 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
315 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
316 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
317 { ELSE, TOKENTYPE_NONE, "ELSE" },
318 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
319 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
320 { FOR, TOKENTYPE_IVAL, "FOR" },
321 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
322 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
323 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
324 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
325 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
326 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
327 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
328 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
329 { IF, TOKENTYPE_IVAL, "IF" },
330 { LABEL, TOKENTYPE_PVAL, "LABEL" },
331 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
332 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
333 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
334 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
335 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
336 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
337 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
338 { MY, TOKENTYPE_IVAL, "MY" },
339 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
340 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
341 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
342 { OROP, TOKENTYPE_IVAL, "OROP" },
343 { OROR, TOKENTYPE_NONE, "OROR" },
344 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
345 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
346 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
347 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
348 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
349 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
350 { PREINC, TOKENTYPE_NONE, "PREINC" },
351 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
352 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
353 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
354 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
355 { SUB, TOKENTYPE_NONE, "SUB" },
356 { THING, TOKENTYPE_OPVAL, "THING" },
357 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
358 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
359 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
360 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
361 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
362 { USE, TOKENTYPE_IVAL, "USE" },
363 { WHEN, TOKENTYPE_IVAL, "WHEN" },
364 { WHILE, TOKENTYPE_IVAL, "WHILE" },
365 { WORD, TOKENTYPE_OPVAL, "WORD" },
366 { 0, TOKENTYPE_NONE, NULL }
369 /* dump the returned token in rv, plus any optional arg in yylval */
372 S_tokereport(pTHX_ I32 rv)
376 const char *name = NULL;
377 enum token_type type = TOKENTYPE_NONE;
378 const struct debug_tokens *p;
379 SV* const report = newSVpvs("<== ");
381 for (p = debug_tokens; p->token; p++) {
382 if (p->token == (int)rv) {
389 Perl_sv_catpv(aTHX_ report, name);
390 else if ((char)rv > ' ' && (char)rv < '~')
391 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
393 sv_catpvs(report, "EOF");
395 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
398 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
401 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
403 case TOKENTYPE_OPNUM:
404 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
405 PL_op_name[yylval.ival]);
408 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
410 case TOKENTYPE_OPVAL:
412 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
413 PL_op_name[yylval.opval->op_type]);
414 if (yylval.opval->op_type == OP_CONST) {
415 Perl_sv_catpvf(aTHX_ report, " %s",
416 SvPEEK(cSVOPx_sv(yylval.opval)));
421 sv_catpvs(report, "(opval=null)");
424 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
430 /* print the buffer with suitable escapes */
433 S_printbuf(pTHX_ const char* fmt, const char* s)
435 SV* const tmp = newSVpvs("");
436 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
445 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
446 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
450 S_ao(pTHX_ int toketype)
453 if (*PL_bufptr == '=') {
455 if (toketype == ANDAND)
456 yylval.ival = OP_ANDASSIGN;
457 else if (toketype == OROR)
458 yylval.ival = OP_ORASSIGN;
459 else if (toketype == DORDOR)
460 yylval.ival = OP_DORASSIGN;
468 * When Perl expects an operator and finds something else, no_op
469 * prints the warning. It always prints "<something> found where
470 * operator expected. It prints "Missing semicolon on previous line?"
471 * if the surprise occurs at the start of the line. "do you need to
472 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
473 * where the compiler doesn't know if foo is a method call or a function.
474 * It prints "Missing operator before end of line" if there's nothing
475 * after the missing operator, or "... before <...>" if there is something
476 * after the missing operator.
480 S_no_op(pTHX_ const char *what, char *s)
483 char * const oldbp = PL_bufptr;
484 const bool is_first = (PL_oldbufptr == PL_linestart);
490 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
491 if (ckWARN_d(WARN_SYNTAX)) {
493 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
494 "\t(Missing semicolon on previous line?)\n");
495 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
497 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
499 if (t < PL_bufptr && isSPACE(*t))
500 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
501 "\t(Do you need to predeclare %.*s?)\n",
502 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
506 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
507 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
515 * Complain about missing quote/regexp/heredoc terminator.
516 * If it's called with NULL then it cauterizes the line buffer.
517 * If we're in a delimited string and the delimiter is a control
518 * character, it's reformatted into a two-char sequence like ^C.
523 S_missingterm(pTHX_ char *s)
529 char * const nl = strrchr(s,'\n');
535 iscntrl(PL_multi_close)
537 PL_multi_close < 32 || PL_multi_close == 127
541 tmpbuf[1] = (char)toCTRL(PL_multi_close);
546 *tmpbuf = (char)PL_multi_close;
550 q = strchr(s,'"') ? '\'' : '"';
551 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
554 #define FEATURE_IS_ENABLED(name) \
555 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
556 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
558 * S_feature_is_enabled
559 * Check whether the named feature is enabled.
562 S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
565 HV * const hinthv = GvHV(PL_hintgv);
566 char he_name[32] = "feature_";
567 (void) my_strlcpy(&he_name[8], name, 24);
569 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
577 Perl_deprecate(pTHX_ const char *s)
579 if (ckWARN(WARN_DEPRECATED))
580 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
584 Perl_deprecate_old(pTHX_ const char *s)
586 /* This function should NOT be called for any new deprecated warnings */
587 /* Use Perl_deprecate instead */
589 /* It is here to maintain backward compatibility with the pre-5.8 */
590 /* warnings category hierarchy. The "deprecated" category used to */
591 /* live under the "syntax" category. It is now a top-level category */
592 /* in its own right. */
594 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
595 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
596 "Use of %s is deprecated", s);
600 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
601 * utf16-to-utf8-reversed.
604 #ifdef PERL_CR_FILTER
608 register const char *s = SvPVX_const(sv);
609 register const char * const e = s + SvCUR(sv);
610 /* outer loop optimized to do nothing if there are no CR-LFs */
612 if (*s++ == '\r' && *s == '\n') {
613 /* hit a CR-LF, need to copy the rest */
614 register char *d = s - 1;
617 if (*s == '\r' && s[1] == '\n')
628 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
630 const I32 count = FILTER_READ(idx+1, sv, maxlen);
631 if (count > 0 && !maxlen)
642 * Create a parser object and initialise its parser and lexer fields
644 * rsfp is the opened file handle to read from (if any),
646 * line holds any initial content already read from the file (or in
647 * the case of no file, such as an eval, the whole contents);
649 * new_filter indicates that this is a new file and it shouldn't inherit
650 * the filters from the current parser (ie require).
654 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
657 const char *s = NULL;
659 yy_parser *parser, *oparser;
661 /* create and initialise a parser */
663 Newxz(parser, 1, yy_parser);
664 parser->old_parser = oparser = PL_parser;
667 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
668 parser->ps = parser->stack;
669 parser->stack_size = YYINITDEPTH;
671 parser->stack->state = 0;
672 parser->yyerrstatus = 0;
673 parser->yychar = YYEMPTY; /* Cause a token to be read. */
675 /* on scope exit, free this parser and restore any outer one */
677 parser->saved_curcop = PL_curcop;
679 /* initialise lexer state */
682 parser->curforce = -1;
684 parser->nexttoke = 0;
686 parser->copline = NOLINE;
687 parser->lex_state = LEX_NORMAL;
688 parser->expect = XSTATE;
690 parser->rsfp_filters = (new_filter || !oparser) ? newAV()
691 : (AV*)SvREFCNT_inc(oparser->rsfp_filters);
693 Newx(parser->lex_brackstack, 120, char);
694 Newx(parser->lex_casestack, 12, char);
695 *parser->lex_casestack = '\0';
698 s = SvPV_const(line, len);
704 parser->linestr = newSVpvs("\n;");
705 } else if (SvREADONLY(line) || s[len-1] != ';') {
706 parser->linestr = newSVsv(line);
708 sv_catpvs(parser->linestr, "\n;");
711 SvREFCNT_inc_simple_void_NN(line);
712 parser->linestr = line;
714 parser->oldoldbufptr =
717 parser->linestart = SvPVX(parser->linestr);
718 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
719 parser->last_lop = parser->last_uni = NULL;
723 /* delete a parser object */
726 Perl_parser_free(pTHX_ const yy_parser *parser)
728 PL_curcop = parser->saved_curcop;
729 SvREFCNT_dec(parser->linestr);
731 if (parser->rsfp == PerlIO_stdin())
732 PerlIO_clearerr(parser->rsfp);
733 else if (parser->rsfp && parser->old_parser
734 && parser->rsfp != parser->old_parser->rsfp)
735 PerlIO_close(parser->rsfp);
736 SvREFCNT_dec(parser->rsfp_filters);
738 Safefree(parser->stack);
739 Safefree(parser->lex_brackstack);
740 Safefree(parser->lex_casestack);
741 PL_parser = parser->old_parser;
748 * Finalizer for lexing operations. Must be called when the parser is
749 * done with the lexer.
756 PL_doextract = FALSE;
761 * This subroutine has nothing to do with tilting, whether at windmills
762 * or pinball tables. Its name is short for "increment line". It
763 * increments the current line number in CopLINE(PL_curcop) and checks
764 * to see whether the line starts with a comment of the form
765 * # line 500 "foo.pm"
766 * If so, it sets the current line number and file to the values in the comment.
770 S_incline(pTHX_ const char *s)
777 CopLINE_inc(PL_curcop);
780 while (SPACE_OR_TAB(*s))
782 if (strnEQ(s, "line", 4))
786 if (SPACE_OR_TAB(*s))
790 while (SPACE_OR_TAB(*s))
798 while (SPACE_OR_TAB(*s))
800 if (*s == '"' && (t = strchr(s+1, '"'))) {
810 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
812 if (*e != '\n' && *e != '\0')
813 return; /* false alarm */
816 const STRLEN len = t - s;
818 const char * const cf = CopFILE(PL_curcop);
819 STRLEN tmplen = cf ? strlen(cf) : 0;
820 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
821 /* must copy *{"::_<(eval N)[oldfilename:L]"}
822 * to *{"::_<newfilename"} */
823 /* However, the long form of evals is only turned on by the
824 debugger - usually they're "(eval %lu)" */
828 STRLEN tmplen2 = len;
829 if (tmplen + 2 <= sizeof smallbuf)
832 Newx(tmpbuf, tmplen + 2, char);
835 memcpy(tmpbuf + 2, cf, tmplen);
837 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
842 if (tmplen2 + 2 <= sizeof smallbuf)
845 Newx(tmpbuf2, tmplen2 + 2, char);
847 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
848 /* Either they malloc'd it, or we malloc'd it,
849 so no prefix is present in ours. */
854 memcpy(tmpbuf2 + 2, s, tmplen2);
857 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
859 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
860 /* adjust ${"::_<newfilename"} to store the new file name */
861 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
862 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
863 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
866 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
868 if (tmpbuf != smallbuf) Safefree(tmpbuf);
871 CopFILE_free(PL_curcop);
872 CopFILE_setn(PL_curcop, s, len);
874 CopLINE_set(PL_curcop, atoi(n)-1);
878 /* skip space before PL_thistoken */
881 S_skipspace0(pTHX_ register char *s)
888 PL_thiswhite = newSVpvs("");
889 sv_catsv(PL_thiswhite, PL_skipwhite);
890 sv_free(PL_skipwhite);
893 PL_realtokenstart = s - SvPVX(PL_linestr);
897 /* skip space after PL_thistoken */
900 S_skipspace1(pTHX_ register char *s)
902 const char *start = s;
903 I32 startoff = start - SvPVX(PL_linestr);
908 start = SvPVX(PL_linestr) + startoff;
909 if (!PL_thistoken && PL_realtokenstart >= 0) {
910 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
911 PL_thistoken = newSVpvn(tstart, start - tstart);
913 PL_realtokenstart = -1;
916 PL_nextwhite = newSVpvs("");
917 sv_catsv(PL_nextwhite, PL_skipwhite);
918 sv_free(PL_skipwhite);
925 S_skipspace2(pTHX_ register char *s, SV **svp)
928 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
929 const I32 startoff = s - SvPVX(PL_linestr);
932 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
933 if (!PL_madskills || !svp)
935 start = SvPVX(PL_linestr) + startoff;
936 if (!PL_thistoken && PL_realtokenstart >= 0) {
937 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
938 PL_thistoken = newSVpvn(tstart, start - tstart);
939 PL_realtokenstart = -1;
944 sv_setsv(*svp, PL_skipwhite);
945 sv_free(PL_skipwhite);
954 S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len)
956 AV *av = CopFILEAVx(PL_curcop);
958 SV * const sv = newSV_type(SVt_PVMG);
960 sv_setsv(sv, orig_sv);
962 sv_setpvn(sv, buf, len);
965 av_store(av, (I32)CopLINE(PL_curcop), sv);
971 * Called to gobble the appropriate amount and type of whitespace.
972 * Skips comments as well.
976 S_skipspace(pTHX_ register char *s)
981 int startoff = s - SvPVX(PL_linestr);
984 sv_free(PL_skipwhite);
989 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
990 while (s < PL_bufend && SPACE_OR_TAB(*s))
1000 SSize_t oldprevlen, oldoldprevlen;
1001 SSize_t oldloplen = 0, oldunilen = 0;
1002 while (s < PL_bufend && isSPACE(*s)) {
1003 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1008 if (s < PL_bufend && *s == '#') {
1009 while (s < PL_bufend && *s != '\n')
1011 if (s < PL_bufend) {
1013 if (PL_in_eval && !PL_rsfp) {
1020 /* only continue to recharge the buffer if we're at the end
1021 * of the buffer, we're not reading from a source filter, and
1022 * we're in normal lexing mode
1024 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1025 PL_lex_state == LEX_FORMLINE)
1032 /* try to recharge the buffer */
1034 curoff = s - SvPVX(PL_linestr);
1037 if ((s = filter_gets(PL_linestr, PL_rsfp,
1038 (prevlen = SvCUR(PL_linestr)))) == NULL)
1041 if (PL_madskills && curoff != startoff) {
1043 PL_skipwhite = newSVpvs("");
1044 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1048 /* mustn't throw out old stuff yet if madpropping */
1049 SvCUR(PL_linestr) = curoff;
1050 s = SvPVX(PL_linestr) + curoff;
1052 if (curoff && s[-1] == '\n')
1056 /* end of file. Add on the -p or -n magic */
1057 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1060 sv_catpvs(PL_linestr,
1061 ";}continue{print or die qq(-p destination: $!\\n);}");
1063 sv_setpvs(PL_linestr,
1064 ";}continue{print or die qq(-p destination: $!\\n);}");
1066 PL_minus_n = PL_minus_p = 0;
1068 else if (PL_minus_n) {
1070 sv_catpvn(PL_linestr, ";}", 2);
1072 sv_setpvn(PL_linestr, ";}", 2);
1078 sv_catpvn(PL_linestr,";", 1);
1080 sv_setpvn(PL_linestr,";", 1);
1083 /* reset variables for next time we lex */
1084 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1090 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1091 PL_last_lop = PL_last_uni = NULL;
1093 /* Close the filehandle. Could be from -P preprocessor,
1094 * STDIN, or a regular file. If we were reading code from
1095 * STDIN (because the commandline held no -e or filename)
1096 * then we don't close it, we reset it so the code can
1097 * read from STDIN too.
1100 if (PL_preprocess && !PL_in_eval)
1101 (void)PerlProc_pclose(PL_rsfp);
1102 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1103 PerlIO_clearerr(PL_rsfp);
1105 (void)PerlIO_close(PL_rsfp);
1110 /* not at end of file, so we only read another line */
1111 /* make corresponding updates to old pointers, for yyerror() */
1112 oldprevlen = PL_oldbufptr - PL_bufend;
1113 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1115 oldunilen = PL_last_uni - PL_bufend;
1117 oldloplen = PL_last_lop - PL_bufend;
1118 PL_linestart = PL_bufptr = s + prevlen;
1119 PL_bufend = s + SvCUR(PL_linestr);
1121 PL_oldbufptr = s + oldprevlen;
1122 PL_oldoldbufptr = s + oldoldprevlen;
1124 PL_last_uni = s + oldunilen;
1126 PL_last_lop = s + oldloplen;
1129 /* debugger active and we're not compiling the debugger code,
1130 * so store the line into the debugger's array of lines
1132 if (PERLDB_LINE && PL_curstash != PL_debstash)
1133 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1140 PL_skipwhite = newSVpvs("");
1141 curoff = s - SvPVX(PL_linestr);
1142 if (curoff - startoff)
1143 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1152 * Check the unary operators to ensure there's no ambiguity in how they're
1153 * used. An ambiguous piece of code would be:
1155 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1156 * the +5 is its argument.
1166 if (PL_oldoldbufptr != PL_last_uni)
1168 while (isSPACE(*PL_last_uni))
1171 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1173 if ((t = strchr(s, '(')) && t < PL_bufptr)
1176 if (ckWARN_d(WARN_AMBIGUOUS)){
1177 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1178 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1179 (int)(s - PL_last_uni), PL_last_uni);
1184 * LOP : macro to build a list operator. Its behaviour has been replaced
1185 * with a subroutine, S_lop() for which LOP is just another name.
1188 #define LOP(f,x) return lop(f,x,s)
1192 * Build a list operator (or something that might be one). The rules:
1193 * - if we have a next token, then it's a list operator [why?]
1194 * - if the next thing is an opening paren, then it's a function
1195 * - else it's a list operator
1199 S_lop(pTHX_ I32 f, int x, char *s)
1206 PL_last_lop = PL_oldbufptr;
1207 PL_last_lop_op = (OPCODE)f;
1210 return REPORT(LSTOP);
1213 return REPORT(LSTOP);
1216 return REPORT(FUNC);
1219 return REPORT(FUNC);
1221 return REPORT(LSTOP);
1227 * Sets up for an eventual force_next(). start_force(0) basically does
1228 * an unshift, while start_force(-1) does a push. yylex removes items
1233 S_start_force(pTHX_ int where)
1237 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1238 where = PL_lasttoke;
1239 assert(PL_curforce < 0 || PL_curforce == where);
1240 if (PL_curforce != where) {
1241 for (i = PL_lasttoke; i > where; --i) {
1242 PL_nexttoke[i] = PL_nexttoke[i-1];
1246 if (PL_curforce < 0) /* in case of duplicate start_force() */
1247 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1248 PL_curforce = where;
1251 curmad('^', newSVpvs(""));
1252 CURMAD('_', PL_nextwhite);
1257 S_curmad(pTHX_ char slot, SV *sv)
1263 if (PL_curforce < 0)
1264 where = &PL_thismad;
1266 where = &PL_nexttoke[PL_curforce].next_mad;
1269 sv_setpvn(sv, "", 0);
1272 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1274 else if (PL_encoding) {
1275 sv_recode_to_utf8(sv, PL_encoding);
1280 /* keep a slot open for the head of the list? */
1281 if (slot != '_' && *where && (*where)->mad_key == '^') {
1282 (*where)->mad_key = slot;
1283 sv_free((SV*)((*where)->mad_val));
1284 (*where)->mad_val = (void*)sv;
1287 addmad(newMADsv(slot, sv), where, 0);
1290 # define start_force(where) NOOP
1291 # define curmad(slot, sv) NOOP
1296 * When the lexer realizes it knows the next token (for instance,
1297 * it is reordering tokens for the parser) then it can call S_force_next
1298 * to know what token to return the next time the lexer is called. Caller
1299 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1300 * and possibly PL_expect to ensure the lexer handles the token correctly.
1304 S_force_next(pTHX_ I32 type)
1308 if (PL_curforce < 0)
1309 start_force(PL_lasttoke);
1310 PL_nexttoke[PL_curforce].next_type = type;
1311 if (PL_lex_state != LEX_KNOWNEXT)
1312 PL_lex_defer = PL_lex_state;
1313 PL_lex_state = LEX_KNOWNEXT;
1314 PL_lex_expect = PL_expect;
1317 PL_nexttype[PL_nexttoke] = type;
1319 if (PL_lex_state != LEX_KNOWNEXT) {
1320 PL_lex_defer = PL_lex_state;
1321 PL_lex_expect = PL_expect;
1322 PL_lex_state = LEX_KNOWNEXT;
1328 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
1331 SV * const sv = newSVpvn(start,len);
1332 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
1339 * When the lexer knows the next thing is a word (for instance, it has
1340 * just seen -> and it knows that the next char is a word char, then
1341 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1345 * char *start : buffer position (must be within PL_linestr)
1346 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1347 * int check_keyword : if true, Perl checks to make sure the word isn't
1348 * a keyword (do this if the word is a label, e.g. goto FOO)
1349 * int allow_pack : if true, : characters will also be allowed (require,
1350 * use, etc. do this)
1351 * int allow_initial_tick : used by the "sub" lexer only.
1355 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1361 start = SKIPSPACE1(start);
1363 if (isIDFIRST_lazy_if(s,UTF) ||
1364 (allow_pack && *s == ':') ||
1365 (allow_initial_tick && *s == '\'') )
1367 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1368 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1370 start_force(PL_curforce);
1372 curmad('X', newSVpvn(start,s-start));
1373 if (token == METHOD) {
1378 PL_expect = XOPERATOR;
1382 curmad('g', newSVpvs( "forced" ));
1383 NEXTVAL_NEXTTOKE.opval
1384 = (OP*)newSVOP(OP_CONST,0,
1385 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1386 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1394 * Called when the lexer wants $foo *foo &foo etc, but the program
1395 * text only contains the "foo" portion. The first argument is a pointer
1396 * to the "foo", and the second argument is the type symbol to prefix.
1397 * Forces the next token to be a "WORD".
1398 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1402 S_force_ident(pTHX_ register const char *s, int kind)
1406 const STRLEN len = strlen(s);
1407 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1408 start_force(PL_curforce);
1409 NEXTVAL_NEXTTOKE.opval = o;
1412 o->op_private = OPpCONST_ENTERED;
1413 /* XXX see note in pp_entereval() for why we forgo typo
1414 warnings if the symbol must be introduced in an eval.
1416 gv_fetchpvn_flags(s, len,
1417 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1419 kind == '$' ? SVt_PV :
1420 kind == '@' ? SVt_PVAV :
1421 kind == '%' ? SVt_PVHV :
1429 Perl_str_to_version(pTHX_ SV *sv)
1434 const char *start = SvPV_const(sv,len);
1435 const char * const end = start + len;
1436 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1437 while (start < end) {
1441 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1446 retval += ((NV)n)/nshift;
1455 * Forces the next token to be a version number.
1456 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1457 * and if "guessing" is TRUE, then no new token is created (and the caller
1458 * must use an alternative parsing method).
1462 S_force_version(pTHX_ char *s, int guessing)
1468 I32 startoff = s - SvPVX(PL_linestr);
1477 while (isDIGIT(*d) || *d == '_' || *d == '.')
1481 start_force(PL_curforce);
1482 curmad('X', newSVpvn(s,d-s));
1485 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1487 s = scan_num(s, &yylval);
1488 version = yylval.opval;
1489 ver = cSVOPx(version)->op_sv;
1490 if (SvPOK(ver) && !SvNIOK(ver)) {
1491 SvUPGRADE(ver, SVt_PVNV);
1492 SvNV_set(ver, str_to_version(ver));
1493 SvNOK_on(ver); /* hint that it is a version */
1496 else if (guessing) {
1499 sv_free(PL_nextwhite); /* let next token collect whitespace */
1501 s = SvPVX(PL_linestr) + startoff;
1509 if (PL_madskills && !version) {
1510 sv_free(PL_nextwhite); /* let next token collect whitespace */
1512 s = SvPVX(PL_linestr) + startoff;
1515 /* NOTE: The parser sees the package name and the VERSION swapped */
1516 start_force(PL_curforce);
1517 NEXTVAL_NEXTTOKE.opval = version;
1525 * Tokenize a quoted string passed in as an SV. It finds the next
1526 * chunk, up to end of string or a backslash. It may make a new
1527 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1532 S_tokeq(pTHX_ SV *sv)
1536 register char *send;
1544 s = SvPV_force(sv, len);
1545 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1548 while (s < send && *s != '\\')
1553 if ( PL_hints & HINT_NEW_STRING ) {
1554 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1560 if (s + 1 < send && (s[1] == '\\'))
1561 s++; /* all that, just for this */
1566 SvCUR_set(sv, d - SvPVX_const(sv));
1568 if ( PL_hints & HINT_NEW_STRING )
1569 return new_constant(NULL, 0, "q", sv, pv, "q");
1574 * Now come three functions related to double-quote context,
1575 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1576 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1577 * interact with PL_lex_state, and create fake ( ... ) argument lists
1578 * to handle functions and concatenation.
1579 * They assume that whoever calls them will be setting up a fake
1580 * join call, because each subthing puts a ',' after it. This lets
1583 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1585 * (I'm not sure whether the spurious commas at the end of lcfirst's
1586 * arguments and join's arguments are created or not).
1591 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1593 * Pattern matching will set PL_lex_op to the pattern-matching op to
1594 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1596 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1598 * Everything else becomes a FUNC.
1600 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1601 * had an OP_CONST or OP_READLINE). This just sets us up for a
1602 * call to S_sublex_push().
1606 S_sublex_start(pTHX)
1609 register const I32 op_type = yylval.ival;
1611 if (op_type == OP_NULL) {
1612 yylval.opval = PL_lex_op;
1616 if (op_type == OP_CONST || op_type == OP_READLINE) {
1617 SV *sv = tokeq(PL_lex_stuff);
1619 if (SvTYPE(sv) == SVt_PVIV) {
1620 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1622 const char * const p = SvPV_const(sv, len);
1623 SV * const nsv = newSVpvn(p, len);
1629 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1630 PL_lex_stuff = NULL;
1631 /* Allow <FH> // "foo" */
1632 if (op_type == OP_READLINE)
1633 PL_expect = XTERMORDORDOR;
1636 else if (op_type == OP_BACKTICK && PL_lex_op) {
1637 /* readpipe() vas overriden */
1638 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1639 yylval.opval = PL_lex_op;
1641 PL_lex_stuff = NULL;
1645 PL_sublex_info.super_state = PL_lex_state;
1646 PL_sublex_info.sub_inwhat = (U16)op_type;
1647 PL_sublex_info.sub_op = PL_lex_op;
1648 PL_lex_state = LEX_INTERPPUSH;
1652 yylval.opval = PL_lex_op;
1662 * Create a new scope to save the lexing state. The scope will be
1663 * ended in S_sublex_done. Returns a '(', starting the function arguments
1664 * to the uc, lc, etc. found before.
1665 * Sets PL_lex_state to LEX_INTERPCONCAT.
1674 PL_lex_state = PL_sublex_info.super_state;
1675 SAVEBOOL(PL_lex_dojoin);
1676 SAVEI32(PL_lex_brackets);
1677 SAVEI32(PL_lex_casemods);
1678 SAVEI32(PL_lex_starts);
1679 SAVEI8(PL_lex_state);
1680 SAVEVPTR(PL_lex_inpat);
1681 SAVEI16(PL_lex_inwhat);
1682 SAVECOPLINE(PL_curcop);
1683 SAVEPPTR(PL_bufptr);
1684 SAVEPPTR(PL_bufend);
1685 SAVEPPTR(PL_oldbufptr);
1686 SAVEPPTR(PL_oldoldbufptr);
1687 SAVEPPTR(PL_last_lop);
1688 SAVEPPTR(PL_last_uni);
1689 SAVEPPTR(PL_linestart);
1690 SAVESPTR(PL_linestr);
1691 SAVEGENERICPV(PL_lex_brackstack);
1692 SAVEGENERICPV(PL_lex_casestack);
1694 PL_linestr = PL_lex_stuff;
1695 PL_lex_stuff = NULL;
1697 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1698 = SvPVX(PL_linestr);
1699 PL_bufend += SvCUR(PL_linestr);
1700 PL_last_lop = PL_last_uni = NULL;
1701 SAVEFREESV(PL_linestr);
1703 PL_lex_dojoin = FALSE;
1704 PL_lex_brackets = 0;
1705 Newx(PL_lex_brackstack, 120, char);
1706 Newx(PL_lex_casestack, 12, char);
1707 PL_lex_casemods = 0;
1708 *PL_lex_casestack = '\0';
1710 PL_lex_state = LEX_INTERPCONCAT;
1711 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1713 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1714 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1715 PL_lex_inpat = PL_sublex_info.sub_op;
1717 PL_lex_inpat = NULL;
1724 * Restores lexer state after a S_sublex_push.
1731 if (!PL_lex_starts++) {
1732 SV * const sv = newSVpvs("");
1733 if (SvUTF8(PL_linestr))
1735 PL_expect = XOPERATOR;
1736 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1740 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1741 PL_lex_state = LEX_INTERPCASEMOD;
1745 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1746 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1747 PL_linestr = PL_lex_repl;
1749 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1750 PL_bufend += SvCUR(PL_linestr);
1751 PL_last_lop = PL_last_uni = NULL;
1752 SAVEFREESV(PL_linestr);
1753 PL_lex_dojoin = FALSE;
1754 PL_lex_brackets = 0;
1755 PL_lex_casemods = 0;
1756 *PL_lex_casestack = '\0';
1758 if (SvEVALED(PL_lex_repl)) {
1759 PL_lex_state = LEX_INTERPNORMAL;
1761 /* we don't clear PL_lex_repl here, so that we can check later
1762 whether this is an evalled subst; that means we rely on the
1763 logic to ensure sublex_done() is called again only via the
1764 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1767 PL_lex_state = LEX_INTERPCONCAT;
1777 PL_endwhite = newSVpvs("");
1778 sv_catsv(PL_endwhite, PL_thiswhite);
1782 sv_setpvn(PL_thistoken,"",0);
1784 PL_realtokenstart = -1;
1788 PL_bufend = SvPVX(PL_linestr);
1789 PL_bufend += SvCUR(PL_linestr);
1790 PL_expect = XOPERATOR;
1791 PL_sublex_info.sub_inwhat = 0;
1799 Extracts a pattern, double-quoted string, or transliteration. This
1802 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1803 processing a pattern (PL_lex_inpat is true), a transliteration
1804 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1806 Returns a pointer to the character scanned up to. If this is
1807 advanced from the start pointer supplied (i.e. if anything was
1808 successfully parsed), will leave an OP for the substring scanned
1809 in yylval. Caller must intuit reason for not parsing further
1810 by looking at the next characters herself.
1814 double-quoted style: \r and \n
1815 regexp special ones: \D \s
1818 case and quoting: \U \Q \E
1819 stops on @ and $, but not for $ as tail anchor
1821 In transliterations:
1822 characters are VERY literal, except for - not at the start or end
1823 of the string, which indicates a range. If the range is in bytes,
1824 scan_const expands the range to the full set of intermediate
1825 characters. If the range is in utf8, the hyphen is replaced with
1826 a certain range mark which will be handled by pmtrans() in op.c.
1828 In double-quoted strings:
1830 double-quoted style: \r and \n
1832 deprecated backrefs: \1 (in substitution replacements)
1833 case and quoting: \U \Q \E
1836 scan_const does *not* construct ops to handle interpolated strings.
1837 It stops processing as soon as it finds an embedded $ or @ variable
1838 and leaves it to the caller to work out what's going on.
1840 embedded arrays (whether in pattern or not) could be:
1841 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1843 $ in double-quoted strings must be the symbol of an embedded scalar.
1845 $ in pattern could be $foo or could be tail anchor. Assumption:
1846 it's a tail anchor if $ is the last thing in the string, or if it's
1847 followed by one of "()| \r\n\t"
1849 \1 (backreferences) are turned into $1
1851 The structure of the code is
1852 while (there's a character to process) {
1853 handle transliteration ranges
1854 skip regexp comments /(?#comment)/ and codes /(?{code})/
1855 skip #-initiated comments in //x patterns
1856 check for embedded arrays
1857 check for embedded scalars
1859 leave intact backslashes from leaveit (below)
1860 deprecate \1 in substitution replacements
1861 handle string-changing backslashes \l \U \Q \E, etc.
1862 switch (what was escaped) {
1863 handle \- in a transliteration (becomes a literal -)
1864 handle \132 (octal characters)
1865 handle \x15 and \x{1234} (hex characters)
1866 handle \N{name} (named characters)
1867 handle \cV (control characters)
1868 handle printf-style backslashes (\f, \r, \n, etc)
1870 } (end if backslash)
1871 } (end while character to read)
1876 S_scan_const(pTHX_ char *start)
1879 register char *send = PL_bufend; /* end of the constant */
1880 SV *sv = newSV(send - start); /* sv for the constant */
1881 register char *s = start; /* start of the constant */
1882 register char *d = SvPVX(sv); /* destination for copies */
1883 bool dorange = FALSE; /* are we in a translit range? */
1884 bool didrange = FALSE; /* did we just finish a range? */
1885 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1886 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1889 UV literal_endpoint = 0;
1890 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1893 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1894 /* If we are doing a trans and we know we want UTF8 set expectation */
1895 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1896 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1900 while (s < send || dorange) {
1901 /* get transliterations out of the way (they're most literal) */
1902 if (PL_lex_inwhat == OP_TRANS) {
1903 /* expand a range A-Z to the full set of characters. AIE! */
1905 I32 i; /* current expanded character */
1906 I32 min; /* first character in range */
1907 I32 max; /* last character in range */
1918 char * const c = (char*)utf8_hop((U8*)d, -1);
1922 *c = (char)UTF_TO_NATIVE(0xff);
1923 /* mark the range as done, and continue */
1929 i = d - SvPVX_const(sv); /* remember current offset */
1932 SvLEN(sv) + (has_utf8 ?
1933 (512 - UTF_CONTINUATION_MARK +
1936 /* How many two-byte within 0..255: 128 in UTF-8,
1937 * 96 in UTF-8-mod. */
1939 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1941 d = SvPVX(sv) + i; /* refresh d after realloc */
1945 for (j = 0; j <= 1; j++) {
1946 char * const c = (char*)utf8_hop((U8*)d, -1);
1947 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
1953 max = (U8)0xff; /* only to \xff */
1954 uvmax = uv; /* \x{100} to uvmax */
1956 d = c; /* eat endpoint chars */
1961 d -= 2; /* eat the first char and the - */
1962 min = (U8)*d; /* first char in range */
1963 max = (U8)d[1]; /* last char in range */
1970 "Invalid range \"%c-%c\" in transliteration operator",
1971 (char)min, (char)max);
1975 if (literal_endpoint == 2 &&
1976 ((isLOWER(min) && isLOWER(max)) ||
1977 (isUPPER(min) && isUPPER(max)))) {
1979 for (i = min; i <= max; i++)
1981 *d++ = NATIVE_TO_NEED(has_utf8,i);
1983 for (i = min; i <= max; i++)
1985 *d++ = NATIVE_TO_NEED(has_utf8,i);
1990 for (i = min; i <= max; i++)
1993 const U8 ch = (U8)NATIVE_TO_UTF(i);
1994 if (UNI_IS_INVARIANT(ch))
1997 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
1998 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2007 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2009 *d++ = (char)UTF_TO_NATIVE(0xff);
2011 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2015 /* mark the range as done, and continue */
2019 literal_endpoint = 0;
2024 /* range begins (ignore - as first or last char) */
2025 else if (*s == '-' && s+1 < send && s != start) {
2027 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2034 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2044 literal_endpoint = 0;
2045 native_range = TRUE;
2050 /* if we get here, we're not doing a transliteration */
2052 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2053 except for the last char, which will be done separately. */
2054 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2056 while (s+1 < send && *s != ')')
2057 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2059 else if (s[2] == '{' /* This should match regcomp.c */
2060 || (s[2] == '?' && s[3] == '{'))
2063 char *regparse = s + (s[2] == '{' ? 3 : 4);
2066 while (count && (c = *regparse)) {
2067 if (c == '\\' && regparse[1])
2075 if (*regparse != ')')
2076 regparse--; /* Leave one char for continuation. */
2077 while (s < regparse)
2078 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2082 /* likewise skip #-initiated comments in //x patterns */
2083 else if (*s == '#' && PL_lex_inpat &&
2084 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2085 while (s+1 < send && *s != '\n')
2086 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2089 /* check for embedded arrays
2090 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2092 else if (*s == '@' && s[1]) {
2093 if (isALNUM_lazy_if(s+1,UTF))
2095 if (strchr(":'{$", s[1]))
2097 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2098 break; /* in regexp, neither @+ nor @- are interpolated */
2101 /* check for embedded scalars. only stop if we're sure it's a
2104 else if (*s == '$') {
2105 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2107 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
2108 break; /* in regexp, $ might be tail anchor */
2111 /* End of else if chain - OP_TRANS rejoin rest */
2114 if (*s == '\\' && s+1 < send) {
2117 /* deprecate \1 in strings and substitution replacements */
2118 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2119 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2121 if (ckWARN(WARN_SYNTAX))
2122 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2127 /* string-change backslash escapes */
2128 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2132 /* skip any other backslash escapes in a pattern */
2133 else if (PL_lex_inpat) {
2134 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2135 goto default_action;
2138 /* if we get here, it's either a quoted -, or a digit */
2141 /* quoted - in transliterations */
2143 if (PL_lex_inwhat == OP_TRANS) {
2150 if ((isALPHA(*s) || isDIGIT(*s)) &&
2152 Perl_warner(aTHX_ packWARN(WARN_MISC),
2153 "Unrecognized escape \\%c passed through",
2155 /* default action is to copy the quoted character */
2156 goto default_action;
2159 /* \132 indicates an octal constant */
2160 case '0': case '1': case '2': case '3':
2161 case '4': case '5': case '6': case '7':
2165 uv = grok_oct(s, &len, &flags, NULL);
2168 goto NUM_ESCAPE_INSERT;
2170 /* \x24 indicates a hex constant */
2174 char* const e = strchr(s, '}');
2175 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2176 PERL_SCAN_DISALLOW_PREFIX;
2181 yyerror("Missing right brace on \\x{}");
2185 uv = grok_hex(s, &len, &flags, NULL);
2191 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2192 uv = grok_hex(s, &len, &flags, NULL);
2198 /* Insert oct or hex escaped character.
2199 * There will always enough room in sv since such
2200 * escapes will be longer than any UTF-8 sequence
2201 * they can end up as. */
2203 /* We need to map to chars to ASCII before doing the tests
2206 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2207 if (!has_utf8 && uv > 255) {
2208 /* Might need to recode whatever we have
2209 * accumulated so far if it contains any
2212 * (Can't we keep track of that and avoid
2213 * this rescan? --jhi)
2217 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2218 if (!NATIVE_IS_INVARIANT(*c)) {
2223 const STRLEN offset = d - SvPVX_const(sv);
2225 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2229 while (src >= (const U8 *)SvPVX_const(sv)) {
2230 if (!NATIVE_IS_INVARIANT(*src)) {
2231 const U8 ch = NATIVE_TO_ASCII(*src);
2232 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2233 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2243 if (has_utf8 || uv > 255) {
2244 d = (char*)uvchr_to_utf8((U8*)d, uv);
2246 if (PL_lex_inwhat == OP_TRANS &&
2247 PL_sublex_info.sub_op) {
2248 PL_sublex_info.sub_op->op_private |=
2249 (PL_lex_repl ? OPpTRANS_FROM_UTF
2253 if (uv > 255 && !dorange)
2254 native_range = FALSE;
2266 /* \N{LATIN SMALL LETTER A} is a named character */
2270 char* e = strchr(s, '}');
2277 yyerror("Missing right brace on \\N{}");
2281 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2283 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2284 PERL_SCAN_DISALLOW_PREFIX;
2287 uv = grok_hex(s, &len, &flags, NULL);
2288 if ( e > s && len != (STRLEN)(e - s) ) {
2292 goto NUM_ESCAPE_INSERT;
2294 res = newSVpvn(s + 1, e - s - 1);
2295 type = newSVpvn(s - 2,e - s + 3);
2296 res = new_constant( NULL, 0, "charnames",
2297 res, NULL, SvPVX(type) );
2300 sv_utf8_upgrade(res);
2301 str = SvPV_const(res,len);
2302 #ifdef EBCDIC_NEVER_MIND
2303 /* charnames uses pack U and that has been
2304 * recently changed to do the below uni->native
2305 * mapping, so this would be redundant (and wrong,
2306 * the code point would be doubly converted).
2307 * But leave this in just in case the pack U change
2308 * gets revoked, but the semantics is still
2309 * desireable for charnames. --jhi */
2311 UV uv = utf8_to_uvchr((const U8*)str, 0);
2314 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2316 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2317 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2318 str = SvPV_const(res, len);
2322 if (!has_utf8 && SvUTF8(res)) {
2323 const char * const ostart = SvPVX_const(sv);
2324 SvCUR_set(sv, d - ostart);
2327 sv_utf8_upgrade(sv);
2328 /* this just broke our allocation above... */
2329 SvGROW(sv, (STRLEN)(send - start));
2330 d = SvPVX(sv) + SvCUR(sv);
2333 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2334 const char * const odest = SvPVX_const(sv);
2336 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2337 d = SvPVX(sv) + (d - odest);
2341 native_range = FALSE; /* \N{} is guessed to be Unicode */
2343 Copy(str, d, len, char);
2350 yyerror("Missing braces on \\N{}");
2353 /* \c is a control character */
2362 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2365 yyerror("Missing control char name in \\c");
2369 /* printf-style backslashes, formfeeds, newlines, etc */
2371 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2374 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2377 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2380 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2383 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2386 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2389 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2395 } /* end if (backslash) */
2402 /* If we started with encoded form, or already know we want it
2403 and then encode the next character */
2404 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2406 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2407 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2410 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2411 const STRLEN off = d - SvPVX_const(sv);
2412 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2414 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2417 if (uv > 255 && !dorange)
2418 native_range = FALSE;
2422 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2424 } /* while loop to process each character */
2426 /* terminate the string and set up the sv */
2428 SvCUR_set(sv, d - SvPVX_const(sv));
2429 if (SvCUR(sv) >= SvLEN(sv))
2430 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2433 if (PL_encoding && !has_utf8) {
2434 sv_recode_to_utf8(sv, PL_encoding);
2440 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2441 PL_sublex_info.sub_op->op_private |=
2442 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2446 /* shrink the sv if we allocated more than we used */
2447 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2448 SvPV_shrink_to_cur(sv);
2451 /* return the substring (via yylval) only if we parsed anything */
2452 if (s > PL_bufptr) {
2453 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2454 sv = new_constant(start, s - start,
2455 (const char *)(PL_lex_inpat ? "qr" : "q"),
2458 (( PL_lex_inwhat == OP_TRANS
2460 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2463 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2470 * Returns TRUE if there's more to the expression (e.g., a subscript),
2473 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2475 * ->[ and ->{ return TRUE
2476 * { and [ outside a pattern are always subscripts, so return TRUE
2477 * if we're outside a pattern and it's not { or [, then return FALSE
2478 * if we're in a pattern and the first char is a {
2479 * {4,5} (any digits around the comma) returns FALSE
2480 * if we're in a pattern and the first char is a [
2482 * [SOMETHING] has a funky algorithm to decide whether it's a
2483 * character class or not. It has to deal with things like
2484 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2485 * anything else returns TRUE
2488 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2491 S_intuit_more(pTHX_ register char *s)
2494 if (PL_lex_brackets)
2496 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2498 if (*s != '{' && *s != '[')
2503 /* In a pattern, so maybe we have {n,m}. */
2520 /* On the other hand, maybe we have a character class */
2523 if (*s == ']' || *s == '^')
2526 /* this is terrifying, and it works */
2527 int weight = 2; /* let's weigh the evidence */
2529 unsigned char un_char = 255, last_un_char;
2530 const char * const send = strchr(s,']');
2531 char tmpbuf[sizeof PL_tokenbuf * 4];
2533 if (!send) /* has to be an expression */
2536 Zero(seen,256,char);
2539 else if (isDIGIT(*s)) {
2541 if (isDIGIT(s[1]) && s[2] == ']')
2547 for (; s < send; s++) {
2548 last_un_char = un_char;
2549 un_char = (unsigned char)*s;
2554 weight -= seen[un_char] * 10;
2555 if (isALNUM_lazy_if(s+1,UTF)) {
2557 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2558 len = (int)strlen(tmpbuf);
2559 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2564 else if (*s == '$' && s[1] &&
2565 strchr("[#!%*<>()-=",s[1])) {
2566 if (/*{*/ strchr("])} =",s[2]))
2575 if (strchr("wds]",s[1]))
2577 else if (seen[(U8)'\''] || seen[(U8)'"'])
2579 else if (strchr("rnftbxcav",s[1]))
2581 else if (isDIGIT(s[1])) {
2583 while (s[1] && isDIGIT(s[1]))
2593 if (strchr("aA01! ",last_un_char))
2595 if (strchr("zZ79~",s[1]))
2597 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2598 weight -= 5; /* cope with negative subscript */
2601 if (!isALNUM(last_un_char)
2602 && !(last_un_char == '$' || last_un_char == '@'
2603 || last_un_char == '&')
2604 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2609 if (keyword(tmpbuf, d - tmpbuf, 0))
2612 if (un_char == last_un_char + 1)
2614 weight -= seen[un_char];
2619 if (weight >= 0) /* probably a character class */
2629 * Does all the checking to disambiguate
2631 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2632 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2634 * First argument is the stuff after the first token, e.g. "bar".
2636 * Not a method if bar is a filehandle.
2637 * Not a method if foo is a subroutine prototyped to take a filehandle.
2638 * Not a method if it's really "Foo $bar"
2639 * Method if it's "foo $bar"
2640 * Not a method if it's really "print foo $bar"
2641 * Method if it's really "foo package::" (interpreted as package->foo)
2642 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2643 * Not a method if bar is a filehandle or package, but is quoted with
2648 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2651 char *s = start + (*start == '$');
2652 char tmpbuf[sizeof PL_tokenbuf];
2660 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2664 const char *proto = SvPVX_const(cv);
2675 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2676 /* start is the beginning of the possible filehandle/object,
2677 * and s is the end of it
2678 * tmpbuf is a copy of it
2681 if (*start == '$') {
2682 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2683 isUPPER(*PL_tokenbuf))
2686 len = start - SvPVX(PL_linestr);
2690 start = SvPVX(PL_linestr) + len;
2694 return *s == '(' ? FUNCMETH : METHOD;
2696 if (!keyword(tmpbuf, len, 0)) {
2697 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2701 soff = s - SvPVX(PL_linestr);
2705 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2706 if (indirgv && GvCVu(indirgv))
2708 /* filehandle or package name makes it a method */
2709 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2711 soff = s - SvPVX(PL_linestr);
2714 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2715 return 0; /* no assumptions -- "=>" quotes bearword */
2717 start_force(PL_curforce);
2718 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2719 newSVpvn(tmpbuf,len));
2720 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2722 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2727 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2729 return *s == '(' ? FUNCMETH : METHOD;
2737 * Return a string of Perl code to load the debugger. If PERL5DB
2738 * is set, it will return the contents of that, otherwise a
2739 * compile-time require of perl5db.pl.
2747 const char * const pdb = PerlEnv_getenv("PERL5DB");
2751 SETERRNO(0,SS_NORMAL);
2752 return "BEGIN { require 'perl5db.pl' }";
2758 /* Encoded script support. filter_add() effectively inserts a
2759 * 'pre-processing' function into the current source input stream.
2760 * Note that the filter function only applies to the current source file
2761 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2763 * The datasv parameter (which may be NULL) can be used to pass
2764 * private data to this instance of the filter. The filter function
2765 * can recover the SV using the FILTER_DATA macro and use it to
2766 * store private buffers and state information.
2768 * The supplied datasv parameter is upgraded to a PVIO type
2769 * and the IoDIRP/IoANY field is used to store the function pointer,
2770 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2771 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2772 * private use must be set using malloc'd pointers.
2776 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2785 if (!PL_rsfp_filters)
2786 PL_rsfp_filters = newAV();
2789 SvUPGRADE(datasv, SVt_PVIO);
2790 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2791 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2792 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2793 FPTR2DPTR(void *, IoANY(datasv)),
2794 SvPV_nolen(datasv)));
2795 av_unshift(PL_rsfp_filters, 1);
2796 av_store(PL_rsfp_filters, 0, datasv) ;
2801 /* Delete most recently added instance of this filter function. */
2803 Perl_filter_del(pTHX_ filter_t funcp)
2809 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2810 FPTR2DPTR(void*, funcp)));
2812 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2814 /* if filter is on top of stack (usual case) just pop it off */
2815 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2816 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2817 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2818 IoANY(datasv) = (void *)NULL;
2819 sv_free(av_pop(PL_rsfp_filters));
2823 /* we need to search for the correct entry and clear it */
2824 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2828 /* Invoke the idxth filter function for the current rsfp. */
2829 /* maxlen 0 = read one text line */
2831 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2836 /* This API is bad. It should have been using unsigned int for maxlen.
2837 Not sure if we want to change the API, but if not we should sanity
2838 check the value here. */
2839 const unsigned int correct_length
2848 if (!PL_parser || !PL_rsfp_filters)
2850 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2851 /* Provide a default input filter to make life easy. */
2852 /* Note that we append to the line. This is handy. */
2853 DEBUG_P(PerlIO_printf(Perl_debug_log,
2854 "filter_read %d: from rsfp\n", idx));
2855 if (correct_length) {
2858 const int old_len = SvCUR(buf_sv);
2860 /* ensure buf_sv is large enough */
2861 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2862 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2863 correct_length)) <= 0) {
2864 if (PerlIO_error(PL_rsfp))
2865 return -1; /* error */
2867 return 0 ; /* end of file */
2869 SvCUR_set(buf_sv, old_len + len) ;
2872 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2873 if (PerlIO_error(PL_rsfp))
2874 return -1; /* error */
2876 return 0 ; /* end of file */
2879 return SvCUR(buf_sv);
2881 /* Skip this filter slot if filter has been deleted */
2882 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2883 DEBUG_P(PerlIO_printf(Perl_debug_log,
2884 "filter_read %d: skipped (filter deleted)\n",
2886 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2888 /* Get function pointer hidden within datasv */
2889 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2890 DEBUG_P(PerlIO_printf(Perl_debug_log,
2891 "filter_read %d: via function %p (%s)\n",
2892 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2893 /* Call function. The function is expected to */
2894 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2895 /* Return: <0:error, =0:eof, >0:not eof */
2896 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2900 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2903 #ifdef PERL_CR_FILTER
2904 if (!PL_rsfp_filters) {
2905 filter_add(S_cr_textfilter,NULL);
2908 if (PL_rsfp_filters) {
2910 SvCUR_set(sv, 0); /* start with empty line */
2911 if (FILTER_READ(0, sv, 0) > 0)
2912 return ( SvPVX(sv) ) ;
2917 return (sv_gets(sv, fp, append));
2921 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2926 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2930 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2931 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2933 return GvHV(gv); /* Foo:: */
2936 /* use constant CLASS => 'MyClass' */
2937 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
2938 if (gv && GvCV(gv)) {
2939 SV * const sv = cv_const_sv(GvCV(gv));
2941 pkgname = SvPV_nolen_const(sv);
2944 return gv_stashpv(pkgname, 0);
2948 * S_readpipe_override
2949 * Check whether readpipe() is overriden, and generates the appropriate
2950 * optree, provided sublex_start() is called afterwards.
2953 S_readpipe_override(pTHX)
2956 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
2957 yylval.ival = OP_BACKTICK;
2959 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
2961 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
2962 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
2963 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
2965 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
2966 append_elem(OP_LIST,
2967 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
2968 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
2978 * The intent of this yylex wrapper is to minimize the changes to the
2979 * tokener when we aren't interested in collecting madprops. It remains
2980 * to be seen how successful this strategy will be...
2987 char *s = PL_bufptr;
2989 /* make sure PL_thiswhite is initialized */
2993 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2994 if (PL_pending_ident)
2995 return S_pending_ident(aTHX);
2997 /* previous token ate up our whitespace? */
2998 if (!PL_lasttoke && PL_nextwhite) {
2999 PL_thiswhite = PL_nextwhite;
3003 /* isolate the token, and figure out where it is without whitespace */
3004 PL_realtokenstart = -1;
3008 assert(PL_curforce < 0);
3010 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
3011 if (!PL_thistoken) {
3012 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3013 PL_thistoken = newSVpvs("");
3015 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3016 PL_thistoken = newSVpvn(tstart, s - tstart);
3019 if (PL_thismad) /* install head */
3020 CURMAD('X', PL_thistoken);
3023 /* last whitespace of a sublex? */
3024 if (optype == ')' && PL_endwhite) {
3025 CURMAD('X', PL_endwhite);
3030 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
3031 if (!PL_thiswhite && !PL_endwhite && !optype) {
3032 sv_free(PL_thistoken);
3037 /* put off final whitespace till peg */
3038 if (optype == ';' && !PL_rsfp) {
3039 PL_nextwhite = PL_thiswhite;
3042 else if (PL_thisopen) {
3043 CURMAD('q', PL_thisopen);
3045 sv_free(PL_thistoken);
3049 /* Store actual token text as madprop X */
3050 CURMAD('X', PL_thistoken);
3054 /* add preceding whitespace as madprop _ */
3055 CURMAD('_', PL_thiswhite);
3059 /* add quoted material as madprop = */
3060 CURMAD('=', PL_thisstuff);
3064 /* add terminating quote as madprop Q */
3065 CURMAD('Q', PL_thisclose);
3069 /* special processing based on optype */
3073 /* opval doesn't need a TOKEN since it can already store mp */
3084 append_madprops(PL_thismad, yylval.opval, 0);
3092 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3101 /* remember any fake bracket that lexer is about to discard */
3102 if (PL_lex_brackets == 1 &&
3103 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3106 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3109 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3110 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3113 break; /* don't bother looking for trailing comment */
3122 /* attach a trailing comment to its statement instead of next token */
3126 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3128 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3130 if (*s == '\n' || *s == '#') {
3131 while (s < PL_bufend && *s != '\n')
3135 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3136 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3153 /* Create new token struct. Note: opvals return early above. */
3154 yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
3161 S_tokenize_use(pTHX_ int is_use, char *s) {
3163 if (PL_expect != XSTATE)
3164 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3165 is_use ? "use" : "no"));
3167 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3168 s = force_version(s, TRUE);
3169 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3170 start_force(PL_curforce);
3171 NEXTVAL_NEXTTOKE.opval = NULL;
3174 else if (*s == 'v') {
3175 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3176 s = force_version(s, FALSE);
3180 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3181 s = force_version(s, FALSE);
3183 yylval.ival = is_use;
3187 static const char* const exp_name[] =
3188 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3189 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3196 Works out what to call the token just pulled out of the input
3197 stream. The yacc parser takes care of taking the ops we return and
3198 stitching them into a tree.
3204 if read an identifier
3205 if we're in a my declaration
3206 croak if they tried to say my($foo::bar)
3207 build the ops for a my() declaration
3208 if it's an access to a my() variable
3209 are we in a sort block?
3210 croak if my($a); $a <=> $b
3211 build ops for access to a my() variable
3212 if in a dq string, and they've said @foo and we can't find @foo
3214 build ops for a bareword
3215 if we already built the token before, use it.
3220 #pragma segment Perl_yylex
3226 register char *s = PL_bufptr;
3231 /* orig_keyword, gvp, and gv are initialized here because
3232 * jump to the label just_a_word_zero can bypass their
3233 * initialization later. */
3234 I32 orig_keyword = 0;
3239 SV* tmp = newSVpvs("");
3240 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3241 (IV)CopLINE(PL_curcop),
3242 lex_state_names[PL_lex_state],
3243 exp_name[PL_expect],
3244 pv_display(tmp, s, strlen(s), 0, 60));
3247 /* check if there's an identifier for us to look at */
3248 if (PL_pending_ident)
3249 return REPORT(S_pending_ident(aTHX));
3251 /* no identifier pending identification */
3253 switch (PL_lex_state) {
3255 case LEX_NORMAL: /* Some compilers will produce faster */
3256 case LEX_INTERPNORMAL: /* code if we comment these out. */
3260 /* when we've already built the next token, just pull it out of the queue */
3264 yylval = PL_nexttoke[PL_lasttoke].next_val;
3266 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3267 PL_nexttoke[PL_lasttoke].next_mad = 0;
3268 if (PL_thismad && PL_thismad->mad_key == '_') {
3269 PL_thiswhite = (SV*)PL_thismad->mad_val;
3270 PL_thismad->mad_val = 0;
3271 mad_free(PL_thismad);
3276 PL_lex_state = PL_lex_defer;
3277 PL_expect = PL_lex_expect;
3278 PL_lex_defer = LEX_NORMAL;
3279 if (!PL_nexttoke[PL_lasttoke].next_type)
3284 yylval = PL_nextval[PL_nexttoke];
3286 PL_lex_state = PL_lex_defer;
3287 PL_expect = PL_lex_expect;
3288 PL_lex_defer = LEX_NORMAL;
3292 /* FIXME - can these be merged? */
3293 return(PL_nexttoke[PL_lasttoke].next_type);
3295 return REPORT(PL_nexttype[PL_nexttoke]);
3298 /* interpolated case modifiers like \L \U, including \Q and \E.
3299 when we get here, PL_bufptr is at the \
3301 case LEX_INTERPCASEMOD:
3303 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3304 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3306 /* handle \E or end of string */
3307 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3309 if (PL_lex_casemods) {
3310 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3311 PL_lex_casestack[PL_lex_casemods] = '\0';
3313 if (PL_bufptr != PL_bufend
3314 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3316 PL_lex_state = LEX_INTERPCONCAT;
3319 PL_thistoken = newSVpvs("\\E");
3325 while (PL_bufptr != PL_bufend &&
3326 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3328 PL_thiswhite = newSVpvs("");
3329 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3333 if (PL_bufptr != PL_bufend)
3336 PL_lex_state = LEX_INTERPCONCAT;
3340 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3341 "### Saw case modifier\n"); });
3343 if (s[1] == '\\' && s[2] == 'E') {
3346 PL_thiswhite = newSVpvs("");
3347 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3350 PL_lex_state = LEX_INTERPCONCAT;
3355 if (!PL_madskills) /* when just compiling don't need correct */
3356 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3357 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3358 if ((*s == 'L' || *s == 'U') &&
3359 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3360 PL_lex_casestack[--PL_lex_casemods] = '\0';
3363 if (PL_lex_casemods > 10)
3364 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3365 PL_lex_casestack[PL_lex_casemods++] = *s;
3366 PL_lex_casestack[PL_lex_casemods] = '\0';
3367 PL_lex_state = LEX_INTERPCONCAT;
3368 start_force(PL_curforce);
3369 NEXTVAL_NEXTTOKE.ival = 0;
3371 start_force(PL_curforce);
3373 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3375 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3377 NEXTVAL_NEXTTOKE.ival = OP_LC;
3379 NEXTVAL_NEXTTOKE.ival = OP_UC;
3381 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3383 Perl_croak(aTHX_ "panic: yylex");
3385 SV* const tmpsv = newSVpvs("");
3386 Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3392 if (PL_lex_starts) {
3398 sv_free(PL_thistoken);
3399 PL_thistoken = newSVpvs("");
3402 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3403 if (PL_lex_casemods == 1 && PL_lex_inpat)
3412 case LEX_INTERPPUSH:
3413 return REPORT(sublex_push());
3415 case LEX_INTERPSTART:
3416 if (PL_bufptr == PL_bufend)
3417 return REPORT(sublex_done());
3418 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3419 "### Interpolated variable\n"); });
3421 PL_lex_dojoin = (*PL_bufptr == '@');
3422 PL_lex_state = LEX_INTERPNORMAL;
3423 if (PL_lex_dojoin) {
3424 start_force(PL_curforce);
3425 NEXTVAL_NEXTTOKE.ival = 0;
3427 start_force(PL_curforce);
3428 force_ident("\"", '$');
3429 start_force(PL_curforce);
3430 NEXTVAL_NEXTTOKE.ival = 0;
3432 start_force(PL_curforce);
3433 NEXTVAL_NEXTTOKE.ival = 0;
3435 start_force(PL_curforce);
3436 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3439 if (PL_lex_starts++) {
3444 sv_free(PL_thistoken);
3445 PL_thistoken = newSVpvs("");
3448 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3449 if (!PL_lex_casemods && PL_lex_inpat)
3456 case LEX_INTERPENDMAYBE:
3457 if (intuit_more(PL_bufptr)) {
3458 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3464 if (PL_lex_dojoin) {
3465 PL_lex_dojoin = FALSE;
3466 PL_lex_state = LEX_INTERPCONCAT;
3470 sv_free(PL_thistoken);
3471 PL_thistoken = newSVpvs("");
3476 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3477 && SvEVALED(PL_lex_repl))
3479 if (PL_bufptr != PL_bufend)
3480 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3484 case LEX_INTERPCONCAT:
3486 if (PL_lex_brackets)
3487 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3489 if (PL_bufptr == PL_bufend)
3490 return REPORT(sublex_done());
3492 if (SvIVX(PL_linestr) == '\'') {
3493 SV *sv = newSVsv(PL_linestr);
3496 else if ( PL_hints & HINT_NEW_RE )
3497 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3498 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3502 s = scan_const(PL_bufptr);
3504 PL_lex_state = LEX_INTERPCASEMOD;
3506 PL_lex_state = LEX_INTERPSTART;
3509 if (s != PL_bufptr) {
3510 start_force(PL_curforce);
3512 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3514 NEXTVAL_NEXTTOKE = yylval;
3517 if (PL_lex_starts++) {
3521 sv_free(PL_thistoken);
3522 PL_thistoken = newSVpvs("");
3525 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3526 if (!PL_lex_casemods && PL_lex_inpat)
3539 PL_lex_state = LEX_NORMAL;
3540 s = scan_formline(PL_bufptr);
3541 if (!PL_lex_formbrack)
3547 PL_oldoldbufptr = PL_oldbufptr;
3553 sv_free(PL_thistoken);
3556 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3560 if (isIDFIRST_lazy_if(s,UTF))
3562 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3565 goto fake_eof; /* emulate EOF on ^D or ^Z */
3574 if (PL_lex_brackets) {
3575 yyerror((const char *)
3577 ? "Format not terminated"
3578 : "Missing right curly or square bracket"));
3580 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3581 "### Tokener got EOF\n");
3585 if (s++ < PL_bufend)
3586 goto retry; /* ignore stray nulls */
3589 if (!PL_in_eval && !PL_preambled) {
3590 PL_preambled = TRUE;
3595 sv_setpv(PL_linestr,incl_perldb());
3596 if (SvCUR(PL_linestr))
3597 sv_catpvs(PL_linestr,";");
3599 while(AvFILLp(PL_preambleav) >= 0) {
3600 SV *tmpsv = av_shift(PL_preambleav);
3601 sv_catsv(PL_linestr, tmpsv);
3602 sv_catpvs(PL_linestr, ";");
3605 sv_free((SV*)PL_preambleav);
3606 PL_preambleav = NULL;
3608 if (PL_minus_n || PL_minus_p) {
3609 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3611 sv_catpvs(PL_linestr,"chomp;");
3614 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3615 || *PL_splitstr == '"')
3616 && strchr(PL_splitstr + 1, *PL_splitstr))
3617 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3619 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3620 bytes can be used as quoting characters. :-) */
3621 const char *splits = PL_splitstr;
3622 sv_catpvs(PL_linestr, "our @F=split(q\0");
3625 if (*splits == '\\')
3626 sv_catpvn(PL_linestr, splits, 1);
3627 sv_catpvn(PL_linestr, splits, 1);
3628 } while (*splits++);
3629 /* This loop will embed the trailing NUL of
3630 PL_linestr as the last thing it does before
3632 sv_catpvs(PL_linestr, ");");
3636 sv_catpvs(PL_linestr,"our @F=split(' ');");
3640 sv_catpvs(PL_linestr,"use feature ':5.10';");
3641 sv_catpvs(PL_linestr, "\n");
3642 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3643 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3644 PL_last_lop = PL_last_uni = NULL;
3645 if (PERLDB_LINE && PL_curstash != PL_debstash)
3646 update_debugger_info(PL_linestr, NULL, 0);
3650 bof = PL_rsfp ? TRUE : FALSE;
3651 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3654 PL_realtokenstart = -1;
3657 if (PL_preprocess && !PL_in_eval)
3658 (void)PerlProc_pclose(PL_rsfp);
3659 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3660 PerlIO_clearerr(PL_rsfp);
3662 (void)PerlIO_close(PL_rsfp);
3664 PL_doextract = FALSE;
3666 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3671 sv_setpv(PL_linestr,
3674 ? ";}continue{print;}" : ";}"));
3675 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3676 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3677 PL_last_lop = PL_last_uni = NULL;
3678 PL_minus_n = PL_minus_p = 0;
3681 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3682 PL_last_lop = PL_last_uni = NULL;
3683 sv_setpvn(PL_linestr,"",0);
3684 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3686 /* If it looks like the start of a BOM or raw UTF-16,
3687 * check if it in fact is. */
3693 #ifdef PERLIO_IS_STDIO
3694 # ifdef __GNU_LIBRARY__
3695 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3696 # define FTELL_FOR_PIPE_IS_BROKEN
3700 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3701 # define FTELL_FOR_PIPE_IS_BROKEN
3706 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3707 /* This loses the possibility to detect the bof
3708 * situation on perl -P when the libc5 is being used.
3709 * Workaround? Maybe attach some extra state to PL_rsfp?
3712 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3714 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3717 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3718 s = swallow_bom((U8*)s);
3722 /* Incest with pod. */
3725 sv_catsv(PL_thiswhite, PL_linestr);
3727 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3728 sv_setpvn(PL_linestr, "", 0);
3729 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3730 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3731 PL_last_lop = PL_last_uni = NULL;
3732 PL_doextract = FALSE;
3736 } while (PL_doextract);
3737 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3738 if (PERLDB_LINE && PL_curstash != PL_debstash)
3739 update_debugger_info(PL_linestr, NULL, 0);
3740 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3741 PL_last_lop = PL_last_uni = NULL;
3742 if (CopLINE(PL_curcop) == 1) {
3743 while (s < PL_bufend && isSPACE(*s))
3745 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3749 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3753 if (*s == '#' && *(s+1) == '!')
3755 #ifdef ALTERNATE_SHEBANG
3757 static char const as[] = ALTERNATE_SHEBANG;
3758 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3759 d = s + (sizeof(as) - 1);
3761 #endif /* ALTERNATE_SHEBANG */
3770 while (*d && !isSPACE(*d))
3774 #ifdef ARG_ZERO_IS_SCRIPT
3775 if (ipathend > ipath) {
3777 * HP-UX (at least) sets argv[0] to the script name,
3778 * which makes $^X incorrect. And Digital UNIX and Linux,
3779 * at least, set argv[0] to the basename of the Perl
3780 * interpreter. So, having found "#!", we'll set it right.
3782 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3784 assert(SvPOK(x) || SvGMAGICAL(x));
3785 if (sv_eq(x, CopFILESV(PL_curcop))) {
3786 sv_setpvn(x, ipath, ipathend - ipath);
3792 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3793 const char * const lstart = SvPV_const(x,llen);
3795 bstart += blen - llen;
3796 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3797 sv_setpvn(x, ipath, ipathend - ipath);
3802 TAINT_NOT; /* $^X is always tainted, but that's OK */
3804 #endif /* ARG_ZERO_IS_SCRIPT */
3809 d = instr(s,"perl -");
3811 d = instr(s,"perl");
3813 /* avoid getting into infinite loops when shebang
3814 * line contains "Perl" rather than "perl" */
3816 for (d = ipathend-4; d >= ipath; --d) {
3817 if ((*d == 'p' || *d == 'P')
3818 && !ibcmp(d, "perl", 4))
3828 #ifdef ALTERNATE_SHEBANG
3830 * If the ALTERNATE_SHEBANG on this system starts with a
3831 * character that can be part of a Perl expression, then if
3832 * we see it but not "perl", we're probably looking at the
3833 * start of Perl code, not a request to hand off to some
3834 * other interpreter. Similarly, if "perl" is there, but
3835 * not in the first 'word' of the line, we assume the line
3836 * contains the start of the Perl program.
3838 if (d && *s != '#') {
3839 const char *c = ipath;
3840 while (*c && !strchr("; \t\r\n\f\v#", *c))
3843 d = NULL; /* "perl" not in first word; ignore */
3845 *s = '#'; /* Don't try to parse shebang line */
3847 #endif /* ALTERNATE_SHEBANG */
3848 #ifndef MACOS_TRADITIONAL
3853 !instr(s,"indir") &&
3854 instr(PL_origargv[0],"perl"))
3861 while (s < PL_bufend && isSPACE(*s))
3863 if (s < PL_bufend) {
3864 Newxz(newargv,PL_origargc+3,char*);
3866 while (s < PL_bufend && !isSPACE(*s))
3869 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3872 newargv = PL_origargv;
3875 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3877 Perl_croak(aTHX_ "Can't exec %s", ipath);
3881 while (*d && !isSPACE(*d))
3883 while (SPACE_OR_TAB(*d))
3887 const bool switches_done = PL_doswitches;
3888 const U32 oldpdb = PL_perldb;
3889 const bool oldn = PL_minus_n;
3890 const bool oldp = PL_minus_p;
3893 if (*d == 'M' || *d == 'm' || *d == 'C') {
3894 const char * const m = d;
3895 while (*d && !isSPACE(*d))
3897 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3900 d = moreswitches(d);
3902 if (PL_doswitches && !switches_done) {
3903 int argc = PL_origargc;
3904 char **argv = PL_origargv;
3907 } while (argc && argv[0][0] == '-' && argv[0][1]);
3908 init_argv_symbols(argc,argv);
3910 if ((PERLDB_LINE && !oldpdb) ||
3911 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3912 /* if we have already added "LINE: while (<>) {",
3913 we must not do it again */
3915 sv_setpvn(PL_linestr, "", 0);
3916 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3917 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3918 PL_last_lop = PL_last_uni = NULL;
3919 PL_preambled = FALSE;
3921 (void)gv_fetchfile(PL_origfilename);
3928 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3930 PL_lex_state = LEX_FORMLINE;
3935 #ifdef PERL_STRICT_CR
3936 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3938 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3940 case ' ': case '\t': case '\f': case 013:
3941 #ifdef MACOS_TRADITIONAL
3945 PL_realtokenstart = -1;
3947 PL_thiswhite = newSVpvs("");
3948 sv_catpvn(PL_thiswhite, s, 1);
3955 PL_realtokenstart = -1;
3959 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3960 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3961 /* handle eval qq[#line 1 "foo"\n ...] */
3962 CopLINE_dec(PL_curcop);
3965 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3967 if (!PL_in_eval || PL_rsfp)
3972 while (d < PL_bufend && *d != '\n')
3976 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3977 Perl_croak(aTHX_ "panic: input overflow");
3980 PL_thiswhite = newSVpvn(s, d - s);
3985 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3987 PL_lex_state = LEX_FORMLINE;
3993 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3994 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3997 TOKEN(PEG); /* make sure any #! line is accessible */
4002 /* if (PL_madskills && PL_lex_formbrack) { */
4004 while (d < PL_bufend && *d != '\n')
4008 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4009 Perl_croak(aTHX_ "panic: input overflow");
4010 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4012 PL_thiswhite = newSVpvs("");
4013 if (CopLINE(PL_curcop) == 1) {
4014 sv_setpvn(PL_thiswhite, "", 0);
4017 sv_catpvn(PL_thiswhite, s, d - s);
4031 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4039 while (s < PL_bufend && SPACE_OR_TAB(*s))
4042 if (strnEQ(s,"=>",2)) {
4043 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4044 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4045 OPERATOR('-'); /* unary minus */
4047 PL_last_uni = PL_oldbufptr;
4049 case 'r': ftst = OP_FTEREAD; break;
4050 case 'w': ftst = OP_FTEWRITE; break;
4051 case 'x': ftst = OP_FTEEXEC; break;
4052 case 'o': ftst = OP_FTEOWNED; break;
4053 case 'R': ftst = OP_FTRREAD; break;
4054 case 'W': ftst = OP_FTRWRITE; break;
4055 case 'X': ftst = OP_FTREXEC; break;
4056 case 'O': ftst = OP_FTROWNED; break;
4057 case 'e': ftst = OP_FTIS; break;
4058 case 'z': ftst = OP_FTZERO; break;
4059 case 's': ftst = OP_FTSIZE; break;
4060 case 'f': ftst = OP_FTFILE; break;
4061 case 'd': ftst = OP_FTDIR; break;
4062 case 'l': ftst = OP_FTLINK; break;
4063 case 'p': ftst = OP_FTPIPE; break;
4064 case 'S': ftst = OP_FTSOCK; break;
4065 case 'u': ftst = OP_FTSUID; break;
4066 case 'g': ftst = OP_FTSGID; break;
4067 case 'k': ftst = OP_FTSVTX; break;
4068 case 'b': ftst = OP_FTBLK; break;
4069 case 'c': ftst = OP_FTCHR; break;
4070 case 't': ftst = OP_FTTTY; break;
4071 case 'T': ftst = OP_FTTEXT; break;
4072 case 'B': ftst = OP_FTBINARY; break;
4073 case 'M': case 'A': case 'C':
4074 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4076 case 'M': ftst = OP_FTMTIME; break;
4077 case 'A': ftst = OP_FTATIME; break;
4078 case 'C': ftst = OP_FTCTIME; break;
4086 PL_last_lop_op = (OPCODE)ftst;
4087 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4088 "### Saw file test %c\n", (int)tmp);
4093 /* Assume it was a minus followed by a one-letter named
4094 * subroutine call (or a -bareword), then. */
4095 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4096 "### '-%c' looked like a file test but was not\n",
4103 const char tmp = *s++;
4106 if (PL_expect == XOPERATOR)
4111 else if (*s == '>') {
4114 if (isIDFIRST_lazy_if(s,UTF)) {
4115 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4123 if (PL_expect == XOPERATOR)
4126 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4128 OPERATOR('-'); /* unary minus */
4134 const char tmp = *s++;
4137 if (PL_expect == XOPERATOR)
4142 if (PL_expect == XOPERATOR)
4145 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4152 if (PL_expect != XOPERATOR) {
4153 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4154 PL_expect = XOPERATOR;
4155 force_ident(PL_tokenbuf, '*');
4168 if (PL_expect == XOPERATOR) {
4172 PL_tokenbuf[0] = '%';
4173 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4174 sizeof PL_tokenbuf - 1, FALSE);
4175 if (!PL_tokenbuf[1]) {
4178 PL_pending_ident = '%';
4189 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4196 const char tmp = *s++;
4202 goto just_a_word_zero_gv;
4205 switch (PL_expect) {
4211 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4213 PL_bufptr = s; /* update in case we back off */
4219 PL_expect = XTERMBLOCK;
4222 stuffstart = s - SvPVX(PL_linestr) - 1;
4226 while (isIDFIRST_lazy_if(s,UTF)) {
4229 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4230 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4231 if (tmp < 0) tmp = -tmp;
4246 sv = newSVpvn(s, len);
4248 d = scan_str(d,TRUE,TRUE);
4250 /* MUST advance bufptr here to avoid bogus
4251 "at end of line" context messages from yyerror().
4253 PL_bufptr = s + len;
4254 yyerror("Unterminated attribute parameter in attribute list");
4258 return REPORT(0); /* EOF indicator */
4262 sv_catsv(sv, PL_lex_stuff);
4263 attrs = append_elem(OP_LIST, attrs,
4264 newSVOP(OP_CONST, 0, sv));
4265 SvREFCNT_dec(PL_lex_stuff);
4266 PL_lex_stuff = NULL;
4269 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4271 if (PL_in_my == KEY_our) {
4273 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4275 /* skip to avoid loading attributes.pm */
4277 deprecate(":unique");
4280 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4283 /* NOTE: any CV attrs applied here need to be part of
4284 the CVf_BUILTIN_ATTRS define in cv.h! */
4285 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4287 CvLVALUE_on(PL_compcv);
4289 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4291 CvLOCKED_on(PL_compcv);
4293 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4295 CvMETHOD_on(PL_compcv);
4297 else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4299 CvASSERTION_on(PL_compcv);
4301 /* After we've set the flags, it could be argued that
4302 we don't need to do the attributes.pm-based setting
4303 process, and shouldn't bother appending recognized
4304 flags. To experiment with that, uncomment the
4305 following "else". (Note that's already been
4306 uncommented. That keeps the above-applied built-in
4307 attributes from being intercepted (and possibly
4308 rejected) by a package's attribute routines, but is
4309 justified by the performance win for the common case
4310 of applying only built-in attributes.) */
4312 attrs = append_elem(OP_LIST, attrs,
4313 newSVOP(OP_CONST, 0,
4317 if (*s == ':' && s[1] != ':')
4320 break; /* require real whitespace or :'s */
4321 /* XXX losing whitespace on sequential attributes here */
4325 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4326 if (*s != ';' && *s != '}' && *s != tmp
4327 && (tmp != '=' || *s != ')')) {
4328 const char q = ((*s == '\'') ? '"' : '\'');
4329 /* If here for an expression, and parsed no attrs, back
4331 if (tmp == '=' && !attrs) {
4335 /* MUST advance bufptr here to avoid bogus "at end of line"
4336 context messages from yyerror().
4339 yyerror( (const char *)
4341 ? Perl_form(aTHX_ "Invalid separator character "
4342 "%c%c%c in attribute list", q, *s, q)
4343 : "Unterminated attribute list" ) );
4351 start_force(PL_curforce);
4352 NEXTVAL_NEXTTOKE.opval = attrs;
4353 CURMAD('_', PL_nextwhite);
4358 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4359 (s - SvPVX(PL_linestr)) - stuffstart);
4367 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4368 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4376 const char tmp = *s++;
4381 const char tmp = *s++;
4389 if (PL_lex_brackets <= 0)
4390 yyerror("Unmatched right square bracket");
4393 if (PL_lex_state == LEX_INTERPNORMAL) {
4394 if (PL_lex_brackets == 0) {
4395 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4396 PL_lex_state = LEX_INTERPEND;
4403 if (PL_lex_brackets > 100) {
4404 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4406 switch (PL_expect) {
4408 if (PL_lex_formbrack) {
4412 if (PL_oldoldbufptr == PL_last_lop)
4413 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4415 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4416 OPERATOR(HASHBRACK);
4418 while (s < PL_bufend && SPACE_OR_TAB(*s))
4421 PL_tokenbuf[0] = '\0';
4422 if (d < PL_bufend && *d == '-') {
4423 PL_tokenbuf[0] = '-';
4425 while (d < PL_bufend && SPACE_OR_TAB(*d))
4428 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4429 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4431 while (d < PL_bufend && SPACE_OR_TAB(*d))
4434 const char minus = (PL_tokenbuf[0] == '-');
4435 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4443 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4448 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4453 if (PL_oldoldbufptr == PL_last_lop)
4454 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4456 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4459 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4461 /* This hack is to get the ${} in the message. */
4463 yyerror("syntax error");
4466 OPERATOR(HASHBRACK);
4468 /* This hack serves to disambiguate a pair of curlies
4469 * as being a block or an anon hash. Normally, expectation
4470 * determines that, but in cases where we're not in a
4471 * position to expect anything in particular (like inside
4472 * eval"") we have to resolve the ambiguity. This code
4473 * covers the case where the first term in the curlies is a
4474 * quoted string. Most other cases need to be explicitly
4475 * disambiguated by prepending a "+" before the opening
4476 * curly in order to force resolution as an anon hash.
4478 * XXX should probably propagate the outer expectation
4479 * into eval"" to rely less on this hack, but that could
4480 * potentially break current behavior of eval"".
4484 if (*s == '\'' || *s == '"' || *s == '`') {
4485 /* common case: get past first string, handling escapes */
4486 for (t++; t < PL_bufend && *t != *s;)
4487 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4491 else if (*s == 'q') {
4494 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4497 /* skip q//-like construct */
4499 char open, close, term;
4502 while (t < PL_bufend && isSPACE(*t))
4504 /* check for q => */
4505 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4506 OPERATOR(HASHBRACK);
4510 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4514 for (t++; t < PL_bufend; t++) {
4515 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4517 else if (*t == open)
4521 for (t++; t < PL_bufend; t++) {
4522 if (*t == '\\' && t+1 < PL_bufend)
4524 else if (*t == close && --brackets <= 0)
4526 else if (*t == open)
4533 /* skip plain q word */
4534 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4537 else if (isALNUM_lazy_if(t,UTF)) {
4539 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4542 while (t < PL_bufend && isSPACE(*t))
4544 /* if comma follows first term, call it an anon hash */
4545 /* XXX it could be a comma expression with loop modifiers */
4546 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4547 || (*t == '=' && t[1] == '>')))
4548 OPERATOR(HASHBRACK);
4549 if (PL_expect == XREF)
4552 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4558 yylval.ival = CopLINE(PL_curcop);
4559 if (isSPACE(*s) || *s == '#')
4560 PL_copline = NOLINE; /* invalidate current command line number */
4565 if (PL_lex_brackets <= 0)
4566 yyerror("Unmatched right curly bracket");
4568 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4569 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4570 PL_lex_formbrack = 0;
4571 if (PL_lex_state == LEX_INTERPNORMAL) {
4572 if (PL_lex_brackets == 0) {
4573 if (PL_expect & XFAKEBRACK) {
4574 PL_expect &= XENUMMASK;
4575 PL_lex_state = LEX_INTERPEND;
4580 PL_thiswhite = newSVpvs("");
4581 sv_catpvn(PL_thiswhite,"}",1);
4584 return yylex(); /* ignore fake brackets */
4586 if (*s == '-' && s[1] == '>')
4587 PL_lex_state = LEX_INTERPENDMAYBE;
4588 else if (*s != '[' && *s != '{')
4589 PL_lex_state = LEX_INTERPEND;
4592 if (PL_expect & XFAKEBRACK) {
4593 PL_expect &= XENUMMASK;
4595 return yylex(); /* ignore fake brackets */
4597 start_force(PL_curforce);
4599 curmad('X', newSVpvn(s-1,1));
4600 CURMAD('_', PL_thiswhite);
4605 PL_thistoken = newSVpvs("");
4613 if (PL_expect == XOPERATOR) {
4614 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4615 && isIDFIRST_lazy_if(s,UTF))
4617 CopLINE_dec(PL_curcop);
4618 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4619 CopLINE_inc(PL_curcop);
4624 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4626 PL_expect = XOPERATOR;
4627 force_ident(PL_tokenbuf, '&');
4631 yylval.ival = (OPpENTERSUB_AMPER<<8);
4643 const char tmp = *s++;
4650 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4651 && strchr("+-*/%.^&|<",tmp))
4652 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4653 "Reversed %c= operator",(int)tmp);
4655 if (PL_expect == XSTATE && isALPHA(tmp) &&
4656 (s == PL_linestart+1 || s[-2] == '\n') )
4658 if (PL_in_eval && !PL_rsfp) {
4663 if (strnEQ(s,"=cut",4)) {
4679 PL_thiswhite = newSVpvs("");
4680 sv_catpvn(PL_thiswhite, PL_linestart,
4681 PL_bufend - PL_linestart);
4685 PL_doextract = TRUE;
4689 if (PL_lex_brackets < PL_lex_formbrack) {
4691 #ifdef PERL_STRICT_CR
4692 while (SPACE_OR_TAB(*t))
4694 while (SPACE_OR_TAB(*t) || *t == '\r')
4697 if (*t == '\n' || *t == '#') {
4708 const char tmp = *s++;
4710 /* was this !=~ where !~ was meant?
4711 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4713 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4714 const char *t = s+1;
4716 while (t < PL_bufend && isSPACE(*t))
4719 if (*t == '/' || *t == '?' ||
4720 ((*t == 'm' || *t == 's' || *t == 'y')
4721 && !isALNUM(t[1])) ||
4722 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4723 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4724 "!=~ should be !~");
4734 if (PL_expect != XOPERATOR) {
4735 if (s[1] != '<' && !strchr(s,'>'))
4738 s = scan_heredoc(s);
4740 s = scan_inputsymbol(s);
4741 TERM(sublex_start());
4747 SHop(OP_LEFT_SHIFT);
4761 const char tmp = *s++;
4763 SHop(OP_RIGHT_SHIFT);
4764 else if (tmp == '=')
4773 if (PL_expect == XOPERATOR) {
4774 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4776 deprecate_old(commaless_variable_list);
4777 return REPORT(','); /* grandfather non-comma-format format */
4781 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4782 PL_tokenbuf[0] = '@';
4783 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4784 sizeof PL_tokenbuf - 1, FALSE);
4785 if (PL_expect == XOPERATOR)
4786 no_op("Array length", s);
4787 if (!PL_tokenbuf[1])
4789 PL_expect = XOPERATOR;
4790 PL_pending_ident = '#';
4794 PL_tokenbuf[0] = '$';
4795 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4796 sizeof PL_tokenbuf - 1, FALSE);
4797 if (PL_expect == XOPERATOR)
4799 if (!PL_tokenbuf[1]) {
4801 yyerror("Final $ should be \\$ or $name");
4805 /* This kludge not intended to be bulletproof. */
4806 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4807 yylval.opval = newSVOP(OP_CONST, 0,
4808 newSViv(CopARYBASE_get(&PL_compiling)));
4809 yylval.opval->op_private = OPpCONST_ARYBASE;
4815 const char tmp = *s;
4816 if (PL_lex_state == LEX_NORMAL)
4819 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4820 && intuit_more(s)) {
4822 PL_tokenbuf[0] = '@';
4823 if (ckWARN(WARN_SYNTAX)) {
4826 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4829 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4830 while (t < PL_bufend && *t != ']')
4832 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4833 "Multidimensional syntax %.*s not supported",
4834 (int)((t - PL_bufptr) + 1), PL_bufptr);
4838 else if (*s == '{') {
4840 PL_tokenbuf[0] = '%';
4841 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4842 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4844 char tmpbuf[sizeof PL_tokenbuf];
4847 } while (isSPACE(*t));
4848 if (isIDFIRST_lazy_if(t,UTF)) {
4850 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4854 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4855 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4856 "You need to quote \"%s\"",
4863 PL_expect = XOPERATOR;
4864 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4865 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4866 if (!islop || PL_last_lop_op == OP_GREPSTART)
4867 PL_expect = XOPERATOR;
4868 else if (strchr("$@\"'`q", *s))
4869 PL_expect = XTERM; /* e.g. print $fh "foo" */
4870 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4871 PL_expect = XTERM; /* e.g. print $fh &sub */
4872 else if (isIDFIRST_lazy_if(s,UTF)) {
4873 char tmpbuf[sizeof PL_tokenbuf];
4875 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4876 if ((t2 = keyword(tmpbuf, len, 0))) {
4877 /* binary operators exclude handle interpretations */
4889 PL_expect = XTERM; /* e.g. print $fh length() */
4894 PL_expect = XTERM; /* e.g. print $fh subr() */
4897 else if (isDIGIT(*s))
4898 PL_expect = XTERM; /* e.g. print $fh 3 */
4899 else if (*s == '.' && isDIGIT(s[1]))
4900 PL_expect = XTERM; /* e.g. print $fh .3 */
4901 else if ((*s == '?' || *s == '-' || *s == '+')
4902 && !isSPACE(s[1]) && s[1] != '=')
4903 PL_expect = XTERM; /* e.g. print $fh -1 */
4904 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4906 PL_expect = XTERM; /* e.g. print $fh /.../
4907 XXX except DORDOR operator
4909 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4911 PL_expect = XTERM; /* print $fh <<"EOF" */
4914 PL_pending_ident = '$';
4918 if (PL_expect == XOPERATOR)
4920 PL_tokenbuf[0] = '@';
4921 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4922 if (!PL_tokenbuf[1]) {
4925 if (PL_lex_state == LEX_NORMAL)
4927 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4929 PL_tokenbuf[0] = '%';
4931 /* Warn about @ where they meant $. */
4932 if (*s == '[' || *s == '{') {
4933 if (ckWARN(WARN_SYNTAX)) {
4934 const char *t = s + 1;
4935 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4937 if (*t == '}' || *t == ']') {
4939 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4940 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4941 "Scalar value %.*s better written as $%.*s",
4942 (int)(t-PL_bufptr), PL_bufptr,
4943 (int)(t-PL_bufptr-1), PL_bufptr+1);
4948 PL_pending_ident = '@';
4951 case '/': /* may be division, defined-or, or pattern */
4952 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4956 case '?': /* may either be conditional or pattern */
4957 if(PL_expect == XOPERATOR) {
4965 /* A // operator. */
4975 /* Disable warning on "study /blah/" */
4976 if (PL_oldoldbufptr == PL_last_uni
4977 && (*PL_last_uni != 's' || s - PL_last_uni < 5
4978 || memNE(PL_last_uni, "study", 5)
4979 || isALNUM_lazy_if(PL_last_uni+5,UTF)
4982 s = scan_pat(s,OP_MATCH);
4983 TERM(sublex_start());
4987 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4988 #ifdef PERL_STRICT_CR
4991 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4993 && (s == PL_linestart || s[-1] == '\n') )
4995 PL_lex_formbrack = 0;
4999 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
5005 yylval.ival = OPf_SPECIAL;
5011 if (PL_expect != XOPERATOR)
5016 case '0': case '1': case '2': case '3': case '4':
5017 case '5': case '6': case '7': case '8': case '9':
5018 s = scan_num(s, &yylval);
5019 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
5020 if (PL_expect == XOPERATOR)
5025 s = scan_str(s,!!PL_madskills,FALSE);
5026 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5027 if (PL_expect == XOPERATOR) {
5028 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5030 deprecate_old(commaless_variable_list);
5031 return REPORT(','); /* grandfather non-comma-format format */
5038 yylval.ival = OP_CONST;
5039 TERM(sublex_start());
5042 s = scan_str(s,!!PL_madskills,FALSE);
5043 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5044 if (PL_expect == XOPERATOR) {
5045 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5047 deprecate_old(commaless_variable_list);
5048 return REPORT(','); /* grandfather non-comma-format format */
5055 yylval.ival = OP_CONST;
5056 /* FIXME. I think that this can be const if char *d is replaced by
5057 more localised variables. */
5058 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5059 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5060 yylval.ival = OP_STRINGIFY;
5064 TERM(sublex_start());
5067 s = scan_str(s,!!PL_madskills,FALSE);
5068 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5069 if (PL_expect == XOPERATOR)
5070 no_op("Backticks",s);
5073 readpipe_override();
5074 TERM(sublex_start());
5078 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5079 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5081 if (PL_expect == XOPERATOR)
5082 no_op("Backslash",s);
5086 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5087 char *start = s + 2;
5088 while (isDIGIT(*start) || *start == '_')
5090 if (*start == '.' && isDIGIT(start[1])) {
5091 s = scan_num(s, &yylval);
5094 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5095 else if (!isALPHA(*start) && (PL_expect == XTERM
5096 || PL_expect == XREF || PL_expect == XSTATE
5097 || PL_expect == XTERMORDORDOR)) {
5098 /* XXX Use gv_fetchpvn rather than stomping on a const string */
5099 const char c = *start;
5102 gv = gv_fetchpv(s, 0, SVt_PVCV);
5105 s = scan_num(s, &yylval);
5112 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5154 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5156 /* Some keywords can be followed by any delimiter, including ':' */
5157 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5158 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5159 (PL_tokenbuf[0] == 'q' &&
5160 strchr("qwxr", PL_tokenbuf[1])))));
5162 /* x::* is just a word, unless x is "CORE" */
5163 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5167 while (d < PL_bufend && isSPACE(*d))
5168 d++; /* no comments skipped here, or s### is misparsed */
5170 /* Is this a label? */
5171 if (!tmp && PL_expect == XSTATE
5172 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5174 yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5179 /* Check for keywords */
5180 tmp = keyword(PL_tokenbuf, len, 0);
5182 /* Is this a word before a => operator? */
5183 if (*d == '=' && d[1] == '>') {
5186 = (OP*)newSVOP(OP_CONST, 0,
5187 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5188 yylval.opval->op_private = OPpCONST_BARE;
5192 if (tmp < 0) { /* second-class keyword? */
5193 GV *ogv = NULL; /* override (winner) */
5194 GV *hgv = NULL; /* hidden (loser) */
5195 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5197 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5200 if (GvIMPORTED_CV(gv))
5202 else if (! CvMETHOD(cv))
5206 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5207 (gv = *gvp) && isGV_with_GP(gv) &&
5208 GvCVu(gv) && GvIMPORTED_CV(gv))
5215 tmp = 0; /* overridden by import or by GLOBAL */
5218 && -tmp==KEY_lock /* XXX generalizable kludge */
5221 tmp = 0; /* any sub overrides "weak" keyword */
5223 else { /* no override */
5225 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5226 Perl_warner(aTHX_ packWARN(WARN_MISC),
5227 "dump() better written as CORE::dump()");
5231 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5232 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
5233 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5234 "Ambiguous call resolved as CORE::%s(), %s",
5235 GvENAME(hgv), "qualify as such or use &");
5242 default: /* not a keyword */
5243 /* Trade off - by using this evil construction we can pull the
5244 variable gv into the block labelled keylookup. If not, then
5245 we have to give it function scope so that the goto from the
5246 earlier ':' case doesn't bypass the initialisation. */
5248 just_a_word_zero_gv:
5256 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5259 SV *nextPL_nextwhite = 0;
5263 /* Get the rest if it looks like a package qualifier */
5265 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5267 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5270 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5271 *s == '\'' ? "'" : "::");
5276 if (PL_expect == XOPERATOR) {
5277 if (PL_bufptr == PL_linestart) {
5278 CopLINE_dec(PL_curcop);
5279 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5280 CopLINE_inc(PL_curcop);
5283 no_op("Bareword",s);
5286 /* Look for a subroutine with this name in current package,
5287 unless name is "Foo::", in which case Foo is a bearword
5288 (and a package name). */
5290 if (len > 2 && !PL_madskills &&
5291 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5293 if (ckWARN(WARN_BAREWORD)
5294 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5295 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5296 "Bareword \"%s\" refers to nonexistent package",
5299 PL_tokenbuf[len] = '\0';
5305 /* Mustn't actually add anything to a symbol table.
5306 But also don't want to "initialise" any placeholder
5307 constants that might already be there into full
5308 blown PVGVs with attached PVCV. */
5309 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5310 GV_NOADD_NOINIT, SVt_PVCV);
5315 /* if we saw a global override before, get the right name */
5318 sv = newSVpvs("CORE::GLOBAL::");
5319 sv_catpv(sv,PL_tokenbuf);
5322 /* If len is 0, newSVpv does strlen(), which is correct.
5323 If len is non-zero, then it will be the true length,
5324 and so the scalar will be created correctly. */
5325 sv = newSVpv(PL_tokenbuf,len);
5328 if (PL_madskills && !PL_thistoken) {
5329 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5330 PL_thistoken = newSVpv(start,s - start);
5331 PL_realtokenstart = s - SvPVX(PL_linestr);
5335 /* Presume this is going to be a bareword of some sort. */
5338 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5339 yylval.opval->op_private = OPpCONST_BARE;
5340 /* UTF-8 package name? */
5341 if (UTF && !IN_BYTES &&
5342 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5345 /* And if "Foo::", then that's what it certainly is. */
5350 /* Do the explicit type check so that we don't need to force
5351 the initialisation of the symbol table to have a real GV.
5352 Beware - gv may not really be a PVGV, cv may not really be
5353 a PVCV, (because of the space optimisations that gv_init
5354 understands) But they're true if for this symbol there is
5355 respectively a typeglob and a subroutine.
5357 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5358 /* Real typeglob, so get the real subroutine: */
5360 /* A proxy for a subroutine in this package? */
5361 : SvOK(gv) ? (CV *) gv : NULL)
5364 /* See if it's the indirect object for a list operator. */
5366 if (PL_oldoldbufptr &&
5367 PL_oldoldbufptr < PL_bufptr &&
5368 (PL_oldoldbufptr == PL_last_lop
5369 || PL_oldoldbufptr == PL_last_uni) &&
5370 /* NO SKIPSPACE BEFORE HERE! */
5371 (PL_expect == XREF ||
5372 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5374 bool immediate_paren = *s == '(';
5376 /* (Now we can afford to cross potential line boundary.) */
5377 s = SKIPSPACE2(s,nextPL_nextwhite);
5379 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5382 /* Two barewords in a row may indicate method call. */
5384 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5385 (tmp = intuit_method(s, gv, cv)))
5388 /* If not a declared subroutine, it's an indirect object. */
5389 /* (But it's an indir obj regardless for sort.) */
5390 /* Also, if "_" follows a filetest operator, it's a bareword */
5393 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5395 (PL_last_lop_op != OP_MAPSTART &&
5396 PL_last_lop_op != OP_GREPSTART))))
5397 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5398 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5401 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5406 PL_expect = XOPERATOR;
5409 s = SKIPSPACE2(s,nextPL_nextwhite);
5410 PL_nextwhite = nextPL_nextwhite;
5415 /* Is this a word before a => operator? */
5416 if (*s == '=' && s[1] == '>' && !pkgname) {
5418 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5419 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5420 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5424 /* If followed by a paren, it's certainly a subroutine. */
5429 while (SPACE_OR_TAB(*d))
5431 if (*d == ')' && (sv = gv_const_sv(gv))) {
5435 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5436 sv_catpvn(PL_thistoken, par, s - par);
5438 sv_free(PL_nextwhite);
5449 PL_nextwhite = PL_thiswhite;
5452 start_force(PL_curforce);
5454 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5455 PL_expect = XOPERATOR;
5458 PL_nextwhite = nextPL_nextwhite;
5459 curmad('X', PL_thistoken);
5460 PL_thistoken = newSVpvs("");
5468 /* If followed by var or block, call it a method (unless sub) */
5470 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5471 PL_last_lop = PL_oldbufptr;
5472 PL_last_lop_op = OP_METHOD;
5476 /* If followed by a bareword, see if it looks like indir obj. */
5479 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5480 && (tmp = intuit_method(s, gv, cv)))
5483 /* Not a method, so call it a subroutine (if defined) */
5486 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5487 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5488 "Ambiguous use of -%s resolved as -&%s()",
5489 PL_tokenbuf, PL_tokenbuf);
5490 /* Check for a constant sub */
5491 if ((sv = gv_const_sv(gv)) && !PL_madskills) {
5493 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5494 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5495 yylval.opval->op_private = 0;
5499 /* Resolve to GV now. */
5500 if (SvTYPE(gv) != SVt_PVGV) {
5501 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5502 assert (SvTYPE(gv) == SVt_PVGV);
5503 /* cv must have been some sort of placeholder, so
5504 now needs replacing with a real code reference. */
5508 op_free(yylval.opval);
5509 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5510 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5511 PL_last_lop = PL_oldbufptr;
5512 PL_last_lop_op = OP_ENTERSUB;
5513 /* Is there a prototype? */
5521 const char *proto = SvPV_const((SV*)cv, protolen);
5524 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5526 while (*proto == ';')
5528 if (*proto == '&' && *s == '{') {
5529 sv_setpv(PL_subname,
5532 "__ANON__" : "__ANON__::__ANON__"));
5539 PL_nextwhite = PL_thiswhite;
5542 start_force(PL_curforce);
5543 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5546 PL_nextwhite = nextPL_nextwhite;
5547 curmad('X', PL_thistoken);
5548 PL_thistoken = newSVpvs("");
5555 /* Guess harder when madskills require "best effort". */
5556 if (PL_madskills && (!gv || !GvCVu(gv))) {
5557 int probable_sub = 0;
5558 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5560 else if (isALPHA(*s)) {
5564 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5565 if (!keyword(tmpbuf, tmplen, 0))
5568 while (d < PL_bufend && isSPACE(*d))
5570 if (*d == '=' && d[1] == '>')
5575 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5576 op_free(yylval.opval);
5577 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5578 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5579 PL_last_lop = PL_oldbufptr;
5580 PL_last_lop_op = OP_ENTERSUB;
5581 PL_nextwhite = PL_thiswhite;
5583 start_force(PL_curforce);
5584 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5586 PL_nextwhite = nextPL_nextwhite;
5587 curmad('X', PL_thistoken);
5588 PL_thistoken = newSVpvs("");
5593 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5600 /* Call it a bare word */
5602 if (PL_hints & HINT_STRICT_SUBS)
5603 yylval.opval->op_private |= OPpCONST_STRICT;
5606 if (lastchar != '-') {
5607 if (ckWARN(WARN_RESERVED)) {
5611 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5612 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5619 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5620 && ckWARN_d(WARN_AMBIGUOUS)) {
5621 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5622 "Operator or semicolon missing before %c%s",
5623 lastchar, PL_tokenbuf);
5624 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5625 "Ambiguous use of %c resolved as operator %c",
5626 lastchar, lastchar);
5632 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5633 newSVpv(CopFILE(PL_curcop),0));
5637 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5638 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5641 case KEY___PACKAGE__:
5642 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5644 ? newSVhek(HvNAME_HEK(PL_curstash))
5651 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5652 const char *pname = "main";
5653 if (PL_tokenbuf[2] == 'D')
5654 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5655 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5659 GvIOp(gv) = newIO();
5660 IoIFP(GvIOp(gv)) = PL_rsfp;
5661 #if defined(HAS_FCNTL) && defined(F_SETFD)
5663 const int fd = PerlIO_fileno(PL_rsfp);
5664 fcntl(fd,F_SETFD,fd >= 3);
5667 /* Mark this internal pseudo-handle as clean */
5668 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5670 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5671 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5672 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5674 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5675 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5676 /* if the script was opened in binmode, we need to revert
5677 * it to text mode for compatibility; but only iff it has CRs
5678 * XXX this is a questionable hack at best. */
5679 if (PL_bufend-PL_bufptr > 2
5680 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5683 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5684 loc = PerlIO_tell(PL_rsfp);
5685 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5688 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5690 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5691 #endif /* NETWARE */
5692 #ifdef PERLIO_IS_STDIO /* really? */
5693 # if defined(__BORLANDC__)
5694 /* XXX see note in do_binmode() */
5695 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5699 PerlIO_seek(PL_rsfp, loc, 0);
5703 #ifdef PERLIO_LAYERS
5706 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5707 else if (PL_encoding) {
5714 XPUSHs(PL_encoding);
5716 call_method("name", G_SCALAR);
5720 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5721 Perl_form(aTHX_ ":encoding(%"SVf")",
5730 if (PL_realtokenstart >= 0) {
5731 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5733 PL_endwhite = newSVpvs("");
5734 sv_catsv(PL_endwhite, PL_thiswhite);
5736 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5737 PL_realtokenstart = -1;
5739 while ((s = filter_gets(PL_endwhite, PL_rsfp,
5740 SvCUR(PL_endwhite))) != Nullch) ;
5755 if (PL_expect == XSTATE) {
5762 if (*s == ':' && s[1] == ':') {
5765 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5766 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5767 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5770 else if (tmp == KEY_require || tmp == KEY_do)
5771 /* that's a way to remember we saw "CORE::" */
5784 LOP(OP_ACCEPT,XTERM);
5790 LOP(OP_ATAN2,XTERM);
5796 LOP(OP_BINMODE,XTERM);
5799 LOP(OP_BLESS,XTERM);
5808 /* When 'use switch' is in effect, continue has a dual
5809 life as a control operator. */
5811 if (!FEATURE_IS_ENABLED("switch"))
5814 /* We have to disambiguate the two senses of
5815 "continue". If the next token is a '{' then
5816 treat it as the start of a continue block;
5817 otherwise treat it as a control operator.
5829 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5846 if (!PL_cryptseen) {
5847 PL_cryptseen = TRUE;
5851 LOP(OP_CRYPT,XTERM);
5854 LOP(OP_CHMOD,XTERM);
5857 LOP(OP_CHOWN,XTERM);
5860 LOP(OP_CONNECT,XTERM);
5879 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5880 if (orig_keyword == KEY_do) {
5889 PL_hints |= HINT_BLOCK_SCOPE;
5899 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5900 LOP(OP_DBMOPEN,XTERM);
5906 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5913 yylval.ival = CopLINE(PL_curcop);
5929 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5930 UNIBRACK(OP_ENTEREVAL);
5948 case KEY_endhostent:
5954 case KEY_endservent:
5957 case KEY_endprotoent:
5968 yylval.ival = CopLINE(PL_curcop);
5970 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5973 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5976 if ((PL_bufend - p) >= 3 &&
5977 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5979 else if ((PL_bufend - p) >= 4 &&
5980 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5983 if (isIDFIRST_lazy_if(p,UTF)) {
5984 p = scan_ident(p, PL_bufend,
5985 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5989 Perl_croak(aTHX_ "Missing $ on loop variable");
5991 s = SvPVX(PL_linestr) + soff;
5997 LOP(OP_FORMLINE,XTERM);
6003 LOP(OP_FCNTL,XTERM);
6009 LOP(OP_FLOCK,XTERM);
6018 LOP(OP_GREPSTART, XREF);
6021 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6036 case KEY_getpriority:
6037 LOP(OP_GETPRIORITY,XTERM);
6039 case KEY_getprotobyname:
6042 case KEY_getprotobynumber:
6043 LOP(OP_GPBYNUMBER,XTERM);
6045 case KEY_getprotoent:
6057 case KEY_getpeername:
6058 UNI(OP_GETPEERNAME);
6060 case KEY_gethostbyname:
6063 case KEY_gethostbyaddr:
6064 LOP(OP_GHBYADDR,XTERM);
6066 case KEY_gethostent:
6069 case KEY_getnetbyname:
6072 case KEY_getnetbyaddr:
6073 LOP(OP_GNBYADDR,XTERM);
6078 case KEY_getservbyname:
6079 LOP(OP_GSBYNAME,XTERM);
6081 case KEY_getservbyport:
6082 LOP(OP_GSBYPORT,XTERM);
6084 case KEY_getservent:
6087 case KEY_getsockname:
6088 UNI(OP_GETSOCKNAME);
6090 case KEY_getsockopt:
6091 LOP(OP_GSOCKOPT,XTERM);
6106 yylval.ival = CopLINE(PL_curcop);
6117 yylval.ival = CopLINE(PL_curcop);
6121 LOP(OP_INDEX,XTERM);
6127 LOP(OP_IOCTL,XTERM);
6139 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6171 LOP(OP_LISTEN,XTERM);
6180 s = scan_pat(s,OP_MATCH);
6181 TERM(sublex_start());
6184 LOP(OP_MAPSTART, XREF);
6187 LOP(OP_MKDIR,XTERM);
6190 LOP(OP_MSGCTL,XTERM);
6193 LOP(OP_MSGGET,XTERM);
6196 LOP(OP_MSGRCV,XTERM);
6199 LOP(OP_MSGSND,XTERM);
6204 PL_in_my = (U16)tmp;
6206 if (isIDFIRST_lazy_if(s,UTF)) {
6210 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6211 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6213 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6214 if (!PL_in_my_stash) {
6217 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6221 if (PL_madskills) { /* just add type to declarator token */
6222 sv_catsv(PL_thistoken, PL_nextwhite);
6224 sv_catpvn(PL_thistoken, start, s - start);
6232 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6239 s = tokenize_use(0, s);
6243 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6250 if (isIDFIRST_lazy_if(s,UTF)) {
6252 for (d = s; isALNUM_lazy_if(d,UTF);)
6254 for (t=d; isSPACE(*t);)
6256 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6258 && !(t[0] == '=' && t[1] == '>')
6260 int parms_len = (int)(d-s);
6261 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6262 "Precedence problem: open %.*s should be open(%.*s)",
6263 parms_len, s, parms_len, s);
6269 yylval.ival = OP_OR;
6279 LOP(OP_OPEN_DIR,XTERM);
6282 checkcomma(s,PL_tokenbuf,"filehandle");
6286 checkcomma(s,PL_tokenbuf,"filehandle");
6305 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6309 LOP(OP_PIPE_OP,XTERM);
6312 s = scan_str(s,!!PL_madskills,FALSE);
6315 yylval.ival = OP_CONST;
6316 TERM(sublex_start());
6322 s = scan_str(s,!!PL_madskills,FALSE);
6325 PL_expect = XOPERATOR;
6327 if (SvCUR(PL_lex_stuff)) {
6330 d = SvPV_force(PL_lex_stuff, len);
6332 for (; isSPACE(*d) && len; --len, ++d)
6337 if (!warned && ckWARN(WARN_QW)) {
6338 for (; !isSPACE(*d) && len; --len, ++d) {
6340 Perl_warner(aTHX_ packWARN(WARN_QW),
6341 "Possible attempt to separate words with commas");
6344 else if (*d == '#') {
6345 Perl_warner(aTHX_ packWARN(WARN_QW),
6346 "Possible attempt to put comments in qw() list");
6352 for (; !isSPACE(*d) && len; --len, ++d)
6355 sv = newSVpvn(b, d-b);
6356 if (DO_UTF8(PL_lex_stuff))
6358 words = append_elem(OP_LIST, words,
6359 newSVOP(OP_CONST, 0, tokeq(sv)));
6363 start_force(PL_curforce);
6364 NEXTVAL_NEXTTOKE.opval = words;
6369 SvREFCNT_dec(PL_lex_stuff);
6370 PL_lex_stuff = NULL;
6376 s = scan_str(s,!!PL_madskills,FALSE);
6379 yylval.ival = OP_STRINGIFY;
6380 if (SvIVX(PL_lex_stuff) == '\'')
6381 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6382 TERM(sublex_start());
6385 s = scan_pat(s,OP_QR);
6386 TERM(sublex_start());
6389 s = scan_str(s,!!PL_madskills,FALSE);
6392 readpipe_override();
6393 TERM(sublex_start());
6401 s = force_version(s, FALSE);
6403 else if (*s != 'v' || !isDIGIT(s[1])
6404 || (s = force_version(s, TRUE), *s == 'v'))
6406 *PL_tokenbuf = '\0';
6407 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6408 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6409 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6411 yyerror("<> should be quotes");
6413 if (orig_keyword == KEY_require) {
6421 PL_last_uni = PL_oldbufptr;
6422 PL_last_lop_op = OP_REQUIRE;
6424 return REPORT( (int)REQUIRE );
6430 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6434 LOP(OP_RENAME,XTERM);
6443 LOP(OP_RINDEX,XTERM);
6453 UNIDOR(OP_READLINE);
6457 UNIDOR(OP_BACKTICK);
6466 LOP(OP_REVERSE,XTERM);
6469 UNIDOR(OP_READLINK);
6477 TERM(sublex_start());
6479 TOKEN(1); /* force error */
6482 checkcomma(s,PL_tokenbuf,"filehandle");
6492 LOP(OP_SELECT,XTERM);
6498 LOP(OP_SEMCTL,XTERM);
6501 LOP(OP_SEMGET,XTERM);
6504 LOP(OP_SEMOP,XTERM);
6510 LOP(OP_SETPGRP,XTERM);
6512 case KEY_setpriority:
6513 LOP(OP_SETPRIORITY,XTERM);
6515 case KEY_sethostent:
6521 case KEY_setservent:
6524 case KEY_setprotoent:
6534 LOP(OP_SEEKDIR,XTERM);
6536 case KEY_setsockopt:
6537 LOP(OP_SSOCKOPT,XTERM);
6543 LOP(OP_SHMCTL,XTERM);
6546 LOP(OP_SHMGET,XTERM);
6549 LOP(OP_SHMREAD,XTERM);
6552 LOP(OP_SHMWRITE,XTERM);
6555 LOP(OP_SHUTDOWN,XTERM);
6564 LOP(OP_SOCKET,XTERM);
6566 case KEY_socketpair:
6567 LOP(OP_SOCKPAIR,XTERM);
6570 checkcomma(s,PL_tokenbuf,"subroutine name");
6572 if (*s == ';' || *s == ')') /* probably a close */
6573 Perl_croak(aTHX_ "sort is now a reserved word");
6575 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6579 LOP(OP_SPLIT,XTERM);
6582 LOP(OP_SPRINTF,XTERM);
6585 LOP(OP_SPLICE,XTERM);
6600 LOP(OP_SUBSTR,XTERM);
6606 char tmpbuf[sizeof PL_tokenbuf];
6607 SSize_t tboffset = 0;
6608 expectation attrful;
6609 bool have_name, have_proto;
6610 const int key = tmp;
6615 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6616 SV *subtoken = newSVpvn(tstart, s - tstart);
6620 s = SKIPSPACE2(s,tmpwhite);
6625 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6626 (*s == ':' && s[1] == ':'))
6633 attrful = XATTRBLOCK;
6634 /* remember buffer pos'n for later force_word */
6635 tboffset = s - PL_oldbufptr;
6636 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6639 nametoke = newSVpvn(s, d - s);
6641 if (memchr(tmpbuf, ':', len))
6642 sv_setpvn(PL_subname, tmpbuf, len);
6644 sv_setsv(PL_subname,PL_curstname);
6645 sv_catpvs(PL_subname,"::");
6646 sv_catpvn(PL_subname,tmpbuf,len);
6653 CURMAD('X', nametoke);
6654 CURMAD('_', tmpwhite);
6655 (void) force_word(PL_oldbufptr + tboffset, WORD,
6658 s = SKIPSPACE2(d,tmpwhite);
6665 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6666 PL_expect = XTERMBLOCK;
6667 attrful = XATTRTERM;
6668 sv_setpvn(PL_subname,"?",1);
6672 if (key == KEY_format) {
6674 PL_lex_formbrack = PL_lex_brackets + 1;
6676 PL_thistoken = subtoken;
6680 (void) force_word(PL_oldbufptr + tboffset, WORD,
6686 /* Look for a prototype */
6689 bool bad_proto = FALSE;
6690 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6692 s = scan_str(s,!!PL_madskills,FALSE);
6694 Perl_croak(aTHX_ "Prototype not terminated");
6695 /* strip spaces and check for bad characters */
6696 d = SvPVX(PL_lex_stuff);
6698 for (p = d; *p; ++p) {
6701 if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
6707 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6708 "Illegal character in prototype for %"SVf" : %s",
6709 SVfARG(PL_subname), d);
6710 SvCUR_set(PL_lex_stuff, tmp);
6715 CURMAD('q', PL_thisopen);
6716 CURMAD('_', tmpwhite);
6717 CURMAD('=', PL_thisstuff);
6718 CURMAD('Q', PL_thisclose);
6719 NEXTVAL_NEXTTOKE.opval =
6720 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6721 PL_lex_stuff = Nullsv;
6724 s = SKIPSPACE2(s,tmpwhite);
6732 if (*s == ':' && s[1] != ':')
6733 PL_expect = attrful;
6734 else if (*s != '{' && key == KEY_sub) {
6736 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6738 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6745 curmad('^', newSVpvs(""));
6746 CURMAD('_', tmpwhite);
6750 PL_thistoken = subtoken;
6753 NEXTVAL_NEXTTOKE.opval =
6754 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6755 PL_lex_stuff = NULL;
6760 sv_setpv(PL_subname,
6762 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
6766 (void) force_word(PL_oldbufptr + tboffset, WORD,
6776 LOP(OP_SYSTEM,XREF);
6779 LOP(OP_SYMLINK,XTERM);
6782 LOP(OP_SYSCALL,XTERM);
6785 LOP(OP_SYSOPEN,XTERM);
6788 LOP(OP_SYSSEEK,XTERM);
6791 LOP(OP_SYSREAD,XTERM);
6794 LOP(OP_SYSWRITE,XTERM);
6798 TERM(sublex_start());
6819 LOP(OP_TRUNCATE,XTERM);
6831 yylval.ival = CopLINE(PL_curcop);
6835 yylval.ival = CopLINE(PL_curcop);
6839 LOP(OP_UNLINK,XTERM);
6845 LOP(OP_UNPACK,XTERM);
6848 LOP(OP_UTIME,XTERM);
6854 LOP(OP_UNSHIFT,XTERM);
6857 s = tokenize_use(1, s);
6867 yylval.ival = CopLINE(PL_curcop);
6871 yylval.ival = CopLINE(PL_curcop);
6875 PL_hints |= HINT_BLOCK_SCOPE;
6882 LOP(OP_WAITPID,XTERM);
6891 ctl_l[0] = toCTRL('L');
6893 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6896 /* Make sure $^L is defined */
6897 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6902 if (PL_expect == XOPERATOR)
6908 yylval.ival = OP_XOR;
6913 TERM(sublex_start());
6918 #pragma segment Main
6922 S_pending_ident(pTHX)
6927 /* pit holds the identifier we read and pending_ident is reset */
6928 char pit = PL_pending_ident;
6929 PL_pending_ident = 0;
6931 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6932 DEBUG_T({ PerlIO_printf(Perl_debug_log,
6933 "### Pending identifier '%s'\n", PL_tokenbuf); });
6935 /* if we're in a my(), we can't allow dynamics here.
6936 $foo'bar has already been turned into $foo::bar, so
6937 just check for colons.
6939 if it's a legal name, the OP is a PADANY.
6942 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
6943 if (strchr(PL_tokenbuf,':'))
6944 yyerror(Perl_form(aTHX_ "No package name allowed for "
6945 "variable %s in \"our\"",
6947 tmp = allocmy(PL_tokenbuf);
6950 if (strchr(PL_tokenbuf,':'))
6951 yyerror(Perl_form(aTHX_ PL_no_myglob,
6952 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
6954 yylval.opval = newOP(OP_PADANY, 0);
6955 yylval.opval->op_targ = allocmy(PL_tokenbuf);
6961 build the ops for accesses to a my() variable.
6963 Deny my($a) or my($b) in a sort block, *if* $a or $b is
6964 then used in a comparison. This catches most, but not
6965 all cases. For instance, it catches
6966 sort { my($a); $a <=> $b }
6968 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6969 (although why you'd do that is anyone's guess).
6972 if (!strchr(PL_tokenbuf,':')) {
6974 tmp = pad_findmy(PL_tokenbuf);
6975 if (tmp != NOT_IN_PAD) {
6976 /* might be an "our" variable" */
6977 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6978 /* build ops for a bareword */
6979 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
6980 HEK * const stashname = HvNAME_HEK(stash);
6981 SV * const sym = newSVhek(stashname);
6982 sv_catpvs(sym, "::");
6983 sv_catpv(sym, PL_tokenbuf+1);
6984 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6985 yylval.opval->op_private = OPpCONST_ENTERED;
6988 ? (GV_ADDMULTI | GV_ADDINEVAL)
6991 ((PL_tokenbuf[0] == '$') ? SVt_PV
6992 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6997 /* if it's a sort block and they're naming $a or $b */
6998 if (PL_last_lop_op == OP_SORT &&
6999 PL_tokenbuf[0] == '$' &&
7000 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
7003 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
7004 d < PL_bufend && *d != '\n';
7007 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
7008 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
7014 yylval.opval = newOP(OP_PADANY, 0);
7015 yylval.opval->op_targ = tmp;
7021 Whine if they've said @foo in a doublequoted string,
7022 and @foo isn't a variable we can find in the symbol
7025 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
7026 GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
7027 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
7028 && ckWARN(WARN_AMBIGUOUS)
7029 /* DO NOT warn for @- and @+ */
7030 && !( PL_tokenbuf[2] == '\0' &&
7031 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
7034 /* Downgraded from fatal to warning 20000522 mjd */
7035 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7036 "Possible unintended interpolation of %s in string",
7041 /* build ops for a bareword */
7042 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
7043 yylval.opval->op_private = OPpCONST_ENTERED;
7046 /* If the identifier refers to a stash, don't autovivify it.
7047 * Change 24660 had the side effect of causing symbol table
7048 * hashes to always be defined, even if they were freshly
7049 * created and the only reference in the entire program was
7050 * the single statement with the defined %foo::bar:: test.
7051 * It appears that all code in the wild doing this actually
7052 * wants to know whether sub-packages have been loaded, so
7053 * by avoiding auto-vivifying symbol tables, we ensure that
7054 * defined %foo::bar:: continues to be false, and the existing
7055 * tests still give the expected answers, even though what
7056 * they're actually testing has now changed subtly.
7058 (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
7060 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7061 ((PL_tokenbuf[0] == '$') ? SVt_PV
7062 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7068 * The following code was generated by perl_keyword.pl.
7072 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7077 case 1: /* 5 tokens of length 1 */
7109 case 2: /* 18 tokens of length 2 */
7255 case 3: /* 29 tokens of length 3 */
7259 if (name[1] == 'N' &&
7322 if (name[1] == 'i' &&
7344 return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7362 if (name[1] == 'o' &&
7371 if (name[1] == 'e' &&
7380 if (name[1] == 'n' &&
7389 if (name[1] == 'o' &&
7398 if (name[1] == 'a' &&
7407 if (name[1] == 'o' &&
7469 if (name[1] == 'e' &&
7483 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7509 if (name[1] == 'i' &&
7518 if (name[1] == 's' &&
7527 if (name[1] == 'e' &&
7536 if (name[1] == 'o' &&
7548 case 4: /* 41 tokens of length 4 */
7552 if (name[1] == 'O' &&
7562 if (name[1] == 'N' &&
7572 if (name[1] == 'i' &&
7582 if (name[1] == 'h' &&
7592 if (name[1] == 'u' &&
7605 if (name[2] == 'c' &&
7614 if (name[2] == 's' &&
7623 if (name[2] == 'a' &&
7659 if (name[1] == 'o' &&
7672 if (name[2] == 't' &&
7681 if (name[2] == 'o' &&
7690 if (name[2] == 't' &&
7699 if (name[2] == 'e' &&
7712 if (name[1] == 'o' &&
7725 if (name[2] == 'y' &&
7734 if (name[2] == 'l' &&
7750 if (name[2] == 's' &&
7759 if (name[2] == 'n' &&
7768 if (name[2] == 'c' &&
7781 if (name[1] == 'e' &&
7791 if (name[1] == 'p' &&
7804 if (name[2] == 'c' &&
7813 if (name[2] == 'p' &&
7822 if (name[2] == 's' &&
7838 if (name[2] == 'n' &&
7908 if (name[2] == 'r' &&
7917 if (name[2] == 'r' &&
7926 if (name[2] == 'a' &&
7942 if (name[2] == 'l' &&
8004 if (name[2] == 'e' &&
8007 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
8020 case 5: /* 39 tokens of length 5 */
8024 if (name[1] == 'E' &&
8035 if (name[1] == 'H' &&
8049 if (name[2] == 'a' &&
8059 if (name[2] == 'a' &&
8076 if (name[2] == 'e' &&
8086 if (name[2] == 'e' &&
8090 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8106 if (name[3] == 'i' &&
8115 if (name[3] == 'o' &&
8151 if (name[2] == 'o' &&
8161 if (name[2] == 'y' &&
8175 if (name[1] == 'l' &&
8189 if (name[2] == 'n' &&
8199 if (name[2] == 'o' &&
8213 if (name[1] == 'i' &&
8218 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8227 if (name[2] == 'd' &&
8237 if (name[2] == 'c' &&
8254 if (name[2] == 'c' &&
8264 if (name[2] == 't' &&
8278 if (name[1] == 'k' &&
8289 if (name[1] == 'r' &&
8303 if (name[2] == 's' &&
8313 if (name[2] == 'd' &&
8330 if (name[2] == 'm' &&
8340 if (name[2] == 'i' &&
8350 if (name[2] == 'e' &&
8360 if (name[2] == 'l' &&
8370 if (name[2] == 'a' &&
8383 if (name[3] == 't' &&
8386 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8392 if (name[3] == 'd' &&
8409 if (name[1] == 'i' &&
8423 if (name[2] == 'a' &&
8436 if (name[3] == 'e' &&
8471 if (name[2] == 'i' &&
8488 if (name[2] == 'i' &&
8498 if (name[2] == 'i' &&
8515 case 6: /* 33 tokens of length 6 */
8519 if (name[1] == 'c' &&
8534 if (name[2] == 'l' &&
8545 if (name[2] == 'r' &&
8560 if (name[1] == 'e' &&
8575 if (name[2] == 's' &&
8580 if(ckWARN_d(WARN_SYNTAX))
8581 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8587 if (name[2] == 'i' &&
8605 if (name[2] == 'l' &&
8616 if (name[2] == 'r' &&
8631 if (name[1] == 'm' &&
8646 if (name[2] == 'n' &&
8657 if (name[2] == 's' &&
8672 if (name[1] == 's' &&
8678 if (name[4] == 't' &&
8687 if (name[4] == 'e' &&
8696 if (name[4] == 'c' &&
8705 if (name[4] == 'n' &&
8721 if (name[1] == 'r' &&
8739 if (name[3] == 'a' &&
8749 if (name[3] == 'u' &&
8763 if (name[2] == 'n' &&
8781 if (name[2] == 'a' &&
8795 if (name[3] == 'e' &&
8808 if (name[4] == 't' &&
8817 if (name[4] == 'e' &&
8839 if (name[4] == 't' &&
8848 if (name[4] == 'e' &&
8864 if (name[2] == 'c' &&
8875 if (name[2] == 'l' &&
8886 if (name[2] == 'b' &&
8897 if (name[2] == 's' &&
8920 if (name[4] == 's' &&
8929 if (name[4] == 'n' &&
8942 if (name[3] == 'a' &&
8959 if (name[1] == 'a' &&
8974 case 7: /* 29 tokens of length 7 */
8978 if (name[1] == 'E' &&
8991 if (name[1] == '_' &&
9004 if (name[1] == 'i' &&
9011 return -KEY_binmode;
9017 if (name[1] == 'o' &&
9024 return -KEY_connect;
9033 if (name[2] == 'm' &&
9039 return -KEY_dbmopen;
9050 if (name[4] == 'u' &&
9054 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9060 if (name[4] == 'n' &&
9081 if (name[1] == 'o' &&
9094 if (name[1] == 'e' &&
9101 if (name[5] == 'r' &&
9104 return -KEY_getpgrp;
9110 if (name[5] == 'i' &&
9113 return -KEY_getppid;
9126 if (name[1] == 'c' &&
9133 return -KEY_lcfirst;
9139 if (name[1] == 'p' &&
9146 return -KEY_opendir;
9152 if (name[1] == 'a' &&
9170 if (name[3] == 'd' &&
9175 return -KEY_readdir;
9181 if (name[3] == 'u' &&
9192 if (name[3] == 'e' &&
9197 return -KEY_reverse;
9216 if (name[3] == 'k' &&
9221 return -KEY_seekdir;
9227 if (name[3] == 'p' &&
9232 return -KEY_setpgrp;
9242 if (name[2] == 'm' &&
9248 return -KEY_shmread;
9254 if (name[2] == 'r' &&
9260 return -KEY_sprintf;
9269 if (name[3] == 'l' &&
9274 return -KEY_symlink;
9283 if (name[4] == 'a' &&
9287 return -KEY_syscall;
9293 if (name[4] == 'p' &&
9297 return -KEY_sysopen;
9303 if (name[4] == 'e' &&
9307 return -KEY_sysread;
9313 if (name[4] == 'e' &&
9317 return -KEY_sysseek;
9335 if (name[1] == 'e' &&
9342 return -KEY_telldir;
9351 if (name[2] == 'f' &&
9357 return -KEY_ucfirst;
9363 if (name[2] == 's' &&
9369 return -KEY_unshift;
9379 if (name[1] == 'a' &&
9386 return -KEY_waitpid;
9395 case 8: /* 26 tokens of length 8 */
9399 if (name[1] == 'U' &&
9407 return KEY_AUTOLOAD;
9418 if (name[3] == 'A' &&
9424 return KEY___DATA__;
9430 if (name[3] == 'I' &&
9436 return -KEY___FILE__;
9442 if (name[3] == 'I' &&
9448 return -KEY___LINE__;
9464 if (name[2] == 'o' &&
9471 return -KEY_closedir;
9477 if (name[2] == 'n' &&
9484 return -KEY_continue;
9494 if (name[1] == 'b' &&
9502 return -KEY_dbmclose;
9508 if (name[1] == 'n' &&
9514 if (name[4] == 'r' &&
9519 return -KEY_endgrent;
9525 if (name[4] == 'w' &&
9530 return -KEY_endpwent;
9543 if (name[1] == 'o' &&
9551 return -KEY_formline;
9557 if (name[1] == 'e' &&
9568 if (name[6] == 'n' &&
9571 return -KEY_getgrent;
9577 if (name[6] == 'i' &&
9580 return -KEY_getgrgid;
9586 if (name[6] == 'a' &&
9589 return -KEY_getgrnam;
9602 if (name[4] == 'o' &&
9607 return -KEY_getlogin;
9618 if (name[6] == 'n' &&
9621 return -KEY_getpwent;
9627 if (name[6] == 'a' &&
9630 return -KEY_getpwnam;
9636 if (name[6] == 'i' &&
9639 return -KEY_getpwuid;
9659 if (name[1] == 'e' &&
9666 if (name[5] == 'i' &&
9673 return -KEY_readline;
9678 return -KEY_readlink;
9689 if (name[5] == 'i' &&
9693 return -KEY_readpipe;
9714 if (name[4] == 'r' &&
9719 return -KEY_setgrent;
9725 if (name[4] == 'w' &&
9730 return -KEY_setpwent;
9746 if (name[3] == 'w' &&
9752 return -KEY_shmwrite;
9758 if (name[3] == 't' &&
9764 return -KEY_shutdown;
9774 if (name[2] == 's' &&
9781 return -KEY_syswrite;
9791 if (name[1] == 'r' &&
9799 return -KEY_truncate;
9808 case 9: /* 9 tokens of length 9 */
9812 if (name[1] == 'N' &&
9821 return KEY_UNITCHECK;
9827 if (name[1] == 'n' &&
9836 return -KEY_endnetent;
9842 if (name[1] == 'e' &&
9851 return -KEY_getnetent;
9857 if (name[1] == 'o' &&
9866 return -KEY_localtime;
9872 if (name[1] == 'r' &&
9881 return KEY_prototype;
9887 if (name[1] == 'u' &&
9896 return -KEY_quotemeta;
9902 if (name[1] == 'e' &&
9911 return -KEY_rewinddir;
9917 if (name[1] == 'e' &&
9926 return -KEY_setnetent;
9932 if (name[1] == 'a' &&
9941 return -KEY_wantarray;
9950 case 10: /* 9 tokens of length 10 */
9954 if (name[1] == 'n' &&
9960 if (name[4] == 'o' &&
9967 return -KEY_endhostent;
9973 if (name[4] == 'e' &&
9980 return -KEY_endservent;
9993 if (name[1] == 'e' &&
9999 if (name[4] == 'o' &&
10006 return -KEY_gethostent;
10015 if (name[5] == 'r' &&
10021 return -KEY_getservent;
10027 if (name[5] == 'c' &&
10033 return -KEY_getsockopt;
10053 if (name[2] == 't')
10058 if (name[4] == 'o' &&
10065 return -KEY_sethostent;
10074 if (name[5] == 'r' &&
10080 return -KEY_setservent;
10086 if (name[5] == 'c' &&
10092 return -KEY_setsockopt;
10109 if (name[2] == 'c' &&
10118 return -KEY_socketpair;
10131 case 11: /* 8 tokens of length 11 */
10135 if (name[1] == '_' &&
10145 { /* __PACKAGE__ */
10146 return -KEY___PACKAGE__;
10152 if (name[1] == 'n' &&
10162 { /* endprotoent */
10163 return -KEY_endprotoent;
10169 if (name[1] == 'e' &&
10178 if (name[5] == 'e' &&
10184 { /* getpeername */
10185 return -KEY_getpeername;
10194 if (name[6] == 'o' &&
10199 { /* getpriority */
10200 return -KEY_getpriority;
10206 if (name[6] == 't' &&
10211 { /* getprotoent */
10212 return -KEY_getprotoent;
10226 if (name[4] == 'o' &&
10233 { /* getsockname */
10234 return -KEY_getsockname;
10247 if (name[1] == 'e' &&
10255 if (name[6] == 'o' &&
10260 { /* setpriority */
10261 return -KEY_setpriority;
10267 if (name[6] == 't' &&
10272 { /* setprotoent */
10273 return -KEY_setprotoent;
10289 case 12: /* 2 tokens of length 12 */
10290 if (name[0] == 'g' &&
10302 if (name[9] == 'd' &&
10305 { /* getnetbyaddr */
10306 return -KEY_getnetbyaddr;
10312 if (name[9] == 'a' &&
10315 { /* getnetbyname */
10316 return -KEY_getnetbyname;
10328 case 13: /* 4 tokens of length 13 */
10329 if (name[0] == 'g' &&
10336 if (name[4] == 'o' &&
10345 if (name[10] == 'd' &&
10348 { /* gethostbyaddr */
10349 return -KEY_gethostbyaddr;
10355 if (name[10] == 'a' &&
10358 { /* gethostbyname */
10359 return -KEY_gethostbyname;
10372 if (name[4] == 'e' &&
10381 if (name[10] == 'a' &&
10384 { /* getservbyname */
10385 return -KEY_getservbyname;
10391 if (name[10] == 'o' &&
10394 { /* getservbyport */
10395 return -KEY_getservbyport;
10414 case 14: /* 1 tokens of length 14 */
10415 if (name[0] == 'g' &&
10429 { /* getprotobyname */
10430 return -KEY_getprotobyname;
10435 case 16: /* 1 tokens of length 16 */
10436 if (name[0] == 'g' &&
10452 { /* getprotobynumber */
10453 return -KEY_getprotobynumber;
10467 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10471 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10472 if (ckWARN(WARN_SYNTAX)) {
10475 for (w = s+2; *w && level; w++) {
10478 else if (*w == ')')
10481 while (isSPACE(*w))
10483 /* the list of chars below is for end of statements or
10484 * block / parens, boolean operators (&&, ||, //) and branch
10485 * constructs (or, and, if, until, unless, while, err, for).
10486 * Not a very solid hack... */
10487 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
10488 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10489 "%s (...) interpreted as function",name);
10492 while (s < PL_bufend && isSPACE(*s))
10496 while (s < PL_bufend && isSPACE(*s))
10498 if (isIDFIRST_lazy_if(s,UTF)) {
10499 const char * const w = s++;
10500 while (isALNUM_lazy_if(s,UTF))
10502 while (s < PL_bufend && isSPACE(*s))
10506 if (keyword(w, s - w, 0))
10509 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10510 if (gv && GvCVu(gv))
10512 Perl_croak(aTHX_ "No comma allowed after %s", what);
10517 /* Either returns sv, or mortalizes sv and returns a new SV*.
10518 Best used as sv=new_constant(..., sv, ...).
10519 If s, pv are NULL, calls subroutine with one argument,
10520 and type is used with error messages only. */
10523 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10527 HV * const table = GvHV(PL_hintgv); /* ^H */
10531 const char *why1 = "", *why2 = "", *why3 = "";
10533 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10536 why2 = (const char *)
10537 (strEQ(key,"charnames")
10538 ? "(possibly a missing \"use charnames ...\")"
10540 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10541 (type ? type: "undef"), why2);
10543 /* This is convoluted and evil ("goto considered harmful")
10544 * but I do not understand the intricacies of all the different
10545 * failure modes of %^H in here. The goal here is to make
10546 * the most probable error message user-friendly. --jhi */
10551 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10552 (type ? type: "undef"), why1, why2, why3);
10554 yyerror(SvPVX_const(msg));
10558 cvp = hv_fetch(table, key, strlen(key), FALSE);
10559 if (!cvp || !SvOK(*cvp)) {
10562 why3 = "} is not defined";
10565 sv_2mortal(sv); /* Parent created it permanently */
10568 pv = sv_2mortal(newSVpvn(s, len));
10570 typesv = sv_2mortal(newSVpv(type, 0));
10572 typesv = &PL_sv_undef;
10574 PUSHSTACKi(PERLSI_OVERLOAD);
10586 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10590 /* Check the eval first */
10591 if (!PL_in_eval && SvTRUE(ERRSV)) {
10592 sv_catpvs(ERRSV, "Propagated");
10593 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10595 res = SvREFCNT_inc_simple(sv);
10599 SvREFCNT_inc_simple_void(res);
10608 why1 = "Call to &{$^H{";
10610 why3 = "}} did not return a defined value";
10618 /* Returns a NUL terminated string, with the length of the string written to
10622 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10625 register char *d = dest;
10626 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10629 Perl_croak(aTHX_ ident_too_long);
10630 if (isALNUM(*s)) /* UTF handled below */
10632 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10637 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10641 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10642 char *t = s + UTF8SKIP(s);
10644 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10648 Perl_croak(aTHX_ ident_too_long);
10649 Copy(s, d, len, char);
10662 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10665 char *bracket = NULL;
10667 register char *d = dest;
10668 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10673 while (isDIGIT(*s)) {
10675 Perl_croak(aTHX_ ident_too_long);
10682 Perl_croak(aTHX_ ident_too_long);
10683 if (isALNUM(*s)) /* UTF handled below */
10685 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10690 else if (*s == ':' && s[1] == ':') {
10694 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10695 char *t = s + UTF8SKIP(s);
10696 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10698 if (d + (t - s) > e)
10699 Perl_croak(aTHX_ ident_too_long);
10700 Copy(s, d, t - s, char);
10711 if (PL_lex_state != LEX_NORMAL)
10712 PL_lex_state = LEX_INTERPENDMAYBE;
10715 if (*s == '$' && s[1] &&
10716 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10729 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10734 if (isSPACE(s[-1])) {
10736 const char ch = *s++;
10737 if (!SPACE_OR_TAB(ch)) {
10743 if (isIDFIRST_lazy_if(d,UTF)) {
10747 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10748 end += UTF8SKIP(end);
10749 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10750 end += UTF8SKIP(end);
10752 Copy(s, d, end - s, char);
10757 while ((isALNUM(*s) || *s == ':') && d < e)
10760 Perl_croak(aTHX_ ident_too_long);
10763 while (s < send && SPACE_OR_TAB(*s))
10765 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10766 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10767 const char * const brack =
10769 ((*s == '[') ? "[...]" : "{...}");
10770 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10771 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10772 funny, dest, brack, funny, dest, brack);
10775 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10779 /* Handle extended ${^Foo} variables
10780 * 1999-02-27 mjd-perl-patch@plover.com */
10781 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10785 while (isALNUM(*s) && d < e) {
10789 Perl_croak(aTHX_ ident_too_long);
10794 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10795 PL_lex_state = LEX_INTERPEND;
10798 if (PL_lex_state == LEX_NORMAL) {
10799 if (ckWARN(WARN_AMBIGUOUS) &&
10800 (keyword(dest, d - dest, 0)
10801 || get_cvn_flags(dest, d - dest, 0)))
10805 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10806 "Ambiguous use of %c{%s} resolved to %c%s",
10807 funny, dest, funny, dest);
10812 s = bracket; /* let the parser handle it */
10816 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10817 PL_lex_state = LEX_INTERPEND;
10822 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10824 PERL_UNUSED_CONTEXT;
10828 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
10829 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
10830 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
10831 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
10832 case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break;
10838 S_scan_pat(pTHX_ char *start, I32 type)
10842 char *s = scan_str(start,!!PL_madskills,FALSE);
10843 const char * const valid_flags =
10844 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10851 const char * const delimiter = skipspace(start);
10855 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10856 : "Search pattern not terminated" ));
10859 pm = (PMOP*)newPMOP(type, 0);
10860 if (PL_multi_open == '?') {
10861 /* This is the only point in the code that sets PMf_ONCE: */
10862 pm->op_pmflags |= PMf_ONCE;
10864 /* Hence it's safe to do this bit of PMOP book-keeping here, which
10865 allows us to restrict the list needed by reset to just the ??
10867 assert(type != OP_TRANS);
10869 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
10872 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0,
10875 elements = mg->mg_len / sizeof(PMOP**);
10876 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
10877 ((PMOP**)mg->mg_ptr) [elements++] = pm;
10878 mg->mg_len = elements * sizeof(PMOP**);
10879 PmopSTASH_set(pm,PL_curstash);
10885 while (*s && strchr(valid_flags, *s))
10886 pmflag(&pm->op_pmflags,*s++);
10888 if (PL_madskills && modstart != s) {
10889 SV* tmptoken = newSVpvn(modstart, s - modstart);
10890 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10893 /* issue a warning if /c is specified,but /g is not */
10894 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10895 && ckWARN(WARN_REGEXP))
10897 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
10898 "Use of /c modifier is meaningless without /g" );
10901 PL_lex_op = (OP*)pm;
10902 yylval.ival = OP_MATCH;
10907 S_scan_subst(pTHX_ char *start)
10918 yylval.ival = OP_NULL;
10920 s = scan_str(start,!!PL_madskills,FALSE);
10923 Perl_croak(aTHX_ "Substitution pattern not terminated");
10925 if (s[-1] == PL_multi_open)
10928 if (PL_madskills) {
10929 CURMAD('q', PL_thisopen);
10930 CURMAD('_', PL_thiswhite);
10931 CURMAD('E', PL_thisstuff);
10932 CURMAD('Q', PL_thisclose);
10933 PL_realtokenstart = s - SvPVX(PL_linestr);
10937 first_start = PL_multi_start;
10938 s = scan_str(s,!!PL_madskills,FALSE);
10940 if (PL_lex_stuff) {
10941 SvREFCNT_dec(PL_lex_stuff);
10942 PL_lex_stuff = NULL;
10944 Perl_croak(aTHX_ "Substitution replacement not terminated");
10946 PL_multi_start = first_start; /* so whole substitution is taken together */
10948 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10951 if (PL_madskills) {
10952 CURMAD('z', PL_thisopen);
10953 CURMAD('R', PL_thisstuff);
10954 CURMAD('Z', PL_thisclose);
10960 if (*s == EXEC_PAT_MOD) {
10964 else if (strchr(S_PAT_MODS, *s))
10965 pmflag(&pm->op_pmflags,*s++);
10971 if (PL_madskills) {
10973 curmad('m', newSVpvn(modstart, s - modstart));
10974 append_madprops(PL_thismad, (OP*)pm, 0);
10978 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10979 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10983 SV * const repl = newSVpvs("");
10985 PL_sublex_info.super_bufptr = s;
10986 PL_sublex_info.super_bufend = PL_bufend;
10988 pm->op_pmflags |= PMf_EVAL;
10990 sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10991 sv_catpvs(repl, "{");
10992 sv_catsv(repl, PL_lex_repl);
10993 if (strchr(SvPVX(PL_lex_repl), '#'))
10994 sv_catpvs(repl, "\n");
10995 sv_catpvs(repl, "}");
10997 SvREFCNT_dec(PL_lex_repl);
10998 PL_lex_repl = repl;
11001 PL_lex_op = (OP*)pm;
11002 yylval.ival = OP_SUBST;
11007 S_scan_trans(pTHX_ char *start)
11020 yylval.ival = OP_NULL;
11022 s = scan_str(start,!!PL_madskills,FALSE);
11024 Perl_croak(aTHX_ "Transliteration pattern not terminated");
11026 if (s[-1] == PL_multi_open)
11029 if (PL_madskills) {
11030 CURMAD('q', PL_thisopen);
11031 CURMAD('_', PL_thiswhite);
11032 CURMAD('E', PL_thisstuff);
11033 CURMAD('Q', PL_thisclose);
11034 PL_realtokenstart = s - SvPVX(PL_linestr);
11038 s = scan_str(s,!!PL_madskills,FALSE);
11040 if (PL_lex_stuff) {
11041 SvREFCNT_dec(PL_lex_stuff);
11042 PL_lex_stuff = NULL;
11044 Perl_croak(aTHX_ "Transliteration replacement not terminated");
11046 if (PL_madskills) {
11047 CURMAD('z', PL_thisopen);
11048 CURMAD('R', PL_thisstuff);
11049 CURMAD('Z', PL_thisclose);
11052 complement = del = squash = 0;
11059 complement = OPpTRANS_COMPLEMENT;
11062 del = OPpTRANS_DELETE;
11065 squash = OPpTRANS_SQUASH;
11074 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11075 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11076 o->op_private &= ~OPpTRANS_ALL;
11077 o->op_private |= del|squash|complement|
11078 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11079 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11082 yylval.ival = OP_TRANS;
11085 if (PL_madskills) {
11087 curmad('m', newSVpvn(modstart, s - modstart));
11088 append_madprops(PL_thismad, o, 0);
11097 S_scan_heredoc(pTHX_ register char *s)
11101 I32 op_type = OP_SCALAR;
11105 const char *found_newline;
11109 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11111 I32 stuffstart = s - SvPVX(PL_linestr);
11114 PL_realtokenstart = -1;
11119 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11123 while (SPACE_OR_TAB(*peek))
11125 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11128 s = delimcpy(d, e, s, PL_bufend, term, &len);
11138 if (!isALNUM_lazy_if(s,UTF))
11139 deprecate_old("bare << to mean <<\"\"");
11140 for (; isALNUM_lazy_if(s,UTF); s++) {
11145 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11146 Perl_croak(aTHX_ "Delimiter for here document is too long");
11149 len = d - PL_tokenbuf;
11152 if (PL_madskills) {
11153 tstart = PL_tokenbuf + !outer;
11154 PL_thisclose = newSVpvn(tstart, len - !outer);
11155 tstart = SvPVX(PL_linestr) + stuffstart;
11156 PL_thisopen = newSVpvn(tstart, s - tstart);
11157 stuffstart = s - SvPVX(PL_linestr);
11160 #ifndef PERL_STRICT_CR
11161 d = strchr(s, '\r');
11163 char * const olds = s;
11165 while (s < PL_bufend) {
11171 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11180 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11187 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11188 herewas = newSVpvn(s,PL_bufend-s);
11192 herewas = newSVpvn(s-1,found_newline-s+1);
11195 herewas = newSVpvn(s,found_newline-s);
11199 if (PL_madskills) {
11200 tstart = SvPVX(PL_linestr) + stuffstart;
11202 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11204 PL_thisstuff = newSVpvn(tstart, s - tstart);
11207 s += SvCUR(herewas);
11210 stuffstart = s - SvPVX(PL_linestr);
11216 tmpstr = newSV_type(SVt_PVIV);
11217 SvGROW(tmpstr, 80);
11218 if (term == '\'') {
11219 op_type = OP_CONST;
11220 SvIV_set(tmpstr, -1);
11222 else if (term == '`') {
11223 op_type = OP_BACKTICK;
11224 SvIV_set(tmpstr, '\\');
11228 PL_multi_start = CopLINE(PL_curcop);
11229 PL_multi_open = PL_multi_close = '<';
11230 term = *PL_tokenbuf;
11231 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11232 char * const bufptr = PL_sublex_info.super_bufptr;
11233 char * const bufend = PL_sublex_info.super_bufend;
11234 char * const olds = s - SvCUR(herewas);
11235 s = strchr(bufptr, '\n');
11239 while (s < bufend &&
11240 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11242 CopLINE_inc(PL_curcop);
11245 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11246 missingterm(PL_tokenbuf);
11248 sv_setpvn(herewas,bufptr,d-bufptr+1);
11249 sv_setpvn(tmpstr,d+1,s-d);
11251 sv_catpvn(herewas,s,bufend-s);
11252 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11259 while (s < PL_bufend &&
11260 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11262 CopLINE_inc(PL_curcop);
11264 if (s >= PL_bufend) {
11265 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11266 missingterm(PL_tokenbuf);
11268 sv_setpvn(tmpstr,d+1,s-d);
11270 if (PL_madskills) {
11272 sv_catpvn(PL_thisstuff, d + 1, s - d);
11274 PL_thisstuff = newSVpvn(d + 1, s - d);
11275 stuffstart = s - SvPVX(PL_linestr);
11279 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11281 sv_catpvn(herewas,s,PL_bufend-s);
11282 sv_setsv(PL_linestr,herewas);
11283 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11284 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11285 PL_last_lop = PL_last_uni = NULL;
11288 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
11289 while (s >= PL_bufend) { /* multiple line string? */
11291 if (PL_madskills) {
11292 tstart = SvPVX(PL_linestr) + stuffstart;
11294 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11296 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11300 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11301 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11302 missingterm(PL_tokenbuf);
11305 stuffstart = s - SvPVX(PL_linestr);
11307 CopLINE_inc(PL_curcop);
11308 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11309 PL_last_lop = PL_last_uni = NULL;
11310 #ifndef PERL_STRICT_CR
11311 if (PL_bufend - PL_linestart >= 2) {
11312 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11313 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11315 PL_bufend[-2] = '\n';
11317 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11319 else if (PL_bufend[-1] == '\r')
11320 PL_bufend[-1] = '\n';
11322 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11323 PL_bufend[-1] = '\n';
11325 if (PERLDB_LINE && PL_curstash != PL_debstash)
11326 update_debugger_info(PL_linestr, NULL, 0);
11327 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11328 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11329 *(SvPVX(PL_linestr) + off ) = ' ';
11330 sv_catsv(PL_linestr,herewas);
11331 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11332 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11336 sv_catsv(tmpstr,PL_linestr);
11341 PL_multi_end = CopLINE(PL_curcop);
11342 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11343 SvPV_shrink_to_cur(tmpstr);
11345 SvREFCNT_dec(herewas);
11347 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11349 else if (PL_encoding)
11350 sv_recode_to_utf8(tmpstr, PL_encoding);
11352 PL_lex_stuff = tmpstr;
11353 yylval.ival = op_type;
11357 /* scan_inputsymbol
11358 takes: current position in input buffer
11359 returns: new position in input buffer
11360 side-effects: yylval and lex_op are set.
11365 <FH> read from filehandle
11366 <pkg::FH> read from package qualified filehandle
11367 <pkg'FH> read from package qualified filehandle
11368 <$fh> read from filehandle in $fh
11369 <*.h> filename glob
11374 S_scan_inputsymbol(pTHX_ char *start)
11377 register char *s = start; /* current position in buffer */
11381 char *d = PL_tokenbuf; /* start of temp holding space */
11382 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11384 end = strchr(s, '\n');
11387 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11389 /* die if we didn't have space for the contents of the <>,
11390 or if it didn't end, or if we see a newline
11393 if (len >= (I32)sizeof PL_tokenbuf)
11394 Perl_croak(aTHX_ "Excessively long <> operator");
11396 Perl_croak(aTHX_ "Unterminated <> operator");
11401 Remember, only scalar variables are interpreted as filehandles by
11402 this code. Anything more complex (e.g., <$fh{$num}>) will be
11403 treated as a glob() call.
11404 This code makes use of the fact that except for the $ at the front,
11405 a scalar variable and a filehandle look the same.
11407 if (*d == '$' && d[1]) d++;
11409 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11410 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11413 /* If we've tried to read what we allow filehandles to look like, and
11414 there's still text left, then it must be a glob() and not a getline.
11415 Use scan_str to pull out the stuff between the <> and treat it
11416 as nothing more than a string.
11419 if (d - PL_tokenbuf != len) {
11420 yylval.ival = OP_GLOB;
11422 s = scan_str(start,!!PL_madskills,FALSE);
11424 Perl_croak(aTHX_ "Glob not terminated");
11428 bool readline_overriden = FALSE;
11431 /* we're in a filehandle read situation */
11434 /* turn <> into <ARGV> */
11436 Copy("ARGV",d,5,char);
11438 /* Check whether readline() is overriden */
11439 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11441 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11443 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11444 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11445 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11446 readline_overriden = TRUE;
11448 /* if <$fh>, create the ops to turn the variable into a
11452 /* try to find it in the pad for this block, otherwise find
11453 add symbol table ops
11455 const PADOFFSET tmp = pad_findmy(d);
11456 if (tmp != NOT_IN_PAD) {
11457 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11458 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11459 HEK * const stashname = HvNAME_HEK(stash);
11460 SV * const sym = sv_2mortal(newSVhek(stashname));
11461 sv_catpvs(sym, "::");
11462 sv_catpv(sym, d+1);
11467 OP * const o = newOP(OP_PADSV, 0);
11469 PL_lex_op = readline_overriden
11470 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11471 append_elem(OP_LIST, o,
11472 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11473 : (OP*)newUNOP(OP_READLINE, 0, o);
11482 ? (GV_ADDMULTI | GV_ADDINEVAL)
11485 PL_lex_op = readline_overriden
11486 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11487 append_elem(OP_LIST,
11488 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11489 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11490 : (OP*)newUNOP(OP_READLINE, 0,
11491 newUNOP(OP_RV2SV, 0,
11492 newGVOP(OP_GV, 0, gv)));
11494 if (!readline_overriden)
11495 PL_lex_op->op_flags |= OPf_SPECIAL;
11496 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11497 yylval.ival = OP_NULL;
11500 /* If it's none of the above, it must be a literal filehandle
11501 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11503 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11504 PL_lex_op = readline_overriden
11505 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11506 append_elem(OP_LIST,
11507 newGVOP(OP_GV, 0, gv),
11508 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11509 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11510 yylval.ival = OP_NULL;
11519 takes: start position in buffer
11520 keep_quoted preserve \ on the embedded delimiter(s)
11521 keep_delims preserve the delimiters around the string
11522 returns: position to continue reading from buffer
11523 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11524 updates the read buffer.
11526 This subroutine pulls a string out of the input. It is called for:
11527 q single quotes q(literal text)
11528 ' single quotes 'literal text'
11529 qq double quotes qq(interpolate $here please)
11530 " double quotes "interpolate $here please"
11531 qx backticks qx(/bin/ls -l)
11532 ` backticks `/bin/ls -l`
11533 qw quote words @EXPORT_OK = qw( func() $spam )
11534 m// regexp match m/this/
11535 s/// regexp substitute s/this/that/
11536 tr/// string transliterate tr/this/that/
11537 y/// string transliterate y/this/that/
11538 ($*@) sub prototypes sub foo ($)
11539 (stuff) sub attr parameters sub foo : attr(stuff)
11540 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11542 In most of these cases (all but <>, patterns and transliterate)
11543 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11544 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11545 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11548 It skips whitespace before the string starts, and treats the first
11549 character as the delimiter. If the delimiter is one of ([{< then
11550 the corresponding "close" character )]}> is used as the closing
11551 delimiter. It allows quoting of delimiters, and if the string has
11552 balanced delimiters ([{<>}]) it allows nesting.
11554 On success, the SV with the resulting string is put into lex_stuff or,
11555 if that is already non-NULL, into lex_repl. The second case occurs only
11556 when parsing the RHS of the special constructs s/// and tr/// (y///).
11557 For convenience, the terminating delimiter character is stuffed into
11562 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11565 SV *sv; /* scalar value: string */
11566 const char *tmps; /* temp string, used for delimiter matching */
11567 register char *s = start; /* current position in the buffer */
11568 register char term; /* terminating character */
11569 register char *to; /* current position in the sv's data */
11570 I32 brackets = 1; /* bracket nesting level */
11571 bool has_utf8 = FALSE; /* is there any utf8 content? */
11572 I32 termcode; /* terminating char. code */
11573 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11574 STRLEN termlen; /* length of terminating string */
11575 int last_off = 0; /* last position for nesting bracket */
11581 /* skip space before the delimiter */
11587 if (PL_realtokenstart >= 0) {
11588 stuffstart = PL_realtokenstart;
11589 PL_realtokenstart = -1;
11592 stuffstart = start - SvPVX(PL_linestr);
11594 /* mark where we are, in case we need to report errors */
11597 /* after skipping whitespace, the next character is the terminator */
11600 termcode = termstr[0] = term;
11604 termcode = utf8_to_uvchr((U8*)s, &termlen);
11605 Copy(s, termstr, termlen, U8);
11606 if (!UTF8_IS_INVARIANT(term))
11610 /* mark where we are */
11611 PL_multi_start = CopLINE(PL_curcop);
11612 PL_multi_open = term;
11614 /* find corresponding closing delimiter */
11615 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11616 termcode = termstr[0] = term = tmps[5];
11618 PL_multi_close = term;
11620 /* create a new SV to hold the contents. 79 is the SV's initial length.
11621 What a random number. */
11622 sv = newSV_type(SVt_PVIV);
11624 SvIV_set(sv, termcode);
11625 (void)SvPOK_only(sv); /* validate pointer */
11627 /* move past delimiter and try to read a complete string */
11629 sv_catpvn(sv, s, termlen);
11632 tstart = SvPVX(PL_linestr) + stuffstart;
11633 if (!PL_thisopen && !keep_delims) {
11634 PL_thisopen = newSVpvn(tstart, s - tstart);
11635 stuffstart = s - SvPVX(PL_linestr);
11639 if (PL_encoding && !UTF) {
11643 int offset = s - SvPVX_const(PL_linestr);
11644 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11645 &offset, (char*)termstr, termlen);
11646 const char * const ns = SvPVX_const(PL_linestr) + offset;
11647 char * const svlast = SvEND(sv) - 1;
11649 for (; s < ns; s++) {
11650 if (*s == '\n' && !PL_rsfp)
11651 CopLINE_inc(PL_curcop);
11654 goto read_more_line;
11656 /* handle quoted delimiters */
11657 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11659 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11661 if ((svlast-1 - t) % 2) {
11662 if (!keep_quoted) {
11663 *(svlast-1) = term;
11665 SvCUR_set(sv, SvCUR(sv) - 1);
11670 if (PL_multi_open == PL_multi_close) {
11676 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11677 /* At here, all closes are "was quoted" one,
11678 so we don't check PL_multi_close. */
11680 if (!keep_quoted && *(t+1) == PL_multi_open)
11685 else if (*t == PL_multi_open)
11693 SvCUR_set(sv, w - SvPVX_const(sv));
11695 last_off = w - SvPVX(sv);
11696 if (--brackets <= 0)
11701 if (!keep_delims) {
11702 SvCUR_set(sv, SvCUR(sv) - 1);
11708 /* extend sv if need be */
11709 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11710 /* set 'to' to the next character in the sv's string */
11711 to = SvPVX(sv)+SvCUR(sv);
11713 /* if open delimiter is the close delimiter read unbridle */
11714 if (PL_multi_open == PL_multi_close) {
11715 for (; s < PL_bufend; s++,to++) {
11716 /* embedded newlines increment the current line number */
11717 if (*s == '\n' && !PL_rsfp)
11718 CopLINE_inc(PL_curcop);
11719 /* handle quoted delimiters */
11720 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11721 if (!keep_quoted && s[1] == term)
11723 /* any other quotes are simply copied straight through */
11727 /* terminate when run out of buffer (the for() condition), or
11728 have found the terminator */
11729 else if (*s == term) {
11732 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11735 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11741 /* if the terminator isn't the same as the start character (e.g.,
11742 matched brackets), we have to allow more in the quoting, and
11743 be prepared for nested brackets.
11746 /* read until we run out of string, or we find the terminator */
11747 for (; s < PL_bufend; s++,to++) {
11748 /* embedded newlines increment the line count */
11749 if (*s == '\n' && !PL_rsfp)
11750 CopLINE_inc(PL_curcop);
11751 /* backslashes can escape the open or closing characters */
11752 if (*s == '\\' && s+1 < PL_bufend) {
11753 if (!keep_quoted &&
11754 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11759 /* allow nested opens and closes */
11760 else if (*s == PL_multi_close && --brackets <= 0)
11762 else if (*s == PL_multi_open)
11764 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11769 /* terminate the copied string and update the sv's end-of-string */
11771 SvCUR_set(sv, to - SvPVX_const(sv));
11774 * this next chunk reads more into the buffer if we're not done yet
11778 break; /* handle case where we are done yet :-) */
11780 #ifndef PERL_STRICT_CR
11781 if (to - SvPVX_const(sv) >= 2) {
11782 if ((to[-2] == '\r' && to[-1] == '\n') ||
11783 (to[-2] == '\n' && to[-1] == '\r'))
11787 SvCUR_set(sv, to - SvPVX_const(sv));
11789 else if (to[-1] == '\r')
11792 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11797 /* if we're out of file, or a read fails, bail and reset the current
11798 line marker so we can report where the unterminated string began
11801 if (PL_madskills) {
11802 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11804 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11806 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11810 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11812 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11818 /* we read a line, so increment our line counter */
11819 CopLINE_inc(PL_curcop);
11821 /* update debugger info */
11822 if (PERLDB_LINE && PL_curstash != PL_debstash)
11823 update_debugger_info(PL_linestr, NULL, 0);
11825 /* having changed the buffer, we must update PL_bufend */
11826 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11827 PL_last_lop = PL_last_uni = NULL;
11830 /* at this point, we have successfully read the delimited string */
11832 if (!PL_encoding || UTF) {
11834 if (PL_madskills) {
11835 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11836 const int len = s - tstart;
11838 sv_catpvn(PL_thisstuff, tstart, len);
11840 PL_thisstuff = newSVpvn(tstart, len);
11841 if (!PL_thisclose && !keep_delims)
11842 PL_thisclose = newSVpvn(s,termlen);
11847 sv_catpvn(sv, s, termlen);
11852 if (PL_madskills) {
11853 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11854 const int len = s - tstart - termlen;
11856 sv_catpvn(PL_thisstuff, tstart, len);
11858 PL_thisstuff = newSVpvn(tstart, len);
11859 if (!PL_thisclose && !keep_delims)
11860 PL_thisclose = newSVpvn(s - termlen,termlen);
11864 if (has_utf8 || PL_encoding)
11867 PL_multi_end = CopLINE(PL_curcop);
11869 /* if we allocated too much space, give some back */
11870 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11871 SvLEN_set(sv, SvCUR(sv) + 1);
11872 SvPV_renew(sv, SvLEN(sv));
11875 /* decide whether this is the first or second quoted string we've read
11888 takes: pointer to position in buffer
11889 returns: pointer to new position in buffer
11890 side-effects: builds ops for the constant in yylval.op
11892 Read a number in any of the formats that Perl accepts:
11894 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11895 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11898 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11900 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11903 If it reads a number without a decimal point or an exponent, it will
11904 try converting the number to an integer and see if it can do so
11905 without loss of precision.
11909 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11912 register const char *s = start; /* current position in buffer */
11913 register char *d; /* destination in temp buffer */
11914 register char *e; /* end of temp buffer */
11915 NV nv; /* number read, as a double */
11916 SV *sv = NULL; /* place to put the converted number */
11917 bool floatit; /* boolean: int or float? */
11918 const char *lastub = NULL; /* position of last underbar */
11919 static char const number_too_long[] = "Number too long";
11921 /* We use the first character to decide what type of number this is */
11925 Perl_croak(aTHX_ "panic: scan_num");
11927 /* if it starts with a 0, it could be an octal number, a decimal in
11928 0.13 disguise, or a hexadecimal number, or a binary number. */
11932 u holds the "number so far"
11933 shift the power of 2 of the base
11934 (hex == 4, octal == 3, binary == 1)
11935 overflowed was the number more than we can hold?
11937 Shift is used when we add a digit. It also serves as an "are
11938 we in octal/hex/binary?" indicator to disallow hex characters
11939 when in octal mode.
11944 bool overflowed = FALSE;
11945 bool just_zero = TRUE; /* just plain 0 or binary number? */
11946 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11947 static const char* const bases[5] =
11948 { "", "binary", "", "octal", "hexadecimal" };
11949 static const char* const Bases[5] =
11950 { "", "Binary", "", "Octal", "Hexadecimal" };
11951 static const char* const maxima[5] =
11953 "0b11111111111111111111111111111111",
11957 const char *base, *Base, *max;
11959 /* check for hex */
11964 } else if (s[1] == 'b') {
11969 /* check for a decimal in disguise */
11970 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11972 /* so it must be octal */
11979 if (ckWARN(WARN_SYNTAX))
11980 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11981 "Misplaced _ in number");
11985 base = bases[shift];
11986 Base = Bases[shift];
11987 max = maxima[shift];
11989 /* read the rest of the number */
11991 /* x is used in the overflow test,
11992 b is the digit we're adding on. */
11997 /* if we don't mention it, we're done */
12001 /* _ are ignored -- but warned about if consecutive */
12003 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12004 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12005 "Misplaced _ in number");
12009 /* 8 and 9 are not octal */
12010 case '8': case '9':
12012 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
12016 case '2': case '3': case '4':
12017 case '5': case '6': case '7':
12019 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
12022 case '0': case '1':
12023 b = *s++ & 15; /* ASCII digit -> value of digit */
12027 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
12028 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
12029 /* make sure they said 0x */
12032 b = (*s++ & 7) + 9;
12034 /* Prepare to put the digit we have onto the end
12035 of the number so far. We check for overflows.
12041 x = u << shift; /* make room for the digit */
12043 if ((x >> shift) != u
12044 && !(PL_hints & HINT_NEW_BINARY)) {
12047 if (ckWARN_d(WARN_OVERFLOW))
12048 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12049 "Integer overflow in %s number",
12052 u = x | b; /* add the digit to the end */
12055 n *= nvshift[shift];
12056 /* If an NV has not enough bits in its
12057 * mantissa to represent an UV this summing of
12058 * small low-order numbers is a waste of time
12059 * (because the NV cannot preserve the
12060 * low-order bits anyway): we could just
12061 * remember when did we overflow and in the
12062 * end just multiply n by the right
12070 /* if we get here, we had success: make a scalar value from
12075 /* final misplaced underbar check */
12076 if (s[-1] == '_') {
12077 if (ckWARN(WARN_SYNTAX))
12078 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12083 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12084 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12085 "%s number > %s non-portable",
12091 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12092 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12093 "%s number > %s non-portable",
12098 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12099 sv = new_constant(start, s - start, "integer",
12101 else if (PL_hints & HINT_NEW_BINARY)
12102 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
12107 handle decimal numbers.
12108 we're also sent here when we read a 0 as the first digit
12110 case '1': case '2': case '3': case '4': case '5':
12111 case '6': case '7': case '8': case '9': case '.':
12114 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12117 /* read next group of digits and _ and copy into d */
12118 while (isDIGIT(*s) || *s == '_') {
12119 /* skip underscores, checking for misplaced ones
12123 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12124 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12125 "Misplaced _ in number");
12129 /* check for end of fixed-length buffer */
12131 Perl_croak(aTHX_ number_too_long);
12132 /* if we're ok, copy the character */
12137 /* final misplaced underbar check */
12138 if (lastub && s == lastub + 1) {
12139 if (ckWARN(WARN_SYNTAX))
12140 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12143 /* read a decimal portion if there is one. avoid
12144 3..5 being interpreted as the number 3. followed
12147 if (*s == '.' && s[1] != '.') {
12152 if (ckWARN(WARN_SYNTAX))
12153 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12154 "Misplaced _ in number");
12158 /* copy, ignoring underbars, until we run out of digits.
12160 for (; isDIGIT(*s) || *s == '_'; s++) {
12161 /* fixed length buffer check */
12163 Perl_croak(aTHX_ number_too_long);
12165 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12166 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12167 "Misplaced _ in number");
12173 /* fractional part ending in underbar? */
12174 if (s[-1] == '_') {
12175 if (ckWARN(WARN_SYNTAX))
12176 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12177 "Misplaced _ in number");
12179 if (*s == '.' && isDIGIT(s[1])) {
12180 /* oops, it's really a v-string, but without the "v" */
12186 /* read exponent part, if present */
12187 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12191 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12192 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12194 /* stray preinitial _ */
12196 if (ckWARN(WARN_SYNTAX))
12197 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12198 "Misplaced _ in number");
12202 /* allow positive or negative exponent */
12203 if (*s == '+' || *s == '-')
12206 /* stray initial _ */
12208 if (ckWARN(WARN_SYNTAX))
12209 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12210 "Misplaced _ in number");
12214 /* read digits of exponent */
12215 while (isDIGIT(*s) || *s == '_') {
12218 Perl_croak(aTHX_ number_too_long);
12222 if (((lastub && s == lastub + 1) ||
12223 (!isDIGIT(s[1]) && s[1] != '_'))
12224 && ckWARN(WARN_SYNTAX))
12225 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12226 "Misplaced _ in number");
12233 /* make an sv from the string */
12237 We try to do an integer conversion first if no characters
12238 indicating "float" have been found.
12243 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12245 if (flags == IS_NUMBER_IN_UV) {
12247 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12250 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12251 if (uv <= (UV) IV_MIN)
12252 sv_setiv(sv, -(IV)uv);
12259 /* terminate the string */
12261 nv = Atof(PL_tokenbuf);
12265 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12266 (PL_hints & HINT_NEW_INTEGER) )
12267 sv = new_constant(PL_tokenbuf,
12270 (floatit ? "float" : "integer"),
12274 /* if it starts with a v, it could be a v-string */
12277 sv = newSV(5); /* preallocate storage space */
12278 s = scan_vstring(s, PL_bufend, sv);
12282 /* make the op for the constant and return */
12285 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12287 lvalp->opval = NULL;
12293 S_scan_formline(pTHX_ register char *s)
12296 register char *eol;
12298 SV * const stuff = newSVpvs("");
12299 bool needargs = FALSE;
12300 bool eofmt = FALSE;
12302 char *tokenstart = s;
12305 if (PL_madskills) {
12306 savewhite = PL_thiswhite;
12311 while (!needargs) {
12314 #ifdef PERL_STRICT_CR
12315 while (SPACE_OR_TAB(*t))
12318 while (SPACE_OR_TAB(*t) || *t == '\r')
12321 if (*t == '\n' || t == PL_bufend) {
12326 if (PL_in_eval && !PL_rsfp) {
12327 eol = (char *) memchr(s,'\n',PL_bufend-s);
12332 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12334 for (t = s; t < eol; t++) {
12335 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12337 goto enough; /* ~~ must be first line in formline */
12339 if (*t == '@' || *t == '^')
12343 sv_catpvn(stuff, s, eol-s);
12344 #ifndef PERL_STRICT_CR
12345 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12346 char *end = SvPVX(stuff) + SvCUR(stuff);
12349 SvCUR_set(stuff, SvCUR(stuff) - 1);
12359 if (PL_madskills) {
12361 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12363 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12366 s = filter_gets(PL_linestr, PL_rsfp, 0);
12368 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12370 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12372 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12373 PL_last_lop = PL_last_uni = NULL;
12382 if (SvCUR(stuff)) {
12385 PL_lex_state = LEX_NORMAL;
12386 start_force(PL_curforce);
12387 NEXTVAL_NEXTTOKE.ival = 0;
12391 PL_lex_state = LEX_FORMLINE;
12393 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12395 else if (PL_encoding)
12396 sv_recode_to_utf8(stuff, PL_encoding);
12398 start_force(PL_curforce);
12399 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12401 start_force(PL_curforce);
12402 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12406 SvREFCNT_dec(stuff);
12408 PL_lex_formbrack = 0;
12412 if (PL_madskills) {
12414 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12416 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12417 PL_thiswhite = savewhite;
12429 PL_cshlen = strlen(PL_cshname);
12431 #if defined(USE_ITHREADS)
12432 PERL_UNUSED_CONTEXT;
12438 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12441 const I32 oldsavestack_ix = PL_savestack_ix;
12442 CV* const outsidecv = PL_compcv;
12445 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12447 SAVEI32(PL_subline);
12448 save_item(PL_subname);
12449 SAVESPTR(PL_compcv);
12451 PL_compcv = (CV*)newSV_type(is_format ? SVt_PVFM : SVt_PVCV);
12452 CvFLAGS(PL_compcv) |= flags;
12454 PL_subline = CopLINE(PL_curcop);
12455 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12456 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12457 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12459 return oldsavestack_ix;
12463 #pragma segment Perl_yylex
12466 Perl_yywarn(pTHX_ const char *s)
12469 PL_in_eval |= EVAL_WARNONLY;
12471 PL_in_eval &= ~EVAL_WARNONLY;
12476 Perl_yyerror(pTHX_ const char *s)
12479 const char *where = NULL;
12480 const char *context = NULL;
12483 int yychar = PL_parser->yychar;
12485 if (!yychar || (yychar == ';' && !PL_rsfp))
12487 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12488 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12489 PL_oldbufptr != PL_bufptr) {
12492 The code below is removed for NetWare because it abends/crashes on NetWare
12493 when the script has error such as not having the closing quotes like:
12494 if ($var eq "value)
12495 Checking of white spaces is anyway done in NetWare code.
12498 while (isSPACE(*PL_oldoldbufptr))
12501 context = PL_oldoldbufptr;
12502 contlen = PL_bufptr - PL_oldoldbufptr;
12504 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12505 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12508 The code below is removed for NetWare because it abends/crashes on NetWare
12509 when the script has error such as not having the closing quotes like:
12510 if ($var eq "value)
12511 Checking of white spaces is anyway done in NetWare code.
12514 while (isSPACE(*PL_oldbufptr))
12517 context = PL_oldbufptr;
12518 contlen = PL_bufptr - PL_oldbufptr;
12520 else if (yychar > 255)
12521 where = "next token ???";
12522 else if (yychar == -2) { /* YYEMPTY */
12523 if (PL_lex_state == LEX_NORMAL ||
12524 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12525 where = "at end of line";
12526 else if (PL_lex_inpat)
12527 where = "within pattern";
12529 where = "within string";
12532 SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12534 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12535 else if (isPRINT_LC(yychar))
12536 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12538 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12539 where = SvPVX_const(where_sv);
12541 msg = sv_2mortal(newSVpv(s, 0));
12542 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12543 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12545 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12547 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12548 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12549 Perl_sv_catpvf(aTHX_ msg,
12550 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12551 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12554 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12555 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12558 if (PL_error_count >= 10) {
12559 if (PL_in_eval && SvCUR(ERRSV))
12560 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12561 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12563 Perl_croak(aTHX_ "%s has too many errors.\n",
12564 OutCopFILE(PL_curcop));
12567 PL_in_my_stash = NULL;
12571 #pragma segment Main
12575 S_swallow_bom(pTHX_ U8 *s)
12578 const STRLEN slen = SvCUR(PL_linestr);
12581 if (s[1] == 0xFE) {
12582 /* UTF-16 little-endian? (or UTF32-LE?) */
12583 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12584 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12585 #ifndef PERL_NO_UTF16_FILTER
12586 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12589 if (PL_bufend > (char*)s) {
12593 filter_add(utf16rev_textfilter, NULL);
12594 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12595 utf16_to_utf8_reversed(s, news,
12596 PL_bufend - (char*)s - 1,
12598 sv_setpvn(PL_linestr, (const char*)news, newlen);
12600 s = (U8*)SvPVX(PL_linestr);
12601 Copy(news, s, newlen, U8);
12605 SvUTF8_on(PL_linestr);
12606 s = (U8*)SvPVX(PL_linestr);
12608 /* FIXME - is this a general bug fix? */
12611 PL_bufend = SvPVX(PL_linestr) + newlen;
12614 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12619 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12620 #ifndef PERL_NO_UTF16_FILTER
12621 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12624 if (PL_bufend > (char *)s) {
12628 filter_add(utf16_textfilter, NULL);
12629 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12630 utf16_to_utf8(s, news,
12631 PL_bufend - (char*)s,
12633 sv_setpvn(PL_linestr, (const char*)news, newlen);
12635 SvUTF8_on(PL_linestr);
12636 s = (U8*)SvPVX(PL_linestr);
12637 PL_bufend = SvPVX(PL_linestr) + newlen;
12640 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12645 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12646 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12647 s += 3; /* UTF-8 */
12653 if (s[2] == 0xFE && s[3] == 0xFF) {
12654 /* UTF-32 big-endian */
12655 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12658 else if (s[2] == 0 && s[3] != 0) {
12661 * are a good indicator of UTF-16BE. */
12662 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12668 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12669 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12670 s += 4; /* UTF-8 */
12676 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12679 * are a good indicator of UTF-16LE. */
12680 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12688 #ifndef PERL_NO_UTF16_FILTER
12690 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12693 const STRLEN old = SvCUR(sv);
12694 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12695 DEBUG_P(PerlIO_printf(Perl_debug_log,
12696 "utf16_textfilter(%p): %d %d (%d)\n",
12697 FPTR2DPTR(void *, utf16_textfilter),
12698 idx, maxlen, (int) count));
12702 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12703 Copy(SvPVX_const(sv), tmps, old, char);
12704 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12705 SvCUR(sv) - old, &newlen);
12706 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12708 DEBUG_P({sv_dump(sv);});
12713 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12716 const STRLEN old = SvCUR(sv);
12717 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12718 DEBUG_P(PerlIO_printf(Perl_debug_log,
12719 "utf16rev_textfilter(%p): %d %d (%d)\n",
12720 FPTR2DPTR(void *, utf16rev_textfilter),
12721 idx, maxlen, (int) count));
12725 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12726 Copy(SvPVX_const(sv), tmps, old, char);
12727 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12728 SvCUR(sv) - old, &newlen);
12729 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12731 DEBUG_P({ sv_dump(sv); });
12737 Returns a pointer to the next character after the parsed
12738 vstring, as well as updating the passed in sv.
12740 Function must be called like
12743 s = scan_vstring(s,e,sv);
12745 where s and e are the start and end of the string.
12746 The sv should already be large enough to store the vstring
12747 passed in, for performance reasons.
12752 Perl_scan_vstring(pTHX_ const char *s, const char *e, SV *sv)
12755 const char *pos = s;
12756 const char *start = s;
12757 if (*pos == 'v') pos++; /* get past 'v' */
12758 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12760 if ( *pos != '.') {
12761 /* this may not be a v-string if followed by => */
12762 const char *next = pos;
12763 while (next < e && isSPACE(*next))
12765 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12766 /* return string not v-string */
12767 sv_setpvn(sv,(char *)s,pos-s);
12768 return (char *)pos;
12772 if (!isALPHA(*pos)) {
12773 U8 tmpbuf[UTF8_MAXBYTES+1];
12776 s++; /* get past 'v' */
12778 sv_setpvn(sv, "", 0);
12781 /* this is atoi() that tolerates underscores */
12784 const char *end = pos;
12786 while (--end >= s) {
12788 const UV orev = rev;
12789 rev += (*end - '0') * mult;
12791 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12792 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12793 "Integer overflow in decimal number");
12797 if (rev > 0x7FFFFFFF)
12798 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12800 /* Append native character for the rev point */
12801 tmpend = uvchr_to_utf8(tmpbuf, rev);
12802 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12803 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12805 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12811 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12815 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12823 * c-indentation-style: bsd
12824 * c-basic-offset: 4
12825 * indent-tabs-mode: t
12828 * ex: set ts=8 sts=4 sw=4 noet: