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((I32)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_ 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* const 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] = (char)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 * const 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 register const 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)tmp);
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.) */
4275 /* Also, if "_" follows a filetest operator, it's a bareword */
4278 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4279 ((!gv || !GvCVu(gv)) &&
4280 (PL_last_lop_op != OP_MAPSTART &&
4281 PL_last_lop_op != OP_GREPSTART))))
4282 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
4283 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
4286 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4291 PL_expect = XOPERATOR;
4294 /* Is this a word before a => operator? */
4295 if (*s == '=' && s[1] == '>' && !pkgname) {
4297 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4298 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4299 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4303 /* If followed by a paren, it's certainly a subroutine. */
4306 if (gv && GvCVu(gv)) {
4307 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4308 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4313 PL_nextval[PL_nexttoke].opval = yylval.opval;
4314 PL_expect = XOPERATOR;
4320 /* If followed by var or block, call it a method (unless sub) */
4322 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4323 PL_last_lop = PL_oldbufptr;
4324 PL_last_lop_op = OP_METHOD;
4328 /* If followed by a bareword, see if it looks like indir obj. */
4331 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4332 && (tmp = intuit_method(s,gv)))
4335 /* Not a method, so call it a subroutine (if defined) */
4337 if (gv && GvCVu(gv)) {
4339 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4340 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4341 "Ambiguous use of -%s resolved as -&%s()",
4342 PL_tokenbuf, PL_tokenbuf);
4343 /* Check for a constant sub */
4345 if ((sv = cv_const_sv(cv))) {
4347 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4348 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4349 yylval.opval->op_private = 0;
4353 /* Resolve to GV now. */
4354 op_free(yylval.opval);
4355 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4356 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4357 PL_last_lop = PL_oldbufptr;
4358 PL_last_lop_op = OP_ENTERSUB;
4359 /* Is there a prototype? */
4362 const char *proto = SvPV_const((SV*)cv, len);
4365 if (*proto == '$' && proto[1] == '\0')
4367 while (*proto == ';')
4369 if (*proto == '&' && *s == '{') {
4370 sv_setpv(PL_subname, PL_curstash ?
4371 "__ANON__" : "__ANON__::__ANON__");
4375 PL_nextval[PL_nexttoke].opval = yylval.opval;
4381 /* Call it a bare word */
4383 if (PL_hints & HINT_STRICT_SUBS)
4384 yylval.opval->op_private |= OPpCONST_STRICT;
4387 if (lastchar != '-') {
4388 if (ckWARN(WARN_RESERVED)) {
4389 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4390 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4391 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4398 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4399 && ckWARN_d(WARN_AMBIGUOUS)) {
4400 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4401 "Operator or semicolon missing before %c%s",
4402 lastchar, PL_tokenbuf);
4403 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4404 "Ambiguous use of %c resolved as operator %c",
4405 lastchar, lastchar);
4411 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4412 newSVpv(CopFILE(PL_curcop),0));
4416 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4417 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4420 case KEY___PACKAGE__:
4421 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4423 ? newSVhek(HvNAME_HEK(PL_curstash))
4430 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4431 const char *pname = "main";
4432 if (PL_tokenbuf[2] == 'D')
4433 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
4434 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4437 GvIOp(gv) = newIO();
4438 IoIFP(GvIOp(gv)) = PL_rsfp;
4439 #if defined(HAS_FCNTL) && defined(F_SETFD)
4441 const int fd = PerlIO_fileno(PL_rsfp);
4442 fcntl(fd,F_SETFD,fd >= 3);
4445 /* Mark this internal pseudo-handle as clean */
4446 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4448 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4449 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4450 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4452 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4453 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4454 /* if the script was opened in binmode, we need to revert
4455 * it to text mode for compatibility; but only iff it has CRs
4456 * XXX this is a questionable hack at best. */
4457 if (PL_bufend-PL_bufptr > 2
4458 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4461 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4462 loc = PerlIO_tell(PL_rsfp);
4463 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4466 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4468 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4469 #endif /* NETWARE */
4470 #ifdef PERLIO_IS_STDIO /* really? */
4471 # if defined(__BORLANDC__)
4472 /* XXX see note in do_binmode() */
4473 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4477 PerlIO_seek(PL_rsfp, loc, 0);
4481 #ifdef PERLIO_LAYERS
4484 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4485 else if (PL_encoding) {
4492 XPUSHs(PL_encoding);
4494 call_method("name", G_SCALAR);
4498 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4499 Perl_form(aTHX_ ":encoding(%"SVf")",
4517 if (PL_expect == XSTATE) {
4524 if (*s == ':' && s[1] == ':') {
4527 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4528 if (!(tmp = keyword(PL_tokenbuf, len)))
4529 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4532 else if (tmp == KEY_require || tmp == KEY_do)
4533 /* that's a way to remember we saw "CORE::" */
4546 LOP(OP_ACCEPT,XTERM);
4552 LOP(OP_ATAN2,XTERM);
4558 LOP(OP_BINMODE,XTERM);
4561 LOP(OP_BLESS,XTERM);
4570 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4587 if (!PL_cryptseen) {
4588 PL_cryptseen = TRUE;
4592 LOP(OP_CRYPT,XTERM);
4595 LOP(OP_CHMOD,XTERM);
4598 LOP(OP_CHOWN,XTERM);
4601 LOP(OP_CONNECT,XTERM);
4617 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4618 if (orig_keyword == KEY_do) {
4627 PL_hints |= HINT_BLOCK_SCOPE;
4637 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4638 LOP(OP_DBMOPEN,XTERM);
4644 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4651 yylval.ival = CopLINE(PL_curcop);
4665 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4666 UNIBRACK(OP_ENTEREVAL);
4684 case KEY_endhostent:
4690 case KEY_endservent:
4693 case KEY_endprotoent:
4704 yylval.ival = CopLINE(PL_curcop);
4706 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4708 if ((PL_bufend - p) >= 3 &&
4709 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4711 else if ((PL_bufend - p) >= 4 &&
4712 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4715 if (isIDFIRST_lazy_if(p,UTF)) {
4716 p = scan_ident(p, PL_bufend,
4717 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4721 Perl_croak(aTHX_ "Missing $ on loop variable");
4726 LOP(OP_FORMLINE,XTERM);
4732 LOP(OP_FCNTL,XTERM);
4738 LOP(OP_FLOCK,XTERM);
4747 LOP(OP_GREPSTART, XREF);
4750 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4765 case KEY_getpriority:
4766 LOP(OP_GETPRIORITY,XTERM);
4768 case KEY_getprotobyname:
4771 case KEY_getprotobynumber:
4772 LOP(OP_GPBYNUMBER,XTERM);
4774 case KEY_getprotoent:
4786 case KEY_getpeername:
4787 UNI(OP_GETPEERNAME);
4789 case KEY_gethostbyname:
4792 case KEY_gethostbyaddr:
4793 LOP(OP_GHBYADDR,XTERM);
4795 case KEY_gethostent:
4798 case KEY_getnetbyname:
4801 case KEY_getnetbyaddr:
4802 LOP(OP_GNBYADDR,XTERM);
4807 case KEY_getservbyname:
4808 LOP(OP_GSBYNAME,XTERM);
4810 case KEY_getservbyport:
4811 LOP(OP_GSBYPORT,XTERM);
4813 case KEY_getservent:
4816 case KEY_getsockname:
4817 UNI(OP_GETSOCKNAME);
4819 case KEY_getsockopt:
4820 LOP(OP_GSOCKOPT,XTERM);
4842 yylval.ival = CopLINE(PL_curcop);
4846 LOP(OP_INDEX,XTERM);
4852 LOP(OP_IOCTL,XTERM);
4864 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4896 LOP(OP_LISTEN,XTERM);
4905 s = scan_pat(s,OP_MATCH);
4906 TERM(sublex_start());
4909 LOP(OP_MAPSTART, XREF);
4912 LOP(OP_MKDIR,XTERM);
4915 LOP(OP_MSGCTL,XTERM);
4918 LOP(OP_MSGGET,XTERM);
4921 LOP(OP_MSGRCV,XTERM);
4924 LOP(OP_MSGSND,XTERM);
4930 if (isIDFIRST_lazy_if(s,UTF)) {
4931 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4932 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4934 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4935 if (!PL_in_my_stash) {
4938 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4946 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4953 s = tokenize_use(0, s);
4957 if (*s == '(' || (s = skipspace(s), *s == '('))
4964 if (isIDFIRST_lazy_if(s,UTF)) {
4966 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4967 for (t=d; *t && isSPACE(*t); t++) ;
4968 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4970 && !(t[0] == '=' && t[1] == '>')
4972 int len = (int)(d-s);
4973 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4974 "Precedence problem: open %.*s should be open(%.*s)",
4981 yylval.ival = OP_OR;
4991 LOP(OP_OPEN_DIR,XTERM);
4994 checkcomma(s,PL_tokenbuf,"filehandle");
4998 checkcomma(s,PL_tokenbuf,"filehandle");
5017 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5021 LOP(OP_PIPE_OP,XTERM);
5024 s = scan_str(s,FALSE,FALSE);
5026 missingterm((char*)0);
5027 yylval.ival = OP_CONST;
5028 TERM(sublex_start());
5034 s = scan_str(s,FALSE,FALSE);
5036 missingterm((char*)0);
5037 PL_expect = XOPERATOR;
5039 if (SvCUR(PL_lex_stuff)) {
5042 d = SvPV_force(PL_lex_stuff, len);
5045 for (; isSPACE(*d) && len; --len, ++d) ;
5048 if (!warned && ckWARN(WARN_QW)) {
5049 for (; !isSPACE(*d) && len; --len, ++d) {
5051 Perl_warner(aTHX_ packWARN(WARN_QW),
5052 "Possible attempt to separate words with commas");
5055 else if (*d == '#') {
5056 Perl_warner(aTHX_ packWARN(WARN_QW),
5057 "Possible attempt to put comments in qw() list");
5063 for (; !isSPACE(*d) && len; --len, ++d) ;
5065 sv = newSVpvn(b, d-b);
5066 if (DO_UTF8(PL_lex_stuff))
5068 words = append_elem(OP_LIST, words,
5069 newSVOP(OP_CONST, 0, tokeq(sv)));
5073 PL_nextval[PL_nexttoke].opval = words;
5078 SvREFCNT_dec(PL_lex_stuff);
5079 PL_lex_stuff = Nullsv;
5085 s = scan_str(s,FALSE,FALSE);
5087 missingterm((char*)0);
5088 yylval.ival = OP_STRINGIFY;
5089 if (SvIVX(PL_lex_stuff) == '\'')
5090 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
5091 TERM(sublex_start());
5094 s = scan_pat(s,OP_QR);
5095 TERM(sublex_start());
5098 s = scan_str(s,FALSE,FALSE);
5100 missingterm((char*)0);
5101 yylval.ival = OP_BACKTICK;
5103 TERM(sublex_start());
5111 s = force_version(s, FALSE);
5113 else if (*s != 'v' || !isDIGIT(s[1])
5114 || (s = force_version(s, TRUE), *s == 'v'))
5116 *PL_tokenbuf = '\0';
5117 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5118 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5119 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5121 yyerror("<> should be quotes");
5123 if (orig_keyword == KEY_require) {
5131 PL_last_uni = PL_oldbufptr;
5132 PL_last_lop_op = OP_REQUIRE;
5134 return REPORT( (int)REQUIRE );
5140 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5144 LOP(OP_RENAME,XTERM);
5153 LOP(OP_RINDEX,XTERM);
5163 UNIDOR(OP_READLINE);
5176 LOP(OP_REVERSE,XTERM);
5179 UNIDOR(OP_READLINK);
5187 TERM(sublex_start());
5189 TOKEN(1); /* force error */
5198 LOP(OP_SELECT,XTERM);
5204 LOP(OP_SEMCTL,XTERM);
5207 LOP(OP_SEMGET,XTERM);
5210 LOP(OP_SEMOP,XTERM);
5216 LOP(OP_SETPGRP,XTERM);
5218 case KEY_setpriority:
5219 LOP(OP_SETPRIORITY,XTERM);
5221 case KEY_sethostent:
5227 case KEY_setservent:
5230 case KEY_setprotoent:
5240 LOP(OP_SEEKDIR,XTERM);
5242 case KEY_setsockopt:
5243 LOP(OP_SSOCKOPT,XTERM);
5249 LOP(OP_SHMCTL,XTERM);
5252 LOP(OP_SHMGET,XTERM);
5255 LOP(OP_SHMREAD,XTERM);
5258 LOP(OP_SHMWRITE,XTERM);
5261 LOP(OP_SHUTDOWN,XTERM);
5270 LOP(OP_SOCKET,XTERM);
5272 case KEY_socketpair:
5273 LOP(OP_SOCKPAIR,XTERM);
5276 checkcomma(s,PL_tokenbuf,"subroutine name");
5278 if (*s == ';' || *s == ')') /* probably a close */
5279 Perl_croak(aTHX_ "sort is now a reserved word");
5281 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5285 LOP(OP_SPLIT,XTERM);
5288 LOP(OP_SPRINTF,XTERM);
5291 LOP(OP_SPLICE,XTERM);
5306 LOP(OP_SUBSTR,XTERM);
5312 char tmpbuf[sizeof PL_tokenbuf];
5313 SSize_t tboffset = 0;
5314 expectation attrful;
5315 bool have_name, have_proto, bad_proto;
5316 const int key = tmp;
5320 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5321 (*s == ':' && s[1] == ':'))
5324 attrful = XATTRBLOCK;
5325 /* remember buffer pos'n for later force_word */
5326 tboffset = s - PL_oldbufptr;
5327 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5328 if (strchr(tmpbuf, ':'))
5329 sv_setpv(PL_subname, tmpbuf);
5331 sv_setsv(PL_subname,PL_curstname);
5332 sv_catpvn(PL_subname,"::",2);
5333 sv_catpvn(PL_subname,tmpbuf,len);
5340 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5341 PL_expect = XTERMBLOCK;
5342 attrful = XATTRTERM;
5343 sv_setpvn(PL_subname,"?",1);
5347 if (key == KEY_format) {
5349 PL_lex_formbrack = PL_lex_brackets + 1;
5351 (void) force_word(PL_oldbufptr + tboffset, WORD,
5356 /* Look for a prototype */
5360 s = scan_str(s,FALSE,FALSE);
5362 Perl_croak(aTHX_ "Prototype not terminated");
5363 /* strip spaces and check for bad characters */
5364 d = SvPVX(PL_lex_stuff);
5367 for (p = d; *p; ++p) {
5370 if (!strchr("$@%*;[]&\\", *p))
5375 if (bad_proto && ckWARN(WARN_SYNTAX))
5376 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5377 "Illegal character in prototype for %"SVf" : %s",
5379 SvCUR_set(PL_lex_stuff, tmp);
5387 if (*s == ':' && s[1] != ':')
5388 PL_expect = attrful;
5389 else if (*s != '{' && key == KEY_sub) {
5391 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5393 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5397 PL_nextval[PL_nexttoke].opval =
5398 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5399 PL_lex_stuff = Nullsv;
5403 sv_setpv(PL_subname,
5404 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5407 (void) force_word(PL_oldbufptr + tboffset, WORD,
5416 LOP(OP_SYSTEM,XREF);
5419 LOP(OP_SYMLINK,XTERM);
5422 LOP(OP_SYSCALL,XTERM);
5425 LOP(OP_SYSOPEN,XTERM);
5428 LOP(OP_SYSSEEK,XTERM);
5431 LOP(OP_SYSREAD,XTERM);
5434 LOP(OP_SYSWRITE,XTERM);
5438 TERM(sublex_start());
5459 LOP(OP_TRUNCATE,XTERM);
5471 yylval.ival = CopLINE(PL_curcop);
5475 yylval.ival = CopLINE(PL_curcop);
5479 LOP(OP_UNLINK,XTERM);
5485 LOP(OP_UNPACK,XTERM);
5488 LOP(OP_UTIME,XTERM);
5494 LOP(OP_UNSHIFT,XTERM);
5497 s = tokenize_use(1, s);
5507 yylval.ival = CopLINE(PL_curcop);
5511 PL_hints |= HINT_BLOCK_SCOPE;
5518 LOP(OP_WAITPID,XTERM);
5527 ctl_l[0] = toCTRL('L');
5529 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5532 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5537 if (PL_expect == XOPERATOR)
5543 yylval.ival = OP_XOR;
5548 TERM(sublex_start());
5553 #pragma segment Main
5557 S_pending_ident(pTHX)
5560 register I32 tmp = 0;
5561 /* pit holds the identifier we read and pending_ident is reset */
5562 char pit = PL_pending_ident;
5563 PL_pending_ident = 0;
5565 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5566 "### Pending identifier '%s'\n", PL_tokenbuf); });
5568 /* if we're in a my(), we can't allow dynamics here.
5569 $foo'bar has already been turned into $foo::bar, so
5570 just check for colons.
5572 if it's a legal name, the OP is a PADANY.
5575 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5576 if (strchr(PL_tokenbuf,':'))
5577 yyerror(Perl_form(aTHX_ "No package name allowed for "
5578 "variable %s in \"our\"",
5580 tmp = allocmy(PL_tokenbuf);
5583 if (strchr(PL_tokenbuf,':'))
5584 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5586 yylval.opval = newOP(OP_PADANY, 0);
5587 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5593 build the ops for accesses to a my() variable.
5595 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5596 then used in a comparison. This catches most, but not
5597 all cases. For instance, it catches
5598 sort { my($a); $a <=> $b }
5600 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5601 (although why you'd do that is anyone's guess).
5604 if (!strchr(PL_tokenbuf,':')) {
5606 tmp = pad_findmy(PL_tokenbuf);
5607 if (tmp != NOT_IN_PAD) {
5608 /* might be an "our" variable" */
5609 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5610 /* build ops for a bareword */
5611 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
5612 HEK * const stashname = HvNAME_HEK(stash);
5613 SV * const sym = newSVhek(stashname);
5614 sv_catpvn(sym, "::", 2);
5615 sv_catpv(sym, PL_tokenbuf+1);
5616 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5617 yylval.opval->op_private = OPpCONST_ENTERED;
5620 ? (GV_ADDMULTI | GV_ADDINEVAL)
5623 ((PL_tokenbuf[0] == '$') ? SVt_PV
5624 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5629 /* if it's a sort block and they're naming $a or $b */
5630 if (PL_last_lop_op == OP_SORT &&
5631 PL_tokenbuf[0] == '$' &&
5632 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5635 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5636 d < PL_bufend && *d != '\n';
5639 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5640 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5646 yylval.opval = newOP(OP_PADANY, 0);
5647 yylval.opval->op_targ = tmp;
5653 Whine if they've said @foo in a doublequoted string,
5654 and @foo isn't a variable we can find in the symbol
5657 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5658 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5659 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5660 && ckWARN(WARN_AMBIGUOUS))
5662 /* Downgraded from fatal to warning 20000522 mjd */
5663 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5664 "Possible unintended interpolation of %s in string",
5669 /* build ops for a bareword */
5670 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5671 yylval.opval->op_private = OPpCONST_ENTERED;
5672 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5673 ((PL_tokenbuf[0] == '$') ? SVt_PV
5674 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5680 * The following code was generated by perl_keyword.pl.
5684 Perl_keyword (pTHX_ const char *name, I32 len)
5688 case 1: /* 5 tokens of length 1 */
5720 case 2: /* 18 tokens of length 2 */
5866 case 3: /* 28 tokens of length 3 */
5870 if (name[1] == 'N' &&
5933 if (name[1] == 'i' &&
5973 if (name[1] == 'o' &&
5982 if (name[1] == 'e' &&
5991 if (name[1] == 'n' &&
6000 if (name[1] == 'o' &&
6009 if (name[1] == 'a' &&
6018 if (name[1] == 'o' &&
6080 if (name[1] == 'e' &&
6112 if (name[1] == 'i' &&
6121 if (name[1] == 's' &&
6130 if (name[1] == 'e' &&
6139 if (name[1] == 'o' &&
6151 case 4: /* 40 tokens of length 4 */
6155 if (name[1] == 'O' &&
6165 if (name[1] == 'N' &&
6175 if (name[1] == 'i' &&
6185 if (name[1] == 'h' &&
6195 if (name[1] == 'u' &&
6208 if (name[2] == 'c' &&
6217 if (name[2] == 's' &&
6226 if (name[2] == 'a' &&
6262 if (name[1] == 'o' &&
6275 if (name[2] == 't' &&
6284 if (name[2] == 'o' &&
6293 if (name[2] == 't' &&
6302 if (name[2] == 'e' &&
6315 if (name[1] == 'o' &&
6328 if (name[2] == 'y' &&
6337 if (name[2] == 'l' &&
6353 if (name[2] == 's' &&
6362 if (name[2] == 'n' &&
6371 if (name[2] == 'c' &&
6384 if (name[1] == 'e' &&
6394 if (name[1] == 'p' &&
6407 if (name[2] == 'c' &&
6416 if (name[2] == 'p' &&
6425 if (name[2] == 's' &&
6441 if (name[2] == 'n' &&
6511 if (name[2] == 'r' &&
6520 if (name[2] == 'r' &&
6529 if (name[2] == 'a' &&
6545 if (name[2] == 'l' &&
6612 case 5: /* 36 tokens of length 5 */
6616 if (name[1] == 'E' &&
6627 if (name[1] == 'H' &&
6641 if (name[2] == 'a' &&
6651 if (name[2] == 'a' &&
6665 if (name[1] == 'l' &&
6682 if (name[3] == 'i' &&
6691 if (name[3] == 'o' &&
6727 if (name[2] == 'o' &&
6737 if (name[2] == 'y' &&
6751 if (name[1] == 'l' &&
6765 if (name[2] == 'n' &&
6775 if (name[2] == 'o' &&
6792 if (name[2] == 'd' &&
6802 if (name[2] == 'c' &&
6819 if (name[2] == 'c' &&
6829 if (name[2] == 't' &&
6843 if (name[1] == 'k' &&
6854 if (name[1] == 'r' &&
6868 if (name[2] == 's' &&
6878 if (name[2] == 'd' &&
6895 if (name[2] == 'm' &&
6905 if (name[2] == 'i' &&
6915 if (name[2] == 'e' &&
6925 if (name[2] == 'l' &&
6935 if (name[2] == 'a' &&
6945 if (name[2] == 'u' &&
6959 if (name[1] == 'i' &&
6973 if (name[2] == 'a' &&
6986 if (name[3] == 'e' &&
7021 if (name[2] == 'i' &&
7038 if (name[2] == 'i' &&
7048 if (name[2] == 'i' &&
7065 case 6: /* 33 tokens of length 6 */
7069 if (name[1] == 'c' &&
7084 if (name[2] == 'l' &&
7095 if (name[2] == 'r' &&
7110 if (name[1] == 'e' &&
7125 if (name[2] == 's' &&
7130 if(ckWARN_d(WARN_SYNTAX))
7131 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7137 if (name[2] == 'i' &&
7155 if (name[2] == 'l' &&
7166 if (name[2] == 'r' &&
7181 if (name[1] == 'm' &&
7196 if (name[2] == 'n' &&
7207 if (name[2] == 's' &&
7222 if (name[1] == 's' &&
7228 if (name[4] == 't' &&
7237 if (name[4] == 'e' &&
7246 if (name[4] == 'c' &&
7255 if (name[4] == 'n' &&
7271 if (name[1] == 'r' &&
7289 if (name[3] == 'a' &&
7299 if (name[3] == 'u' &&
7313 if (name[2] == 'n' &&
7331 if (name[2] == 'a' &&
7345 if (name[3] == 'e' &&
7358 if (name[4] == 't' &&
7367 if (name[4] == 'e' &&
7389 if (name[4] == 't' &&
7398 if (name[4] == 'e' &&
7414 if (name[2] == 'c' &&
7425 if (name[2] == 'l' &&
7436 if (name[2] == 'b' &&
7447 if (name[2] == 's' &&
7470 if (name[4] == 's' &&
7479 if (name[4] == 'n' &&
7492 if (name[3] == 'a' &&
7509 if (name[1] == 'a' &&
7524 case 7: /* 28 tokens of length 7 */
7528 if (name[1] == 'E' &&
7541 if (name[1] == '_' &&
7554 if (name[1] == 'i' &&
7561 return -KEY_binmode;
7567 if (name[1] == 'o' &&
7574 return -KEY_connect;
7583 if (name[2] == 'm' &&
7589 return -KEY_dbmopen;
7595 if (name[2] == 'f' &&
7611 if (name[1] == 'o' &&
7624 if (name[1] == 'e' &&
7631 if (name[5] == 'r' &&
7634 return -KEY_getpgrp;
7640 if (name[5] == 'i' &&
7643 return -KEY_getppid;
7656 if (name[1] == 'c' &&
7663 return -KEY_lcfirst;
7669 if (name[1] == 'p' &&
7676 return -KEY_opendir;
7682 if (name[1] == 'a' &&
7700 if (name[3] == 'd' &&
7705 return -KEY_readdir;
7711 if (name[3] == 'u' &&
7722 if (name[3] == 'e' &&
7727 return -KEY_reverse;
7746 if (name[3] == 'k' &&
7751 return -KEY_seekdir;
7757 if (name[3] == 'p' &&
7762 return -KEY_setpgrp;
7772 if (name[2] == 'm' &&
7778 return -KEY_shmread;
7784 if (name[2] == 'r' &&
7790 return -KEY_sprintf;
7799 if (name[3] == 'l' &&
7804 return -KEY_symlink;
7813 if (name[4] == 'a' &&
7817 return -KEY_syscall;
7823 if (name[4] == 'p' &&
7827 return -KEY_sysopen;
7833 if (name[4] == 'e' &&
7837 return -KEY_sysread;
7843 if (name[4] == 'e' &&
7847 return -KEY_sysseek;
7865 if (name[1] == 'e' &&
7872 return -KEY_telldir;
7881 if (name[2] == 'f' &&
7887 return -KEY_ucfirst;
7893 if (name[2] == 's' &&
7899 return -KEY_unshift;
7909 if (name[1] == 'a' &&
7916 return -KEY_waitpid;
7925 case 8: /* 26 tokens of length 8 */
7929 if (name[1] == 'U' &&
7937 return KEY_AUTOLOAD;
7948 if (name[3] == 'A' &&
7954 return KEY___DATA__;
7960 if (name[3] == 'I' &&
7966 return -KEY___FILE__;
7972 if (name[3] == 'I' &&
7978 return -KEY___LINE__;
7994 if (name[2] == 'o' &&
8001 return -KEY_closedir;
8007 if (name[2] == 'n' &&
8014 return -KEY_continue;
8024 if (name[1] == 'b' &&
8032 return -KEY_dbmclose;
8038 if (name[1] == 'n' &&
8044 if (name[4] == 'r' &&
8049 return -KEY_endgrent;
8055 if (name[4] == 'w' &&
8060 return -KEY_endpwent;
8073 if (name[1] == 'o' &&
8081 return -KEY_formline;
8087 if (name[1] == 'e' &&
8098 if (name[6] == 'n' &&
8101 return -KEY_getgrent;
8107 if (name[6] == 'i' &&
8110 return -KEY_getgrgid;
8116 if (name[6] == 'a' &&
8119 return -KEY_getgrnam;
8132 if (name[4] == 'o' &&
8137 return -KEY_getlogin;
8148 if (name[6] == 'n' &&
8151 return -KEY_getpwent;
8157 if (name[6] == 'a' &&
8160 return -KEY_getpwnam;
8166 if (name[6] == 'i' &&
8169 return -KEY_getpwuid;
8189 if (name[1] == 'e' &&
8196 if (name[5] == 'i' &&
8203 return -KEY_readline;
8208 return -KEY_readlink;
8219 if (name[5] == 'i' &&
8223 return -KEY_readpipe;
8244 if (name[4] == 'r' &&
8249 return -KEY_setgrent;
8255 if (name[4] == 'w' &&
8260 return -KEY_setpwent;
8276 if (name[3] == 'w' &&
8282 return -KEY_shmwrite;
8288 if (name[3] == 't' &&
8294 return -KEY_shutdown;
8304 if (name[2] == 's' &&
8311 return -KEY_syswrite;
8321 if (name[1] == 'r' &&
8329 return -KEY_truncate;
8338 case 9: /* 8 tokens of length 9 */
8342 if (name[1] == 'n' &&
8351 return -KEY_endnetent;
8357 if (name[1] == 'e' &&
8366 return -KEY_getnetent;
8372 if (name[1] == 'o' &&
8381 return -KEY_localtime;
8387 if (name[1] == 'r' &&
8396 return KEY_prototype;
8402 if (name[1] == 'u' &&
8411 return -KEY_quotemeta;
8417 if (name[1] == 'e' &&
8426 return -KEY_rewinddir;
8432 if (name[1] == 'e' &&
8441 return -KEY_setnetent;
8447 if (name[1] == 'a' &&
8456 return -KEY_wantarray;
8465 case 10: /* 9 tokens of length 10 */
8469 if (name[1] == 'n' &&
8475 if (name[4] == 'o' &&
8482 return -KEY_endhostent;
8488 if (name[4] == 'e' &&
8495 return -KEY_endservent;
8508 if (name[1] == 'e' &&
8514 if (name[4] == 'o' &&
8521 return -KEY_gethostent;
8530 if (name[5] == 'r' &&
8536 return -KEY_getservent;
8542 if (name[5] == 'c' &&
8548 return -KEY_getsockopt;
8573 if (name[4] == 'o' &&
8580 return -KEY_sethostent;
8589 if (name[5] == 'r' &&
8595 return -KEY_setservent;
8601 if (name[5] == 'c' &&
8607 return -KEY_setsockopt;
8624 if (name[2] == 'c' &&
8633 return -KEY_socketpair;
8646 case 11: /* 8 tokens of length 11 */
8650 if (name[1] == '_' &&
8661 return -KEY___PACKAGE__;
8667 if (name[1] == 'n' &&
8678 return -KEY_endprotoent;
8684 if (name[1] == 'e' &&
8693 if (name[5] == 'e' &&
8700 return -KEY_getpeername;
8709 if (name[6] == 'o' &&
8715 return -KEY_getpriority;
8721 if (name[6] == 't' &&
8727 return -KEY_getprotoent;
8741 if (name[4] == 'o' &&
8749 return -KEY_getsockname;
8762 if (name[1] == 'e' &&
8770 if (name[6] == 'o' &&
8776 return -KEY_setpriority;
8782 if (name[6] == 't' &&
8788 return -KEY_setprotoent;
8804 case 12: /* 2 tokens of length 12 */
8805 if (name[0] == 'g' &&
8817 if (name[9] == 'd' &&
8820 { /* getnetbyaddr */
8821 return -KEY_getnetbyaddr;
8827 if (name[9] == 'a' &&
8830 { /* getnetbyname */
8831 return -KEY_getnetbyname;
8843 case 13: /* 4 tokens of length 13 */
8844 if (name[0] == 'g' &&
8851 if (name[4] == 'o' &&
8860 if (name[10] == 'd' &&
8863 { /* gethostbyaddr */
8864 return -KEY_gethostbyaddr;
8870 if (name[10] == 'a' &&
8873 { /* gethostbyname */
8874 return -KEY_gethostbyname;
8887 if (name[4] == 'e' &&
8896 if (name[10] == 'a' &&
8899 { /* getservbyname */
8900 return -KEY_getservbyname;
8906 if (name[10] == 'o' &&
8909 { /* getservbyport */
8910 return -KEY_getservbyport;
8929 case 14: /* 1 tokens of length 14 */
8930 if (name[0] == 'g' &&
8944 { /* getprotobyname */
8945 return -KEY_getprotobyname;
8950 case 16: /* 1 tokens of length 16 */
8951 if (name[0] == 'g' &&
8967 { /* getprotobynumber */
8968 return -KEY_getprotobynumber;
8982 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
8986 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8987 if (ckWARN(WARN_SYNTAX)) {
8989 for (w = s+2; *w && level; w++) {
8996 for (; *w && isSPACE(*w); w++) ;
8997 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
8998 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8999 "%s (...) interpreted as function",name);
9002 while (s < PL_bufend && isSPACE(*s))
9006 while (s < PL_bufend && isSPACE(*s))
9008 if (isIDFIRST_lazy_if(s,UTF)) {
9010 while (isALNUM_lazy_if(s,UTF))
9012 while (s < PL_bufend && isSPACE(*s))
9016 *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9017 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9021 Perl_croak(aTHX_ "No comma allowed after %s", what);
9026 /* Either returns sv, or mortalizes sv and returns a new SV*.
9027 Best used as sv=new_constant(..., sv, ...).
9028 If s, pv are NULL, calls subroutine with one argument,
9029 and type is used with error messages only. */
9032 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9036 HV * const table = GvHV(PL_hintgv); /* ^H */
9040 const char *why1 = "", *why2 = "", *why3 = "";
9042 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9045 why2 = strEQ(key,"charnames")
9046 ? "(possibly a missing \"use charnames ...\")"
9048 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9049 (type ? type: "undef"), why2);
9051 /* This is convoluted and evil ("goto considered harmful")
9052 * but I do not understand the intricacies of all the different
9053 * failure modes of %^H in here. The goal here is to make
9054 * the most probable error message user-friendly. --jhi */
9059 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9060 (type ? type: "undef"), why1, why2, why3);
9062 yyerror(SvPVX_const(msg));
9066 cvp = hv_fetch(table, key, strlen(key), FALSE);
9067 if (!cvp || !SvOK(*cvp)) {
9070 why3 = "} is not defined";
9073 sv_2mortal(sv); /* Parent created it permanently */
9076 pv = sv_2mortal(newSVpvn(s, len));
9078 typesv = sv_2mortal(newSVpv(type, 0));
9080 typesv = &PL_sv_undef;
9082 PUSHSTACKi(PERLSI_OVERLOAD);
9094 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9098 /* Check the eval first */
9099 if (!PL_in_eval && SvTRUE(ERRSV)) {
9100 sv_catpv(ERRSV, "Propagated");
9101 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9103 res = SvREFCNT_inc(sv);
9107 (void)SvREFCNT_inc(res);
9116 why1 = "Call to &{$^H{";
9118 why3 = "}} did not return a defined value";
9126 /* Returns a NUL terminated string, with the length of the string written to
9130 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9132 register char *d = dest;
9133 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
9136 Perl_croak(aTHX_ ident_too_long);
9137 if (isALNUM(*s)) /* UTF handled below */
9139 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9144 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9148 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9149 char *t = s + UTF8SKIP(s);
9150 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9152 if (d + (t - s) > e)
9153 Perl_croak(aTHX_ ident_too_long);
9154 Copy(s, d, t - s, char);
9167 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9171 char *bracket = Nullch;
9177 e = d + destlen - 3; /* two-character token, ending NUL */
9179 while (isDIGIT(*s)) {
9181 Perl_croak(aTHX_ ident_too_long);
9188 Perl_croak(aTHX_ ident_too_long);
9189 if (isALNUM(*s)) /* UTF handled below */
9191 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9196 else if (*s == ':' && s[1] == ':') {
9200 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9201 char *t = s + UTF8SKIP(s);
9202 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9204 if (d + (t - s) > e)
9205 Perl_croak(aTHX_ ident_too_long);
9206 Copy(s, d, t - s, char);
9217 if (PL_lex_state != LEX_NORMAL)
9218 PL_lex_state = LEX_INTERPENDMAYBE;
9221 if (*s == '$' && s[1] &&
9222 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9235 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9240 if (isSPACE(s[-1])) {
9242 const char ch = *s++;
9243 if (!SPACE_OR_TAB(ch)) {
9249 if (isIDFIRST_lazy_if(d,UTF)) {
9253 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9255 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9258 Copy(s, d, e - s, char);
9263 while ((isALNUM(*s) || *s == ':') && d < e)
9266 Perl_croak(aTHX_ ident_too_long);
9269 while (s < send && SPACE_OR_TAB(*s)) s++;
9270 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9271 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9272 const char *brack = *s == '[' ? "[...]" : "{...}";
9273 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9274 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9275 funny, dest, brack, funny, dest, brack);
9278 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9282 /* Handle extended ${^Foo} variables
9283 * 1999-02-27 mjd-perl-patch@plover.com */
9284 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9288 while (isALNUM(*s) && d < e) {
9292 Perl_croak(aTHX_ ident_too_long);
9297 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9298 PL_lex_state = LEX_INTERPEND;
9303 if (PL_lex_state == LEX_NORMAL) {
9304 if (ckWARN(WARN_AMBIGUOUS) &&
9305 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9307 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9308 "Ambiguous use of %c{%s} resolved to %c%s",
9309 funny, dest, funny, dest);
9314 s = bracket; /* let the parser handle it */
9318 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9319 PL_lex_state = LEX_INTERPEND;
9324 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9329 *pmfl |= PMf_GLOBAL;
9331 *pmfl |= PMf_CONTINUE;
9335 *pmfl |= PMf_MULTILINE;
9337 *pmfl |= PMf_SINGLELINE;
9339 *pmfl |= PMf_EXTENDED;
9343 S_scan_pat(pTHX_ char *start, I32 type)
9346 char *s = scan_str(start,FALSE,FALSE);
9349 char * const delimiter = skipspace(start);
9350 Perl_croak(aTHX_ *delimiter == '?'
9351 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9352 : "Search pattern not terminated" );
9355 pm = (PMOP*)newPMOP(type, 0);
9356 if (PL_multi_open == '?')
9357 pm->op_pmflags |= PMf_ONCE;
9359 while (*s && strchr("iomsx", *s))
9360 pmflag(&pm->op_pmflags,*s++);
9363 while (*s && strchr("iogcmsx", *s))
9364 pmflag(&pm->op_pmflags,*s++);
9366 /* issue a warning if /c is specified,but /g is not */
9367 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9368 && ckWARN(WARN_REGEXP))
9370 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
9373 pm->op_pmpermflags = pm->op_pmflags;
9375 PL_lex_op = (OP*)pm;
9376 yylval.ival = OP_MATCH;
9381 S_scan_subst(pTHX_ char *start)
9389 yylval.ival = OP_NULL;
9391 s = scan_str(start,FALSE,FALSE);
9394 Perl_croak(aTHX_ "Substitution pattern not terminated");
9396 if (s[-1] == PL_multi_open)
9399 first_start = PL_multi_start;
9400 s = scan_str(s,FALSE,FALSE);
9403 SvREFCNT_dec(PL_lex_stuff);
9404 PL_lex_stuff = Nullsv;
9406 Perl_croak(aTHX_ "Substitution replacement not terminated");
9408 PL_multi_start = first_start; /* so whole substitution is taken together */
9410 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9416 else if (strchr("iogcmsx", *s))
9417 pmflag(&pm->op_pmflags,*s++);
9422 /* /c is not meaningful with s/// */
9423 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
9425 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
9430 PL_sublex_info.super_bufptr = s;
9431 PL_sublex_info.super_bufend = PL_bufend;
9433 pm->op_pmflags |= PMf_EVAL;
9434 repl = newSVpvn("",0);
9436 sv_catpv(repl, es ? "eval " : "do ");
9437 sv_catpvn(repl, "{ ", 2);
9438 sv_catsv(repl, PL_lex_repl);
9439 sv_catpvn(repl, " };", 2);
9441 SvREFCNT_dec(PL_lex_repl);
9445 pm->op_pmpermflags = pm->op_pmflags;
9446 PL_lex_op = (OP*)pm;
9447 yylval.ival = OP_SUBST;
9452 S_scan_trans(pTHX_ char *start)
9461 yylval.ival = OP_NULL;
9463 s = scan_str(start,FALSE,FALSE);
9465 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9466 if (s[-1] == PL_multi_open)
9469 s = scan_str(s,FALSE,FALSE);
9472 SvREFCNT_dec(PL_lex_stuff);
9473 PL_lex_stuff = Nullsv;
9475 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9478 complement = del = squash = 0;
9482 complement = OPpTRANS_COMPLEMENT;
9485 del = OPpTRANS_DELETE;
9488 squash = OPpTRANS_SQUASH;
9497 Newx(tbl, complement&&!del?258:256, short);
9498 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9499 o->op_private &= ~OPpTRANS_ALL;
9500 o->op_private |= del|squash|complement|
9501 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9502 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9505 yylval.ival = OP_TRANS;
9510 S_scan_heredoc(pTHX_ register char *s)
9513 I32 op_type = OP_SCALAR;
9517 const char newline[] = "\n";
9518 const char *found_newline;
9522 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9526 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9529 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9530 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9533 s = delimcpy(d, e, s, PL_bufend, term, &len);
9543 if (!isALNUM_lazy_if(s,UTF))
9544 deprecate_old("bare << to mean <<\"\"");
9545 for (; isALNUM_lazy_if(s,UTF); s++) {
9550 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9551 Perl_croak(aTHX_ "Delimiter for here document is too long");
9554 len = d - PL_tokenbuf;
9555 #ifndef PERL_STRICT_CR
9556 d = strchr(s, '\r');
9558 char * const olds = s;
9560 while (s < PL_bufend) {
9566 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9575 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9579 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9580 herewas = newSVpvn(s,PL_bufend-s);
9584 herewas = newSVpvn(s,found_newline-s);
9586 s += SvCUR(herewas);
9588 tmpstr = NEWSV(87,79);
9589 sv_upgrade(tmpstr, SVt_PVIV);
9592 SvIV_set(tmpstr, -1);
9594 else if (term == '`') {
9595 op_type = OP_BACKTICK;
9596 SvIV_set(tmpstr, '\\');
9600 PL_multi_start = CopLINE(PL_curcop);
9601 PL_multi_open = PL_multi_close = '<';
9602 term = *PL_tokenbuf;
9603 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9604 char *bufptr = PL_sublex_info.super_bufptr;
9605 char *bufend = PL_sublex_info.super_bufend;
9606 char * const olds = s - SvCUR(herewas);
9607 s = strchr(bufptr, '\n');
9611 while (s < bufend &&
9612 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9614 CopLINE_inc(PL_curcop);
9617 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9618 missingterm(PL_tokenbuf);
9620 sv_setpvn(herewas,bufptr,d-bufptr+1);
9621 sv_setpvn(tmpstr,d+1,s-d);
9623 sv_catpvn(herewas,s,bufend-s);
9624 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9631 while (s < PL_bufend &&
9632 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9634 CopLINE_inc(PL_curcop);
9636 if (s >= PL_bufend) {
9637 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9638 missingterm(PL_tokenbuf);
9640 sv_setpvn(tmpstr,d+1,s-d);
9642 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9644 sv_catpvn(herewas,s,PL_bufend-s);
9645 sv_setsv(PL_linestr,herewas);
9646 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9647 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9648 PL_last_lop = PL_last_uni = Nullch;
9651 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9652 while (s >= PL_bufend) { /* multiple line string? */
9654 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9655 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9656 missingterm(PL_tokenbuf);
9658 CopLINE_inc(PL_curcop);
9659 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9660 PL_last_lop = PL_last_uni = Nullch;
9661 #ifndef PERL_STRICT_CR
9662 if (PL_bufend - PL_linestart >= 2) {
9663 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9664 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9666 PL_bufend[-2] = '\n';
9668 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9670 else if (PL_bufend[-1] == '\r')
9671 PL_bufend[-1] = '\n';
9673 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9674 PL_bufend[-1] = '\n';
9676 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9677 SV *sv = NEWSV(88,0);
9679 sv_upgrade(sv, SVt_PVMG);
9680 sv_setsv(sv,PL_linestr);
9683 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9685 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9686 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9687 *(SvPVX(PL_linestr) + off ) = ' ';
9688 sv_catsv(PL_linestr,herewas);
9689 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9690 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9694 sv_catsv(tmpstr,PL_linestr);
9699 PL_multi_end = CopLINE(PL_curcop);
9700 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9701 SvPV_shrink_to_cur(tmpstr);
9703 SvREFCNT_dec(herewas);
9705 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9707 else if (PL_encoding)
9708 sv_recode_to_utf8(tmpstr, PL_encoding);
9710 PL_lex_stuff = tmpstr;
9711 yylval.ival = op_type;
9716 takes: current position in input buffer
9717 returns: new position in input buffer
9718 side-effects: yylval and lex_op are set.
9723 <FH> read from filehandle
9724 <pkg::FH> read from package qualified filehandle
9725 <pkg'FH> read from package qualified filehandle
9726 <$fh> read from filehandle in $fh
9732 S_scan_inputsymbol(pTHX_ char *start)
9734 register char *s = start; /* current position in buffer */
9740 d = PL_tokenbuf; /* start of temp holding space */
9741 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9742 end = strchr(s, '\n');
9745 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9747 /* die if we didn't have space for the contents of the <>,
9748 or if it didn't end, or if we see a newline
9751 if (len >= sizeof PL_tokenbuf)
9752 Perl_croak(aTHX_ "Excessively long <> operator");
9754 Perl_croak(aTHX_ "Unterminated <> operator");
9759 Remember, only scalar variables are interpreted as filehandles by
9760 this code. Anything more complex (e.g., <$fh{$num}>) will be
9761 treated as a glob() call.
9762 This code makes use of the fact that except for the $ at the front,
9763 a scalar variable and a filehandle look the same.
9765 if (*d == '$' && d[1]) d++;
9767 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9768 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9771 /* If we've tried to read what we allow filehandles to look like, and
9772 there's still text left, then it must be a glob() and not a getline.
9773 Use scan_str to pull out the stuff between the <> and treat it
9774 as nothing more than a string.
9777 if (d - PL_tokenbuf != len) {
9778 yylval.ival = OP_GLOB;
9780 s = scan_str(start,FALSE,FALSE);
9782 Perl_croak(aTHX_ "Glob not terminated");
9786 bool readline_overriden = FALSE;
9787 GV *gv_readline = Nullgv;
9789 /* we're in a filehandle read situation */
9792 /* turn <> into <ARGV> */
9794 Copy("ARGV",d,5,char);
9796 /* Check whether readline() is overriden */
9797 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9798 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9800 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9801 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9802 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9803 readline_overriden = TRUE;
9805 /* if <$fh>, create the ops to turn the variable into a
9811 /* try to find it in the pad for this block, otherwise find
9812 add symbol table ops
9814 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9815 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9816 HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9817 HEK *stashname = HvNAME_HEK(stash);
9818 SV *sym = sv_2mortal(newSVhek(stashname));
9819 sv_catpvn(sym, "::", 2);
9825 OP *o = newOP(OP_PADSV, 0);
9827 PL_lex_op = readline_overriden
9828 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9829 append_elem(OP_LIST, o,
9830 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9831 : (OP*)newUNOP(OP_READLINE, 0, o);
9840 ? (GV_ADDMULTI | GV_ADDINEVAL)
9843 PL_lex_op = readline_overriden
9844 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9845 append_elem(OP_LIST,
9846 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9847 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9848 : (OP*)newUNOP(OP_READLINE, 0,
9849 newUNOP(OP_RV2SV, 0,
9850 newGVOP(OP_GV, 0, gv)));
9852 if (!readline_overriden)
9853 PL_lex_op->op_flags |= OPf_SPECIAL;
9854 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9855 yylval.ival = OP_NULL;
9858 /* If it's none of the above, it must be a literal filehandle
9859 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9861 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9862 PL_lex_op = readline_overriden
9863 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9864 append_elem(OP_LIST,
9865 newGVOP(OP_GV, 0, gv),
9866 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9867 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9868 yylval.ival = OP_NULL;
9877 takes: start position in buffer
9878 keep_quoted preserve \ on the embedded delimiter(s)
9879 keep_delims preserve the delimiters around the string
9880 returns: position to continue reading from buffer
9881 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9882 updates the read buffer.
9884 This subroutine pulls a string out of the input. It is called for:
9885 q single quotes q(literal text)
9886 ' single quotes 'literal text'
9887 qq double quotes qq(interpolate $here please)
9888 " double quotes "interpolate $here please"
9889 qx backticks qx(/bin/ls -l)
9890 ` backticks `/bin/ls -l`
9891 qw quote words @EXPORT_OK = qw( func() $spam )
9892 m// regexp match m/this/
9893 s/// regexp substitute s/this/that/
9894 tr/// string transliterate tr/this/that/
9895 y/// string transliterate y/this/that/
9896 ($*@) sub prototypes sub foo ($)
9897 (stuff) sub attr parameters sub foo : attr(stuff)
9898 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9900 In most of these cases (all but <>, patterns and transliterate)
9901 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9902 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9903 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9906 It skips whitespace before the string starts, and treats the first
9907 character as the delimiter. If the delimiter is one of ([{< then
9908 the corresponding "close" character )]}> is used as the closing
9909 delimiter. It allows quoting of delimiters, and if the string has
9910 balanced delimiters ([{<>}]) it allows nesting.
9912 On success, the SV with the resulting string is put into lex_stuff or,
9913 if that is already non-NULL, into lex_repl. The second case occurs only
9914 when parsing the RHS of the special constructs s/// and tr/// (y///).
9915 For convenience, the terminating delimiter character is stuffed into
9920 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9922 SV *sv; /* scalar value: string */
9923 char *tmps; /* temp string, used for delimiter matching */
9924 register char *s = start; /* current position in the buffer */
9925 register char term; /* terminating character */
9926 register char *to; /* current position in the sv's data */
9927 I32 brackets = 1; /* bracket nesting level */
9928 bool has_utf8 = FALSE; /* is there any utf8 content? */
9929 I32 termcode; /* terminating char. code */
9930 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9931 STRLEN termlen; /* length of terminating string */
9932 char *last = NULL; /* last position for nesting bracket */
9934 /* skip space before the delimiter */
9938 /* mark where we are, in case we need to report errors */
9941 /* after skipping whitespace, the next character is the terminator */
9944 termcode = termstr[0] = term;
9948 termcode = utf8_to_uvchr((U8*)s, &termlen);
9949 Copy(s, termstr, termlen, U8);
9950 if (!UTF8_IS_INVARIANT(term))
9954 /* mark where we are */
9955 PL_multi_start = CopLINE(PL_curcop);
9956 PL_multi_open = term;
9958 /* find corresponding closing delimiter */
9959 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9960 termcode = termstr[0] = term = tmps[5];
9962 PL_multi_close = term;
9964 /* create a new SV to hold the contents. 87 is leak category, I'm
9965 assuming. 79 is the SV's initial length. What a random number. */
9967 sv_upgrade(sv, SVt_PVIV);
9968 SvIV_set(sv, termcode);
9969 (void)SvPOK_only(sv); /* validate pointer */
9971 /* move past delimiter and try to read a complete string */
9973 sv_catpvn(sv, s, termlen);
9976 if (PL_encoding && !UTF) {
9980 int offset = s - SvPVX_const(PL_linestr);
9981 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9982 &offset, (char*)termstr, termlen);
9983 const char *ns = SvPVX_const(PL_linestr) + offset;
9984 char *svlast = SvEND(sv) - 1;
9986 for (; s < ns; s++) {
9987 if (*s == '\n' && !PL_rsfp)
9988 CopLINE_inc(PL_curcop);
9991 goto read_more_line;
9993 /* handle quoted delimiters */
9994 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9996 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9998 if ((svlast-1 - t) % 2) {
10000 *(svlast-1) = term;
10002 SvCUR_set(sv, SvCUR(sv) - 1);
10007 if (PL_multi_open == PL_multi_close) {
10015 for (t = w = last; t < svlast; w++, t++) {
10016 /* At here, all closes are "was quoted" one,
10017 so we don't check PL_multi_close. */
10019 if (!keep_quoted && *(t+1) == PL_multi_open)
10024 else if (*t == PL_multi_open)
10032 SvCUR_set(sv, w - SvPVX_const(sv));
10035 if (--brackets <= 0)
10040 if (!keep_delims) {
10041 SvCUR_set(sv, SvCUR(sv) - 1);
10047 /* extend sv if need be */
10048 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10049 /* set 'to' to the next character in the sv's string */
10050 to = SvPVX(sv)+SvCUR(sv);
10052 /* if open delimiter is the close delimiter read unbridle */
10053 if (PL_multi_open == PL_multi_close) {
10054 for (; s < PL_bufend; s++,to++) {
10055 /* embedded newlines increment the current line number */
10056 if (*s == '\n' && !PL_rsfp)
10057 CopLINE_inc(PL_curcop);
10058 /* handle quoted delimiters */
10059 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10060 if (!keep_quoted && s[1] == term)
10062 /* any other quotes are simply copied straight through */
10066 /* terminate when run out of buffer (the for() condition), or
10067 have found the terminator */
10068 else if (*s == term) {
10071 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10074 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10080 /* if the terminator isn't the same as the start character (e.g.,
10081 matched brackets), we have to allow more in the quoting, and
10082 be prepared for nested brackets.
10085 /* read until we run out of string, or we find the terminator */
10086 for (; s < PL_bufend; s++,to++) {
10087 /* embedded newlines increment the line count */
10088 if (*s == '\n' && !PL_rsfp)
10089 CopLINE_inc(PL_curcop);
10090 /* backslashes can escape the open or closing characters */
10091 if (*s == '\\' && s+1 < PL_bufend) {
10092 if (!keep_quoted &&
10093 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10098 /* allow nested opens and closes */
10099 else if (*s == PL_multi_close && --brackets <= 0)
10101 else if (*s == PL_multi_open)
10103 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10108 /* terminate the copied string and update the sv's end-of-string */
10110 SvCUR_set(sv, to - SvPVX_const(sv));
10113 * this next chunk reads more into the buffer if we're not done yet
10117 break; /* handle case where we are done yet :-) */
10119 #ifndef PERL_STRICT_CR
10120 if (to - SvPVX_const(sv) >= 2) {
10121 if ((to[-2] == '\r' && to[-1] == '\n') ||
10122 (to[-2] == '\n' && to[-1] == '\r'))
10126 SvCUR_set(sv, to - SvPVX_const(sv));
10128 else if (to[-1] == '\r')
10131 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10136 /* if we're out of file, or a read fails, bail and reset the current
10137 line marker so we can report where the unterminated string began
10140 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10142 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10145 /* we read a line, so increment our line counter */
10146 CopLINE_inc(PL_curcop);
10148 /* update debugger info */
10149 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10150 SV *sv = NEWSV(88,0);
10152 sv_upgrade(sv, SVt_PVMG);
10153 sv_setsv(sv,PL_linestr);
10154 (void)SvIOK_on(sv);
10156 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10159 /* having changed the buffer, we must update PL_bufend */
10160 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10161 PL_last_lop = PL_last_uni = Nullch;
10164 /* at this point, we have successfully read the delimited string */
10166 if (!PL_encoding || UTF) {
10168 sv_catpvn(sv, s, termlen);
10171 if (has_utf8 || PL_encoding)
10174 PL_multi_end = CopLINE(PL_curcop);
10176 /* if we allocated too much space, give some back */
10177 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10178 SvLEN_set(sv, SvCUR(sv) + 1);
10179 SvPV_renew(sv, SvLEN(sv));
10182 /* decide whether this is the first or second quoted string we've read
10195 takes: pointer to position in buffer
10196 returns: pointer to new position in buffer
10197 side-effects: builds ops for the constant in yylval.op
10199 Read a number in any of the formats that Perl accepts:
10201 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10202 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10205 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10207 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10210 If it reads a number without a decimal point or an exponent, it will
10211 try converting the number to an integer and see if it can do so
10212 without loss of precision.
10216 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10218 register const char *s = start; /* current position in buffer */
10219 register char *d; /* destination in temp buffer */
10220 register char *e; /* end of temp buffer */
10221 NV nv; /* number read, as a double */
10222 SV *sv = Nullsv; /* place to put the converted number */
10223 bool floatit; /* boolean: int or float? */
10224 const char *lastub = 0; /* position of last underbar */
10225 static char const number_too_long[] = "Number too long";
10227 /* We use the first character to decide what type of number this is */
10231 Perl_croak(aTHX_ "panic: scan_num");
10233 /* if it starts with a 0, it could be an octal number, a decimal in
10234 0.13 disguise, or a hexadecimal number, or a binary number. */
10238 u holds the "number so far"
10239 shift the power of 2 of the base
10240 (hex == 4, octal == 3, binary == 1)
10241 overflowed was the number more than we can hold?
10243 Shift is used when we add a digit. It also serves as an "are
10244 we in octal/hex/binary?" indicator to disallow hex characters
10245 when in octal mode.
10250 bool overflowed = FALSE;
10251 bool just_zero = TRUE; /* just plain 0 or binary number? */
10252 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10253 static const char* const bases[5] =
10254 { "", "binary", "", "octal", "hexadecimal" };
10255 static const char* const Bases[5] =
10256 { "", "Binary", "", "Octal", "Hexadecimal" };
10257 static const char* const maxima[5] =
10259 "0b11111111111111111111111111111111",
10263 const char *base, *Base, *max;
10265 /* check for hex */
10270 } else if (s[1] == 'b') {
10275 /* check for a decimal in disguise */
10276 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10278 /* so it must be octal */
10285 if (ckWARN(WARN_SYNTAX))
10286 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10287 "Misplaced _ in number");
10291 base = bases[shift];
10292 Base = Bases[shift];
10293 max = maxima[shift];
10295 /* read the rest of the number */
10297 /* x is used in the overflow test,
10298 b is the digit we're adding on. */
10303 /* if we don't mention it, we're done */
10307 /* _ are ignored -- but warned about if consecutive */
10309 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10310 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10311 "Misplaced _ in number");
10315 /* 8 and 9 are not octal */
10316 case '8': case '9':
10318 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10322 case '2': case '3': case '4':
10323 case '5': case '6': case '7':
10325 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10328 case '0': case '1':
10329 b = *s++ & 15; /* ASCII digit -> value of digit */
10333 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10334 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10335 /* make sure they said 0x */
10338 b = (*s++ & 7) + 9;
10340 /* Prepare to put the digit we have onto the end
10341 of the number so far. We check for overflows.
10347 x = u << shift; /* make room for the digit */
10349 if ((x >> shift) != u
10350 && !(PL_hints & HINT_NEW_BINARY)) {
10353 if (ckWARN_d(WARN_OVERFLOW))
10354 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10355 "Integer overflow in %s number",
10358 u = x | b; /* add the digit to the end */
10361 n *= nvshift[shift];
10362 /* If an NV has not enough bits in its
10363 * mantissa to represent an UV this summing of
10364 * small low-order numbers is a waste of time
10365 * (because the NV cannot preserve the
10366 * low-order bits anyway): we could just
10367 * remember when did we overflow and in the
10368 * end just multiply n by the right
10376 /* if we get here, we had success: make a scalar value from
10381 /* final misplaced underbar check */
10382 if (s[-1] == '_') {
10383 if (ckWARN(WARN_SYNTAX))
10384 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10389 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10390 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10391 "%s number > %s non-portable",
10397 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10398 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10399 "%s number > %s non-portable",
10404 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10405 sv = new_constant(start, s - start, "integer",
10407 else if (PL_hints & HINT_NEW_BINARY)
10408 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10413 handle decimal numbers.
10414 we're also sent here when we read a 0 as the first digit
10416 case '1': case '2': case '3': case '4': case '5':
10417 case '6': case '7': case '8': case '9': case '.':
10420 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10423 /* read next group of digits and _ and copy into d */
10424 while (isDIGIT(*s) || *s == '_') {
10425 /* skip underscores, checking for misplaced ones
10429 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10430 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10431 "Misplaced _ in number");
10435 /* check for end of fixed-length buffer */
10437 Perl_croak(aTHX_ number_too_long);
10438 /* if we're ok, copy the character */
10443 /* final misplaced underbar check */
10444 if (lastub && s == lastub + 1) {
10445 if (ckWARN(WARN_SYNTAX))
10446 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10449 /* read a decimal portion if there is one. avoid
10450 3..5 being interpreted as the number 3. followed
10453 if (*s == '.' && s[1] != '.') {
10458 if (ckWARN(WARN_SYNTAX))
10459 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10460 "Misplaced _ in number");
10464 /* copy, ignoring underbars, until we run out of digits.
10466 for (; isDIGIT(*s) || *s == '_'; s++) {
10467 /* fixed length buffer check */
10469 Perl_croak(aTHX_ number_too_long);
10471 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10472 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10473 "Misplaced _ in number");
10479 /* fractional part ending in underbar? */
10480 if (s[-1] == '_') {
10481 if (ckWARN(WARN_SYNTAX))
10482 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10483 "Misplaced _ in number");
10485 if (*s == '.' && isDIGIT(s[1])) {
10486 /* oops, it's really a v-string, but without the "v" */
10492 /* read exponent part, if present */
10493 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10497 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10498 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10500 /* stray preinitial _ */
10502 if (ckWARN(WARN_SYNTAX))
10503 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10504 "Misplaced _ in number");
10508 /* allow positive or negative exponent */
10509 if (*s == '+' || *s == '-')
10512 /* stray initial _ */
10514 if (ckWARN(WARN_SYNTAX))
10515 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10516 "Misplaced _ in number");
10520 /* read digits of exponent */
10521 while (isDIGIT(*s) || *s == '_') {
10524 Perl_croak(aTHX_ number_too_long);
10528 if (((lastub && s == lastub + 1) ||
10529 (!isDIGIT(s[1]) && s[1] != '_'))
10530 && ckWARN(WARN_SYNTAX))
10531 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10532 "Misplaced _ in number");
10539 /* make an sv from the string */
10543 We try to do an integer conversion first if no characters
10544 indicating "float" have been found.
10549 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10551 if (flags == IS_NUMBER_IN_UV) {
10553 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10556 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10557 if (uv <= (UV) IV_MIN)
10558 sv_setiv(sv, -(IV)uv);
10565 /* terminate the string */
10567 nv = Atof(PL_tokenbuf);
10571 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10572 (PL_hints & HINT_NEW_INTEGER) )
10573 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10574 (floatit ? "float" : "integer"),
10578 /* if it starts with a v, it could be a v-string */
10581 sv = NEWSV(92,5); /* preallocate storage space */
10582 s = scan_vstring(s,sv);
10586 /* make the op for the constant and return */
10589 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10591 lvalp->opval = Nullop;
10597 S_scan_formline(pTHX_ register char *s)
10599 register char *eol;
10601 SV *stuff = newSVpvn("",0);
10602 bool needargs = FALSE;
10603 bool eofmt = FALSE;
10605 while (!needargs) {
10607 #ifdef PERL_STRICT_CR
10608 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10610 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10612 if (*t == '\n' || t == PL_bufend) {
10617 if (PL_in_eval && !PL_rsfp) {
10618 eol = (char *) memchr(s,'\n',PL_bufend-s);
10623 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10625 for (t = s; t < eol; t++) {
10626 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10628 goto enough; /* ~~ must be first line in formline */
10630 if (*t == '@' || *t == '^')
10634 sv_catpvn(stuff, s, eol-s);
10635 #ifndef PERL_STRICT_CR
10636 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10637 char *end = SvPVX(stuff) + SvCUR(stuff);
10640 SvCUR_set(stuff, SvCUR(stuff) - 1);
10649 s = filter_gets(PL_linestr, PL_rsfp, 0);
10650 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10651 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10652 PL_last_lop = PL_last_uni = Nullch;
10661 if (SvCUR(stuff)) {
10664 PL_lex_state = LEX_NORMAL;
10665 PL_nextval[PL_nexttoke].ival = 0;
10669 PL_lex_state = LEX_FORMLINE;
10671 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10673 else if (PL_encoding)
10674 sv_recode_to_utf8(stuff, PL_encoding);
10676 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10678 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10682 SvREFCNT_dec(stuff);
10684 PL_lex_formbrack = 0;
10695 PL_cshlen = strlen(PL_cshname);
10700 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10702 const I32 oldsavestack_ix = PL_savestack_ix;
10703 CV* outsidecv = PL_compcv;
10706 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10708 SAVEI32(PL_subline);
10709 save_item(PL_subname);
10710 SAVESPTR(PL_compcv);
10712 PL_compcv = (CV*)NEWSV(1104,0);
10713 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10714 CvFLAGS(PL_compcv) |= flags;
10716 PL_subline = CopLINE(PL_curcop);
10717 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10718 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10719 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10721 return oldsavestack_ix;
10725 #pragma segment Perl_yylex
10728 Perl_yywarn(pTHX_ const char *s)
10730 PL_in_eval |= EVAL_WARNONLY;
10732 PL_in_eval &= ~EVAL_WARNONLY;
10737 Perl_yyerror(pTHX_ const char *s)
10739 const char *where = NULL;
10740 const char *context = NULL;
10744 if (!yychar || (yychar == ';' && !PL_rsfp))
10746 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10747 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10748 PL_oldbufptr != PL_bufptr) {
10751 The code below is removed for NetWare because it abends/crashes on NetWare
10752 when the script has error such as not having the closing quotes like:
10753 if ($var eq "value)
10754 Checking of white spaces is anyway done in NetWare code.
10757 while (isSPACE(*PL_oldoldbufptr))
10760 context = PL_oldoldbufptr;
10761 contlen = PL_bufptr - PL_oldoldbufptr;
10763 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10764 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10767 The code below is removed for NetWare because it abends/crashes on NetWare
10768 when the script has error such as not having the closing quotes like:
10769 if ($var eq "value)
10770 Checking of white spaces is anyway done in NetWare code.
10773 while (isSPACE(*PL_oldbufptr))
10776 context = PL_oldbufptr;
10777 contlen = PL_bufptr - PL_oldbufptr;
10779 else if (yychar > 255)
10780 where = "next token ???";
10781 else if (yychar == -2) { /* YYEMPTY */
10782 if (PL_lex_state == LEX_NORMAL ||
10783 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10784 where = "at end of line";
10785 else if (PL_lex_inpat)
10786 where = "within pattern";
10788 where = "within string";
10791 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10793 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10794 else if (isPRINT_LC(yychar))
10795 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10797 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10798 where = SvPVX_const(where_sv);
10800 msg = sv_2mortal(newSVpv(s, 0));
10801 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10802 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10804 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10806 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10807 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10808 Perl_sv_catpvf(aTHX_ msg,
10809 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10810 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10813 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10814 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10817 if (PL_error_count >= 10) {
10818 if (PL_in_eval && SvCUR(ERRSV))
10819 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10820 ERRSV, OutCopFILE(PL_curcop));
10822 Perl_croak(aTHX_ "%s has too many errors.\n",
10823 OutCopFILE(PL_curcop));
10826 PL_in_my_stash = Nullhv;
10830 #pragma segment Main
10834 S_swallow_bom(pTHX_ U8 *s)
10836 const STRLEN slen = SvCUR(PL_linestr);
10839 if (s[1] == 0xFE) {
10840 /* UTF-16 little-endian? (or UTF32-LE?) */
10841 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10842 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10843 #ifndef PERL_NO_UTF16_FILTER
10844 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10847 if (PL_bufend > (char*)s) {
10851 filter_add(utf16rev_textfilter, NULL);
10852 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10853 utf16_to_utf8_reversed(s, news,
10854 PL_bufend - (char*)s - 1,
10856 sv_setpvn(PL_linestr, (const char*)news, newlen);
10858 SvUTF8_on(PL_linestr);
10859 s = (U8*)SvPVX(PL_linestr);
10860 PL_bufend = SvPVX(PL_linestr) + newlen;
10863 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10868 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10869 #ifndef PERL_NO_UTF16_FILTER
10870 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10873 if (PL_bufend > (char *)s) {
10877 filter_add(utf16_textfilter, NULL);
10878 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10879 utf16_to_utf8(s, news,
10880 PL_bufend - (char*)s,
10882 sv_setpvn(PL_linestr, (const char*)news, newlen);
10884 SvUTF8_on(PL_linestr);
10885 s = (U8*)SvPVX(PL_linestr);
10886 PL_bufend = SvPVX(PL_linestr) + newlen;
10889 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10894 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10895 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10896 s += 3; /* UTF-8 */
10902 if (s[2] == 0xFE && s[3] == 0xFF) {
10903 /* UTF-32 big-endian */
10904 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10907 else if (s[2] == 0 && s[3] != 0) {
10910 * are a good indicator of UTF-16BE. */
10911 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10916 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10919 * are a good indicator of UTF-16LE. */
10920 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10929 * Restore a source filter.
10933 restore_rsfp(pTHX_ void *f)
10935 PerlIO *fp = (PerlIO*)f;
10937 if (PL_rsfp == PerlIO_stdin())
10938 PerlIO_clearerr(PL_rsfp);
10939 else if (PL_rsfp && (PL_rsfp != fp))
10940 PerlIO_close(PL_rsfp);
10944 #ifndef PERL_NO_UTF16_FILTER
10946 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10948 const STRLEN old = SvCUR(sv);
10949 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10950 DEBUG_P(PerlIO_printf(Perl_debug_log,
10951 "utf16_textfilter(%p): %d %d (%d)\n",
10952 utf16_textfilter, idx, maxlen, (int) count));
10956 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10957 Copy(SvPVX_const(sv), tmps, old, char);
10958 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10959 SvCUR(sv) - old, &newlen);
10960 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10962 DEBUG_P({sv_dump(sv);});
10967 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10969 const STRLEN old = SvCUR(sv);
10970 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10971 DEBUG_P(PerlIO_printf(Perl_debug_log,
10972 "utf16rev_textfilter(%p): %d %d (%d)\n",
10973 utf16rev_textfilter, idx, maxlen, (int) count));
10977 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10978 Copy(SvPVX_const(sv), tmps, old, char);
10979 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10980 SvCUR(sv) - old, &newlen);
10981 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10983 DEBUG_P({ sv_dump(sv); });
10989 Returns a pointer to the next character after the parsed
10990 vstring, as well as updating the passed in sv.
10992 Function must be called like
10995 s = scan_vstring(s,sv);
10997 The sv should already be large enough to store the vstring
10998 passed in, for performance reasons.
11003 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
11005 const char *pos = s;
11006 const char *start = s;
11007 if (*pos == 'v') pos++; /* get past 'v' */
11008 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11010 if ( *pos != '.') {
11011 /* this may not be a v-string if followed by => */
11012 const char *next = pos;
11013 while (next < PL_bufend && isSPACE(*next))
11015 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11016 /* return string not v-string */
11017 sv_setpvn(sv,(char *)s,pos-s);
11018 return (char *)pos;
11022 if (!isALPHA(*pos)) {
11024 U8 tmpbuf[UTF8_MAXBYTES+1];
11027 if (*s == 'v') s++; /* get past 'v' */
11029 sv_setpvn(sv, "", 0);
11034 /* this is atoi() that tolerates underscores */
11035 const char *end = pos;
11037 while (--end >= s) {
11042 rev += (*end - '0') * mult;
11044 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11045 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11046 "Integer overflow in decimal number");
11050 if (rev > 0x7FFFFFFF)
11051 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11053 /* Append native character for the rev point */
11054 tmpend = uvchr_to_utf8(tmpbuf, rev);
11055 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11056 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11058 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11064 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11068 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11076 * c-indentation-style: bsd
11077 * c-basic-offset: 4
11078 * indent-tabs-mode: t
11081 * ex: set ts=8 sts=4 sw=4 noet: