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 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
415 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
416 "\t(Missing operator before %.*s?)\n", (int)(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 * const 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) &&
4259 /* NO SKIPSPACE BEFORE HERE! */
4260 (PL_expect == XREF ||
4261 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4263 bool immediate_paren = *s == '(';
4265 /* (Now we can afford to cross potential line boundary.) */
4268 /* Two barewords in a row may indicate method call. */
4270 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4273 /* If not a declared subroutine, it's an indirect object. */
4274 /* (But it's an indir obj regardless for sort.) */
4276 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4277 ((!gv || !GvCVu(gv)) &&
4278 (PL_last_lop_op != OP_MAPSTART &&
4279 PL_last_lop_op != OP_GREPSTART))))
4281 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4286 PL_expect = XOPERATOR;
4289 /* Is this a word before a => operator? */
4290 if (*s == '=' && s[1] == '>' && !pkgname) {
4292 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4293 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4294 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4298 /* If followed by a paren, it's certainly a subroutine. */
4301 if (gv && GvCVu(gv)) {
4302 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4303 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4308 PL_nextval[PL_nexttoke].opval = yylval.opval;
4309 PL_expect = XOPERATOR;
4315 /* If followed by var or block, call it a method (unless sub) */
4317 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4318 PL_last_lop = PL_oldbufptr;
4319 PL_last_lop_op = OP_METHOD;
4323 /* If followed by a bareword, see if it looks like indir obj. */
4326 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4327 && (tmp = intuit_method(s,gv)))
4330 /* Not a method, so call it a subroutine (if defined) */
4332 if (gv && GvCVu(gv)) {
4334 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4335 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4336 "Ambiguous use of -%s resolved as -&%s()",
4337 PL_tokenbuf, PL_tokenbuf);
4338 /* Check for a constant sub */
4340 if ((sv = cv_const_sv(cv))) {
4342 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4343 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4344 yylval.opval->op_private = 0;
4348 /* Resolve to GV now. */
4349 op_free(yylval.opval);
4350 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4351 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4352 PL_last_lop = PL_oldbufptr;
4353 PL_last_lop_op = OP_ENTERSUB;
4354 /* Is there a prototype? */
4357 const char *proto = SvPV_const((SV*)cv, len);
4360 if (*proto == '$' && proto[1] == '\0')
4362 while (*proto == ';')
4364 if (*proto == '&' && *s == '{') {
4365 sv_setpv(PL_subname, PL_curstash ?
4366 "__ANON__" : "__ANON__::__ANON__");
4370 PL_nextval[PL_nexttoke].opval = yylval.opval;
4376 /* Call it a bare word */
4378 if (PL_hints & HINT_STRICT_SUBS)
4379 yylval.opval->op_private |= OPpCONST_STRICT;
4382 if (lastchar != '-') {
4383 if (ckWARN(WARN_RESERVED)) {
4384 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4385 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4386 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4393 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4394 && ckWARN_d(WARN_AMBIGUOUS)) {
4395 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4396 "Operator or semicolon missing before %c%s",
4397 lastchar, PL_tokenbuf);
4398 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4399 "Ambiguous use of %c resolved as operator %c",
4400 lastchar, lastchar);
4406 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4407 newSVpv(CopFILE(PL_curcop),0));
4411 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4412 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4415 case KEY___PACKAGE__:
4416 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4418 ? newSVhek(HvNAME_HEK(PL_curstash))
4425 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4426 const char *pname = "main";
4427 if (PL_tokenbuf[2] == 'D')
4428 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
4429 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4432 GvIOp(gv) = newIO();
4433 IoIFP(GvIOp(gv)) = PL_rsfp;
4434 #if defined(HAS_FCNTL) && defined(F_SETFD)
4436 const int fd = PerlIO_fileno(PL_rsfp);
4437 fcntl(fd,F_SETFD,fd >= 3);
4440 /* Mark this internal pseudo-handle as clean */
4441 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4443 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4444 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4445 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4447 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4448 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4449 /* if the script was opened in binmode, we need to revert
4450 * it to text mode for compatibility; but only iff it has CRs
4451 * XXX this is a questionable hack at best. */
4452 if (PL_bufend-PL_bufptr > 2
4453 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4456 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4457 loc = PerlIO_tell(PL_rsfp);
4458 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4461 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4463 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4464 #endif /* NETWARE */
4465 #ifdef PERLIO_IS_STDIO /* really? */
4466 # if defined(__BORLANDC__)
4467 /* XXX see note in do_binmode() */
4468 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4472 PerlIO_seek(PL_rsfp, loc, 0);
4476 #ifdef PERLIO_LAYERS
4479 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4480 else if (PL_encoding) {
4487 XPUSHs(PL_encoding);
4489 call_method("name", G_SCALAR);
4493 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4494 Perl_form(aTHX_ ":encoding(%"SVf")",
4512 if (PL_expect == XSTATE) {
4519 if (*s == ':' && s[1] == ':') {
4522 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4523 if (!(tmp = keyword(PL_tokenbuf, len)))
4524 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4527 else if (tmp == KEY_require || tmp == KEY_do)
4528 /* that's a way to remember we saw "CORE::" */
4541 LOP(OP_ACCEPT,XTERM);
4547 LOP(OP_ATAN2,XTERM);
4553 LOP(OP_BINMODE,XTERM);
4556 LOP(OP_BLESS,XTERM);
4565 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4582 if (!PL_cryptseen) {
4583 PL_cryptseen = TRUE;
4587 LOP(OP_CRYPT,XTERM);
4590 LOP(OP_CHMOD,XTERM);
4593 LOP(OP_CHOWN,XTERM);
4596 LOP(OP_CONNECT,XTERM);
4612 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4613 if (orig_keyword == KEY_do) {
4622 PL_hints |= HINT_BLOCK_SCOPE;
4632 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4633 LOP(OP_DBMOPEN,XTERM);
4639 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4646 yylval.ival = CopLINE(PL_curcop);
4660 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4661 UNIBRACK(OP_ENTEREVAL);
4679 case KEY_endhostent:
4685 case KEY_endservent:
4688 case KEY_endprotoent:
4699 yylval.ival = CopLINE(PL_curcop);
4701 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4703 if ((PL_bufend - p) >= 3 &&
4704 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4706 else if ((PL_bufend - p) >= 4 &&
4707 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4710 if (isIDFIRST_lazy_if(p,UTF)) {
4711 p = scan_ident(p, PL_bufend,
4712 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4716 Perl_croak(aTHX_ "Missing $ on loop variable");
4721 LOP(OP_FORMLINE,XTERM);
4727 LOP(OP_FCNTL,XTERM);
4733 LOP(OP_FLOCK,XTERM);
4742 LOP(OP_GREPSTART, XREF);
4745 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4760 case KEY_getpriority:
4761 LOP(OP_GETPRIORITY,XTERM);
4763 case KEY_getprotobyname:
4766 case KEY_getprotobynumber:
4767 LOP(OP_GPBYNUMBER,XTERM);
4769 case KEY_getprotoent:
4781 case KEY_getpeername:
4782 UNI(OP_GETPEERNAME);
4784 case KEY_gethostbyname:
4787 case KEY_gethostbyaddr:
4788 LOP(OP_GHBYADDR,XTERM);
4790 case KEY_gethostent:
4793 case KEY_getnetbyname:
4796 case KEY_getnetbyaddr:
4797 LOP(OP_GNBYADDR,XTERM);
4802 case KEY_getservbyname:
4803 LOP(OP_GSBYNAME,XTERM);
4805 case KEY_getservbyport:
4806 LOP(OP_GSBYPORT,XTERM);
4808 case KEY_getservent:
4811 case KEY_getsockname:
4812 UNI(OP_GETSOCKNAME);
4814 case KEY_getsockopt:
4815 LOP(OP_GSOCKOPT,XTERM);
4837 yylval.ival = CopLINE(PL_curcop);
4841 LOP(OP_INDEX,XTERM);
4847 LOP(OP_IOCTL,XTERM);
4859 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4891 LOP(OP_LISTEN,XTERM);
4900 s = scan_pat(s,OP_MATCH);
4901 TERM(sublex_start());
4904 LOP(OP_MAPSTART, XREF);
4907 LOP(OP_MKDIR,XTERM);
4910 LOP(OP_MSGCTL,XTERM);
4913 LOP(OP_MSGGET,XTERM);
4916 LOP(OP_MSGRCV,XTERM);
4919 LOP(OP_MSGSND,XTERM);
4925 if (isIDFIRST_lazy_if(s,UTF)) {
4926 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4927 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4929 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4930 if (!PL_in_my_stash) {
4933 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4941 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4948 s = tokenize_use(0, s);
4952 if (*s == '(' || (s = skipspace(s), *s == '('))
4959 if (isIDFIRST_lazy_if(s,UTF)) {
4961 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4962 for (t=d; *t && isSPACE(*t); t++) ;
4963 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4965 && !(t[0] == '=' && t[1] == '>')
4967 int len = (int)(d-s);
4968 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4969 "Precedence problem: open %.*s should be open(%.*s)",
4976 yylval.ival = OP_OR;
4986 LOP(OP_OPEN_DIR,XTERM);
4989 checkcomma(s,PL_tokenbuf,"filehandle");
4993 checkcomma(s,PL_tokenbuf,"filehandle");
5012 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5016 LOP(OP_PIPE_OP,XTERM);
5019 s = scan_str(s,FALSE,FALSE);
5021 missingterm((char*)0);
5022 yylval.ival = OP_CONST;
5023 TERM(sublex_start());
5029 s = scan_str(s,FALSE,FALSE);
5031 missingterm((char*)0);
5032 PL_expect = XOPERATOR;
5034 if (SvCUR(PL_lex_stuff)) {
5037 d = SvPV_force(PL_lex_stuff, len);
5040 for (; isSPACE(*d) && len; --len, ++d) ;
5043 if (!warned && ckWARN(WARN_QW)) {
5044 for (; !isSPACE(*d) && len; --len, ++d) {
5046 Perl_warner(aTHX_ packWARN(WARN_QW),
5047 "Possible attempt to separate words with commas");
5050 else if (*d == '#') {
5051 Perl_warner(aTHX_ packWARN(WARN_QW),
5052 "Possible attempt to put comments in qw() list");
5058 for (; !isSPACE(*d) && len; --len, ++d) ;
5060 sv = newSVpvn(b, d-b);
5061 if (DO_UTF8(PL_lex_stuff))
5063 words = append_elem(OP_LIST, words,
5064 newSVOP(OP_CONST, 0, tokeq(sv)));
5068 PL_nextval[PL_nexttoke].opval = words;
5073 SvREFCNT_dec(PL_lex_stuff);
5074 PL_lex_stuff = Nullsv;
5080 s = scan_str(s,FALSE,FALSE);
5082 missingterm((char*)0);
5083 yylval.ival = OP_STRINGIFY;
5084 if (SvIVX(PL_lex_stuff) == '\'')
5085 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
5086 TERM(sublex_start());
5089 s = scan_pat(s,OP_QR);
5090 TERM(sublex_start());
5093 s = scan_str(s,FALSE,FALSE);
5095 missingterm((char*)0);
5096 yylval.ival = OP_BACKTICK;
5098 TERM(sublex_start());
5106 s = force_version(s, FALSE);
5108 else if (*s != 'v' || !isDIGIT(s[1])
5109 || (s = force_version(s, TRUE), *s == 'v'))
5111 *PL_tokenbuf = '\0';
5112 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5113 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5114 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5116 yyerror("<> should be quotes");
5118 if (orig_keyword == KEY_require) {
5126 PL_last_uni = PL_oldbufptr;
5127 PL_last_lop_op = OP_REQUIRE;
5129 return REPORT( (int)REQUIRE );
5135 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5139 LOP(OP_RENAME,XTERM);
5148 LOP(OP_RINDEX,XTERM);
5158 UNIDOR(OP_READLINE);
5171 LOP(OP_REVERSE,XTERM);
5174 UNIDOR(OP_READLINK);
5182 TERM(sublex_start());
5184 TOKEN(1); /* force error */
5193 LOP(OP_SELECT,XTERM);
5199 LOP(OP_SEMCTL,XTERM);
5202 LOP(OP_SEMGET,XTERM);
5205 LOP(OP_SEMOP,XTERM);
5211 LOP(OP_SETPGRP,XTERM);
5213 case KEY_setpriority:
5214 LOP(OP_SETPRIORITY,XTERM);
5216 case KEY_sethostent:
5222 case KEY_setservent:
5225 case KEY_setprotoent:
5235 LOP(OP_SEEKDIR,XTERM);
5237 case KEY_setsockopt:
5238 LOP(OP_SSOCKOPT,XTERM);
5244 LOP(OP_SHMCTL,XTERM);
5247 LOP(OP_SHMGET,XTERM);
5250 LOP(OP_SHMREAD,XTERM);
5253 LOP(OP_SHMWRITE,XTERM);
5256 LOP(OP_SHUTDOWN,XTERM);
5265 LOP(OP_SOCKET,XTERM);
5267 case KEY_socketpair:
5268 LOP(OP_SOCKPAIR,XTERM);
5271 checkcomma(s,PL_tokenbuf,"subroutine name");
5273 if (*s == ';' || *s == ')') /* probably a close */
5274 Perl_croak(aTHX_ "sort is now a reserved word");
5276 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5280 LOP(OP_SPLIT,XTERM);
5283 LOP(OP_SPRINTF,XTERM);
5286 LOP(OP_SPLICE,XTERM);
5301 LOP(OP_SUBSTR,XTERM);
5307 char tmpbuf[sizeof PL_tokenbuf];
5308 SSize_t tboffset = 0;
5309 expectation attrful;
5310 bool have_name, have_proto, bad_proto;
5311 const int key = tmp;
5315 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5316 (*s == ':' && s[1] == ':'))
5319 attrful = XATTRBLOCK;
5320 /* remember buffer pos'n for later force_word */
5321 tboffset = s - PL_oldbufptr;
5322 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5323 if (strchr(tmpbuf, ':'))
5324 sv_setpv(PL_subname, tmpbuf);
5326 sv_setsv(PL_subname,PL_curstname);
5327 sv_catpvn(PL_subname,"::",2);
5328 sv_catpvn(PL_subname,tmpbuf,len);
5335 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5336 PL_expect = XTERMBLOCK;
5337 attrful = XATTRTERM;
5338 sv_setpvn(PL_subname,"?",1);
5342 if (key == KEY_format) {
5344 PL_lex_formbrack = PL_lex_brackets + 1;
5346 (void) force_word(PL_oldbufptr + tboffset, WORD,
5351 /* Look for a prototype */
5355 s = scan_str(s,FALSE,FALSE);
5357 Perl_croak(aTHX_ "Prototype not terminated");
5358 /* strip spaces and check for bad characters */
5359 d = SvPVX(PL_lex_stuff);
5362 for (p = d; *p; ++p) {
5365 if (!strchr("$@%*;[]&\\", *p))
5370 if (bad_proto && ckWARN(WARN_SYNTAX))
5371 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5372 "Illegal character in prototype for %"SVf" : %s",
5374 SvCUR_set(PL_lex_stuff, tmp);
5382 if (*s == ':' && s[1] != ':')
5383 PL_expect = attrful;
5384 else if (*s != '{' && key == KEY_sub) {
5386 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5388 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5392 PL_nextval[PL_nexttoke].opval =
5393 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5394 PL_lex_stuff = Nullsv;
5398 sv_setpv(PL_subname,
5399 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5402 (void) force_word(PL_oldbufptr + tboffset, WORD,
5411 LOP(OP_SYSTEM,XREF);
5414 LOP(OP_SYMLINK,XTERM);
5417 LOP(OP_SYSCALL,XTERM);
5420 LOP(OP_SYSOPEN,XTERM);
5423 LOP(OP_SYSSEEK,XTERM);
5426 LOP(OP_SYSREAD,XTERM);
5429 LOP(OP_SYSWRITE,XTERM);
5433 TERM(sublex_start());
5454 LOP(OP_TRUNCATE,XTERM);
5466 yylval.ival = CopLINE(PL_curcop);
5470 yylval.ival = CopLINE(PL_curcop);
5474 LOP(OP_UNLINK,XTERM);
5480 LOP(OP_UNPACK,XTERM);
5483 LOP(OP_UTIME,XTERM);
5489 LOP(OP_UNSHIFT,XTERM);
5492 s = tokenize_use(1, s);
5502 yylval.ival = CopLINE(PL_curcop);
5506 PL_hints |= HINT_BLOCK_SCOPE;
5513 LOP(OP_WAITPID,XTERM);
5522 ctl_l[0] = toCTRL('L');
5524 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5527 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5532 if (PL_expect == XOPERATOR)
5538 yylval.ival = OP_XOR;
5543 TERM(sublex_start());
5548 #pragma segment Main
5552 S_pending_ident(pTHX)
5555 register I32 tmp = 0;
5556 /* pit holds the identifier we read and pending_ident is reset */
5557 char pit = PL_pending_ident;
5558 PL_pending_ident = 0;
5560 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5561 "### Pending identifier '%s'\n", PL_tokenbuf); });
5563 /* if we're in a my(), we can't allow dynamics here.
5564 $foo'bar has already been turned into $foo::bar, so
5565 just check for colons.
5567 if it's a legal name, the OP is a PADANY.
5570 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5571 if (strchr(PL_tokenbuf,':'))
5572 yyerror(Perl_form(aTHX_ "No package name allowed for "
5573 "variable %s in \"our\"",
5575 tmp = allocmy(PL_tokenbuf);
5578 if (strchr(PL_tokenbuf,':'))
5579 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5581 yylval.opval = newOP(OP_PADANY, 0);
5582 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5588 build the ops for accesses to a my() variable.
5590 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5591 then used in a comparison. This catches most, but not
5592 all cases. For instance, it catches
5593 sort { my($a); $a <=> $b }
5595 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5596 (although why you'd do that is anyone's guess).
5599 if (!strchr(PL_tokenbuf,':')) {
5601 tmp = pad_findmy(PL_tokenbuf);
5602 if (tmp != NOT_IN_PAD) {
5603 /* might be an "our" variable" */
5604 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5605 /* build ops for a bareword */
5606 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
5607 HEK * const stashname = HvNAME_HEK(stash);
5608 SV * const sym = newSVhek(stashname);
5609 sv_catpvn(sym, "::", 2);
5610 sv_catpv(sym, PL_tokenbuf+1);
5611 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5612 yylval.opval->op_private = OPpCONST_ENTERED;
5615 ? (GV_ADDMULTI | GV_ADDINEVAL)
5618 ((PL_tokenbuf[0] == '$') ? SVt_PV
5619 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5624 /* if it's a sort block and they're naming $a or $b */
5625 if (PL_last_lop_op == OP_SORT &&
5626 PL_tokenbuf[0] == '$' &&
5627 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5630 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5631 d < PL_bufend && *d != '\n';
5634 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5635 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5641 yylval.opval = newOP(OP_PADANY, 0);
5642 yylval.opval->op_targ = tmp;
5648 Whine if they've said @foo in a doublequoted string,
5649 and @foo isn't a variable we can find in the symbol
5652 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5653 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5654 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5655 && ckWARN(WARN_AMBIGUOUS))
5657 /* Downgraded from fatal to warning 20000522 mjd */
5658 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5659 "Possible unintended interpolation of %s in string",
5664 /* build ops for a bareword */
5665 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5666 yylval.opval->op_private = OPpCONST_ENTERED;
5667 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5668 ((PL_tokenbuf[0] == '$') ? SVt_PV
5669 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5675 * The following code was generated by perl_keyword.pl.
5679 Perl_keyword (pTHX_ const char *name, I32 len)
5683 case 1: /* 5 tokens of length 1 */
5715 case 2: /* 18 tokens of length 2 */
5861 case 3: /* 28 tokens of length 3 */
5865 if (name[1] == 'N' &&
5928 if (name[1] == 'i' &&
5968 if (name[1] == 'o' &&
5977 if (name[1] == 'e' &&
5986 if (name[1] == 'n' &&
5995 if (name[1] == 'o' &&
6004 if (name[1] == 'a' &&
6013 if (name[1] == 'o' &&
6075 if (name[1] == 'e' &&
6107 if (name[1] == 'i' &&
6116 if (name[1] == 's' &&
6125 if (name[1] == 'e' &&
6134 if (name[1] == 'o' &&
6146 case 4: /* 40 tokens of length 4 */
6150 if (name[1] == 'O' &&
6160 if (name[1] == 'N' &&
6170 if (name[1] == 'i' &&
6180 if (name[1] == 'h' &&
6190 if (name[1] == 'u' &&
6203 if (name[2] == 'c' &&
6212 if (name[2] == 's' &&
6221 if (name[2] == 'a' &&
6257 if (name[1] == 'o' &&
6270 if (name[2] == 't' &&
6279 if (name[2] == 'o' &&
6288 if (name[2] == 't' &&
6297 if (name[2] == 'e' &&
6310 if (name[1] == 'o' &&
6323 if (name[2] == 'y' &&
6332 if (name[2] == 'l' &&
6348 if (name[2] == 's' &&
6357 if (name[2] == 'n' &&
6366 if (name[2] == 'c' &&
6379 if (name[1] == 'e' &&
6389 if (name[1] == 'p' &&
6402 if (name[2] == 'c' &&
6411 if (name[2] == 'p' &&
6420 if (name[2] == 's' &&
6436 if (name[2] == 'n' &&
6506 if (name[2] == 'r' &&
6515 if (name[2] == 'r' &&
6524 if (name[2] == 'a' &&
6540 if (name[2] == 'l' &&
6607 case 5: /* 36 tokens of length 5 */
6611 if (name[1] == 'E' &&
6622 if (name[1] == 'H' &&
6636 if (name[2] == 'a' &&
6646 if (name[2] == 'a' &&
6660 if (name[1] == 'l' &&
6677 if (name[3] == 'i' &&
6686 if (name[3] == 'o' &&
6722 if (name[2] == 'o' &&
6732 if (name[2] == 'y' &&
6746 if (name[1] == 'l' &&
6760 if (name[2] == 'n' &&
6770 if (name[2] == 'o' &&
6787 if (name[2] == 'd' &&
6797 if (name[2] == 'c' &&
6814 if (name[2] == 'c' &&
6824 if (name[2] == 't' &&
6838 if (name[1] == 'k' &&
6849 if (name[1] == 'r' &&
6863 if (name[2] == 's' &&
6873 if (name[2] == 'd' &&
6890 if (name[2] == 'm' &&
6900 if (name[2] == 'i' &&
6910 if (name[2] == 'e' &&
6920 if (name[2] == 'l' &&
6930 if (name[2] == 'a' &&
6940 if (name[2] == 'u' &&
6954 if (name[1] == 'i' &&
6968 if (name[2] == 'a' &&
6981 if (name[3] == 'e' &&
7016 if (name[2] == 'i' &&
7033 if (name[2] == 'i' &&
7043 if (name[2] == 'i' &&
7060 case 6: /* 33 tokens of length 6 */
7064 if (name[1] == 'c' &&
7079 if (name[2] == 'l' &&
7090 if (name[2] == 'r' &&
7105 if (name[1] == 'e' &&
7120 if (name[2] == 's' &&
7125 if(ckWARN_d(WARN_SYNTAX))
7126 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7132 if (name[2] == 'i' &&
7150 if (name[2] == 'l' &&
7161 if (name[2] == 'r' &&
7176 if (name[1] == 'm' &&
7191 if (name[2] == 'n' &&
7202 if (name[2] == 's' &&
7217 if (name[1] == 's' &&
7223 if (name[4] == 't' &&
7232 if (name[4] == 'e' &&
7241 if (name[4] == 'c' &&
7250 if (name[4] == 'n' &&
7266 if (name[1] == 'r' &&
7284 if (name[3] == 'a' &&
7294 if (name[3] == 'u' &&
7308 if (name[2] == 'n' &&
7326 if (name[2] == 'a' &&
7340 if (name[3] == 'e' &&
7353 if (name[4] == 't' &&
7362 if (name[4] == 'e' &&
7384 if (name[4] == 't' &&
7393 if (name[4] == 'e' &&
7409 if (name[2] == 'c' &&
7420 if (name[2] == 'l' &&
7431 if (name[2] == 'b' &&
7442 if (name[2] == 's' &&
7465 if (name[4] == 's' &&
7474 if (name[4] == 'n' &&
7487 if (name[3] == 'a' &&
7504 if (name[1] == 'a' &&
7519 case 7: /* 28 tokens of length 7 */
7523 if (name[1] == 'E' &&
7536 if (name[1] == '_' &&
7549 if (name[1] == 'i' &&
7556 return -KEY_binmode;
7562 if (name[1] == 'o' &&
7569 return -KEY_connect;
7578 if (name[2] == 'm' &&
7584 return -KEY_dbmopen;
7590 if (name[2] == 'f' &&
7606 if (name[1] == 'o' &&
7619 if (name[1] == 'e' &&
7626 if (name[5] == 'r' &&
7629 return -KEY_getpgrp;
7635 if (name[5] == 'i' &&
7638 return -KEY_getppid;
7651 if (name[1] == 'c' &&
7658 return -KEY_lcfirst;
7664 if (name[1] == 'p' &&
7671 return -KEY_opendir;
7677 if (name[1] == 'a' &&
7695 if (name[3] == 'd' &&
7700 return -KEY_readdir;
7706 if (name[3] == 'u' &&
7717 if (name[3] == 'e' &&
7722 return -KEY_reverse;
7741 if (name[3] == 'k' &&
7746 return -KEY_seekdir;
7752 if (name[3] == 'p' &&
7757 return -KEY_setpgrp;
7767 if (name[2] == 'm' &&
7773 return -KEY_shmread;
7779 if (name[2] == 'r' &&
7785 return -KEY_sprintf;
7794 if (name[3] == 'l' &&
7799 return -KEY_symlink;
7808 if (name[4] == 'a' &&
7812 return -KEY_syscall;
7818 if (name[4] == 'p' &&
7822 return -KEY_sysopen;
7828 if (name[4] == 'e' &&
7832 return -KEY_sysread;
7838 if (name[4] == 'e' &&
7842 return -KEY_sysseek;
7860 if (name[1] == 'e' &&
7867 return -KEY_telldir;
7876 if (name[2] == 'f' &&
7882 return -KEY_ucfirst;
7888 if (name[2] == 's' &&
7894 return -KEY_unshift;
7904 if (name[1] == 'a' &&
7911 return -KEY_waitpid;
7920 case 8: /* 26 tokens of length 8 */
7924 if (name[1] == 'U' &&
7932 return KEY_AUTOLOAD;
7943 if (name[3] == 'A' &&
7949 return KEY___DATA__;
7955 if (name[3] == 'I' &&
7961 return -KEY___FILE__;
7967 if (name[3] == 'I' &&
7973 return -KEY___LINE__;
7989 if (name[2] == 'o' &&
7996 return -KEY_closedir;
8002 if (name[2] == 'n' &&
8009 return -KEY_continue;
8019 if (name[1] == 'b' &&
8027 return -KEY_dbmclose;
8033 if (name[1] == 'n' &&
8039 if (name[4] == 'r' &&
8044 return -KEY_endgrent;
8050 if (name[4] == 'w' &&
8055 return -KEY_endpwent;
8068 if (name[1] == 'o' &&
8076 return -KEY_formline;
8082 if (name[1] == 'e' &&
8093 if (name[6] == 'n' &&
8096 return -KEY_getgrent;
8102 if (name[6] == 'i' &&
8105 return -KEY_getgrgid;
8111 if (name[6] == 'a' &&
8114 return -KEY_getgrnam;
8127 if (name[4] == 'o' &&
8132 return -KEY_getlogin;
8143 if (name[6] == 'n' &&
8146 return -KEY_getpwent;
8152 if (name[6] == 'a' &&
8155 return -KEY_getpwnam;
8161 if (name[6] == 'i' &&
8164 return -KEY_getpwuid;
8184 if (name[1] == 'e' &&
8191 if (name[5] == 'i' &&
8198 return -KEY_readline;
8203 return -KEY_readlink;
8214 if (name[5] == 'i' &&
8218 return -KEY_readpipe;
8239 if (name[4] == 'r' &&
8244 return -KEY_setgrent;
8250 if (name[4] == 'w' &&
8255 return -KEY_setpwent;
8271 if (name[3] == 'w' &&
8277 return -KEY_shmwrite;
8283 if (name[3] == 't' &&
8289 return -KEY_shutdown;
8299 if (name[2] == 's' &&
8306 return -KEY_syswrite;
8316 if (name[1] == 'r' &&
8324 return -KEY_truncate;
8333 case 9: /* 8 tokens of length 9 */
8337 if (name[1] == 'n' &&
8346 return -KEY_endnetent;
8352 if (name[1] == 'e' &&
8361 return -KEY_getnetent;
8367 if (name[1] == 'o' &&
8376 return -KEY_localtime;
8382 if (name[1] == 'r' &&
8391 return KEY_prototype;
8397 if (name[1] == 'u' &&
8406 return -KEY_quotemeta;
8412 if (name[1] == 'e' &&
8421 return -KEY_rewinddir;
8427 if (name[1] == 'e' &&
8436 return -KEY_setnetent;
8442 if (name[1] == 'a' &&
8451 return -KEY_wantarray;
8460 case 10: /* 9 tokens of length 10 */
8464 if (name[1] == 'n' &&
8470 if (name[4] == 'o' &&
8477 return -KEY_endhostent;
8483 if (name[4] == 'e' &&
8490 return -KEY_endservent;
8503 if (name[1] == 'e' &&
8509 if (name[4] == 'o' &&
8516 return -KEY_gethostent;
8525 if (name[5] == 'r' &&
8531 return -KEY_getservent;
8537 if (name[5] == 'c' &&
8543 return -KEY_getsockopt;
8568 if (name[4] == 'o' &&
8575 return -KEY_sethostent;
8584 if (name[5] == 'r' &&
8590 return -KEY_setservent;
8596 if (name[5] == 'c' &&
8602 return -KEY_setsockopt;
8619 if (name[2] == 'c' &&
8628 return -KEY_socketpair;
8641 case 11: /* 8 tokens of length 11 */
8645 if (name[1] == '_' &&
8656 return -KEY___PACKAGE__;
8662 if (name[1] == 'n' &&
8673 return -KEY_endprotoent;
8679 if (name[1] == 'e' &&
8688 if (name[5] == 'e' &&
8695 return -KEY_getpeername;
8704 if (name[6] == 'o' &&
8710 return -KEY_getpriority;
8716 if (name[6] == 't' &&
8722 return -KEY_getprotoent;
8736 if (name[4] == 'o' &&
8744 return -KEY_getsockname;
8757 if (name[1] == 'e' &&
8765 if (name[6] == 'o' &&
8771 return -KEY_setpriority;
8777 if (name[6] == 't' &&
8783 return -KEY_setprotoent;
8799 case 12: /* 2 tokens of length 12 */
8800 if (name[0] == 'g' &&
8812 if (name[9] == 'd' &&
8815 { /* getnetbyaddr */
8816 return -KEY_getnetbyaddr;
8822 if (name[9] == 'a' &&
8825 { /* getnetbyname */
8826 return -KEY_getnetbyname;
8838 case 13: /* 4 tokens of length 13 */
8839 if (name[0] == 'g' &&
8846 if (name[4] == 'o' &&
8855 if (name[10] == 'd' &&
8858 { /* gethostbyaddr */
8859 return -KEY_gethostbyaddr;
8865 if (name[10] == 'a' &&
8868 { /* gethostbyname */
8869 return -KEY_gethostbyname;
8882 if (name[4] == 'e' &&
8891 if (name[10] == 'a' &&
8894 { /* getservbyname */
8895 return -KEY_getservbyname;
8901 if (name[10] == 'o' &&
8904 { /* getservbyport */
8905 return -KEY_getservbyport;
8924 case 14: /* 1 tokens of length 14 */
8925 if (name[0] == 'g' &&
8939 { /* getprotobyname */
8940 return -KEY_getprotobyname;
8945 case 16: /* 1 tokens of length 16 */
8946 if (name[0] == 'g' &&
8962 { /* getprotobynumber */
8963 return -KEY_getprotobynumber;
8977 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
8981 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8982 if (ckWARN(WARN_SYNTAX)) {
8984 for (w = s+2; *w && level; w++) {
8991 for (; *w && isSPACE(*w); w++) ;
8992 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
8993 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8994 "%s (...) interpreted as function",name);
8997 while (s < PL_bufend && isSPACE(*s))
9001 while (s < PL_bufend && isSPACE(*s))
9003 if (isIDFIRST_lazy_if(s,UTF)) {
9005 while (isALNUM_lazy_if(s,UTF))
9007 while (s < PL_bufend && isSPACE(*s))
9011 *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9012 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9016 Perl_croak(aTHX_ "No comma allowed after %s", what);
9021 /* Either returns sv, or mortalizes sv and returns a new SV*.
9022 Best used as sv=new_constant(..., sv, ...).
9023 If s, pv are NULL, calls subroutine with one argument,
9024 and type is used with error messages only. */
9027 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9031 HV * const table = GvHV(PL_hintgv); /* ^H */
9035 const char *why1 = "", *why2 = "", *why3 = "";
9037 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9040 why2 = strEQ(key,"charnames")
9041 ? "(possibly a missing \"use charnames ...\")"
9043 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9044 (type ? type: "undef"), why2);
9046 /* This is convoluted and evil ("goto considered harmful")
9047 * but I do not understand the intricacies of all the different
9048 * failure modes of %^H in here. The goal here is to make
9049 * the most probable error message user-friendly. --jhi */
9054 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9055 (type ? type: "undef"), why1, why2, why3);
9057 yyerror(SvPVX_const(msg));
9061 cvp = hv_fetch(table, key, strlen(key), FALSE);
9062 if (!cvp || !SvOK(*cvp)) {
9065 why3 = "} is not defined";
9068 sv_2mortal(sv); /* Parent created it permanently */
9071 pv = sv_2mortal(newSVpvn(s, len));
9073 typesv = sv_2mortal(newSVpv(type, 0));
9075 typesv = &PL_sv_undef;
9077 PUSHSTACKi(PERLSI_OVERLOAD);
9089 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9093 /* Check the eval first */
9094 if (!PL_in_eval && SvTRUE(ERRSV)) {
9095 sv_catpv(ERRSV, "Propagated");
9096 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9098 res = SvREFCNT_inc(sv);
9102 (void)SvREFCNT_inc(res);
9111 why1 = "Call to &{$^H{";
9113 why3 = "}} did not return a defined value";
9121 /* Returns a NUL terminated string, with the length of the string written to
9125 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9127 register char *d = dest;
9128 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
9131 Perl_croak(aTHX_ ident_too_long);
9132 if (isALNUM(*s)) /* UTF handled below */
9134 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9139 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9143 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9144 char *t = s + UTF8SKIP(s);
9145 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9147 if (d + (t - s) > e)
9148 Perl_croak(aTHX_ ident_too_long);
9149 Copy(s, d, t - s, char);
9162 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9166 char *bracket = Nullch;
9172 e = d + destlen - 3; /* two-character token, ending NUL */
9174 while (isDIGIT(*s)) {
9176 Perl_croak(aTHX_ ident_too_long);
9183 Perl_croak(aTHX_ ident_too_long);
9184 if (isALNUM(*s)) /* UTF handled below */
9186 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9191 else if (*s == ':' && s[1] == ':') {
9195 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9196 char *t = s + UTF8SKIP(s);
9197 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9199 if (d + (t - s) > e)
9200 Perl_croak(aTHX_ ident_too_long);
9201 Copy(s, d, t - s, char);
9212 if (PL_lex_state != LEX_NORMAL)
9213 PL_lex_state = LEX_INTERPENDMAYBE;
9216 if (*s == '$' && s[1] &&
9217 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9230 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9235 if (isSPACE(s[-1])) {
9237 const char ch = *s++;
9238 if (!SPACE_OR_TAB(ch)) {
9244 if (isIDFIRST_lazy_if(d,UTF)) {
9248 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9250 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9253 Copy(s, d, e - s, char);
9258 while ((isALNUM(*s) || *s == ':') && d < e)
9261 Perl_croak(aTHX_ ident_too_long);
9264 while (s < send && SPACE_OR_TAB(*s)) s++;
9265 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9266 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9267 const char *brack = *s == '[' ? "[...]" : "{...}";
9268 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9269 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9270 funny, dest, brack, funny, dest, brack);
9273 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9277 /* Handle extended ${^Foo} variables
9278 * 1999-02-27 mjd-perl-patch@plover.com */
9279 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9283 while (isALNUM(*s) && d < e) {
9287 Perl_croak(aTHX_ ident_too_long);
9292 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9293 PL_lex_state = LEX_INTERPEND;
9298 if (PL_lex_state == LEX_NORMAL) {
9299 if (ckWARN(WARN_AMBIGUOUS) &&
9300 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9302 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9303 "Ambiguous use of %c{%s} resolved to %c%s",
9304 funny, dest, funny, dest);
9309 s = bracket; /* let the parser handle it */
9313 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9314 PL_lex_state = LEX_INTERPEND;
9319 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9324 *pmfl |= PMf_GLOBAL;
9326 *pmfl |= PMf_CONTINUE;
9330 *pmfl |= PMf_MULTILINE;
9332 *pmfl |= PMf_SINGLELINE;
9334 *pmfl |= PMf_EXTENDED;
9338 S_scan_pat(pTHX_ char *start, I32 type)
9341 char *s = scan_str(start,FALSE,FALSE);
9344 char * const delimiter = skipspace(start);
9345 Perl_croak(aTHX_ *delimiter == '?'
9346 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9347 : "Search pattern not terminated" );
9350 pm = (PMOP*)newPMOP(type, 0);
9351 if (PL_multi_open == '?')
9352 pm->op_pmflags |= PMf_ONCE;
9354 while (*s && strchr("iomsx", *s))
9355 pmflag(&pm->op_pmflags,*s++);
9358 while (*s && strchr("iogcmsx", *s))
9359 pmflag(&pm->op_pmflags,*s++);
9361 /* issue a warning if /c is specified,but /g is not */
9362 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9363 && ckWARN(WARN_REGEXP))
9365 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
9368 pm->op_pmpermflags = pm->op_pmflags;
9370 PL_lex_op = (OP*)pm;
9371 yylval.ival = OP_MATCH;
9376 S_scan_subst(pTHX_ char *start)
9384 yylval.ival = OP_NULL;
9386 s = scan_str(start,FALSE,FALSE);
9389 Perl_croak(aTHX_ "Substitution pattern not terminated");
9391 if (s[-1] == PL_multi_open)
9394 first_start = PL_multi_start;
9395 s = scan_str(s,FALSE,FALSE);
9398 SvREFCNT_dec(PL_lex_stuff);
9399 PL_lex_stuff = Nullsv;
9401 Perl_croak(aTHX_ "Substitution replacement not terminated");
9403 PL_multi_start = first_start; /* so whole substitution is taken together */
9405 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9411 else if (strchr("iogcmsx", *s))
9412 pmflag(&pm->op_pmflags,*s++);
9417 /* /c is not meaningful with s/// */
9418 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
9420 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
9425 PL_sublex_info.super_bufptr = s;
9426 PL_sublex_info.super_bufend = PL_bufend;
9428 pm->op_pmflags |= PMf_EVAL;
9429 repl = newSVpvn("",0);
9431 sv_catpv(repl, es ? "eval " : "do ");
9432 sv_catpvn(repl, "{ ", 2);
9433 sv_catsv(repl, PL_lex_repl);
9434 sv_catpvn(repl, " };", 2);
9436 SvREFCNT_dec(PL_lex_repl);
9440 pm->op_pmpermflags = pm->op_pmflags;
9441 PL_lex_op = (OP*)pm;
9442 yylval.ival = OP_SUBST;
9447 S_scan_trans(pTHX_ char *start)
9456 yylval.ival = OP_NULL;
9458 s = scan_str(start,FALSE,FALSE);
9460 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9461 if (s[-1] == PL_multi_open)
9464 s = scan_str(s,FALSE,FALSE);
9467 SvREFCNT_dec(PL_lex_stuff);
9468 PL_lex_stuff = Nullsv;
9470 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9473 complement = del = squash = 0;
9477 complement = OPpTRANS_COMPLEMENT;
9480 del = OPpTRANS_DELETE;
9483 squash = OPpTRANS_SQUASH;
9492 Newx(tbl, complement&&!del?258:256, short);
9493 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9494 o->op_private &= ~OPpTRANS_ALL;
9495 o->op_private |= del|squash|complement|
9496 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9497 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9500 yylval.ival = OP_TRANS;
9505 S_scan_heredoc(pTHX_ register char *s)
9508 I32 op_type = OP_SCALAR;
9512 const char newline[] = "\n";
9513 const char *found_newline;
9517 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9521 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9524 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9525 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9528 s = delimcpy(d, e, s, PL_bufend, term, &len);
9538 if (!isALNUM_lazy_if(s,UTF))
9539 deprecate_old("bare << to mean <<\"\"");
9540 for (; isALNUM_lazy_if(s,UTF); s++) {
9545 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9546 Perl_croak(aTHX_ "Delimiter for here document is too long");
9549 len = d - PL_tokenbuf;
9550 #ifndef PERL_STRICT_CR
9551 d = strchr(s, '\r');
9553 char * const olds = s;
9555 while (s < PL_bufend) {
9561 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9570 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9574 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9575 herewas = newSVpvn(s,PL_bufend-s);
9579 herewas = newSVpvn(s,found_newline-s);
9581 s += SvCUR(herewas);
9583 tmpstr = NEWSV(87,79);
9584 sv_upgrade(tmpstr, SVt_PVIV);
9587 SvIV_set(tmpstr, -1);
9589 else if (term == '`') {
9590 op_type = OP_BACKTICK;
9591 SvIV_set(tmpstr, '\\');
9595 PL_multi_start = CopLINE(PL_curcop);
9596 PL_multi_open = PL_multi_close = '<';
9597 term = *PL_tokenbuf;
9598 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9599 char *bufptr = PL_sublex_info.super_bufptr;
9600 char *bufend = PL_sublex_info.super_bufend;
9601 char * const olds = s - SvCUR(herewas);
9602 s = strchr(bufptr, '\n');
9606 while (s < bufend &&
9607 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9609 CopLINE_inc(PL_curcop);
9612 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9613 missingterm(PL_tokenbuf);
9615 sv_setpvn(herewas,bufptr,d-bufptr+1);
9616 sv_setpvn(tmpstr,d+1,s-d);
9618 sv_catpvn(herewas,s,bufend-s);
9619 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9626 while (s < PL_bufend &&
9627 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9629 CopLINE_inc(PL_curcop);
9631 if (s >= PL_bufend) {
9632 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9633 missingterm(PL_tokenbuf);
9635 sv_setpvn(tmpstr,d+1,s-d);
9637 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9639 sv_catpvn(herewas,s,PL_bufend-s);
9640 sv_setsv(PL_linestr,herewas);
9641 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9642 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9643 PL_last_lop = PL_last_uni = Nullch;
9646 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9647 while (s >= PL_bufend) { /* multiple line string? */
9649 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9650 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9651 missingterm(PL_tokenbuf);
9653 CopLINE_inc(PL_curcop);
9654 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9655 PL_last_lop = PL_last_uni = Nullch;
9656 #ifndef PERL_STRICT_CR
9657 if (PL_bufend - PL_linestart >= 2) {
9658 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9659 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9661 PL_bufend[-2] = '\n';
9663 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9665 else if (PL_bufend[-1] == '\r')
9666 PL_bufend[-1] = '\n';
9668 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9669 PL_bufend[-1] = '\n';
9671 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9672 SV *sv = NEWSV(88,0);
9674 sv_upgrade(sv, SVt_PVMG);
9675 sv_setsv(sv,PL_linestr);
9678 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9680 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9681 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9682 *(SvPVX(PL_linestr) + off ) = ' ';
9683 sv_catsv(PL_linestr,herewas);
9684 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9685 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9689 sv_catsv(tmpstr,PL_linestr);
9694 PL_multi_end = CopLINE(PL_curcop);
9695 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9696 SvPV_shrink_to_cur(tmpstr);
9698 SvREFCNT_dec(herewas);
9700 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9702 else if (PL_encoding)
9703 sv_recode_to_utf8(tmpstr, PL_encoding);
9705 PL_lex_stuff = tmpstr;
9706 yylval.ival = op_type;
9711 takes: current position in input buffer
9712 returns: new position in input buffer
9713 side-effects: yylval and lex_op are set.
9718 <FH> read from filehandle
9719 <pkg::FH> read from package qualified filehandle
9720 <pkg'FH> read from package qualified filehandle
9721 <$fh> read from filehandle in $fh
9727 S_scan_inputsymbol(pTHX_ char *start)
9729 register char *s = start; /* current position in buffer */
9735 d = PL_tokenbuf; /* start of temp holding space */
9736 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9737 end = strchr(s, '\n');
9740 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9742 /* die if we didn't have space for the contents of the <>,
9743 or if it didn't end, or if we see a newline
9746 if (len >= sizeof PL_tokenbuf)
9747 Perl_croak(aTHX_ "Excessively long <> operator");
9749 Perl_croak(aTHX_ "Unterminated <> operator");
9754 Remember, only scalar variables are interpreted as filehandles by
9755 this code. Anything more complex (e.g., <$fh{$num}>) will be
9756 treated as a glob() call.
9757 This code makes use of the fact that except for the $ at the front,
9758 a scalar variable and a filehandle look the same.
9760 if (*d == '$' && d[1]) d++;
9762 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9763 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9766 /* If we've tried to read what we allow filehandles to look like, and
9767 there's still text left, then it must be a glob() and not a getline.
9768 Use scan_str to pull out the stuff between the <> and treat it
9769 as nothing more than a string.
9772 if (d - PL_tokenbuf != len) {
9773 yylval.ival = OP_GLOB;
9775 s = scan_str(start,FALSE,FALSE);
9777 Perl_croak(aTHX_ "Glob not terminated");
9781 bool readline_overriden = FALSE;
9782 GV *gv_readline = Nullgv;
9784 /* we're in a filehandle read situation */
9787 /* turn <> into <ARGV> */
9789 Copy("ARGV",d,5,char);
9791 /* Check whether readline() is overriden */
9792 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9793 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9795 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9796 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9797 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9798 readline_overriden = TRUE;
9800 /* if <$fh>, create the ops to turn the variable into a
9806 /* try to find it in the pad for this block, otherwise find
9807 add symbol table ops
9809 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9810 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9811 HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9812 HEK *stashname = HvNAME_HEK(stash);
9813 SV *sym = sv_2mortal(newSVhek(stashname));
9814 sv_catpvn(sym, "::", 2);
9820 OP *o = newOP(OP_PADSV, 0);
9822 PL_lex_op = readline_overriden
9823 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9824 append_elem(OP_LIST, o,
9825 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9826 : (OP*)newUNOP(OP_READLINE, 0, o);
9835 ? (GV_ADDMULTI | GV_ADDINEVAL)
9838 PL_lex_op = readline_overriden
9839 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9840 append_elem(OP_LIST,
9841 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9842 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9843 : (OP*)newUNOP(OP_READLINE, 0,
9844 newUNOP(OP_RV2SV, 0,
9845 newGVOP(OP_GV, 0, gv)));
9847 if (!readline_overriden)
9848 PL_lex_op->op_flags |= OPf_SPECIAL;
9849 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9850 yylval.ival = OP_NULL;
9853 /* If it's none of the above, it must be a literal filehandle
9854 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9856 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9857 PL_lex_op = readline_overriden
9858 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9859 append_elem(OP_LIST,
9860 newGVOP(OP_GV, 0, gv),
9861 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9862 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9863 yylval.ival = OP_NULL;
9872 takes: start position in buffer
9873 keep_quoted preserve \ on the embedded delimiter(s)
9874 keep_delims preserve the delimiters around the string
9875 returns: position to continue reading from buffer
9876 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9877 updates the read buffer.
9879 This subroutine pulls a string out of the input. It is called for:
9880 q single quotes q(literal text)
9881 ' single quotes 'literal text'
9882 qq double quotes qq(interpolate $here please)
9883 " double quotes "interpolate $here please"
9884 qx backticks qx(/bin/ls -l)
9885 ` backticks `/bin/ls -l`
9886 qw quote words @EXPORT_OK = qw( func() $spam )
9887 m// regexp match m/this/
9888 s/// regexp substitute s/this/that/
9889 tr/// string transliterate tr/this/that/
9890 y/// string transliterate y/this/that/
9891 ($*@) sub prototypes sub foo ($)
9892 (stuff) sub attr parameters sub foo : attr(stuff)
9893 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9895 In most of these cases (all but <>, patterns and transliterate)
9896 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9897 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9898 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9901 It skips whitespace before the string starts, and treats the first
9902 character as the delimiter. If the delimiter is one of ([{< then
9903 the corresponding "close" character )]}> is used as the closing
9904 delimiter. It allows quoting of delimiters, and if the string has
9905 balanced delimiters ([{<>}]) it allows nesting.
9907 On success, the SV with the resulting string is put into lex_stuff or,
9908 if that is already non-NULL, into lex_repl. The second case occurs only
9909 when parsing the RHS of the special constructs s/// and tr/// (y///).
9910 For convenience, the terminating delimiter character is stuffed into
9915 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9917 SV *sv; /* scalar value: string */
9918 char *tmps; /* temp string, used for delimiter matching */
9919 register char *s = start; /* current position in the buffer */
9920 register char term; /* terminating character */
9921 register char *to; /* current position in the sv's data */
9922 I32 brackets = 1; /* bracket nesting level */
9923 bool has_utf8 = FALSE; /* is there any utf8 content? */
9924 I32 termcode; /* terminating char. code */
9925 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9926 STRLEN termlen; /* length of terminating string */
9927 char *last = NULL; /* last position for nesting bracket */
9929 /* skip space before the delimiter */
9933 /* mark where we are, in case we need to report errors */
9936 /* after skipping whitespace, the next character is the terminator */
9939 termcode = termstr[0] = term;
9943 termcode = utf8_to_uvchr((U8*)s, &termlen);
9944 Copy(s, termstr, termlen, U8);
9945 if (!UTF8_IS_INVARIANT(term))
9949 /* mark where we are */
9950 PL_multi_start = CopLINE(PL_curcop);
9951 PL_multi_open = term;
9953 /* find corresponding closing delimiter */
9954 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9955 termcode = termstr[0] = term = tmps[5];
9957 PL_multi_close = term;
9959 /* create a new SV to hold the contents. 87 is leak category, I'm
9960 assuming. 79 is the SV's initial length. What a random number. */
9962 sv_upgrade(sv, SVt_PVIV);
9963 SvIV_set(sv, termcode);
9964 (void)SvPOK_only(sv); /* validate pointer */
9966 /* move past delimiter and try to read a complete string */
9968 sv_catpvn(sv, s, termlen);
9971 if (PL_encoding && !UTF) {
9975 int offset = s - SvPVX_const(PL_linestr);
9976 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9977 &offset, (char*)termstr, termlen);
9978 const char *ns = SvPVX_const(PL_linestr) + offset;
9979 char *svlast = SvEND(sv) - 1;
9981 for (; s < ns; s++) {
9982 if (*s == '\n' && !PL_rsfp)
9983 CopLINE_inc(PL_curcop);
9986 goto read_more_line;
9988 /* handle quoted delimiters */
9989 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9991 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9993 if ((svlast-1 - t) % 2) {
9997 SvCUR_set(sv, SvCUR(sv) - 1);
10002 if (PL_multi_open == PL_multi_close) {
10010 for (t = w = last; t < svlast; w++, t++) {
10011 /* At here, all closes are "was quoted" one,
10012 so we don't check PL_multi_close. */
10014 if (!keep_quoted && *(t+1) == PL_multi_open)
10019 else if (*t == PL_multi_open)
10027 SvCUR_set(sv, w - SvPVX_const(sv));
10030 if (--brackets <= 0)
10035 if (!keep_delims) {
10036 SvCUR_set(sv, SvCUR(sv) - 1);
10042 /* extend sv if need be */
10043 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10044 /* set 'to' to the next character in the sv's string */
10045 to = SvPVX(sv)+SvCUR(sv);
10047 /* if open delimiter is the close delimiter read unbridle */
10048 if (PL_multi_open == PL_multi_close) {
10049 for (; s < PL_bufend; s++,to++) {
10050 /* embedded newlines increment the current line number */
10051 if (*s == '\n' && !PL_rsfp)
10052 CopLINE_inc(PL_curcop);
10053 /* handle quoted delimiters */
10054 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10055 if (!keep_quoted && s[1] == term)
10057 /* any other quotes are simply copied straight through */
10061 /* terminate when run out of buffer (the for() condition), or
10062 have found the terminator */
10063 else if (*s == term) {
10066 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10069 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10075 /* if the terminator isn't the same as the start character (e.g.,
10076 matched brackets), we have to allow more in the quoting, and
10077 be prepared for nested brackets.
10080 /* read until we run out of string, or we find the terminator */
10081 for (; s < PL_bufend; s++,to++) {
10082 /* embedded newlines increment the line count */
10083 if (*s == '\n' && !PL_rsfp)
10084 CopLINE_inc(PL_curcop);
10085 /* backslashes can escape the open or closing characters */
10086 if (*s == '\\' && s+1 < PL_bufend) {
10087 if (!keep_quoted &&
10088 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10093 /* allow nested opens and closes */
10094 else if (*s == PL_multi_close && --brackets <= 0)
10096 else if (*s == PL_multi_open)
10098 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10103 /* terminate the copied string and update the sv's end-of-string */
10105 SvCUR_set(sv, to - SvPVX_const(sv));
10108 * this next chunk reads more into the buffer if we're not done yet
10112 break; /* handle case where we are done yet :-) */
10114 #ifndef PERL_STRICT_CR
10115 if (to - SvPVX_const(sv) >= 2) {
10116 if ((to[-2] == '\r' && to[-1] == '\n') ||
10117 (to[-2] == '\n' && to[-1] == '\r'))
10121 SvCUR_set(sv, to - SvPVX_const(sv));
10123 else if (to[-1] == '\r')
10126 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10131 /* if we're out of file, or a read fails, bail and reset the current
10132 line marker so we can report where the unterminated string began
10135 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10137 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10140 /* we read a line, so increment our line counter */
10141 CopLINE_inc(PL_curcop);
10143 /* update debugger info */
10144 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10145 SV *sv = NEWSV(88,0);
10147 sv_upgrade(sv, SVt_PVMG);
10148 sv_setsv(sv,PL_linestr);
10149 (void)SvIOK_on(sv);
10151 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10154 /* having changed the buffer, we must update PL_bufend */
10155 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10156 PL_last_lop = PL_last_uni = Nullch;
10159 /* at this point, we have successfully read the delimited string */
10161 if (!PL_encoding || UTF) {
10163 sv_catpvn(sv, s, termlen);
10166 if (has_utf8 || PL_encoding)
10169 PL_multi_end = CopLINE(PL_curcop);
10171 /* if we allocated too much space, give some back */
10172 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10173 SvLEN_set(sv, SvCUR(sv) + 1);
10174 SvPV_renew(sv, SvLEN(sv));
10177 /* decide whether this is the first or second quoted string we've read
10190 takes: pointer to position in buffer
10191 returns: pointer to new position in buffer
10192 side-effects: builds ops for the constant in yylval.op
10194 Read a number in any of the formats that Perl accepts:
10196 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10197 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10200 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10202 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10205 If it reads a number without a decimal point or an exponent, it will
10206 try converting the number to an integer and see if it can do so
10207 without loss of precision.
10211 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10213 register const char *s = start; /* current position in buffer */
10214 register char *d; /* destination in temp buffer */
10215 register char *e; /* end of temp buffer */
10216 NV nv; /* number read, as a double */
10217 SV *sv = Nullsv; /* place to put the converted number */
10218 bool floatit; /* boolean: int or float? */
10219 const char *lastub = 0; /* position of last underbar */
10220 static char const number_too_long[] = "Number too long";
10222 /* We use the first character to decide what type of number this is */
10226 Perl_croak(aTHX_ "panic: scan_num");
10228 /* if it starts with a 0, it could be an octal number, a decimal in
10229 0.13 disguise, or a hexadecimal number, or a binary number. */
10233 u holds the "number so far"
10234 shift the power of 2 of the base
10235 (hex == 4, octal == 3, binary == 1)
10236 overflowed was the number more than we can hold?
10238 Shift is used when we add a digit. It also serves as an "are
10239 we in octal/hex/binary?" indicator to disallow hex characters
10240 when in octal mode.
10245 bool overflowed = FALSE;
10246 bool just_zero = TRUE; /* just plain 0 or binary number? */
10247 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10248 static const char* const bases[5] =
10249 { "", "binary", "", "octal", "hexadecimal" };
10250 static const char* const Bases[5] =
10251 { "", "Binary", "", "Octal", "Hexadecimal" };
10252 static const char* const maxima[5] =
10254 "0b11111111111111111111111111111111",
10258 const char *base, *Base, *max;
10260 /* check for hex */
10265 } else if (s[1] == 'b') {
10270 /* check for a decimal in disguise */
10271 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10273 /* so it must be octal */
10280 if (ckWARN(WARN_SYNTAX))
10281 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10282 "Misplaced _ in number");
10286 base = bases[shift];
10287 Base = Bases[shift];
10288 max = maxima[shift];
10290 /* read the rest of the number */
10292 /* x is used in the overflow test,
10293 b is the digit we're adding on. */
10298 /* if we don't mention it, we're done */
10302 /* _ are ignored -- but warned about if consecutive */
10304 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10305 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10306 "Misplaced _ in number");
10310 /* 8 and 9 are not octal */
10311 case '8': case '9':
10313 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10317 case '2': case '3': case '4':
10318 case '5': case '6': case '7':
10320 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10323 case '0': case '1':
10324 b = *s++ & 15; /* ASCII digit -> value of digit */
10328 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10329 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10330 /* make sure they said 0x */
10333 b = (*s++ & 7) + 9;
10335 /* Prepare to put the digit we have onto the end
10336 of the number so far. We check for overflows.
10342 x = u << shift; /* make room for the digit */
10344 if ((x >> shift) != u
10345 && !(PL_hints & HINT_NEW_BINARY)) {
10348 if (ckWARN_d(WARN_OVERFLOW))
10349 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10350 "Integer overflow in %s number",
10353 u = x | b; /* add the digit to the end */
10356 n *= nvshift[shift];
10357 /* If an NV has not enough bits in its
10358 * mantissa to represent an UV this summing of
10359 * small low-order numbers is a waste of time
10360 * (because the NV cannot preserve the
10361 * low-order bits anyway): we could just
10362 * remember when did we overflow and in the
10363 * end just multiply n by the right
10371 /* if we get here, we had success: make a scalar value from
10376 /* final misplaced underbar check */
10377 if (s[-1] == '_') {
10378 if (ckWARN(WARN_SYNTAX))
10379 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10384 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10385 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10386 "%s number > %s non-portable",
10392 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10393 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10394 "%s number > %s non-portable",
10399 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10400 sv = new_constant(start, s - start, "integer",
10402 else if (PL_hints & HINT_NEW_BINARY)
10403 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10408 handle decimal numbers.
10409 we're also sent here when we read a 0 as the first digit
10411 case '1': case '2': case '3': case '4': case '5':
10412 case '6': case '7': case '8': case '9': case '.':
10415 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10418 /* read next group of digits and _ and copy into d */
10419 while (isDIGIT(*s) || *s == '_') {
10420 /* skip underscores, checking for misplaced ones
10424 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10425 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10426 "Misplaced _ in number");
10430 /* check for end of fixed-length buffer */
10432 Perl_croak(aTHX_ number_too_long);
10433 /* if we're ok, copy the character */
10438 /* final misplaced underbar check */
10439 if (lastub && s == lastub + 1) {
10440 if (ckWARN(WARN_SYNTAX))
10441 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10444 /* read a decimal portion if there is one. avoid
10445 3..5 being interpreted as the number 3. followed
10448 if (*s == '.' && s[1] != '.') {
10453 if (ckWARN(WARN_SYNTAX))
10454 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10455 "Misplaced _ in number");
10459 /* copy, ignoring underbars, until we run out of digits.
10461 for (; isDIGIT(*s) || *s == '_'; s++) {
10462 /* fixed length buffer check */
10464 Perl_croak(aTHX_ number_too_long);
10466 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10467 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10468 "Misplaced _ in number");
10474 /* fractional part ending in underbar? */
10475 if (s[-1] == '_') {
10476 if (ckWARN(WARN_SYNTAX))
10477 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10478 "Misplaced _ in number");
10480 if (*s == '.' && isDIGIT(s[1])) {
10481 /* oops, it's really a v-string, but without the "v" */
10487 /* read exponent part, if present */
10488 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10492 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10493 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10495 /* stray preinitial _ */
10497 if (ckWARN(WARN_SYNTAX))
10498 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10499 "Misplaced _ in number");
10503 /* allow positive or negative exponent */
10504 if (*s == '+' || *s == '-')
10507 /* stray initial _ */
10509 if (ckWARN(WARN_SYNTAX))
10510 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10511 "Misplaced _ in number");
10515 /* read digits of exponent */
10516 while (isDIGIT(*s) || *s == '_') {
10519 Perl_croak(aTHX_ number_too_long);
10523 if (((lastub && s == lastub + 1) ||
10524 (!isDIGIT(s[1]) && s[1] != '_'))
10525 && ckWARN(WARN_SYNTAX))
10526 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10527 "Misplaced _ in number");
10534 /* make an sv from the string */
10538 We try to do an integer conversion first if no characters
10539 indicating "float" have been found.
10544 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10546 if (flags == IS_NUMBER_IN_UV) {
10548 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10551 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10552 if (uv <= (UV) IV_MIN)
10553 sv_setiv(sv, -(IV)uv);
10560 /* terminate the string */
10562 nv = Atof(PL_tokenbuf);
10566 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10567 (PL_hints & HINT_NEW_INTEGER) )
10568 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10569 (floatit ? "float" : "integer"),
10573 /* if it starts with a v, it could be a v-string */
10576 sv = NEWSV(92,5); /* preallocate storage space */
10577 s = scan_vstring(s,sv);
10581 /* make the op for the constant and return */
10584 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10586 lvalp->opval = Nullop;
10592 S_scan_formline(pTHX_ register char *s)
10594 register char *eol;
10596 SV *stuff = newSVpvn("",0);
10597 bool needargs = FALSE;
10598 bool eofmt = FALSE;
10600 while (!needargs) {
10602 #ifdef PERL_STRICT_CR
10603 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10605 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10607 if (*t == '\n' || t == PL_bufend) {
10612 if (PL_in_eval && !PL_rsfp) {
10613 eol = (char *) memchr(s,'\n',PL_bufend-s);
10618 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10620 for (t = s; t < eol; t++) {
10621 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10623 goto enough; /* ~~ must be first line in formline */
10625 if (*t == '@' || *t == '^')
10629 sv_catpvn(stuff, s, eol-s);
10630 #ifndef PERL_STRICT_CR
10631 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10632 char *end = SvPVX(stuff) + SvCUR(stuff);
10635 SvCUR_set(stuff, SvCUR(stuff) - 1);
10644 s = filter_gets(PL_linestr, PL_rsfp, 0);
10645 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10646 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10647 PL_last_lop = PL_last_uni = Nullch;
10656 if (SvCUR(stuff)) {
10659 PL_lex_state = LEX_NORMAL;
10660 PL_nextval[PL_nexttoke].ival = 0;
10664 PL_lex_state = LEX_FORMLINE;
10666 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10668 else if (PL_encoding)
10669 sv_recode_to_utf8(stuff, PL_encoding);
10671 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10673 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10677 SvREFCNT_dec(stuff);
10679 PL_lex_formbrack = 0;
10690 PL_cshlen = strlen(PL_cshname);
10695 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10697 const I32 oldsavestack_ix = PL_savestack_ix;
10698 CV* outsidecv = PL_compcv;
10701 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10703 SAVEI32(PL_subline);
10704 save_item(PL_subname);
10705 SAVESPTR(PL_compcv);
10707 PL_compcv = (CV*)NEWSV(1104,0);
10708 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10709 CvFLAGS(PL_compcv) |= flags;
10711 PL_subline = CopLINE(PL_curcop);
10712 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10713 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10714 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10716 return oldsavestack_ix;
10720 #pragma segment Perl_yylex
10723 Perl_yywarn(pTHX_ const char *s)
10725 PL_in_eval |= EVAL_WARNONLY;
10727 PL_in_eval &= ~EVAL_WARNONLY;
10732 Perl_yyerror(pTHX_ const char *s)
10734 const char *where = NULL;
10735 const char *context = NULL;
10739 if (!yychar || (yychar == ';' && !PL_rsfp))
10741 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10742 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10743 PL_oldbufptr != PL_bufptr) {
10746 The code below is removed for NetWare because it abends/crashes on NetWare
10747 when the script has error such as not having the closing quotes like:
10748 if ($var eq "value)
10749 Checking of white spaces is anyway done in NetWare code.
10752 while (isSPACE(*PL_oldoldbufptr))
10755 context = PL_oldoldbufptr;
10756 contlen = PL_bufptr - PL_oldoldbufptr;
10758 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10759 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10762 The code below is removed for NetWare because it abends/crashes on NetWare
10763 when the script has error such as not having the closing quotes like:
10764 if ($var eq "value)
10765 Checking of white spaces is anyway done in NetWare code.
10768 while (isSPACE(*PL_oldbufptr))
10771 context = PL_oldbufptr;
10772 contlen = PL_bufptr - PL_oldbufptr;
10774 else if (yychar > 255)
10775 where = "next token ???";
10776 else if (yychar == -2) { /* YYEMPTY */
10777 if (PL_lex_state == LEX_NORMAL ||
10778 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10779 where = "at end of line";
10780 else if (PL_lex_inpat)
10781 where = "within pattern";
10783 where = "within string";
10786 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10788 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10789 else if (isPRINT_LC(yychar))
10790 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10792 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10793 where = SvPVX_const(where_sv);
10795 msg = sv_2mortal(newSVpv(s, 0));
10796 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10797 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10799 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10801 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10802 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10803 Perl_sv_catpvf(aTHX_ msg,
10804 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10805 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10808 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10809 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10812 if (PL_error_count >= 10) {
10813 if (PL_in_eval && SvCUR(ERRSV))
10814 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10815 ERRSV, OutCopFILE(PL_curcop));
10817 Perl_croak(aTHX_ "%s has too many errors.\n",
10818 OutCopFILE(PL_curcop));
10821 PL_in_my_stash = Nullhv;
10825 #pragma segment Main
10829 S_swallow_bom(pTHX_ U8 *s)
10831 const STRLEN slen = SvCUR(PL_linestr);
10834 if (s[1] == 0xFE) {
10835 /* UTF-16 little-endian? (or UTF32-LE?) */
10836 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10837 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10838 #ifndef PERL_NO_UTF16_FILTER
10839 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10842 if (PL_bufend > (char*)s) {
10846 filter_add(utf16rev_textfilter, NULL);
10847 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10848 utf16_to_utf8_reversed(s, news,
10849 PL_bufend - (char*)s - 1,
10851 sv_setpvn(PL_linestr, (const char*)news, newlen);
10853 SvUTF8_on(PL_linestr);
10854 s = (U8*)SvPVX(PL_linestr);
10855 PL_bufend = SvPVX(PL_linestr) + newlen;
10858 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10863 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10864 #ifndef PERL_NO_UTF16_FILTER
10865 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10868 if (PL_bufend > (char *)s) {
10872 filter_add(utf16_textfilter, NULL);
10873 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10874 utf16_to_utf8(s, news,
10875 PL_bufend - (char*)s,
10877 sv_setpvn(PL_linestr, (const char*)news, newlen);
10879 SvUTF8_on(PL_linestr);
10880 s = (U8*)SvPVX(PL_linestr);
10881 PL_bufend = SvPVX(PL_linestr) + newlen;
10884 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10889 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10890 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10891 s += 3; /* UTF-8 */
10897 if (s[2] == 0xFE && s[3] == 0xFF) {
10898 /* UTF-32 big-endian */
10899 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10902 else if (s[2] == 0 && s[3] != 0) {
10905 * are a good indicator of UTF-16BE. */
10906 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10911 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10914 * are a good indicator of UTF-16LE. */
10915 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10924 * Restore a source filter.
10928 restore_rsfp(pTHX_ void *f)
10930 PerlIO *fp = (PerlIO*)f;
10932 if (PL_rsfp == PerlIO_stdin())
10933 PerlIO_clearerr(PL_rsfp);
10934 else if (PL_rsfp && (PL_rsfp != fp))
10935 PerlIO_close(PL_rsfp);
10939 #ifndef PERL_NO_UTF16_FILTER
10941 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10943 const STRLEN old = SvCUR(sv);
10944 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10945 DEBUG_P(PerlIO_printf(Perl_debug_log,
10946 "utf16_textfilter(%p): %d %d (%d)\n",
10947 utf16_textfilter, idx, maxlen, (int) count));
10951 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10952 Copy(SvPVX_const(sv), tmps, old, char);
10953 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10954 SvCUR(sv) - old, &newlen);
10955 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10957 DEBUG_P({sv_dump(sv);});
10962 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10964 const STRLEN old = SvCUR(sv);
10965 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10966 DEBUG_P(PerlIO_printf(Perl_debug_log,
10967 "utf16rev_textfilter(%p): %d %d (%d)\n",
10968 utf16rev_textfilter, idx, maxlen, (int) count));
10972 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10973 Copy(SvPVX_const(sv), tmps, old, char);
10974 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10975 SvCUR(sv) - old, &newlen);
10976 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10978 DEBUG_P({ sv_dump(sv); });
10984 Returns a pointer to the next character after the parsed
10985 vstring, as well as updating the passed in sv.
10987 Function must be called like
10990 s = scan_vstring(s,sv);
10992 The sv should already be large enough to store the vstring
10993 passed in, for performance reasons.
10998 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
11000 const char *pos = s;
11001 const char *start = s;
11002 if (*pos == 'v') pos++; /* get past 'v' */
11003 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11005 if ( *pos != '.') {
11006 /* this may not be a v-string if followed by => */
11007 const char *next = pos;
11008 while (next < PL_bufend && isSPACE(*next))
11010 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11011 /* return string not v-string */
11012 sv_setpvn(sv,(char *)s,pos-s);
11013 return (char *)pos;
11017 if (!isALPHA(*pos)) {
11019 U8 tmpbuf[UTF8_MAXBYTES+1];
11022 if (*s == 'v') s++; /* get past 'v' */
11024 sv_setpvn(sv, "", 0);
11029 /* this is atoi() that tolerates underscores */
11030 const char *end = pos;
11032 while (--end >= s) {
11037 rev += (*end - '0') * mult;
11039 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11040 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11041 "Integer overflow in decimal number");
11045 if (rev > 0x7FFFFFFF)
11046 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11048 /* Append native character for the rev point */
11049 tmpend = uvchr_to_utf8(tmpbuf, rev);
11050 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11051 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11053 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11059 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11063 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11071 * c-indentation-style: bsd
11072 * c-basic-offset: 4
11073 * indent-tabs-mode: t
11076 * ex: set ts=8 sts=4 sw=4 noet: