3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 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 yychar (*PL_yycharp)
27 #define yylval (*PL_yylvalp)
29 static const char ident_too_long[] =
30 "Identifier too long";
31 static const char c_without_g[] =
32 "Use of /c modifier is meaningless without /g";
33 static const char c_in_subst[] =
34 "Use of /c modifier is meaningless in s///";
36 static void restore_rsfp(pTHX_ void *f);
37 #ifndef PERL_NO_UTF16_FILTER
38 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
39 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
42 #define XFAKEBRACK 128
45 #ifdef USE_UTF8_SCRIPTS
46 # define UTF (!IN_BYTES)
48 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
51 /* In variables named $^X, these are the legal values for X.
52 * 1999-02-27 mjd-perl-patch@plover.com */
53 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
55 /* On MacOS, respect nonbreaking spaces */
56 #ifdef MACOS_TRADITIONAL
57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
59 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
62 /* LEX_* are values for PL_lex_state, the state of the lexer.
63 * They are arranged oddly so that the guard on the switch statement
64 * can get by with a single comparison (if the compiler is smart enough).
67 /* #define LEX_NOTPARSING 11 is done in perl.h. */
69 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
70 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
71 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
72 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
73 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
75 /* at end of code, eg "$x" followed by: */
76 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
77 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
79 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
80 string or after \E, $foo, etc */
81 #define LEX_INTERPCONST 2 /* NOT USED */
82 #define LEX_FORMLINE 1 /* expecting a format line */
83 #define LEX_KNOWNEXT 0 /* next token known; just return it */
87 static const char* const lex_state_names[] = {
106 #include "keywords.h"
108 /* CLINE is a macro that ensures PL_copline has a sane value */
113 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
116 * Convenience functions to return different tokens and prime the
117 * lexer for the next token. They all take an argument.
119 * TOKEN : generic token (used for '(', DOLSHARP, etc)
120 * OPERATOR : generic operator
121 * AOPERATOR : assignment operator
122 * PREBLOCK : beginning the block after an if, while, foreach, ...
123 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
124 * PREREF : *EXPR where EXPR is not a simple identifier
125 * TERM : expression term
126 * LOOPX : loop exiting command (goto, last, dump, etc)
127 * FTST : file test operator
128 * FUN0 : zero-argument function
129 * FUN1 : not used, except for not, which isn't a UNIOP
130 * BOop : bitwise or or xor
132 * SHop : shift operator
133 * PWop : power operator
134 * PMop : pattern-matching operator
135 * Aop : addition-level operator
136 * Mop : multiplication-level operator
137 * Eop : equality-testing operator
138 * Rop : relational operator <= != gt
140 * Also see LOP and lop() below.
143 #ifdef DEBUGGING /* Serve -DT. */
144 # define REPORT(retval) tokereport(s,(int)retval)
146 # define REPORT(retval) (retval)
149 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
150 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
151 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
152 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
153 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
154 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
155 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
156 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
157 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
158 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
159 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
160 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
161 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
162 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
163 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
164 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
165 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
166 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
167 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
168 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
170 /* This bit of chicanery makes a unary function followed by
171 * a parenthesis into a function with one argument, highest precedence.
172 * The UNIDOR macro is for unary functions that can be followed by the //
173 * operator (such as C<shift // 0>).
175 #define UNI2(f,x) { \
179 PL_last_uni = PL_oldbufptr; \
180 PL_last_lop_op = f; \
182 return REPORT( (int)FUNC1 ); \
184 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
186 #define UNI(f) UNI2(f,XTERM)
187 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
189 #define UNIBRACK(f) { \
192 PL_last_uni = PL_oldbufptr; \
194 return REPORT( (int)FUNC1 ); \
196 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
199 /* grandfather return to old style */
200 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
204 /* how to interpret the yylval associated with the token */
208 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
214 static struct debug_tokens { const int token, type; const char *name; }
215 const debug_tokens[] =
217 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
218 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
219 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
220 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
221 { ARROW, TOKENTYPE_NONE, "ARROW" },
222 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
223 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
224 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
225 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
226 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
227 { DO, TOKENTYPE_NONE, "DO" },
228 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
229 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
230 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
231 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
232 { ELSE, TOKENTYPE_NONE, "ELSE" },
233 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
234 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
235 { FOR, TOKENTYPE_IVAL, "FOR" },
236 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
237 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
238 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
239 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
240 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
241 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
242 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
243 { IF, TOKENTYPE_IVAL, "IF" },
244 { LABEL, TOKENTYPE_PVAL, "LABEL" },
245 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
246 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
247 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
248 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
249 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
250 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
251 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
252 { MY, TOKENTYPE_IVAL, "MY" },
253 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
254 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
255 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
256 { OROP, TOKENTYPE_IVAL, "OROP" },
257 { OROR, TOKENTYPE_NONE, "OROR" },
258 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
259 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
260 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
261 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
262 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
263 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
264 { PREINC, TOKENTYPE_NONE, "PREINC" },
265 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
266 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
267 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
268 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
269 { SUB, TOKENTYPE_NONE, "SUB" },
270 { THING, TOKENTYPE_OPVAL, "THING" },
271 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
272 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
273 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
274 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
275 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
276 { USE, TOKENTYPE_IVAL, "USE" },
277 { WHILE, TOKENTYPE_IVAL, "WHILE" },
278 { WORD, TOKENTYPE_OPVAL, "WORD" },
279 { 0, TOKENTYPE_NONE, 0 }
282 /* dump the returned token in rv, plus any optional arg in yylval */
285 S_tokereport(pTHX_ const char* s, I32 rv)
288 const char *name = Nullch;
289 enum token_type type = TOKENTYPE_NONE;
290 const struct debug_tokens *p;
291 SV* const report = newSVpvn("<== ", 4);
293 for (p = debug_tokens; p->token; p++) {
294 if (p->token == (int)rv) {
301 Perl_sv_catpv(aTHX_ report, name);
302 else if ((char)rv > ' ' && (char)rv < '~')
303 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
305 Perl_sv_catpv(aTHX_ report, "EOF");
307 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
310 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
313 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
315 case TOKENTYPE_OPNUM:
316 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
317 PL_op_name[yylval.ival]);
320 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
322 case TOKENTYPE_OPVAL:
324 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
325 PL_op_name[yylval.opval->op_type]);
326 if (yylval.opval->op_type == OP_CONST) {
327 Perl_sv_catpvf(aTHX_ report, " %s",
328 SvPEEK(cSVOPx_sv(yylval.opval)));
333 Perl_sv_catpv(aTHX_ report, "(opval=null)");
336 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
342 /* print the buffer with suitable escapes */
345 S_printbuf(pTHX_ const char* fmt, const char* s)
347 SV* tmp = newSVpvn("", 0);
348 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
357 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
358 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
362 S_ao(pTHX_ int toketype)
364 if (*PL_bufptr == '=') {
366 if (toketype == ANDAND)
367 yylval.ival = OP_ANDASSIGN;
368 else if (toketype == OROR)
369 yylval.ival = OP_ORASSIGN;
370 else if (toketype == DORDOR)
371 yylval.ival = OP_DORASSIGN;
379 * When Perl expects an operator and finds something else, no_op
380 * prints the warning. It always prints "<something> found where
381 * operator expected. It prints "Missing semicolon on previous line?"
382 * if the surprise occurs at the start of the line. "do you need to
383 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
384 * where the compiler doesn't know if foo is a method call or a function.
385 * It prints "Missing operator before end of line" if there's nothing
386 * after the missing operator, or "... before <...>" if there is something
387 * after the missing operator.
391 S_no_op(pTHX_ const char *what, char *s)
393 char * const oldbp = PL_bufptr;
394 const bool is_first = (PL_oldbufptr == PL_linestart);
400 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
401 if (ckWARN_d(WARN_SYNTAX)) {
403 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
404 "\t(Missing semicolon on previous line?)\n");
405 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
407 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
408 if (t < PL_bufptr && isSPACE(*t))
409 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
410 "\t(Do you need to predeclare %.*s?)\n",
411 t - PL_oldoldbufptr, PL_oldoldbufptr);
415 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
416 "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
424 * Complain about missing quote/regexp/heredoc terminator.
425 * If it's called with (char *)NULL then it cauterizes the line buffer.
426 * If we're in a delimited string and the delimiter is a control
427 * character, it's reformatted into a two-char sequence like ^C.
432 S_missingterm(pTHX_ char *s)
437 char * const nl = strrchr(s,'\n');
443 iscntrl(PL_multi_close)
445 PL_multi_close < 32 || PL_multi_close == 127
449 tmpbuf[1] = toCTRL(PL_multi_close);
454 *tmpbuf = (char)PL_multi_close;
458 q = strchr(s,'"') ? '\'' : '"';
459 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
467 Perl_deprecate(pTHX_ const char *s)
469 if (ckWARN(WARN_DEPRECATED))
470 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
474 Perl_deprecate_old(pTHX_ const char *s)
476 /* This function should NOT be called for any new deprecated warnings */
477 /* Use Perl_deprecate instead */
479 /* It is here to maintain backward compatibility with the pre-5.8 */
480 /* warnings category hierarchy. The "deprecated" category used to */
481 /* live under the "syntax" category. It is now a top-level category */
482 /* in its own right. */
484 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
485 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
486 "Use of %s is deprecated", s);
491 * Deprecate a comma-less variable list.
497 deprecate_old("comma-less variable list");
501 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
502 * utf16-to-utf8-reversed.
505 #ifdef PERL_CR_FILTER
509 register const char *s = SvPVX_const(sv);
510 register const char * const e = s + SvCUR(sv);
511 /* outer loop optimized to do nothing if there are no CR-LFs */
513 if (*s++ == '\r' && *s == '\n') {
514 /* hit a CR-LF, need to copy the rest */
515 register char *d = s - 1;
518 if (*s == '\r' && s[1] == '\n')
529 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
531 const I32 count = FILTER_READ(idx+1, sv, maxlen);
532 if (count > 0 && !maxlen)
540 * Initialize variables. Uses the Perl save_stack to save its state (for
541 * recursive calls to the parser).
545 Perl_lex_start(pTHX_ SV *line)
550 SAVEI32(PL_lex_dojoin);
551 SAVEI32(PL_lex_brackets);
552 SAVEI32(PL_lex_casemods);
553 SAVEI32(PL_lex_starts);
554 SAVEI32(PL_lex_state);
555 SAVEVPTR(PL_lex_inpat);
556 SAVEI32(PL_lex_inwhat);
557 if (PL_lex_state == LEX_KNOWNEXT) {
558 I32 toke = PL_nexttoke;
559 while (--toke >= 0) {
560 SAVEI32(PL_nexttype[toke]);
561 SAVEVPTR(PL_nextval[toke]);
563 SAVEI32(PL_nexttoke);
565 SAVECOPLINE(PL_curcop);
568 SAVEPPTR(PL_oldbufptr);
569 SAVEPPTR(PL_oldoldbufptr);
570 SAVEPPTR(PL_last_lop);
571 SAVEPPTR(PL_last_uni);
572 SAVEPPTR(PL_linestart);
573 SAVESPTR(PL_linestr);
574 SAVEGENERICPV(PL_lex_brackstack);
575 SAVEGENERICPV(PL_lex_casestack);
576 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
577 SAVESPTR(PL_lex_stuff);
578 SAVEI32(PL_lex_defer);
579 SAVEI32(PL_sublex_info.sub_inwhat);
580 SAVESPTR(PL_lex_repl);
582 SAVEINT(PL_lex_expect);
584 PL_lex_state = LEX_NORMAL;
588 Newx(PL_lex_brackstack, 120, char);
589 Newx(PL_lex_casestack, 12, char);
591 *PL_lex_casestack = '\0';
594 PL_lex_stuff = Nullsv;
595 PL_lex_repl = Nullsv;
599 PL_sublex_info.sub_inwhat = 0;
601 if (SvREADONLY(PL_linestr))
602 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
603 s = SvPV_const(PL_linestr, len);
604 if (!len || s[len-1] != ';') {
605 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
606 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
607 sv_catpvn(PL_linestr, "\n;", 2);
609 SvTEMP_off(PL_linestr);
610 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
611 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
612 PL_last_lop = PL_last_uni = Nullch;
618 * Finalizer for lexing operations. Must be called when the parser is
619 * done with the lexer.
625 PL_doextract = FALSE;
630 * This subroutine has nothing to do with tilting, whether at windmills
631 * or pinball tables. Its name is short for "increment line". It
632 * increments the current line number in CopLINE(PL_curcop) and checks
633 * to see whether the line starts with a comment of the form
634 * # line 500 "foo.pm"
635 * If so, it sets the current line number and file to the values in the comment.
639 S_incline(pTHX_ char *s)
646 CopLINE_inc(PL_curcop);
649 while (SPACE_OR_TAB(*s)) s++;
650 if (strnEQ(s, "line", 4))
654 if (SPACE_OR_TAB(*s))
658 while (SPACE_OR_TAB(*s)) s++;
664 while (SPACE_OR_TAB(*s))
666 if (*s == '"' && (t = strchr(s+1, '"'))) {
671 for (t = s; !isSPACE(*t); t++) ;
674 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
676 if (*e != '\n' && *e != '\0')
677 return; /* false alarm */
683 const char *cf = CopFILE(PL_curcop);
684 if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) {
685 /* must copy *{"::_<(eval N)[oldfilename:L]"}
686 * to *{"::_<newfilename"} */
687 char smallbuf[256], smallbuf2[256];
688 char *tmpbuf, *tmpbuf2;
690 STRLEN tmplen = strlen(cf);
691 STRLEN tmplen2 = strlen(s);
692 if (tmplen + 3 < sizeof smallbuf)
695 Newx(tmpbuf, tmplen + 3, char);
696 if (tmplen2 + 3 < sizeof smallbuf2)
699 Newx(tmpbuf2, tmplen2 + 3, char);
700 tmpbuf[0] = tmpbuf2[0] = '_';
701 tmpbuf[1] = tmpbuf2[1] = '<';
702 memcpy(tmpbuf + 2, cf, ++tmplen);
703 memcpy(tmpbuf2 + 2, s, ++tmplen2);
705 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
707 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
709 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
710 /* adjust ${"::_<newfilename"} to store the new file name */
711 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
712 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
713 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
715 if (tmpbuf != smallbuf) Safefree(tmpbuf);
716 if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
719 CopFILE_free(PL_curcop);
720 CopFILE_set(PL_curcop, s);
723 CopLINE_set(PL_curcop, atoi(n)-1);
728 * Called to gobble the appropriate amount and type of whitespace.
729 * Skips comments as well.
733 S_skipspace(pTHX_ register char *s)
735 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
736 while (s < PL_bufend && SPACE_OR_TAB(*s))
742 SSize_t oldprevlen, oldoldprevlen;
743 SSize_t oldloplen = 0, oldunilen = 0;
744 while (s < PL_bufend && isSPACE(*s)) {
745 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
750 if (s < PL_bufend && *s == '#') {
751 while (s < PL_bufend && *s != '\n')
755 if (PL_in_eval && !PL_rsfp) {
762 /* only continue to recharge the buffer if we're at the end
763 * of the buffer, we're not reading from a source filter, and
764 * we're in normal lexing mode
766 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
767 PL_lex_state == LEX_FORMLINE)
770 /* try to recharge the buffer */
771 if ((s = filter_gets(PL_linestr, PL_rsfp,
772 (prevlen = SvCUR(PL_linestr)))) == Nullch)
774 /* end of file. Add on the -p or -n magic */
777 ";}continue{print or die qq(-p destination: $!\\n);}");
778 PL_minus_n = PL_minus_p = 0;
780 else if (PL_minus_n) {
781 sv_setpvn(PL_linestr, ";}", 2);
785 sv_setpvn(PL_linestr,";", 1);
787 /* reset variables for next time we lex */
788 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
790 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
791 PL_last_lop = PL_last_uni = Nullch;
793 /* Close the filehandle. Could be from -P preprocessor,
794 * STDIN, or a regular file. If we were reading code from
795 * STDIN (because the commandline held no -e or filename)
796 * then we don't close it, we reset it so the code can
797 * read from STDIN too.
800 if (PL_preprocess && !PL_in_eval)
801 (void)PerlProc_pclose(PL_rsfp);
802 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
803 PerlIO_clearerr(PL_rsfp);
805 (void)PerlIO_close(PL_rsfp);
810 /* not at end of file, so we only read another line */
811 /* make corresponding updates to old pointers, for yyerror() */
812 oldprevlen = PL_oldbufptr - PL_bufend;
813 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
815 oldunilen = PL_last_uni - PL_bufend;
817 oldloplen = PL_last_lop - PL_bufend;
818 PL_linestart = PL_bufptr = s + prevlen;
819 PL_bufend = s + SvCUR(PL_linestr);
821 PL_oldbufptr = s + oldprevlen;
822 PL_oldoldbufptr = s + oldoldprevlen;
824 PL_last_uni = s + oldunilen;
826 PL_last_lop = s + oldloplen;
829 /* debugger active and we're not compiling the debugger code,
830 * so store the line into the debugger's array of lines
832 if (PERLDB_LINE && PL_curstash != PL_debstash) {
833 SV * const sv = NEWSV(85,0);
835 sv_upgrade(sv, SVt_PVMG);
836 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
839 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
846 * Check the unary operators to ensure there's no ambiguity in how they're
847 * used. An ambiguous piece of code would be:
849 * This doesn't mean rand() + 5. Because rand() is a unary operator,
850 * the +5 is its argument.
859 if (PL_oldoldbufptr != PL_last_uni)
861 while (isSPACE(*PL_last_uni))
863 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
864 if ((t = strchr(s, '(')) && t < PL_bufptr)
866 if (ckWARN_d(WARN_AMBIGUOUS)){
869 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
870 "Warning: Use of \"%s\" without parentheses is ambiguous",
877 * LOP : macro to build a list operator. Its behaviour has been replaced
878 * with a subroutine, S_lop() for which LOP is just another name.
881 #define LOP(f,x) return lop(f,x,s)
885 * Build a list operator (or something that might be one). The rules:
886 * - if we have a next token, then it's a list operator [why?]
887 * - if the next thing is an opening paren, then it's a function
888 * - else it's a list operator
892 S_lop(pTHX_ I32 f, int x, char *s)
898 PL_last_lop = PL_oldbufptr;
899 PL_last_lop_op = (OPCODE)f;
901 return REPORT(LSTOP);
908 return REPORT(LSTOP);
913 * When the lexer realizes it knows the next token (for instance,
914 * it is reordering tokens for the parser) then it can call S_force_next
915 * to know what token to return the next time the lexer is called. Caller
916 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
917 * handles the token correctly.
921 S_force_next(pTHX_ I32 type)
923 PL_nexttype[PL_nexttoke] = type;
925 if (PL_lex_state != LEX_KNOWNEXT) {
926 PL_lex_defer = PL_lex_state;
927 PL_lex_expect = PL_expect;
928 PL_lex_state = LEX_KNOWNEXT;
933 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
935 SV * const sv = newSVpvn(start,len);
936 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
943 * When the lexer knows the next thing is a word (for instance, it has
944 * just seen -> and it knows that the next char is a word char, then
945 * it calls S_force_word to stick the next word into the PL_next lookahead.
948 * char *start : buffer position (must be within PL_linestr)
949 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
950 * int check_keyword : if true, Perl checks to make sure the word isn't
951 * a keyword (do this if the word is a label, e.g. goto FOO)
952 * int allow_pack : if true, : characters will also be allowed (require,
954 * int allow_initial_tick : used by the "sub" lexer only.
958 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
963 start = skipspace(start);
965 if (isIDFIRST_lazy_if(s,UTF) ||
966 (allow_pack && *s == ':') ||
967 (allow_initial_tick && *s == '\'') )
969 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
970 if (check_keyword && keyword(PL_tokenbuf, len))
972 if (token == METHOD) {
977 PL_expect = XOPERATOR;
980 PL_nextval[PL_nexttoke].opval
981 = (OP*)newSVOP(OP_CONST,0,
982 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
983 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
991 * Called when the lexer wants $foo *foo &foo etc, but the program
992 * text only contains the "foo" portion. The first argument is a pointer
993 * to the "foo", and the second argument is the type symbol to prefix.
994 * Forces the next token to be a "WORD".
995 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
999 S_force_ident(pTHX_ register const char *s, int kind)
1002 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
1003 PL_nextval[PL_nexttoke].opval = o;
1006 o->op_private = OPpCONST_ENTERED;
1007 /* XXX see note in pp_entereval() for why we forgo typo
1008 warnings if the symbol must be introduced in an eval.
1010 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1011 kind == '$' ? SVt_PV :
1012 kind == '@' ? SVt_PVAV :
1013 kind == '%' ? SVt_PVHV :
1021 Perl_str_to_version(pTHX_ SV *sv)
1026 const char *start = SvPV_const(sv,len);
1027 const char * const end = start + len;
1028 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1029 while (start < end) {
1033 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1038 retval += ((NV)n)/nshift;
1047 * Forces the next token to be a version number.
1048 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1049 * and if "guessing" is TRUE, then no new token is created (and the caller
1050 * must use an alternative parsing method).
1054 S_force_version(pTHX_ char *s, int guessing)
1056 OP *version = Nullop;
1065 while (isDIGIT(*d) || *d == '_' || *d == '.')
1067 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1069 s = scan_num(s, &yylval);
1070 version = yylval.opval;
1071 ver = cSVOPx(version)->op_sv;
1072 if (SvPOK(ver) && !SvNIOK(ver)) {
1073 SvUPGRADE(ver, SVt_PVNV);
1074 SvNV_set(ver, str_to_version(ver));
1075 SvNOK_on(ver); /* hint that it is a version */
1082 /* NOTE: The parser sees the package name and the VERSION swapped */
1083 PL_nextval[PL_nexttoke].opval = version;
1091 * Tokenize a quoted string passed in as an SV. It finds the next
1092 * chunk, up to end of string or a backslash. It may make a new
1093 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1098 S_tokeq(pTHX_ SV *sv)
1101 register char *send;
1109 s = SvPV_force(sv, len);
1110 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1113 while (s < send && *s != '\\')
1118 if ( PL_hints & HINT_NEW_STRING ) {
1119 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1125 if (s + 1 < send && (s[1] == '\\'))
1126 s++; /* all that, just for this */
1131 SvCUR_set(sv, d - SvPVX_const(sv));
1133 if ( PL_hints & HINT_NEW_STRING )
1134 return new_constant(NULL, 0, "q", sv, pv, "q");
1139 * Now come three functions related to double-quote context,
1140 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1141 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1142 * interact with PL_lex_state, and create fake ( ... ) argument lists
1143 * to handle functions and concatenation.
1144 * They assume that whoever calls them will be setting up a fake
1145 * join call, because each subthing puts a ',' after it. This lets
1148 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1150 * (I'm not sure whether the spurious commas at the end of lcfirst's
1151 * arguments and join's arguments are created or not).
1156 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1158 * Pattern matching will set PL_lex_op to the pattern-matching op to
1159 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1161 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1163 * Everything else becomes a FUNC.
1165 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1166 * had an OP_CONST or OP_READLINE). This just sets us up for a
1167 * call to S_sublex_push().
1171 S_sublex_start(pTHX)
1173 const register I32 op_type = yylval.ival;
1175 if (op_type == OP_NULL) {
1176 yylval.opval = PL_lex_op;
1180 if (op_type == OP_CONST || op_type == OP_READLINE) {
1181 SV *sv = tokeq(PL_lex_stuff);
1183 if (SvTYPE(sv) == SVt_PVIV) {
1184 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1186 const char *p = SvPV_const(sv, len);
1187 SV * const nsv = newSVpvn(p, len);
1193 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1194 PL_lex_stuff = Nullsv;
1195 /* Allow <FH> // "foo" */
1196 if (op_type == OP_READLINE)
1197 PL_expect = XTERMORDORDOR;
1201 PL_sublex_info.super_state = PL_lex_state;
1202 PL_sublex_info.sub_inwhat = op_type;
1203 PL_sublex_info.sub_op = PL_lex_op;
1204 PL_lex_state = LEX_INTERPPUSH;
1208 yylval.opval = PL_lex_op;
1218 * Create a new scope to save the lexing state. The scope will be
1219 * ended in S_sublex_done. Returns a '(', starting the function arguments
1220 * to the uc, lc, etc. found before.
1221 * Sets PL_lex_state to LEX_INTERPCONCAT.
1230 PL_lex_state = PL_sublex_info.super_state;
1231 SAVEI32(PL_lex_dojoin);
1232 SAVEI32(PL_lex_brackets);
1233 SAVEI32(PL_lex_casemods);
1234 SAVEI32(PL_lex_starts);
1235 SAVEI32(PL_lex_state);
1236 SAVEVPTR(PL_lex_inpat);
1237 SAVEI32(PL_lex_inwhat);
1238 SAVECOPLINE(PL_curcop);
1239 SAVEPPTR(PL_bufptr);
1240 SAVEPPTR(PL_bufend);
1241 SAVEPPTR(PL_oldbufptr);
1242 SAVEPPTR(PL_oldoldbufptr);
1243 SAVEPPTR(PL_last_lop);
1244 SAVEPPTR(PL_last_uni);
1245 SAVEPPTR(PL_linestart);
1246 SAVESPTR(PL_linestr);
1247 SAVEGENERICPV(PL_lex_brackstack);
1248 SAVEGENERICPV(PL_lex_casestack);
1250 PL_linestr = PL_lex_stuff;
1251 PL_lex_stuff = Nullsv;
1253 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1254 = SvPVX(PL_linestr);
1255 PL_bufend += SvCUR(PL_linestr);
1256 PL_last_lop = PL_last_uni = Nullch;
1257 SAVEFREESV(PL_linestr);
1259 PL_lex_dojoin = FALSE;
1260 PL_lex_brackets = 0;
1261 Newx(PL_lex_brackstack, 120, char);
1262 Newx(PL_lex_casestack, 12, char);
1263 PL_lex_casemods = 0;
1264 *PL_lex_casestack = '\0';
1266 PL_lex_state = LEX_INTERPCONCAT;
1267 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1269 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1270 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1271 PL_lex_inpat = PL_sublex_info.sub_op;
1273 PL_lex_inpat = Nullop;
1280 * Restores lexer state after a S_sublex_push.
1287 if (!PL_lex_starts++) {
1288 SV * const sv = newSVpvn("",0);
1289 if (SvUTF8(PL_linestr))
1291 PL_expect = XOPERATOR;
1292 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1296 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1297 PL_lex_state = LEX_INTERPCASEMOD;
1301 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1302 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1303 PL_linestr = PL_lex_repl;
1305 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1306 PL_bufend += SvCUR(PL_linestr);
1307 PL_last_lop = PL_last_uni = Nullch;
1308 SAVEFREESV(PL_linestr);
1309 PL_lex_dojoin = FALSE;
1310 PL_lex_brackets = 0;
1311 PL_lex_casemods = 0;
1312 *PL_lex_casestack = '\0';
1314 if (SvEVALED(PL_lex_repl)) {
1315 PL_lex_state = LEX_INTERPNORMAL;
1317 /* we don't clear PL_lex_repl here, so that we can check later
1318 whether this is an evalled subst; that means we rely on the
1319 logic to ensure sublex_done() is called again only via the
1320 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1323 PL_lex_state = LEX_INTERPCONCAT;
1324 PL_lex_repl = Nullsv;
1330 PL_bufend = SvPVX(PL_linestr);
1331 PL_bufend += SvCUR(PL_linestr);
1332 PL_expect = XOPERATOR;
1333 PL_sublex_info.sub_inwhat = 0;
1341 Extracts a pattern, double-quoted string, or transliteration. This
1344 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1345 processing a pattern (PL_lex_inpat is true), a transliteration
1346 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1348 Returns a pointer to the character scanned up to. Iff this is
1349 advanced from the start pointer supplied (ie if anything was
1350 successfully parsed), will leave an OP for the substring scanned
1351 in yylval. Caller must intuit reason for not parsing further
1352 by looking at the next characters herself.
1356 double-quoted style: \r and \n
1357 regexp special ones: \D \s
1359 backrefs: \1 (deprecated in substitution replacements)
1360 case and quoting: \U \Q \E
1361 stops on @ and $, but not for $ as tail anchor
1363 In transliterations:
1364 characters are VERY literal, except for - not at the start or end
1365 of the string, which indicates a range. scan_const expands the
1366 range to the full set of intermediate characters.
1368 In double-quoted strings:
1370 double-quoted style: \r and \n
1372 backrefs: \1 (deprecated)
1373 case and quoting: \U \Q \E
1376 scan_const does *not* construct ops to handle interpolated strings.
1377 It stops processing as soon as it finds an embedded $ or @ variable
1378 and leaves it to the caller to work out what's going on.
1380 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1382 $ in pattern could be $foo or could be tail anchor. Assumption:
1383 it's a tail anchor if $ is the last thing in the string, or if it's
1384 followed by one of ")| \n\t"
1386 \1 (backreferences) are turned into $1
1388 The structure of the code is
1389 while (there's a character to process) {
1390 handle transliteration ranges
1391 skip regexp comments
1392 skip # initiated comments in //x patterns
1393 check for embedded @foo
1394 check for embedded scalars
1396 leave intact backslashes from leave (below)
1397 deprecate \1 in strings and sub replacements
1398 handle string-changing backslashes \l \U \Q \E, etc.
1399 switch (what was escaped) {
1400 handle - in a transliteration (becomes a literal -)
1401 handle \132 octal characters
1402 handle 0x15 hex characters
1403 handle \cV (control V)
1404 handle printf backslashes (\f, \r, \n, etc)
1406 } (end if backslash)
1407 } (end while character to read)
1412 S_scan_const(pTHX_ char *start)
1414 register char *send = PL_bufend; /* end of the constant */
1415 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1416 register char *s = start; /* start of the constant */
1417 register char *d = SvPVX(sv); /* destination for copies */
1418 bool dorange = FALSE; /* are we in a translit range? */
1419 bool didrange = FALSE; /* did we just finish a range? */
1420 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1421 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1424 UV literal_endpoint = 0;
1427 const char *leaveit = /* set of acceptably-backslashed characters */
1429 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1432 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1433 /* If we are doing a trans and we know we want UTF8 set expectation */
1434 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1435 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1439 while (s < send || dorange) {
1440 /* get transliterations out of the way (they're most literal) */
1441 if (PL_lex_inwhat == OP_TRANS) {
1442 /* expand a range A-Z to the full set of characters. AIE! */
1444 I32 i; /* current expanded character */
1445 I32 min; /* first character in range */
1446 I32 max; /* last character in range */
1449 char * const c = (char*)utf8_hop((U8*)d, -1);
1453 *c = (char)UTF_TO_NATIVE(0xff);
1454 /* mark the range as done, and continue */
1460 i = d - SvPVX_const(sv); /* remember current offset */
1461 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1462 d = SvPVX(sv) + i; /* refresh d after realloc */
1463 d -= 2; /* eat the first char and the - */
1465 min = (U8)*d; /* first char in range */
1466 max = (U8)d[1]; /* last char in range */
1470 "Invalid range \"%c-%c\" in transliteration operator",
1471 (char)min, (char)max);
1475 if (literal_endpoint == 2 &&
1476 ((isLOWER(min) && isLOWER(max)) ||
1477 (isUPPER(min) && isUPPER(max)))) {
1479 for (i = min; i <= max; i++)
1481 *d++ = NATIVE_TO_NEED(has_utf8,i);
1483 for (i = min; i <= max; i++)
1485 *d++ = NATIVE_TO_NEED(has_utf8,i);
1490 for (i = min; i <= max; i++)
1493 /* mark the range as done, and continue */
1497 literal_endpoint = 0;
1502 /* range begins (ignore - as first or last char) */
1503 else if (*s == '-' && s+1 < send && s != start) {
1505 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1508 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1518 literal_endpoint = 0;
1523 /* if we get here, we're not doing a transliteration */
1525 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1526 except for the last char, which will be done separately. */
1527 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1529 while (s+1 < send && *s != ')')
1530 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1532 else if (s[2] == '{' /* This should match regcomp.c */
1533 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1536 char *regparse = s + (s[2] == '{' ? 3 : 4);
1539 while (count && (c = *regparse)) {
1540 if (c == '\\' && regparse[1])
1548 if (*regparse != ')')
1549 regparse--; /* Leave one char for continuation. */
1550 while (s < regparse)
1551 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1555 /* likewise skip #-initiated comments in //x patterns */
1556 else if (*s == '#' && PL_lex_inpat &&
1557 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1558 while (s+1 < send && *s != '\n')
1559 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1562 /* check for embedded arrays
1563 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1565 else if (*s == '@' && s[1]
1566 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1569 /* check for embedded scalars. only stop if we're sure it's a
1572 else if (*s == '$') {
1573 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1575 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1576 break; /* in regexp, $ might be tail anchor */
1579 /* End of else if chain - OP_TRANS rejoin rest */
1582 if (*s == '\\' && s+1 < send) {
1585 /* some backslashes we leave behind */
1586 if (*leaveit && *s && strchr(leaveit, *s)) {
1587 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1588 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1592 /* deprecate \1 in strings and substitution replacements */
1593 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1594 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1596 if (ckWARN(WARN_SYNTAX))
1597 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1602 /* string-change backslash escapes */
1603 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1608 /* if we get here, it's either a quoted -, or a digit */
1611 /* quoted - in transliterations */
1613 if (PL_lex_inwhat == OP_TRANS) {
1623 Perl_warner(aTHX_ packWARN(WARN_MISC),
1624 "Unrecognized escape \\%c passed through",
1626 /* default action is to copy the quoted character */
1627 goto default_action;
1630 /* \132 indicates an octal constant */
1631 case '0': case '1': case '2': case '3':
1632 case '4': case '5': case '6': case '7':
1636 uv = grok_oct(s, &len, &flags, NULL);
1639 goto NUM_ESCAPE_INSERT;
1641 /* \x24 indicates a hex constant */
1645 char* const e = strchr(s, '}');
1646 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1647 PERL_SCAN_DISALLOW_PREFIX;
1652 yyerror("Missing right brace on \\x{}");
1656 uv = grok_hex(s, &len, &flags, NULL);
1662 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1663 uv = grok_hex(s, &len, &flags, NULL);
1669 /* Insert oct or hex escaped character.
1670 * There will always enough room in sv since such
1671 * escapes will be longer than any UTF-8 sequence
1672 * they can end up as. */
1674 /* We need to map to chars to ASCII before doing the tests
1677 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1678 if (!has_utf8 && uv > 255) {
1679 /* Might need to recode whatever we have
1680 * accumulated so far if it contains any
1683 * (Can't we keep track of that and avoid
1684 * this rescan? --jhi)
1688 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1689 if (!NATIVE_IS_INVARIANT(*c)) {
1694 const STRLEN offset = d - SvPVX_const(sv);
1696 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1700 while (src >= (const U8 *)SvPVX_const(sv)) {
1701 if (!NATIVE_IS_INVARIANT(*src)) {
1702 const U8 ch = NATIVE_TO_ASCII(*src);
1703 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1704 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1714 if (has_utf8 || uv > 255) {
1715 d = (char*)uvchr_to_utf8((U8*)d, uv);
1717 if (PL_lex_inwhat == OP_TRANS &&
1718 PL_sublex_info.sub_op) {
1719 PL_sublex_info.sub_op->op_private |=
1720 (PL_lex_repl ? OPpTRANS_FROM_UTF
1733 /* \N{LATIN SMALL LETTER A} is a named character */
1737 char* e = strchr(s, '}');
1743 yyerror("Missing right brace on \\N{}");
1747 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1749 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1750 PERL_SCAN_DISALLOW_PREFIX;
1753 uv = grok_hex(s, &len, &flags, NULL);
1755 goto NUM_ESCAPE_INSERT;
1757 res = newSVpvn(s + 1, e - s - 1);
1758 res = new_constant( Nullch, 0, "charnames",
1759 res, Nullsv, "\\N{...}" );
1761 sv_utf8_upgrade(res);
1762 str = SvPV_const(res,len);
1763 #ifdef EBCDIC_NEVER_MIND
1764 /* charnames uses pack U and that has been
1765 * recently changed to do the below uni->native
1766 * mapping, so this would be redundant (and wrong,
1767 * the code point would be doubly converted).
1768 * But leave this in just in case the pack U change
1769 * gets revoked, but the semantics is still
1770 * desireable for charnames. --jhi */
1772 UV uv = utf8_to_uvchr((const U8*)str, 0);
1775 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1777 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1778 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1779 str = SvPV_const(res, len);
1783 if (!has_utf8 && SvUTF8(res)) {
1784 const char * const ostart = SvPVX_const(sv);
1785 SvCUR_set(sv, d - ostart);
1788 sv_utf8_upgrade(sv);
1789 /* this just broke our allocation above... */
1790 SvGROW(sv, (STRLEN)(send - start));
1791 d = SvPVX(sv) + SvCUR(sv);
1794 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1795 const char * const odest = SvPVX_const(sv);
1797 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1798 d = SvPVX(sv) + (d - odest);
1800 Copy(str, d, len, char);
1807 yyerror("Missing braces on \\N{}");
1810 /* \c is a control character */
1819 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1822 yyerror("Missing control char name in \\c");
1826 /* printf-style backslashes, formfeeds, newlines, etc */
1828 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1831 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1834 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1837 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1840 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1843 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1846 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1852 } /* end if (backslash) */
1859 /* If we started with encoded form, or already know we want it
1860 and then encode the next character */
1861 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1863 const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1864 const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1867 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1868 const STRLEN off = d - SvPVX_const(sv);
1869 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1871 d = (char*)uvchr_to_utf8((U8*)d, uv);
1875 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1877 } /* while loop to process each character */
1879 /* terminate the string and set up the sv */
1881 SvCUR_set(sv, d - SvPVX_const(sv));
1882 if (SvCUR(sv) >= SvLEN(sv))
1883 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1886 if (PL_encoding && !has_utf8) {
1887 sv_recode_to_utf8(sv, PL_encoding);
1893 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1894 PL_sublex_info.sub_op->op_private |=
1895 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1899 /* shrink the sv if we allocated more than we used */
1900 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1901 SvPV_shrink_to_cur(sv);
1904 /* return the substring (via yylval) only if we parsed anything */
1905 if (s > PL_bufptr) {
1906 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1907 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1909 ( PL_lex_inwhat == OP_TRANS
1911 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1914 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1921 * Returns TRUE if there's more to the expression (e.g., a subscript),
1924 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1926 * ->[ and ->{ return TRUE
1927 * { and [ outside a pattern are always subscripts, so return TRUE
1928 * if we're outside a pattern and it's not { or [, then return FALSE
1929 * if we're in a pattern and the first char is a {
1930 * {4,5} (any digits around the comma) returns FALSE
1931 * if we're in a pattern and the first char is a [
1933 * [SOMETHING] has a funky algorithm to decide whether it's a
1934 * character class or not. It has to deal with things like
1935 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1936 * anything else returns TRUE
1939 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1942 S_intuit_more(pTHX_ register char *s)
1944 if (PL_lex_brackets)
1946 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1948 if (*s != '{' && *s != '[')
1953 /* In a pattern, so maybe we have {n,m}. */
1970 /* On the other hand, maybe we have a character class */
1973 if (*s == ']' || *s == '^')
1976 /* this is terrifying, and it works */
1977 int weight = 2; /* let's weigh the evidence */
1979 unsigned char un_char = 255, last_un_char;
1980 const char * const send = strchr(s,']');
1981 char tmpbuf[sizeof PL_tokenbuf * 4];
1983 if (!send) /* has to be an expression */
1986 Zero(seen,256,char);
1989 else if (isDIGIT(*s)) {
1991 if (isDIGIT(s[1]) && s[2] == ']')
1997 for (; s < send; s++) {
1998 last_un_char = un_char;
1999 un_char = (unsigned char)*s;
2004 weight -= seen[un_char] * 10;
2005 if (isALNUM_lazy_if(s+1,UTF)) {
2006 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2007 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
2012 else if (*s == '$' && s[1] &&
2013 strchr("[#!%*<>()-=",s[1])) {
2014 if (/*{*/ strchr("])} =",s[2]))
2023 if (strchr("wds]",s[1]))
2025 else if (seen['\''] || seen['"'])
2027 else if (strchr("rnftbxcav",s[1]))
2029 else if (isDIGIT(s[1])) {
2031 while (s[1] && isDIGIT(s[1]))
2041 if (strchr("aA01! ",last_un_char))
2043 if (strchr("zZ79~",s[1]))
2045 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2046 weight -= 5; /* cope with negative subscript */
2049 if (!isALNUM(last_un_char)
2050 && !(last_un_char == '$' || last_un_char == '@'
2051 || last_un_char == '&')
2052 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2057 if (keyword(tmpbuf, d - tmpbuf))
2060 if (un_char == last_un_char + 1)
2062 weight -= seen[un_char];
2067 if (weight >= 0) /* probably a character class */
2077 * Does all the checking to disambiguate
2079 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2080 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2082 * First argument is the stuff after the first token, e.g. "bar".
2084 * Not a method if bar is a filehandle.
2085 * Not a method if foo is a subroutine prototyped to take a filehandle.
2086 * Not a method if it's really "Foo $bar"
2087 * Method if it's "foo $bar"
2088 * Not a method if it's really "print foo $bar"
2089 * Method if it's really "foo package::" (interpreted as package->foo)
2090 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2091 * Not a method if bar is a filehandle or package, but is quoted with
2096 S_intuit_method(pTHX_ char *start, GV *gv)
2098 char *s = start + (*start == '$');
2099 char tmpbuf[sizeof PL_tokenbuf];
2107 if ((cv = GvCVu(gv))) {
2108 const char *proto = SvPVX_const(cv);
2118 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2119 /* start is the beginning of the possible filehandle/object,
2120 * and s is the end of it
2121 * tmpbuf is a copy of it
2124 if (*start == '$') {
2125 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2130 return *s == '(' ? FUNCMETH : METHOD;
2132 if (!keyword(tmpbuf, len)) {
2133 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2138 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2139 if (indirgv && GvCVu(indirgv))
2141 /* filehandle or package name makes it a method */
2142 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2144 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2145 return 0; /* no assumptions -- "=>" quotes bearword */
2147 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2148 newSVpvn(tmpbuf,len));
2149 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2153 return *s == '(' ? FUNCMETH : METHOD;
2161 * Return a string of Perl code to load the debugger. If PERL5DB
2162 * is set, it will return the contents of that, otherwise a
2163 * compile-time require of perl5db.pl.
2170 const char * const pdb = PerlEnv_getenv("PERL5DB");
2174 SETERRNO(0,SS_NORMAL);
2175 return "BEGIN { require 'perl5db.pl' }";
2181 /* Encoded script support. filter_add() effectively inserts a
2182 * 'pre-processing' function into the current source input stream.
2183 * Note that the filter function only applies to the current source file
2184 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2186 * The datasv parameter (which may be NULL) can be used to pass
2187 * private data to this instance of the filter. The filter function
2188 * can recover the SV using the FILTER_DATA macro and use it to
2189 * store private buffers and state information.
2191 * The supplied datasv parameter is upgraded to a PVIO type
2192 * and the IoDIRP/IoANY field is used to store the function pointer,
2193 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2194 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2195 * private use must be set using malloc'd pointers.
2199 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2204 if (!PL_rsfp_filters)
2205 PL_rsfp_filters = newAV();
2207 datasv = NEWSV(255,0);
2208 SvUPGRADE(datasv, SVt_PVIO);
2209 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2210 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2211 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2212 IoANY(datasv), SvPV_nolen(datasv)));
2213 av_unshift(PL_rsfp_filters, 1);
2214 av_store(PL_rsfp_filters, 0, datasv) ;
2219 /* Delete most recently added instance of this filter function. */
2221 Perl_filter_del(pTHX_ filter_t funcp)
2226 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
2228 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2230 /* if filter is on top of stack (usual case) just pop it off */
2231 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2232 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2233 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2234 IoANY(datasv) = (void *)NULL;
2235 sv_free(av_pop(PL_rsfp_filters));
2239 /* we need to search for the correct entry and clear it */
2240 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2244 /* Invoke the idxth filter function for the current rsfp. */
2245 /* maxlen 0 = read one text line */
2247 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2252 if (!PL_rsfp_filters)
2254 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2255 /* Provide a default input filter to make life easy. */
2256 /* Note that we append to the line. This is handy. */
2257 DEBUG_P(PerlIO_printf(Perl_debug_log,
2258 "filter_read %d: from rsfp\n", idx));
2262 const int old_len = SvCUR(buf_sv);
2264 /* ensure buf_sv is large enough */
2265 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2266 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2267 if (PerlIO_error(PL_rsfp))
2268 return -1; /* error */
2270 return 0 ; /* end of file */
2272 SvCUR_set(buf_sv, old_len + len) ;
2275 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2276 if (PerlIO_error(PL_rsfp))
2277 return -1; /* error */
2279 return 0 ; /* end of file */
2282 return SvCUR(buf_sv);
2284 /* Skip this filter slot if filter has been deleted */
2285 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2286 DEBUG_P(PerlIO_printf(Perl_debug_log,
2287 "filter_read %d: skipped (filter deleted)\n",
2289 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2291 /* Get function pointer hidden within datasv */
2292 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2293 DEBUG_P(PerlIO_printf(Perl_debug_log,
2294 "filter_read %d: via function %p (%s)\n",
2295 idx, datasv, SvPV_nolen_const(datasv)));
2296 /* Call function. The function is expected to */
2297 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2298 /* Return: <0:error, =0:eof, >0:not eof */
2299 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2303 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2305 #ifdef PERL_CR_FILTER
2306 if (!PL_rsfp_filters) {
2307 filter_add(S_cr_textfilter,NULL);
2310 if (PL_rsfp_filters) {
2312 SvCUR_set(sv, 0); /* start with empty line */
2313 if (FILTER_READ(0, sv, 0) > 0)
2314 return ( SvPVX(sv) ) ;
2319 return (sv_gets(sv, fp, append));
2323 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2327 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2331 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2332 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2334 return GvHV(gv); /* Foo:: */
2337 /* use constant CLASS => 'MyClass' */
2338 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2340 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2341 pkgname = SvPV_nolen_const(sv);
2345 return gv_stashpv(pkgname, FALSE);
2349 S_tokenize_use(pTHX_ int is_use, char *s) {
2350 if (PL_expect != XSTATE)
2351 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2352 is_use ? "use" : "no"));
2354 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2355 s = force_version(s, TRUE);
2356 if (*s == ';' || (s = skipspace(s), *s == ';')) {
2357 PL_nextval[PL_nexttoke].opval = Nullop;
2360 else if (*s == 'v') {
2361 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2362 s = force_version(s, FALSE);
2366 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2367 s = force_version(s, FALSE);
2369 yylval.ival = is_use;
2373 static const char* const exp_name[] =
2374 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2375 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2382 Works out what to call the token just pulled out of the input
2383 stream. The yacc parser takes care of taking the ops we return and
2384 stitching them into a tree.
2390 if read an identifier
2391 if we're in a my declaration
2392 croak if they tried to say my($foo::bar)
2393 build the ops for a my() declaration
2394 if it's an access to a my() variable
2395 are we in a sort block?
2396 croak if my($a); $a <=> $b
2397 build ops for access to a my() variable
2398 if in a dq string, and they've said @foo and we can't find @foo
2400 build ops for a bareword
2401 if we already built the token before, use it.
2406 #pragma segment Perl_yylex
2411 register char *s = PL_bufptr;
2418 I32 orig_keyword = 0;
2421 SV* tmp = newSVpvn("", 0);
2422 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
2423 (IV)CopLINE(PL_curcop),
2424 lex_state_names[PL_lex_state],
2425 exp_name[PL_expect],
2426 pv_display(tmp, s, strlen(s), 0, 60));
2429 /* check if there's an identifier for us to look at */
2430 if (PL_pending_ident)
2431 return REPORT(S_pending_ident(aTHX));
2433 /* no identifier pending identification */
2435 switch (PL_lex_state) {
2437 case LEX_NORMAL: /* Some compilers will produce faster */
2438 case LEX_INTERPNORMAL: /* code if we comment these out. */
2442 /* when we've already built the next token, just pull it out of the queue */
2445 yylval = PL_nextval[PL_nexttoke];
2447 PL_lex_state = PL_lex_defer;
2448 PL_expect = PL_lex_expect;
2449 PL_lex_defer = LEX_NORMAL;
2451 return REPORT(PL_nexttype[PL_nexttoke]);
2453 /* interpolated case modifiers like \L \U, including \Q and \E.
2454 when we get here, PL_bufptr is at the \
2456 case LEX_INTERPCASEMOD:
2458 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2459 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2461 /* handle \E or end of string */
2462 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2464 if (PL_lex_casemods) {
2465 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
2466 PL_lex_casestack[PL_lex_casemods] = '\0';
2468 if (PL_bufptr != PL_bufend
2469 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2471 PL_lex_state = LEX_INTERPCONCAT;
2475 if (PL_bufptr != PL_bufend)
2477 PL_lex_state = LEX_INTERPCONCAT;
2481 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2482 "### Saw case modifier\n"); });
2484 if (s[1] == '\\' && s[2] == 'E') {
2486 PL_lex_state = LEX_INTERPCONCAT;
2490 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2491 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2492 if ((*s == 'L' || *s == 'U') &&
2493 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2494 PL_lex_casestack[--PL_lex_casemods] = '\0';
2497 if (PL_lex_casemods > 10)
2498 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2499 PL_lex_casestack[PL_lex_casemods++] = *s;
2500 PL_lex_casestack[PL_lex_casemods] = '\0';
2501 PL_lex_state = LEX_INTERPCONCAT;
2502 PL_nextval[PL_nexttoke].ival = 0;
2505 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2507 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2509 PL_nextval[PL_nexttoke].ival = OP_LC;
2511 PL_nextval[PL_nexttoke].ival = OP_UC;
2513 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2515 Perl_croak(aTHX_ "panic: yylex");
2519 if (PL_lex_starts) {
2522 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2523 if (PL_lex_casemods == 1 && PL_lex_inpat)
2532 case LEX_INTERPPUSH:
2533 return REPORT(sublex_push());
2535 case LEX_INTERPSTART:
2536 if (PL_bufptr == PL_bufend)
2537 return REPORT(sublex_done());
2538 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2539 "### Interpolated variable\n"); });
2541 PL_lex_dojoin = (*PL_bufptr == '@');
2542 PL_lex_state = LEX_INTERPNORMAL;
2543 if (PL_lex_dojoin) {
2544 PL_nextval[PL_nexttoke].ival = 0;
2546 force_ident("\"", '$');
2547 PL_nextval[PL_nexttoke].ival = 0;
2549 PL_nextval[PL_nexttoke].ival = 0;
2551 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2554 if (PL_lex_starts++) {
2556 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2557 if (!PL_lex_casemods && PL_lex_inpat)
2564 case LEX_INTERPENDMAYBE:
2565 if (intuit_more(PL_bufptr)) {
2566 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2572 if (PL_lex_dojoin) {
2573 PL_lex_dojoin = FALSE;
2574 PL_lex_state = LEX_INTERPCONCAT;
2577 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2578 && SvEVALED(PL_lex_repl))
2580 if (PL_bufptr != PL_bufend)
2581 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2582 PL_lex_repl = Nullsv;
2585 case LEX_INTERPCONCAT:
2587 if (PL_lex_brackets)
2588 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2590 if (PL_bufptr == PL_bufend)
2591 return REPORT(sublex_done());
2593 if (SvIVX(PL_linestr) == '\'') {
2594 SV *sv = newSVsv(PL_linestr);
2597 else if ( PL_hints & HINT_NEW_RE )
2598 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2599 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2603 s = scan_const(PL_bufptr);
2605 PL_lex_state = LEX_INTERPCASEMOD;
2607 PL_lex_state = LEX_INTERPSTART;
2610 if (s != PL_bufptr) {
2611 PL_nextval[PL_nexttoke] = yylval;
2614 if (PL_lex_starts++) {
2615 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2616 if (!PL_lex_casemods && PL_lex_inpat)
2629 PL_lex_state = LEX_NORMAL;
2630 s = scan_formline(PL_bufptr);
2631 if (!PL_lex_formbrack)
2637 PL_oldoldbufptr = PL_oldbufptr;
2643 if (isIDFIRST_lazy_if(s,UTF))
2645 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2648 goto fake_eof; /* emulate EOF on ^D or ^Z */
2653 if (PL_lex_brackets) {
2654 if (PL_lex_formbrack)
2655 yyerror("Format not terminated");
2657 yyerror("Missing right curly or square bracket");
2659 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2660 "### Tokener got EOF\n");
2664 if (s++ < PL_bufend)
2665 goto retry; /* ignore stray nulls */
2668 if (!PL_in_eval && !PL_preambled) {
2669 PL_preambled = TRUE;
2670 sv_setpv(PL_linestr,incl_perldb());
2671 if (SvCUR(PL_linestr))
2672 sv_catpvn(PL_linestr,";", 1);
2674 while(AvFILLp(PL_preambleav) >= 0) {
2675 SV *tmpsv = av_shift(PL_preambleav);
2676 sv_catsv(PL_linestr, tmpsv);
2677 sv_catpvn(PL_linestr, ";", 1);
2680 sv_free((SV*)PL_preambleav);
2681 PL_preambleav = NULL;
2683 if (PL_minus_n || PL_minus_p) {
2684 sv_catpv(PL_linestr, "LINE: while (<>) {");
2686 sv_catpv(PL_linestr,"chomp;");
2689 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2690 || *PL_splitstr == '"')
2691 && strchr(PL_splitstr + 1, *PL_splitstr))
2692 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2694 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2695 bytes can be used as quoting characters. :-) */
2696 /* The count here deliberately includes the NUL
2697 that terminates the C string constant. This
2698 embeds the opening NUL into the string. */
2699 const char *splits = PL_splitstr;
2700 sv_catpvn(PL_linestr, "our @F=split(q", 15);
2703 if (*splits == '\\')
2704 sv_catpvn(PL_linestr, splits, 1);
2705 sv_catpvn(PL_linestr, splits, 1);
2706 } while (*splits++);
2707 /* This loop will embed the trailing NUL of
2708 PL_linestr as the last thing it does before
2710 sv_catpvn(PL_linestr, ");", 2);
2714 sv_catpv(PL_linestr,"our @F=split(' ');");
2717 sv_catpvn(PL_linestr, "\n", 1);
2718 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2719 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2720 PL_last_lop = PL_last_uni = Nullch;
2721 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2722 SV * const sv = NEWSV(85,0);
2724 sv_upgrade(sv, SVt_PVMG);
2725 sv_setsv(sv,PL_linestr);
2728 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2733 bof = PL_rsfp ? TRUE : FALSE;
2734 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2737 if (PL_preprocess && !PL_in_eval)
2738 (void)PerlProc_pclose(PL_rsfp);
2739 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2740 PerlIO_clearerr(PL_rsfp);
2742 (void)PerlIO_close(PL_rsfp);
2744 PL_doextract = FALSE;
2746 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2747 sv_setpv(PL_linestr,PL_minus_p
2748 ? ";}continue{print;}" : ";}");
2749 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2750 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2751 PL_last_lop = PL_last_uni = Nullch;
2752 PL_minus_n = PL_minus_p = 0;
2755 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2756 PL_last_lop = PL_last_uni = Nullch;
2757 sv_setpvn(PL_linestr,"",0);
2758 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2760 /* If it looks like the start of a BOM or raw UTF-16,
2761 * check if it in fact is. */
2767 #ifdef PERLIO_IS_STDIO
2768 # ifdef __GNU_LIBRARY__
2769 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2770 # define FTELL_FOR_PIPE_IS_BROKEN
2774 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2775 # define FTELL_FOR_PIPE_IS_BROKEN
2780 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2781 /* This loses the possibility to detect the bof
2782 * situation on perl -P when the libc5 is being used.
2783 * Workaround? Maybe attach some extra state to PL_rsfp?
2786 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2788 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2791 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2792 s = swallow_bom((U8*)s);
2796 /* Incest with pod. */
2797 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2798 sv_setpvn(PL_linestr, "", 0);
2799 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2800 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2801 PL_last_lop = PL_last_uni = Nullch;
2802 PL_doextract = FALSE;
2806 } while (PL_doextract);
2807 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2808 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2809 SV * const sv = NEWSV(85,0);
2811 sv_upgrade(sv, SVt_PVMG);
2812 sv_setsv(sv,PL_linestr);
2815 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2817 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2818 PL_last_lop = PL_last_uni = Nullch;
2819 if (CopLINE(PL_curcop) == 1) {
2820 while (s < PL_bufend && isSPACE(*s))
2822 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2826 if (*s == '#' && *(s+1) == '!')
2828 #ifdef ALTERNATE_SHEBANG
2830 static char const as[] = ALTERNATE_SHEBANG;
2831 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2832 d = s + (sizeof(as) - 1);
2834 #endif /* ALTERNATE_SHEBANG */
2843 while (*d && !isSPACE(*d))
2847 #ifdef ARG_ZERO_IS_SCRIPT
2848 if (ipathend > ipath) {
2850 * HP-UX (at least) sets argv[0] to the script name,
2851 * which makes $^X incorrect. And Digital UNIX and Linux,
2852 * at least, set argv[0] to the basename of the Perl
2853 * interpreter. So, having found "#!", we'll set it right.
2855 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2856 assert(SvPOK(x) || SvGMAGICAL(x));
2857 if (sv_eq(x, CopFILESV(PL_curcop))) {
2858 sv_setpvn(x, ipath, ipathend - ipath);
2864 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
2865 const char * const lstart = SvPV_const(x,llen);
2867 bstart += blen - llen;
2868 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2869 sv_setpvn(x, ipath, ipathend - ipath);
2874 TAINT_NOT; /* $^X is always tainted, but that's OK */
2876 #endif /* ARG_ZERO_IS_SCRIPT */
2881 d = instr(s,"perl -");
2883 d = instr(s,"perl");
2885 /* avoid getting into infinite loops when shebang
2886 * line contains "Perl" rather than "perl" */
2888 for (d = ipathend-4; d >= ipath; --d) {
2889 if ((*d == 'p' || *d == 'P')
2890 && !ibcmp(d, "perl", 4))
2900 #ifdef ALTERNATE_SHEBANG
2902 * If the ALTERNATE_SHEBANG on this system starts with a
2903 * character that can be part of a Perl expression, then if
2904 * we see it but not "perl", we're probably looking at the
2905 * start of Perl code, not a request to hand off to some
2906 * other interpreter. Similarly, if "perl" is there, but
2907 * not in the first 'word' of the line, we assume the line
2908 * contains the start of the Perl program.
2910 if (d && *s != '#') {
2911 const char *c = ipath;
2912 while (*c && !strchr("; \t\r\n\f\v#", *c))
2915 d = Nullch; /* "perl" not in first word; ignore */
2917 *s = '#'; /* Don't try to parse shebang line */
2919 #endif /* ALTERNATE_SHEBANG */
2920 #ifndef MACOS_TRADITIONAL
2925 !instr(s,"indir") &&
2926 instr(PL_origargv[0],"perl"))
2933 while (s < PL_bufend && isSPACE(*s))
2935 if (s < PL_bufend) {
2936 Newxz(newargv,PL_origargc+3,char*);
2938 while (s < PL_bufend && !isSPACE(*s))
2941 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2944 newargv = PL_origargv;
2947 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2949 Perl_croak(aTHX_ "Can't exec %s", ipath);
2953 const U32 oldpdb = PL_perldb;
2954 const bool oldn = PL_minus_n;
2955 const bool oldp = PL_minus_p;
2957 while (*d && !isSPACE(*d)) d++;
2958 while (SPACE_OR_TAB(*d)) d++;
2961 const bool switches_done = PL_doswitches;
2963 if (*d == 'M' || *d == 'm' || *d == 'C') {
2964 const char * const m = d;
2965 while (*d && !isSPACE(*d)) d++;
2966 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2969 d = moreswitches(d);
2971 if (PL_doswitches && !switches_done) {
2972 int argc = PL_origargc;
2973 char **argv = PL_origargv;
2976 } while (argc && argv[0][0] == '-' && argv[0][1]);
2977 init_argv_symbols(argc,argv);
2979 if ((PERLDB_LINE && !oldpdb) ||
2980 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2981 /* if we have already added "LINE: while (<>) {",
2982 we must not do it again */
2984 sv_setpvn(PL_linestr, "", 0);
2985 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2986 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2987 PL_last_lop = PL_last_uni = Nullch;
2988 PL_preambled = FALSE;
2990 (void)gv_fetchfile(PL_origfilename);
2993 if (PL_doswitches && !switches_done) {
2994 int argc = PL_origargc;
2995 char **argv = PL_origargv;
2998 } while (argc && argv[0][0] == '-' && argv[0][1]);
2999 init_argv_symbols(argc,argv);
3005 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3007 PL_lex_state = LEX_FORMLINE;
3012 #ifdef PERL_STRICT_CR
3013 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3015 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3017 case ' ': case '\t': case '\f': case 013:
3018 #ifdef MACOS_TRADITIONAL
3025 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3026 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3027 /* handle eval qq[#line 1 "foo"\n ...] */
3028 CopLINE_dec(PL_curcop);
3032 while (s < d && *s != '\n')
3036 else if (s > d) /* Found by Ilya: feed random input to Perl. */
3037 Perl_croak(aTHX_ "panic: input overflow");
3039 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3041 PL_lex_state = LEX_FORMLINE;
3051 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3058 while (s < PL_bufend && SPACE_OR_TAB(*s))
3061 if (strnEQ(s,"=>",2)) {
3062 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3063 DEBUG_T( { S_printbuf(aTHX_
3064 "### Saw unary minus before =>, forcing word %s\n", s);
3066 OPERATOR('-'); /* unary minus */
3068 PL_last_uni = PL_oldbufptr;
3070 case 'r': ftst = OP_FTEREAD; break;
3071 case 'w': ftst = OP_FTEWRITE; break;
3072 case 'x': ftst = OP_FTEEXEC; break;
3073 case 'o': ftst = OP_FTEOWNED; break;
3074 case 'R': ftst = OP_FTRREAD; break;
3075 case 'W': ftst = OP_FTRWRITE; break;
3076 case 'X': ftst = OP_FTREXEC; break;
3077 case 'O': ftst = OP_FTROWNED; break;
3078 case 'e': ftst = OP_FTIS; break;
3079 case 'z': ftst = OP_FTZERO; break;
3080 case 's': ftst = OP_FTSIZE; break;
3081 case 'f': ftst = OP_FTFILE; break;
3082 case 'd': ftst = OP_FTDIR; break;
3083 case 'l': ftst = OP_FTLINK; break;
3084 case 'p': ftst = OP_FTPIPE; break;
3085 case 'S': ftst = OP_FTSOCK; break;
3086 case 'u': ftst = OP_FTSUID; break;
3087 case 'g': ftst = OP_FTSGID; break;
3088 case 'k': ftst = OP_FTSVTX; break;
3089 case 'b': ftst = OP_FTBLK; break;
3090 case 'c': ftst = OP_FTCHR; break;
3091 case 't': ftst = OP_FTTTY; break;
3092 case 'T': ftst = OP_FTTEXT; break;
3093 case 'B': ftst = OP_FTBINARY; break;
3094 case 'M': case 'A': case 'C':
3095 gv_fetchpv("\024",TRUE, SVt_PV);
3097 case 'M': ftst = OP_FTMTIME; break;
3098 case 'A': ftst = OP_FTATIME; break;
3099 case 'C': ftst = OP_FTCTIME; break;
3107 PL_last_lop_op = (OPCODE)ftst;
3108 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3109 "### Saw file test %c\n", (int)ftst);
3114 /* Assume it was a minus followed by a one-letter named
3115 * subroutine call (or a -bareword), then. */
3116 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3117 "### '-%c' looked like a file test but was not\n",
3126 if (PL_expect == XOPERATOR)
3131 else if (*s == '>') {
3134 if (isIDFIRST_lazy_if(s,UTF)) {
3135 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3143 if (PL_expect == XOPERATOR)
3146 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3148 OPERATOR('-'); /* unary minus */
3155 if (PL_expect == XOPERATOR)
3160 if (PL_expect == XOPERATOR)
3163 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3169 if (PL_expect != XOPERATOR) {
3170 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3171 PL_expect = XOPERATOR;
3172 force_ident(PL_tokenbuf, '*');
3185 if (PL_expect == XOPERATOR) {
3189 PL_tokenbuf[0] = '%';
3190 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3191 if (!PL_tokenbuf[1]) {
3194 PL_pending_ident = '%';
3213 switch (PL_expect) {
3216 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3218 PL_bufptr = s; /* update in case we back off */
3224 PL_expect = XTERMBLOCK;
3228 while (isIDFIRST_lazy_if(s,UTF)) {
3229 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3230 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3231 if (tmp < 0) tmp = -tmp;
3247 d = scan_str(d,TRUE,TRUE);
3249 /* MUST advance bufptr here to avoid bogus
3250 "at end of line" context messages from yyerror().
3252 PL_bufptr = s + len;
3253 yyerror("Unterminated attribute parameter in attribute list");
3256 return REPORT(0); /* EOF indicator */
3260 SV *sv = newSVpvn(s, len);
3261 sv_catsv(sv, PL_lex_stuff);
3262 attrs = append_elem(OP_LIST, attrs,
3263 newSVOP(OP_CONST, 0, sv));
3264 SvREFCNT_dec(PL_lex_stuff);
3265 PL_lex_stuff = Nullsv;
3268 if (len == 6 && strnEQ(s, "unique", len)) {
3269 if (PL_in_my == KEY_our)
3271 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3273 ; /* skip to avoid loading attributes.pm */
3276 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3279 /* NOTE: any CV attrs applied here need to be part of
3280 the CVf_BUILTIN_ATTRS define in cv.h! */
3281 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3282 CvLVALUE_on(PL_compcv);
3283 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3284 CvLOCKED_on(PL_compcv);
3285 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3286 CvMETHOD_on(PL_compcv);
3287 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3288 CvASSERTION_on(PL_compcv);
3289 /* After we've set the flags, it could be argued that
3290 we don't need to do the attributes.pm-based setting
3291 process, and shouldn't bother appending recognized
3292 flags. To experiment with that, uncomment the
3293 following "else". (Note that's already been
3294 uncommented. That keeps the above-applied built-in
3295 attributes from being intercepted (and possibly
3296 rejected) by a package's attribute routines, but is
3297 justified by the performance win for the common case
3298 of applying only built-in attributes.) */
3300 attrs = append_elem(OP_LIST, attrs,
3301 newSVOP(OP_CONST, 0,
3305 if (*s == ':' && s[1] != ':')
3308 break; /* require real whitespace or :'s */
3310 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3311 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3312 const char q = ((*s == '\'') ? '"' : '\'');
3313 /* If here for an expression, and parsed no attrs, back off. */
3314 if (tmp == '=' && !attrs) {
3318 /* MUST advance bufptr here to avoid bogus "at end of line"
3319 context messages from yyerror().
3323 yyerror("Unterminated attribute list");
3325 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3333 PL_nextval[PL_nexttoke].opval = attrs;
3341 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3342 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3359 if (PL_lex_brackets <= 0)
3360 yyerror("Unmatched right square bracket");
3363 if (PL_lex_state == LEX_INTERPNORMAL) {
3364 if (PL_lex_brackets == 0) {
3365 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3366 PL_lex_state = LEX_INTERPEND;
3373 if (PL_lex_brackets > 100) {
3374 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3376 switch (PL_expect) {
3378 if (PL_lex_formbrack) {
3382 if (PL_oldoldbufptr == PL_last_lop)
3383 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3385 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3386 OPERATOR(HASHBRACK);
3388 while (s < PL_bufend && SPACE_OR_TAB(*s))
3391 PL_tokenbuf[0] = '\0';
3392 if (d < PL_bufend && *d == '-') {
3393 PL_tokenbuf[0] = '-';
3395 while (d < PL_bufend && SPACE_OR_TAB(*d))
3398 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3399 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3401 while (d < PL_bufend && SPACE_OR_TAB(*d))
3404 const char minus = (PL_tokenbuf[0] == '-');
3405 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3413 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3418 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3423 if (PL_oldoldbufptr == PL_last_lop)
3424 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3426 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3429 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3431 /* This hack is to get the ${} in the message. */
3433 yyerror("syntax error");
3436 OPERATOR(HASHBRACK);
3438 /* This hack serves to disambiguate a pair of curlies
3439 * as being a block or an anon hash. Normally, expectation
3440 * determines that, but in cases where we're not in a
3441 * position to expect anything in particular (like inside
3442 * eval"") we have to resolve the ambiguity. This code
3443 * covers the case where the first term in the curlies is a
3444 * quoted string. Most other cases need to be explicitly
3445 * disambiguated by prepending a "+" before the opening
3446 * curly in order to force resolution as an anon hash.
3448 * XXX should probably propagate the outer expectation
3449 * into eval"" to rely less on this hack, but that could
3450 * potentially break current behavior of eval"".
3454 if (*s == '\'' || *s == '"' || *s == '`') {
3455 /* common case: get past first string, handling escapes */
3456 for (t++; t < PL_bufend && *t != *s;)
3457 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3461 else if (*s == 'q') {
3464 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3467 /* skip q//-like construct */
3469 char open, close, term;
3472 while (t < PL_bufend && isSPACE(*t))
3474 /* check for q => */
3475 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3476 OPERATOR(HASHBRACK);
3480 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3484 for (t++; t < PL_bufend; t++) {
3485 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3487 else if (*t == open)
3491 for (t++; t < PL_bufend; t++) {
3492 if (*t == '\\' && t+1 < PL_bufend)
3494 else if (*t == close && --brackets <= 0)
3496 else if (*t == open)
3503 /* skip plain q word */
3504 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3507 else if (isALNUM_lazy_if(t,UTF)) {
3509 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3512 while (t < PL_bufend && isSPACE(*t))
3514 /* if comma follows first term, call it an anon hash */
3515 /* XXX it could be a comma expression with loop modifiers */
3516 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3517 || (*t == '=' && t[1] == '>')))
3518 OPERATOR(HASHBRACK);
3519 if (PL_expect == XREF)
3522 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3528 yylval.ival = CopLINE(PL_curcop);
3529 if (isSPACE(*s) || *s == '#')
3530 PL_copline = NOLINE; /* invalidate current command line number */
3535 if (PL_lex_brackets <= 0)
3536 yyerror("Unmatched right curly bracket");
3538 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3539 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3540 PL_lex_formbrack = 0;
3541 if (PL_lex_state == LEX_INTERPNORMAL) {
3542 if (PL_lex_brackets == 0) {
3543 if (PL_expect & XFAKEBRACK) {
3544 PL_expect &= XENUMMASK;
3545 PL_lex_state = LEX_INTERPEND;
3547 return yylex(); /* ignore fake brackets */
3549 if (*s == '-' && s[1] == '>')
3550 PL_lex_state = LEX_INTERPENDMAYBE;
3551 else if (*s != '[' && *s != '{')
3552 PL_lex_state = LEX_INTERPEND;
3555 if (PL_expect & XFAKEBRACK) {
3556 PL_expect &= XENUMMASK;
3558 return yylex(); /* ignore fake brackets */
3568 if (PL_expect == XOPERATOR) {
3569 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
3570 && isIDFIRST_lazy_if(s,UTF))
3572 CopLINE_dec(PL_curcop);
3573 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3574 CopLINE_inc(PL_curcop);
3579 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3581 PL_expect = XOPERATOR;
3582 force_ident(PL_tokenbuf, '&');
3586 yylval.ival = (OPpENTERSUB_AMPER<<8);
3605 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
3606 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3608 if (PL_expect == XSTATE && isALPHA(tmp) &&
3609 (s == PL_linestart+1 || s[-2] == '\n') )
3611 if (PL_in_eval && !PL_rsfp) {
3616 if (strnEQ(s,"=cut",4)) {
3630 PL_doextract = TRUE;
3633 if (PL_lex_brackets < PL_lex_formbrack) {
3635 #ifdef PERL_STRICT_CR
3636 for (t = s; SPACE_OR_TAB(*t); t++) ;
3638 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3640 if (*t == '\n' || *t == '#') {
3652 /* was this !=~ where !~ was meant?
3653 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3655 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3656 const char *t = s+1;
3658 while (t < PL_bufend && isSPACE(*t))
3661 if (*t == '/' || *t == '?' ||
3662 ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3663 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3664 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3665 "!=~ should be !~");
3674 if (PL_expect != XOPERATOR) {
3675 if (s[1] != '<' && !strchr(s,'>'))
3678 s = scan_heredoc(s);
3680 s = scan_inputsymbol(s);
3681 TERM(sublex_start());
3686 SHop(OP_LEFT_SHIFT);
3700 SHop(OP_RIGHT_SHIFT);
3709 if (PL_expect == XOPERATOR) {
3710 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3713 return REPORT(','); /* grandfather non-comma-format format */
3717 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3718 PL_tokenbuf[0] = '@';
3719 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3720 sizeof PL_tokenbuf - 1, FALSE);
3721 if (PL_expect == XOPERATOR)
3722 no_op("Array length", s);
3723 if (!PL_tokenbuf[1])
3725 PL_expect = XOPERATOR;
3726 PL_pending_ident = '#';
3730 PL_tokenbuf[0] = '$';
3731 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3732 sizeof PL_tokenbuf - 1, FALSE);
3733 if (PL_expect == XOPERATOR)
3735 if (!PL_tokenbuf[1]) {
3737 yyerror("Final $ should be \\$ or $name");
3741 /* This kludge not intended to be bulletproof. */
3742 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3743 yylval.opval = newSVOP(OP_CONST, 0,
3744 newSViv(PL_compiling.cop_arybase));
3745 yylval.opval->op_private = OPpCONST_ARYBASE;
3751 if (PL_lex_state == LEX_NORMAL)
3754 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3756 PL_tokenbuf[0] = '@';
3757 if (ckWARN(WARN_SYNTAX)) {
3760 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3763 PL_bufptr = skipspace(PL_bufptr);
3764 while (t < PL_bufend && *t != ']')
3766 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3767 "Multidimensional syntax %.*s not supported",
3768 (t - PL_bufptr) + 1, PL_bufptr);
3772 else if (*s == '{') {
3774 PL_tokenbuf[0] = '%';
3775 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
3776 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
3778 char tmpbuf[sizeof PL_tokenbuf];
3779 for (t++; isSPACE(*t); t++) ;
3780 if (isIDFIRST_lazy_if(t,UTF)) {
3782 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3783 for (; isSPACE(*t); t++) ;
3784 if (*t == ';' && get_cv(tmpbuf, FALSE))
3785 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3786 "You need to quote \"%s\"", tmpbuf);
3792 PL_expect = XOPERATOR;
3793 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3794 const bool islop = (PL_last_lop == PL_oldoldbufptr);
3795 if (!islop || PL_last_lop_op == OP_GREPSTART)
3796 PL_expect = XOPERATOR;
3797 else if (strchr("$@\"'`q", *s))
3798 PL_expect = XTERM; /* e.g. print $fh "foo" */
3799 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3800 PL_expect = XTERM; /* e.g. print $fh &sub */
3801 else if (isIDFIRST_lazy_if(s,UTF)) {
3802 char tmpbuf[sizeof PL_tokenbuf];
3803 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3804 if ((tmp = keyword(tmpbuf, len))) {
3805 /* binary operators exclude handle interpretations */
3817 PL_expect = XTERM; /* e.g. print $fh length() */
3822 PL_expect = XTERM; /* e.g. print $fh subr() */
3825 else if (isDIGIT(*s))
3826 PL_expect = XTERM; /* e.g. print $fh 3 */
3827 else if (*s == '.' && isDIGIT(s[1]))
3828 PL_expect = XTERM; /* e.g. print $fh .3 */
3829 else if ((*s == '?' || *s == '-' || *s == '+')
3830 && !isSPACE(s[1]) && s[1] != '=')
3831 PL_expect = XTERM; /* e.g. print $fh -1 */
3832 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3833 PL_expect = XTERM; /* e.g. print $fh /.../
3834 XXX except DORDOR operator */
3835 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3836 PL_expect = XTERM; /* print $fh <<"EOF" */
3838 PL_pending_ident = '$';
3842 if (PL_expect == XOPERATOR)
3844 PL_tokenbuf[0] = '@';
3845 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3846 if (!PL_tokenbuf[1]) {
3849 if (PL_lex_state == LEX_NORMAL)
3851 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3853 PL_tokenbuf[0] = '%';
3855 /* Warn about @ where they meant $. */
3856 if (*s == '[' || *s == '{') {
3857 if (ckWARN(WARN_SYNTAX)) {
3858 const char *t = s + 1;
3859 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3861 if (*t == '}' || *t == ']') {
3863 PL_bufptr = skipspace(PL_bufptr);
3864 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3865 "Scalar value %.*s better written as $%.*s",
3866 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3871 PL_pending_ident = '@';
3874 case '/': /* may be division, defined-or, or pattern */
3875 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3879 case '?': /* may either be conditional or pattern */
3880 if(PL_expect == XOPERATOR) {
3888 /* A // operator. */
3898 /* Disable warning on "study /blah/" */
3899 if (PL_oldoldbufptr == PL_last_uni
3900 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3901 || memNE(PL_last_uni, "study", 5)
3902 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3905 s = scan_pat(s,OP_MATCH);
3906 TERM(sublex_start());
3910 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3911 #ifdef PERL_STRICT_CR
3914 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3916 && (s == PL_linestart || s[-1] == '\n') )
3918 PL_lex_formbrack = 0;
3922 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3928 yylval.ival = OPf_SPECIAL;
3934 if (PL_expect != XOPERATOR)
3939 case '0': case '1': case '2': case '3': case '4':
3940 case '5': case '6': case '7': case '8': case '9':
3941 s = scan_num(s, &yylval);
3942 DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
3943 if (PL_expect == XOPERATOR)
3948 s = scan_str(s,FALSE,FALSE);
3949 DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
3950 if (PL_expect == XOPERATOR) {
3951 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3954 return REPORT(','); /* grandfather non-comma-format format */
3960 missingterm((char*)0);
3961 yylval.ival = OP_CONST;
3962 TERM(sublex_start());
3965 s = scan_str(s,FALSE,FALSE);
3966 DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
3967 if (PL_expect == XOPERATOR) {
3968 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3971 return REPORT(','); /* grandfather non-comma-format format */
3977 missingterm((char*)0);
3978 yylval.ival = OP_CONST;
3979 /* FIXME. I think that this can be const if char *d is replaced by
3980 more localised variables. */
3981 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3982 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3983 yylval.ival = OP_STRINGIFY;
3987 TERM(sublex_start());
3990 s = scan_str(s,FALSE,FALSE);
3991 DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
3992 if (PL_expect == XOPERATOR)
3993 no_op("Backticks",s);
3995 missingterm((char*)0);
3996 yylval.ival = OP_BACKTICK;
3998 TERM(sublex_start());
4002 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
4003 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
4005 if (PL_expect == XOPERATOR)
4006 no_op("Backslash",s);
4010 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4011 char *start = s + 2;
4012 while (isDIGIT(*start) || *start == '_')
4014 if (*start == '.' && isDIGIT(start[1])) {
4015 s = scan_num(s, &yylval);
4018 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4019 else if (!isALPHA(*start) && (PL_expect == XTERM
4020 || PL_expect == XREF || PL_expect == XSTATE
4021 || PL_expect == XTERMORDORDOR)) {
4022 const char c = *start;
4025 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
4028 s = scan_num(s, &yylval);
4035 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4075 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4077 /* Some keywords can be followed by any delimiter, including ':' */
4078 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4079 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4080 (PL_tokenbuf[0] == 'q' &&
4081 strchr("qwxr", PL_tokenbuf[1])))));
4083 /* x::* is just a word, unless x is "CORE" */
4084 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4088 while (d < PL_bufend && isSPACE(*d))
4089 d++; /* no comments skipped here, or s### is misparsed */
4091 /* Is this a label? */
4092 if (!tmp && PL_expect == XSTATE
4093 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4095 yylval.pval = savepv(PL_tokenbuf);
4100 /* Check for keywords */
4101 tmp = keyword(PL_tokenbuf, len);
4103 /* Is this a word before a => operator? */
4104 if (*d == '=' && d[1] == '>') {
4107 = (OP*)newSVOP(OP_CONST, 0,
4108 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4109 yylval.opval->op_private = OPpCONST_BARE;
4113 if (tmp < 0) { /* second-class keyword? */
4114 GV *ogv = Nullgv; /* override (winner) */
4115 GV *hgv = Nullgv; /* hidden (loser) */
4116 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4118 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4121 if (GvIMPORTED_CV(gv))
4123 else if (! CvMETHOD(cv))
4127 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4128 (gv = *gvp) != (GV*)&PL_sv_undef &&
4129 GvCVu(gv) && GvIMPORTED_CV(gv))
4136 tmp = 0; /* overridden by import or by GLOBAL */
4139 && -tmp==KEY_lock /* XXX generalizable kludge */
4141 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4143 tmp = 0; /* any sub overrides "weak" keyword */
4148 && PL_expect != XOPERATOR
4149 && PL_expect != XTERMORDORDOR)
4151 /* any sub overrides the "err" keyword, except when really an
4152 * operator is expected */
4155 else { /* no override */
4157 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4158 Perl_warner(aTHX_ packWARN(WARN_MISC),
4159 "dump() better written as CORE::dump()");
4163 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4164 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
4165 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4166 "Ambiguous call resolved as CORE::%s(), %s",
4167 GvENAME(hgv), "qualify as such or use &");
4174 default: /* not a keyword */
4178 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4180 /* Get the rest if it looks like a package qualifier */
4182 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4184 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4187 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4188 *s == '\'' ? "'" : "::");
4193 if (PL_expect == XOPERATOR) {
4194 if (PL_bufptr == PL_linestart) {
4195 CopLINE_dec(PL_curcop);
4196 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4197 CopLINE_inc(PL_curcop);
4200 no_op("Bareword",s);
4203 /* Look for a subroutine with this name in current package,
4204 unless name is "Foo::", in which case Foo is a bearword
4205 (and a package name). */
4208 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4210 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4211 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4212 "Bareword \"%s\" refers to nonexistent package",
4215 PL_tokenbuf[len] = '\0';
4222 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4225 /* if we saw a global override before, get the right name */
4228 sv = newSVpvn("CORE::GLOBAL::",14);
4229 sv_catpv(sv,PL_tokenbuf);
4232 /* If len is 0, newSVpv does strlen(), which is correct.
4233 If len is non-zero, then it will be the true length,
4234 and so the scalar will be created correctly. */
4235 sv = newSVpv(PL_tokenbuf,len);
4238 /* Presume this is going to be a bareword of some sort. */
4241 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4242 yylval.opval->op_private = OPpCONST_BARE;
4243 /* UTF-8 package name? */
4244 if (UTF && !IN_BYTES &&
4245 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4248 /* And if "Foo::", then that's what it certainly is. */
4253 /* See if it's the indirect object for a list operator. */
4255 if (PL_oldoldbufptr &&
4256 PL_oldoldbufptr < PL_bufptr &&
4257 (PL_oldoldbufptr == PL_last_lop
4258 || PL_oldoldbufptr == PL_last_uni) &&