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[] = "Identifier too long";
31 static void restore_rsfp(pTHX_ void *f);
32 #ifndef PERL_NO_UTF16_FILTER
33 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
34 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
37 #define XFAKEBRACK 128
40 #ifdef USE_UTF8_SCRIPTS
41 # define UTF (!IN_BYTES)
43 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
46 /* In variables named $^X, these are the legal values for X.
47 * 1999-02-27 mjd-perl-patch@plover.com */
48 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
50 /* On MacOS, respect nonbreaking spaces */
51 #ifdef MACOS_TRADITIONAL
52 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
54 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
57 /* LEX_* are values for PL_lex_state, the state of the lexer.
58 * They are arranged oddly so that the guard on the switch statement
59 * can get by with a single comparison (if the compiler is smart enough).
62 /* #define LEX_NOTPARSING 11 is done in perl.h. */
64 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
65 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
66 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
67 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
68 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
70 /* at end of code, eg "$x" followed by: */
71 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
72 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
74 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
75 string or after \E, $foo, etc */
76 #define LEX_INTERPCONST 2 /* NOT USED */
77 #define LEX_FORMLINE 1 /* expecting a format line */
78 #define LEX_KNOWNEXT 0 /* next token known; just return it */
82 static const char* const lex_state_names[] = {
101 #include "keywords.h"
103 /* CLINE is a macro that ensures PL_copline has a sane value */
108 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
111 * Convenience functions to return different tokens and prime the
112 * lexer for the next token. They all take an argument.
114 * TOKEN : generic token (used for '(', DOLSHARP, etc)
115 * OPERATOR : generic operator
116 * AOPERATOR : assignment operator
117 * PREBLOCK : beginning the block after an if, while, foreach, ...
118 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
119 * PREREF : *EXPR where EXPR is not a simple identifier
120 * TERM : expression term
121 * LOOPX : loop exiting command (goto, last, dump, etc)
122 * FTST : file test operator
123 * FUN0 : zero-argument function
124 * FUN1 : not used, except for not, which isn't a UNIOP
125 * BOop : bitwise or or xor
127 * SHop : shift operator
128 * PWop : power operator
129 * PMop : pattern-matching operator
130 * Aop : addition-level operator
131 * Mop : multiplication-level operator
132 * Eop : equality-testing operator
133 * Rop : relational operator <= != gt
135 * Also see LOP and lop() below.
138 #ifdef DEBUGGING /* Serve -DT. */
139 # define REPORT(retval) tokereport((I32)retval)
141 # define REPORT(retval) (retval)
144 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
145 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
146 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
147 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
148 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
149 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
150 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
151 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
152 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
153 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
154 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
155 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
156 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
157 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
158 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
159 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
160 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
161 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
162 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
163 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
165 /* This bit of chicanery makes a unary function followed by
166 * a parenthesis into a function with one argument, highest precedence.
167 * The UNIDOR macro is for unary functions that can be followed by the //
168 * operator (such as C<shift // 0>).
170 #define UNI2(f,x) { \
174 PL_last_uni = PL_oldbufptr; \
175 PL_last_lop_op = f; \
177 return REPORT( (int)FUNC1 ); \
179 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
181 #define UNI(f) UNI2(f,XTERM)
182 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
184 #define UNIBRACK(f) { \
187 PL_last_uni = PL_oldbufptr; \
189 return REPORT( (int)FUNC1 ); \
191 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
194 /* grandfather return to old style */
195 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
199 /* how to interpret the yylval associated with the token */
203 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
209 static struct debug_tokens { const int token, type; const char *name; }
210 const debug_tokens[] =
212 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
213 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
214 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
215 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
216 { ARROW, TOKENTYPE_NONE, "ARROW" },
217 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
218 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
219 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
220 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
221 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
222 { DO, TOKENTYPE_NONE, "DO" },
223 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
224 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
225 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
226 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
227 { ELSE, TOKENTYPE_NONE, "ELSE" },
228 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
229 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
230 { FOR, TOKENTYPE_IVAL, "FOR" },
231 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
232 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
233 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
234 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
235 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
236 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
237 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
238 { IF, TOKENTYPE_IVAL, "IF" },
239 { LABEL, TOKENTYPE_PVAL, "LABEL" },
240 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
241 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
242 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
243 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
244 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
245 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
246 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
247 { MY, TOKENTYPE_IVAL, "MY" },
248 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
249 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
250 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
251 { OROP, TOKENTYPE_IVAL, "OROP" },
252 { OROR, TOKENTYPE_NONE, "OROR" },
253 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
254 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
255 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
256 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
257 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
258 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
259 { PREINC, TOKENTYPE_NONE, "PREINC" },
260 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
261 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
262 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
263 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
264 { SUB, TOKENTYPE_NONE, "SUB" },
265 { THING, TOKENTYPE_OPVAL, "THING" },
266 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
267 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
268 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
269 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
270 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
271 { USE, TOKENTYPE_IVAL, "USE" },
272 { WHILE, TOKENTYPE_IVAL, "WHILE" },
273 { WORD, TOKENTYPE_OPVAL, "WORD" },
274 { 0, TOKENTYPE_NONE, 0 }
277 /* dump the returned token in rv, plus any optional arg in yylval */
280 S_tokereport(pTHX_ I32 rv)
283 const char *name = Nullch;
284 enum token_type type = TOKENTYPE_NONE;
285 const struct debug_tokens *p;
286 SV* const report = newSVpvn("<== ", 4);
288 for (p = debug_tokens; p->token; p++) {
289 if (p->token == (int)rv) {
296 Perl_sv_catpv(aTHX_ report, name);
297 else if ((char)rv > ' ' && (char)rv < '~')
298 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
300 Perl_sv_catpv(aTHX_ report, "EOF");
302 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
305 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
308 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
310 case TOKENTYPE_OPNUM:
311 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
312 PL_op_name[yylval.ival]);
315 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
317 case TOKENTYPE_OPVAL:
319 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
320 PL_op_name[yylval.opval->op_type]);
321 if (yylval.opval->op_type == OP_CONST) {
322 Perl_sv_catpvf(aTHX_ report, " %s",
323 SvPEEK(cSVOPx_sv(yylval.opval)));
328 Perl_sv_catpv(aTHX_ report, "(opval=null)");
331 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
337 /* print the buffer with suitable escapes */
340 S_printbuf(pTHX_ const char* fmt, const char* s)
342 SV* const tmp = newSVpvn("", 0);
343 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
352 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
353 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
357 S_ao(pTHX_ int toketype)
359 if (*PL_bufptr == '=') {
361 if (toketype == ANDAND)
362 yylval.ival = OP_ANDASSIGN;
363 else if (toketype == OROR)
364 yylval.ival = OP_ORASSIGN;
365 else if (toketype == DORDOR)
366 yylval.ival = OP_DORASSIGN;
374 * When Perl expects an operator and finds something else, no_op
375 * prints the warning. It always prints "<something> found where
376 * operator expected. It prints "Missing semicolon on previous line?"
377 * if the surprise occurs at the start of the line. "do you need to
378 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
379 * where the compiler doesn't know if foo is a method call or a function.
380 * It prints "Missing operator before end of line" if there's nothing
381 * after the missing operator, or "... before <...>" if there is something
382 * after the missing operator.
386 S_no_op(pTHX_ const char *what, char *s)
388 char * const oldbp = PL_bufptr;
389 const bool is_first = (PL_oldbufptr == PL_linestart);
395 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
396 if (ckWARN_d(WARN_SYNTAX)) {
398 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
399 "\t(Missing semicolon on previous line?)\n");
400 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
402 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
403 if (t < PL_bufptr && isSPACE(*t))
404 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
405 "\t(Do you need to predeclare %.*s?)\n",
406 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
410 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
411 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
419 * Complain about missing quote/regexp/heredoc terminator.
420 * If it's called with (char *)NULL then it cauterizes the line buffer.
421 * If we're in a delimited string and the delimiter is a control
422 * character, it's reformatted into a two-char sequence like ^C.
427 S_missingterm(pTHX_ char *s)
432 char * const nl = strrchr(s,'\n');
438 iscntrl(PL_multi_close)
440 PL_multi_close < 32 || PL_multi_close == 127
444 tmpbuf[1] = (char)toCTRL(PL_multi_close);
449 *tmpbuf = (char)PL_multi_close;
453 q = strchr(s,'"') ? '\'' : '"';
454 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
462 Perl_deprecate(pTHX_ const char *s)
464 if (ckWARN(WARN_DEPRECATED))
465 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
469 Perl_deprecate_old(pTHX_ const char *s)
471 /* This function should NOT be called for any new deprecated warnings */
472 /* Use Perl_deprecate instead */
474 /* It is here to maintain backward compatibility with the pre-5.8 */
475 /* warnings category hierarchy. The "deprecated" category used to */
476 /* live under the "syntax" category. It is now a top-level category */
477 /* in its own right. */
479 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
480 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
481 "Use of %s is deprecated", s);
486 * Deprecate a comma-less variable list.
492 deprecate_old("comma-less variable list");
496 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
497 * utf16-to-utf8-reversed.
500 #ifdef PERL_CR_FILTER
504 register const char *s = SvPVX_const(sv);
505 register const char * const e = s + SvCUR(sv);
506 /* outer loop optimized to do nothing if there are no CR-LFs */
508 if (*s++ == '\r' && *s == '\n') {
509 /* hit a CR-LF, need to copy the rest */
510 register char *d = s - 1;
513 if (*s == '\r' && s[1] == '\n')
524 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
526 const I32 count = FILTER_READ(idx+1, sv, maxlen);
527 if (count > 0 && !maxlen)
535 * Initialize variables. Uses the Perl save_stack to save its state (for
536 * recursive calls to the parser).
540 Perl_lex_start(pTHX_ SV *line)
545 SAVEI32(PL_lex_dojoin);
546 SAVEI32(PL_lex_brackets);
547 SAVEI32(PL_lex_casemods);
548 SAVEI32(PL_lex_starts);
549 SAVEI32(PL_lex_state);
550 SAVEVPTR(PL_lex_inpat);
551 SAVEI32(PL_lex_inwhat);
552 if (PL_lex_state == LEX_KNOWNEXT) {
553 I32 toke = PL_nexttoke;
554 while (--toke >= 0) {
555 SAVEI32(PL_nexttype[toke]);
556 SAVEVPTR(PL_nextval[toke]);
558 SAVEI32(PL_nexttoke);
560 SAVECOPLINE(PL_curcop);
563 SAVEPPTR(PL_oldbufptr);
564 SAVEPPTR(PL_oldoldbufptr);
565 SAVEPPTR(PL_last_lop);
566 SAVEPPTR(PL_last_uni);
567 SAVEPPTR(PL_linestart);
568 SAVESPTR(PL_linestr);
569 SAVEGENERICPV(PL_lex_brackstack);
570 SAVEGENERICPV(PL_lex_casestack);
571 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
572 SAVESPTR(PL_lex_stuff);
573 SAVEI32(PL_lex_defer);
574 SAVEI32(PL_sublex_info.sub_inwhat);
575 SAVESPTR(PL_lex_repl);
577 SAVEINT(PL_lex_expect);
579 PL_lex_state = LEX_NORMAL;
583 Newx(PL_lex_brackstack, 120, char);
584 Newx(PL_lex_casestack, 12, char);
586 *PL_lex_casestack = '\0';
589 PL_lex_stuff = Nullsv;
590 PL_lex_repl = Nullsv;
594 PL_sublex_info.sub_inwhat = 0;
596 if (SvREADONLY(PL_linestr))
597 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
598 s = SvPV_const(PL_linestr, len);
599 if (!len || s[len-1] != ';') {
600 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
601 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
602 sv_catpvn(PL_linestr, "\n;", 2);
604 SvTEMP_off(PL_linestr);
605 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
606 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
607 PL_last_lop = PL_last_uni = Nullch;
613 * Finalizer for lexing operations. Must be called when the parser is
614 * done with the lexer.
620 PL_doextract = FALSE;
625 * This subroutine has nothing to do with tilting, whether at windmills
626 * or pinball tables. Its name is short for "increment line". It
627 * increments the current line number in CopLINE(PL_curcop) and checks
628 * to see whether the line starts with a comment of the form
629 * # line 500 "foo.pm"
630 * If so, it sets the current line number and file to the values in the comment.
634 S_incline(pTHX_ char *s)
641 CopLINE_inc(PL_curcop);
644 while (SPACE_OR_TAB(*s)) s++;
645 if (strnEQ(s, "line", 4))
649 if (SPACE_OR_TAB(*s))
653 while (SPACE_OR_TAB(*s)) s++;
659 while (SPACE_OR_TAB(*s))
661 if (*s == '"' && (t = strchr(s+1, '"'))) {
666 for (t = s; !isSPACE(*t); t++) ;
669 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
671 if (*e != '\n' && *e != '\0')
672 return; /* false alarm */
678 const char * const cf = CopFILE(PL_curcop);
679 STRLEN tmplen = cf ? strlen(cf) : 0;
680 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
681 /* must copy *{"::_<(eval N)[oldfilename:L]"}
682 * to *{"::_<newfilename"} */
683 char smallbuf[256], smallbuf2[256];
684 char *tmpbuf, *tmpbuf2;
686 STRLEN tmplen2 = strlen(s);
687 if (tmplen + 3 < sizeof smallbuf)
690 Newx(tmpbuf, tmplen + 3, char);
691 if (tmplen2 + 3 < sizeof smallbuf2)
694 Newx(tmpbuf2, tmplen2 + 3, char);
695 tmpbuf[0] = tmpbuf2[0] = '_';
696 tmpbuf[1] = tmpbuf2[1] = '<';
697 memcpy(tmpbuf + 2, cf, ++tmplen);
698 memcpy(tmpbuf2 + 2, s, ++tmplen2);
700 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
702 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
704 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
705 /* adjust ${"::_<newfilename"} to store the new file name */
706 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
707 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
708 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
710 if (tmpbuf != smallbuf) Safefree(tmpbuf);
711 if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
714 CopFILE_free(PL_curcop);
715 CopFILE_set(PL_curcop, s);
718 CopLINE_set(PL_curcop, atoi(n)-1);
723 * Called to gobble the appropriate amount and type of whitespace.
724 * Skips comments as well.
728 S_skipspace(pTHX_ register char *s)
730 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
731 while (s < PL_bufend && SPACE_OR_TAB(*s))
737 SSize_t oldprevlen, oldoldprevlen;
738 SSize_t oldloplen = 0, oldunilen = 0;
739 while (s < PL_bufend && isSPACE(*s)) {
740 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
745 if (s < PL_bufend && *s == '#') {
746 while (s < PL_bufend && *s != '\n')
750 if (PL_in_eval && !PL_rsfp) {
757 /* only continue to recharge the buffer if we're at the end
758 * of the buffer, we're not reading from a source filter, and
759 * we're in normal lexing mode
761 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
762 PL_lex_state == LEX_FORMLINE)
765 /* try to recharge the buffer */
766 if ((s = filter_gets(PL_linestr, PL_rsfp,
767 (prevlen = SvCUR(PL_linestr)))) == Nullch)
769 /* end of file. Add on the -p or -n magic */
772 ";}continue{print or die qq(-p destination: $!\\n);}");
773 PL_minus_n = PL_minus_p = 0;
775 else if (PL_minus_n) {
776 sv_setpvn(PL_linestr, ";}", 2);
780 sv_setpvn(PL_linestr,";", 1);
782 /* reset variables for next time we lex */
783 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
785 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
786 PL_last_lop = PL_last_uni = Nullch;
788 /* Close the filehandle. Could be from -P preprocessor,
789 * STDIN, or a regular file. If we were reading code from
790 * STDIN (because the commandline held no -e or filename)
791 * then we don't close it, we reset it so the code can
792 * read from STDIN too.
795 if (PL_preprocess && !PL_in_eval)
796 (void)PerlProc_pclose(PL_rsfp);
797 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
798 PerlIO_clearerr(PL_rsfp);
800 (void)PerlIO_close(PL_rsfp);
805 /* not at end of file, so we only read another line */
806 /* make corresponding updates to old pointers, for yyerror() */
807 oldprevlen = PL_oldbufptr - PL_bufend;
808 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
810 oldunilen = PL_last_uni - PL_bufend;
812 oldloplen = PL_last_lop - PL_bufend;
813 PL_linestart = PL_bufptr = s + prevlen;
814 PL_bufend = s + SvCUR(PL_linestr);
816 PL_oldbufptr = s + oldprevlen;
817 PL_oldoldbufptr = s + oldoldprevlen;
819 PL_last_uni = s + oldunilen;
821 PL_last_lop = s + oldloplen;
824 /* debugger active and we're not compiling the debugger code,
825 * so store the line into the debugger's array of lines
827 if (PERLDB_LINE && PL_curstash != PL_debstash) {
828 SV * const sv = NEWSV(85,0);
830 sv_upgrade(sv, SVt_PVMG);
831 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
834 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
841 * Check the unary operators to ensure there's no ambiguity in how they're
842 * used. An ambiguous piece of code would be:
844 * This doesn't mean rand() + 5. Because rand() is a unary operator,
845 * the +5 is its argument.
854 if (PL_oldoldbufptr != PL_last_uni)
856 while (isSPACE(*PL_last_uni))
858 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
859 if ((t = strchr(s, '(')) && t < PL_bufptr)
861 if (ckWARN_d(WARN_AMBIGUOUS)){
864 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
865 "Warning: Use of \"%s\" without parentheses is ambiguous",
872 * LOP : macro to build a list operator. Its behaviour has been replaced
873 * with a subroutine, S_lop() for which LOP is just another name.
876 #define LOP(f,x) return lop(f,x,s)
880 * Build a list operator (or something that might be one). The rules:
881 * - if we have a next token, then it's a list operator [why?]
882 * - if the next thing is an opening paren, then it's a function
883 * - else it's a list operator
887 S_lop(pTHX_ I32 f, int x, char *s)
893 PL_last_lop = PL_oldbufptr;
894 PL_last_lop_op = (OPCODE)f;
896 return REPORT(LSTOP);
903 return REPORT(LSTOP);
908 * When the lexer realizes it knows the next token (for instance,
909 * it is reordering tokens for the parser) then it can call S_force_next
910 * to know what token to return the next time the lexer is called. Caller
911 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
912 * handles the token correctly.
916 S_force_next(pTHX_ I32 type)
918 PL_nexttype[PL_nexttoke] = type;
920 if (PL_lex_state != LEX_KNOWNEXT) {
921 PL_lex_defer = PL_lex_state;
922 PL_lex_expect = PL_expect;
923 PL_lex_state = LEX_KNOWNEXT;
928 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
930 SV * const sv = newSVpvn(start,len);
931 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
938 * When the lexer knows the next thing is a word (for instance, it has
939 * just seen -> and it knows that the next char is a word char, then
940 * it calls S_force_word to stick the next word into the PL_next lookahead.
943 * char *start : buffer position (must be within PL_linestr)
944 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
945 * int check_keyword : if true, Perl checks to make sure the word isn't
946 * a keyword (do this if the word is a label, e.g. goto FOO)
947 * int allow_pack : if true, : characters will also be allowed (require,
949 * int allow_initial_tick : used by the "sub" lexer only.
953 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
958 start = skipspace(start);
960 if (isIDFIRST_lazy_if(s,UTF) ||
961 (allow_pack && *s == ':') ||
962 (allow_initial_tick && *s == '\'') )
964 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
965 if (check_keyword && keyword(PL_tokenbuf, len))
967 if (token == METHOD) {
972 PL_expect = XOPERATOR;
975 PL_nextval[PL_nexttoke].opval
976 = (OP*)newSVOP(OP_CONST,0,
977 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
978 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
986 * Called when the lexer wants $foo *foo &foo etc, but the program
987 * text only contains the "foo" portion. The first argument is a pointer
988 * to the "foo", and the second argument is the type symbol to prefix.
989 * Forces the next token to be a "WORD".
990 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
994 S_force_ident(pTHX_ register const char *s, int kind)
997 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
998 PL_nextval[PL_nexttoke].opval = o;
1001 o->op_private = OPpCONST_ENTERED;
1002 /* XXX see note in pp_entereval() for why we forgo typo
1003 warnings if the symbol must be introduced in an eval.
1005 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1006 kind == '$' ? SVt_PV :
1007 kind == '@' ? SVt_PVAV :
1008 kind == '%' ? SVt_PVHV :
1016 Perl_str_to_version(pTHX_ SV *sv)
1021 const char *start = SvPV_const(sv,len);
1022 const char * const end = start + len;
1023 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1024 while (start < end) {
1028 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1033 retval += ((NV)n)/nshift;
1042 * Forces the next token to be a version number.
1043 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1044 * and if "guessing" is TRUE, then no new token is created (and the caller
1045 * must use an alternative parsing method).
1049 S_force_version(pTHX_ char *s, int guessing)
1051 OP *version = Nullop;
1060 while (isDIGIT(*d) || *d == '_' || *d == '.')
1062 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1064 s = scan_num(s, &yylval);
1065 version = yylval.opval;
1066 ver = cSVOPx(version)->op_sv;
1067 if (SvPOK(ver) && !SvNIOK(ver)) {
1068 SvUPGRADE(ver, SVt_PVNV);
1069 SvNV_set(ver, str_to_version(ver));
1070 SvNOK_on(ver); /* hint that it is a version */
1077 /* NOTE: The parser sees the package name and the VERSION swapped */
1078 PL_nextval[PL_nexttoke].opval = version;
1086 * Tokenize a quoted string passed in as an SV. It finds the next
1087 * chunk, up to end of string or a backslash. It may make a new
1088 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1093 S_tokeq(pTHX_ SV *sv)
1096 register char *send;
1104 s = SvPV_force(sv, len);
1105 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1108 while (s < send && *s != '\\')
1113 if ( PL_hints & HINT_NEW_STRING ) {
1114 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1120 if (s + 1 < send && (s[1] == '\\'))
1121 s++; /* all that, just for this */
1126 SvCUR_set(sv, d - SvPVX_const(sv));
1128 if ( PL_hints & HINT_NEW_STRING )
1129 return new_constant(NULL, 0, "q", sv, pv, "q");
1134 * Now come three functions related to double-quote context,
1135 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1136 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1137 * interact with PL_lex_state, and create fake ( ... ) argument lists
1138 * to handle functions and concatenation.
1139 * They assume that whoever calls them will be setting up a fake
1140 * join call, because each subthing puts a ',' after it. This lets
1143 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1145 * (I'm not sure whether the spurious commas at the end of lcfirst's
1146 * arguments and join's arguments are created or not).
1151 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1153 * Pattern matching will set PL_lex_op to the pattern-matching op to
1154 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1156 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1158 * Everything else becomes a FUNC.
1160 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1161 * had an OP_CONST or OP_READLINE). This just sets us up for a
1162 * call to S_sublex_push().
1166 S_sublex_start(pTHX)
1168 register const I32 op_type = yylval.ival;
1170 if (op_type == OP_NULL) {
1171 yylval.opval = PL_lex_op;
1175 if (op_type == OP_CONST || op_type == OP_READLINE) {
1176 SV *sv = tokeq(PL_lex_stuff);
1178 if (SvTYPE(sv) == SVt_PVIV) {
1179 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1181 const char *p = SvPV_const(sv, len);
1182 SV * const nsv = newSVpvn(p, len);
1188 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1189 PL_lex_stuff = Nullsv;
1190 /* Allow <FH> // "foo" */
1191 if (op_type == OP_READLINE)
1192 PL_expect = XTERMORDORDOR;
1196 PL_sublex_info.super_state = PL_lex_state;
1197 PL_sublex_info.sub_inwhat = op_type;
1198 PL_sublex_info.sub_op = PL_lex_op;
1199 PL_lex_state = LEX_INTERPPUSH;
1203 yylval.opval = PL_lex_op;
1213 * Create a new scope to save the lexing state. The scope will be
1214 * ended in S_sublex_done. Returns a '(', starting the function arguments
1215 * to the uc, lc, etc. found before.
1216 * Sets PL_lex_state to LEX_INTERPCONCAT.
1225 PL_lex_state = PL_sublex_info.super_state;
1226 SAVEI32(PL_lex_dojoin);
1227 SAVEI32(PL_lex_brackets);
1228 SAVEI32(PL_lex_casemods);
1229 SAVEI32(PL_lex_starts);
1230 SAVEI32(PL_lex_state);
1231 SAVEVPTR(PL_lex_inpat);
1232 SAVEI32(PL_lex_inwhat);
1233 SAVECOPLINE(PL_curcop);
1234 SAVEPPTR(PL_bufptr);
1235 SAVEPPTR(PL_bufend);
1236 SAVEPPTR(PL_oldbufptr);
1237 SAVEPPTR(PL_oldoldbufptr);
1238 SAVEPPTR(PL_last_lop);
1239 SAVEPPTR(PL_last_uni);
1240 SAVEPPTR(PL_linestart);
1241 SAVESPTR(PL_linestr);
1242 SAVEGENERICPV(PL_lex_brackstack);
1243 SAVEGENERICPV(PL_lex_casestack);
1245 PL_linestr = PL_lex_stuff;
1246 PL_lex_stuff = Nullsv;
1248 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1249 = SvPVX(PL_linestr);
1250 PL_bufend += SvCUR(PL_linestr);
1251 PL_last_lop = PL_last_uni = Nullch;
1252 SAVEFREESV(PL_linestr);
1254 PL_lex_dojoin = FALSE;
1255 PL_lex_brackets = 0;
1256 Newx(PL_lex_brackstack, 120, char);
1257 Newx(PL_lex_casestack, 12, char);
1258 PL_lex_casemods = 0;
1259 *PL_lex_casestack = '\0';
1261 PL_lex_state = LEX_INTERPCONCAT;
1262 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1264 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1265 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1266 PL_lex_inpat = PL_sublex_info.sub_op;
1268 PL_lex_inpat = Nullop;
1275 * Restores lexer state after a S_sublex_push.
1282 if (!PL_lex_starts++) {
1283 SV * const sv = newSVpvn("",0);
1284 if (SvUTF8(PL_linestr))
1286 PL_expect = XOPERATOR;
1287 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1291 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1292 PL_lex_state = LEX_INTERPCASEMOD;
1296 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1297 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1298 PL_linestr = PL_lex_repl;
1300 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1301 PL_bufend += SvCUR(PL_linestr);
1302 PL_last_lop = PL_last_uni = Nullch;
1303 SAVEFREESV(PL_linestr);
1304 PL_lex_dojoin = FALSE;
1305 PL_lex_brackets = 0;
1306 PL_lex_casemods = 0;
1307 *PL_lex_casestack = '\0';
1309 if (SvEVALED(PL_lex_repl)) {
1310 PL_lex_state = LEX_INTERPNORMAL;
1312 /* we don't clear PL_lex_repl here, so that we can check later
1313 whether this is an evalled subst; that means we rely on the
1314 logic to ensure sublex_done() is called again only via the
1315 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1318 PL_lex_state = LEX_INTERPCONCAT;
1319 PL_lex_repl = Nullsv;
1325 PL_bufend = SvPVX(PL_linestr);
1326 PL_bufend += SvCUR(PL_linestr);
1327 PL_expect = XOPERATOR;
1328 PL_sublex_info.sub_inwhat = 0;
1336 Extracts a pattern, double-quoted string, or transliteration. This
1339 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1340 processing a pattern (PL_lex_inpat is true), a transliteration
1341 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1343 Returns a pointer to the character scanned up to. Iff this is
1344 advanced from the start pointer supplied (ie if anything was
1345 successfully parsed), will leave an OP for the substring scanned
1346 in yylval. Caller must intuit reason for not parsing further
1347 by looking at the next characters herself.
1351 double-quoted style: \r and \n
1352 regexp special ones: \D \s
1354 backrefs: \1 (deprecated in substitution replacements)
1355 case and quoting: \U \Q \E
1356 stops on @ and $, but not for $ as tail anchor
1358 In transliterations:
1359 characters are VERY literal, except for - not at the start or end
1360 of the string, which indicates a range. scan_const expands the
1361 range to the full set of intermediate characters.
1363 In double-quoted strings:
1365 double-quoted style: \r and \n
1367 backrefs: \1 (deprecated)
1368 case and quoting: \U \Q \E
1371 scan_const does *not* construct ops to handle interpolated strings.
1372 It stops processing as soon as it finds an embedded $ or @ variable
1373 and leaves it to the caller to work out what's going on.
1375 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1377 $ in pattern could be $foo or could be tail anchor. Assumption:
1378 it's a tail anchor if $ is the last thing in the string, or if it's
1379 followed by one of ")| \n\t"
1381 \1 (backreferences) are turned into $1
1383 The structure of the code is
1384 while (there's a character to process) {
1385 handle transliteration ranges
1386 skip regexp comments
1387 skip # initiated comments in //x patterns
1388 check for embedded @foo
1389 check for embedded scalars
1391 leave intact backslashes from leave (below)
1392 deprecate \1 in strings and sub replacements
1393 handle string-changing backslashes \l \U \Q \E, etc.
1394 switch (what was escaped) {
1395 handle - in a transliteration (becomes a literal -)
1396 handle \132 octal characters
1397 handle 0x15 hex characters
1398 handle \cV (control V)
1399 handle printf backslashes (\f, \r, \n, etc)
1401 } (end if backslash)
1402 } (end while character to read)
1407 S_scan_const(pTHX_ char *start)
1409 register char *send = PL_bufend; /* end of the constant */
1410 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1411 register char *s = start; /* start of the constant */
1412 register char *d = SvPVX(sv); /* destination for copies */
1413 bool dorange = FALSE; /* are we in a translit range? */
1414 bool didrange = FALSE; /* did we just finish a range? */
1415 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1416 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1419 UV literal_endpoint = 0;
1422 const char *leaveit = /* set of acceptably-backslashed characters */
1424 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1427 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1428 /* If we are doing a trans and we know we want UTF8 set expectation */
1429 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1430 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1434 while (s < send || dorange) {
1435 /* get transliterations out of the way (they're most literal) */
1436 if (PL_lex_inwhat == OP_TRANS) {
1437 /* expand a range A-Z to the full set of characters. AIE! */
1439 I32 i; /* current expanded character */
1440 I32 min; /* first character in range */
1441 I32 max; /* last character in range */
1444 char * const c = (char*)utf8_hop((U8*)d, -1);
1448 *c = (char)UTF_TO_NATIVE(0xff);
1449 /* mark the range as done, and continue */
1455 i = d - SvPVX_const(sv); /* remember current offset */
1456 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1457 d = SvPVX(sv) + i; /* refresh d after realloc */
1458 d -= 2; /* eat the first char and the - */
1460 min = (U8)*d; /* first char in range */
1461 max = (U8)d[1]; /* last char in range */
1465 "Invalid range \"%c-%c\" in transliteration operator",
1466 (char)min, (char)max);
1470 if (literal_endpoint == 2 &&
1471 ((isLOWER(min) && isLOWER(max)) ||
1472 (isUPPER(min) && isUPPER(max)))) {
1474 for (i = min; i <= max; i++)
1476 *d++ = NATIVE_TO_NEED(has_utf8,i);
1478 for (i = min; i <= max; i++)
1480 *d++ = NATIVE_TO_NEED(has_utf8,i);
1485 for (i = min; i <= max; i++)
1488 /* mark the range as done, and continue */
1492 literal_endpoint = 0;
1497 /* range begins (ignore - as first or last char) */
1498 else if (*s == '-' && s+1 < send && s != start) {
1500 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1503 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1513 literal_endpoint = 0;
1518 /* if we get here, we're not doing a transliteration */
1520 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1521 except for the last char, which will be done separately. */
1522 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1524 while (s+1 < send && *s != ')')
1525 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1527 else if (s[2] == '{' /* This should match regcomp.c */
1528 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1531 char *regparse = s + (s[2] == '{' ? 3 : 4);
1534 while (count && (c = *regparse)) {
1535 if (c == '\\' && regparse[1])
1543 if (*regparse != ')')
1544 regparse--; /* Leave one char for continuation. */
1545 while (s < regparse)
1546 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1550 /* likewise skip #-initiated comments in //x patterns */
1551 else if (*s == '#' && PL_lex_inpat &&
1552 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1553 while (s+1 < send && *s != '\n')
1554 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1557 /* check for embedded arrays
1558 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1560 else if (*s == '@' && s[1]
1561 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1564 /* check for embedded scalars. only stop if we're sure it's a
1567 else if (*s == '$') {
1568 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1570 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1571 break; /* in regexp, $ might be tail anchor */
1574 /* End of else if chain - OP_TRANS rejoin rest */
1577 if (*s == '\\' && s+1 < send) {
1580 /* some backslashes we leave behind */
1581 if (*leaveit && *s && strchr(leaveit, *s)) {
1582 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1583 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1587 /* deprecate \1 in strings and substitution replacements */
1588 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1589 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1591 if (ckWARN(WARN_SYNTAX))
1592 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1597 /* string-change backslash escapes */
1598 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1603 /* if we get here, it's either a quoted -, or a digit */
1606 /* quoted - in transliterations */
1608 if (PL_lex_inwhat == OP_TRANS) {
1618 Perl_warner(aTHX_ packWARN(WARN_MISC),
1619 "Unrecognized escape \\%c passed through",
1621 /* default action is to copy the quoted character */
1622 goto default_action;
1625 /* \132 indicates an octal constant */
1626 case '0': case '1': case '2': case '3':
1627 case '4': case '5': case '6': case '7':
1631 uv = grok_oct(s, &len, &flags, NULL);
1634 goto NUM_ESCAPE_INSERT;
1636 /* \x24 indicates a hex constant */
1640 char* const e = strchr(s, '}');
1641 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1642 PERL_SCAN_DISALLOW_PREFIX;
1647 yyerror("Missing right brace on \\x{}");
1651 uv = grok_hex(s, &len, &flags, NULL);
1657 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1658 uv = grok_hex(s, &len, &flags, NULL);
1664 /* Insert oct or hex escaped character.
1665 * There will always enough room in sv since such
1666 * escapes will be longer than any UTF-8 sequence
1667 * they can end up as. */
1669 /* We need to map to chars to ASCII before doing the tests
1672 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1673 if (!has_utf8 && uv > 255) {
1674 /* Might need to recode whatever we have
1675 * accumulated so far if it contains any
1678 * (Can't we keep track of that and avoid
1679 * this rescan? --jhi)
1683 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1684 if (!NATIVE_IS_INVARIANT(*c)) {
1689 const STRLEN offset = d - SvPVX_const(sv);
1691 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1695 while (src >= (const U8 *)SvPVX_const(sv)) {
1696 if (!NATIVE_IS_INVARIANT(*src)) {
1697 const U8 ch = NATIVE_TO_ASCII(*src);
1698 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1699 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1709 if (has_utf8 || uv > 255) {
1710 d = (char*)uvchr_to_utf8((U8*)d, uv);
1712 if (PL_lex_inwhat == OP_TRANS &&
1713 PL_sublex_info.sub_op) {
1714 PL_sublex_info.sub_op->op_private |=
1715 (PL_lex_repl ? OPpTRANS_FROM_UTF
1728 /* \N{LATIN SMALL LETTER A} is a named character */
1732 char* e = strchr(s, '}');
1738 yyerror("Missing right brace on \\N{}");
1742 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1744 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1745 PERL_SCAN_DISALLOW_PREFIX;
1748 uv = grok_hex(s, &len, &flags, NULL);
1750 goto NUM_ESCAPE_INSERT;
1752 res = newSVpvn(s + 1, e - s - 1);
1753 res = new_constant( Nullch, 0, "charnames",
1754 res, Nullsv, "\\N{...}" );
1756 sv_utf8_upgrade(res);
1757 str = SvPV_const(res,len);
1758 #ifdef EBCDIC_NEVER_MIND
1759 /* charnames uses pack U and that has been
1760 * recently changed to do the below uni->native
1761 * mapping, so this would be redundant (and wrong,
1762 * the code point would be doubly converted).
1763 * But leave this in just in case the pack U change
1764 * gets revoked, but the semantics is still
1765 * desireable for charnames. --jhi */
1767 UV uv = utf8_to_uvchr((const U8*)str, 0);
1770 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1772 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1773 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1774 str = SvPV_const(res, len);
1778 if (!has_utf8 && SvUTF8(res)) {
1779 const char * const ostart = SvPVX_const(sv);
1780 SvCUR_set(sv, d - ostart);
1783 sv_utf8_upgrade(sv);
1784 /* this just broke our allocation above... */
1785 SvGROW(sv, (STRLEN)(send - start));
1786 d = SvPVX(sv) + SvCUR(sv);
1789 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1790 const char * const odest = SvPVX_const(sv);
1792 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1793 d = SvPVX(sv) + (d - odest);
1795 Copy(str, d, len, char);
1802 yyerror("Missing braces on \\N{}");
1805 /* \c is a control character */
1814 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1817 yyerror("Missing control char name in \\c");
1821 /* printf-style backslashes, formfeeds, newlines, etc */
1823 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1826 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1829 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1832 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1835 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1838 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1841 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1847 } /* end if (backslash) */
1854 /* If we started with encoded form, or already know we want it
1855 and then encode the next character */
1856 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1858 const UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1859 const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1862 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1863 const STRLEN off = d - SvPVX_const(sv);
1864 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1866 d = (char*)uvchr_to_utf8((U8*)d, uv);
1870 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1872 } /* while loop to process each character */
1874 /* terminate the string and set up the sv */
1876 SvCUR_set(sv, d - SvPVX_const(sv));
1877 if (SvCUR(sv) >= SvLEN(sv))
1878 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1881 if (PL_encoding && !has_utf8) {
1882 sv_recode_to_utf8(sv, PL_encoding);
1888 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1889 PL_sublex_info.sub_op->op_private |=
1890 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1894 /* shrink the sv if we allocated more than we used */
1895 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1896 SvPV_shrink_to_cur(sv);
1899 /* return the substring (via yylval) only if we parsed anything */
1900 if (s > PL_bufptr) {
1901 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1902 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1904 ( PL_lex_inwhat == OP_TRANS
1906 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1909 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1916 * Returns TRUE if there's more to the expression (e.g., a subscript),
1919 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1921 * ->[ and ->{ return TRUE
1922 * { and [ outside a pattern are always subscripts, so return TRUE
1923 * if we're outside a pattern and it's not { or [, then return FALSE
1924 * if we're in a pattern and the first char is a {
1925 * {4,5} (any digits around the comma) returns FALSE
1926 * if we're in a pattern and the first char is a [
1928 * [SOMETHING] has a funky algorithm to decide whether it's a
1929 * character class or not. It has to deal with things like
1930 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1931 * anything else returns TRUE
1934 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1937 S_intuit_more(pTHX_ register char *s)
1939 if (PL_lex_brackets)
1941 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1943 if (*s != '{' && *s != '[')
1948 /* In a pattern, so maybe we have {n,m}. */
1965 /* On the other hand, maybe we have a character class */
1968 if (*s == ']' || *s == '^')
1971 /* this is terrifying, and it works */
1972 int weight = 2; /* let's weigh the evidence */
1974 unsigned char un_char = 255, last_un_char;
1975 const char * const send = strchr(s,']');
1976 char tmpbuf[sizeof PL_tokenbuf * 4];
1978 if (!send) /* has to be an expression */
1981 Zero(seen,256,char);
1984 else if (isDIGIT(*s)) {
1986 if (isDIGIT(s[1]) && s[2] == ']')
1992 for (; s < send; s++) {
1993 last_un_char = un_char;
1994 un_char = (unsigned char)*s;
1999 weight -= seen[un_char] * 10;
2000 if (isALNUM_lazy_if(s+1,UTF)) {
2001 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2002 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
2007 else if (*s == '$' && s[1] &&
2008 strchr("[#!%*<>()-=",s[1])) {
2009 if (/*{*/ strchr("])} =",s[2]))
2018 if (strchr("wds]",s[1]))
2020 else if (seen['\''] || seen['"'])
2022 else if (strchr("rnftbxcav",s[1]))
2024 else if (isDIGIT(s[1])) {
2026 while (s[1] && isDIGIT(s[1]))
2036 if (strchr("aA01! ",last_un_char))
2038 if (strchr("zZ79~",s[1]))
2040 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2041 weight -= 5; /* cope with negative subscript */
2044 if (!isALNUM(last_un_char)
2045 && !(last_un_char == '$' || last_un_char == '@'
2046 || last_un_char == '&')
2047 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2052 if (keyword(tmpbuf, d - tmpbuf))
2055 if (un_char == last_un_char + 1)
2057 weight -= seen[un_char];
2062 if (weight >= 0) /* probably a character class */
2072 * Does all the checking to disambiguate
2074 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2075 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2077 * First argument is the stuff after the first token, e.g. "bar".
2079 * Not a method if bar is a filehandle.
2080 * Not a method if foo is a subroutine prototyped to take a filehandle.
2081 * Not a method if it's really "Foo $bar"
2082 * Method if it's "foo $bar"
2083 * Not a method if it's really "print foo $bar"
2084 * Method if it's really "foo package::" (interpreted as package->foo)
2085 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2086 * Not a method if bar is a filehandle or package, but is quoted with
2091 S_intuit_method(pTHX_ char *start, GV *gv)
2093 char *s = start + (*start == '$');
2094 char tmpbuf[sizeof PL_tokenbuf];
2102 if ((cv = GvCVu(gv))) {
2103 const char *proto = SvPVX_const(cv);
2113 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2114 /* start is the beginning of the possible filehandle/object,
2115 * and s is the end of it
2116 * tmpbuf is a copy of it
2119 if (*start == '$') {
2120 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2125 return *s == '(' ? FUNCMETH : METHOD;
2127 if (!keyword(tmpbuf, len)) {
2128 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2133 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2134 if (indirgv && GvCVu(indirgv))
2136 /* filehandle or package name makes it a method */
2137 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2139 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2140 return 0; /* no assumptions -- "=>" quotes bearword */
2142 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2143 newSVpvn(tmpbuf,len));
2144 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2148 return *s == '(' ? FUNCMETH : METHOD;
2156 * Return a string of Perl code to load the debugger. If PERL5DB
2157 * is set, it will return the contents of that, otherwise a
2158 * compile-time require of perl5db.pl.
2165 const char * const pdb = PerlEnv_getenv("PERL5DB");
2169 SETERRNO(0,SS_NORMAL);
2170 return "BEGIN { require 'perl5db.pl' }";
2176 /* Encoded script support. filter_add() effectively inserts a
2177 * 'pre-processing' function into the current source input stream.
2178 * Note that the filter function only applies to the current source file
2179 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2181 * The datasv parameter (which may be NULL) can be used to pass
2182 * private data to this instance of the filter. The filter function
2183 * can recover the SV using the FILTER_DATA macro and use it to
2184 * store private buffers and state information.
2186 * The supplied datasv parameter is upgraded to a PVIO type
2187 * and the IoDIRP/IoANY field is used to store the function pointer,
2188 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2189 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2190 * private use must be set using malloc'd pointers.
2194 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2199 if (!PL_rsfp_filters)
2200 PL_rsfp_filters = newAV();
2202 datasv = NEWSV(255,0);
2203 SvUPGRADE(datasv, SVt_PVIO);
2204 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2205 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2206 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2207 IoANY(datasv), SvPV_nolen(datasv)));
2208 av_unshift(PL_rsfp_filters, 1);
2209 av_store(PL_rsfp_filters, 0, datasv) ;
2214 /* Delete most recently added instance of this filter function. */
2216 Perl_filter_del(pTHX_ filter_t funcp)
2221 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
2223 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2225 /* if filter is on top of stack (usual case) just pop it off */
2226 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2227 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2228 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2229 IoANY(datasv) = (void *)NULL;
2230 sv_free(av_pop(PL_rsfp_filters));
2234 /* we need to search for the correct entry and clear it */
2235 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2239 /* Invoke the idxth filter function for the current rsfp. */
2240 /* maxlen 0 = read one text line */
2242 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2247 if (!PL_rsfp_filters)
2249 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2250 /* Provide a default input filter to make life easy. */
2251 /* Note that we append to the line. This is handy. */
2252 DEBUG_P(PerlIO_printf(Perl_debug_log,
2253 "filter_read %d: from rsfp\n", idx));
2257 const int old_len = SvCUR(buf_sv);
2259 /* ensure buf_sv is large enough */
2260 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2261 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2262 if (PerlIO_error(PL_rsfp))
2263 return -1; /* error */
2265 return 0 ; /* end of file */
2267 SvCUR_set(buf_sv, old_len + len) ;
2270 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2271 if (PerlIO_error(PL_rsfp))
2272 return -1; /* error */
2274 return 0 ; /* end of file */
2277 return SvCUR(buf_sv);
2279 /* Skip this filter slot if filter has been deleted */
2280 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2281 DEBUG_P(PerlIO_printf(Perl_debug_log,
2282 "filter_read %d: skipped (filter deleted)\n",
2284 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2286 /* Get function pointer hidden within datasv */
2287 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2288 DEBUG_P(PerlIO_printf(Perl_debug_log,
2289 "filter_read %d: via function %p (%s)\n",
2290 idx, datasv, SvPV_nolen_const(datasv)));
2291 /* Call function. The function is expected to */
2292 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2293 /* Return: <0:error, =0:eof, >0:not eof */
2294 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2298 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2300 #ifdef PERL_CR_FILTER
2301 if (!PL_rsfp_filters) {
2302 filter_add(S_cr_textfilter,NULL);
2305 if (PL_rsfp_filters) {
2307 SvCUR_set(sv, 0); /* start with empty line */
2308 if (FILTER_READ(0, sv, 0) > 0)
2309 return ( SvPVX(sv) ) ;
2314 return (sv_gets(sv, fp, append));
2318 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2322 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2326 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2327 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2329 return GvHV(gv); /* Foo:: */
2332 /* use constant CLASS => 'MyClass' */
2333 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2335 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2336 pkgname = SvPV_nolen_const(sv);
2340 return gv_stashpv(pkgname, FALSE);
2344 S_tokenize_use(pTHX_ int is_use, char *s) {
2345 if (PL_expect != XSTATE)
2346 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2347 is_use ? "use" : "no"));
2349 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2350 s = force_version(s, TRUE);
2351 if (*s == ';' || (s = skipspace(s), *s == ';')) {
2352 PL_nextval[PL_nexttoke].opval = Nullop;
2355 else if (*s == 'v') {
2356 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2357 s = force_version(s, FALSE);
2361 s = force_word(s,WORD,FALSE,TRUE,FALSE);
2362 s = force_version(s, FALSE);
2364 yylval.ival = is_use;
2368 static const char* const exp_name[] =
2369 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2370 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2377 Works out what to call the token just pulled out of the input
2378 stream. The yacc parser takes care of taking the ops we return and
2379 stitching them into a tree.
2385 if read an identifier
2386 if we're in a my declaration
2387 croak if they tried to say my($foo::bar)
2388 build the ops for a my() declaration
2389 if it's an access to a my() variable
2390 are we in a sort block?
2391 croak if my($a); $a <=> $b
2392 build ops for access to a my() variable
2393 if in a dq string, and they've said @foo and we can't find @foo
2395 build ops for a bareword
2396 if we already built the token before, use it.
2401 #pragma segment Perl_yylex
2406 register char *s = PL_bufptr;
2413 I32 orig_keyword = 0;
2416 SV* tmp = newSVpvn("", 0);
2417 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
2418 (IV)CopLINE(PL_curcop),
2419 lex_state_names[PL_lex_state],
2420 exp_name[PL_expect],
2421 pv_display(tmp, s, strlen(s), 0, 60));
2424 /* check if there's an identifier for us to look at */
2425 if (PL_pending_ident)
2426 return REPORT(S_pending_ident(aTHX));
2428 /* no identifier pending identification */
2430 switch (PL_lex_state) {
2432 case LEX_NORMAL: /* Some compilers will produce faster */
2433 case LEX_INTERPNORMAL: /* code if we comment these out. */
2437 /* when we've already built the next token, just pull it out of the queue */
2440 yylval = PL_nextval[PL_nexttoke];
2442 PL_lex_state = PL_lex_defer;
2443 PL_expect = PL_lex_expect;
2444 PL_lex_defer = LEX_NORMAL;
2446 return REPORT(PL_nexttype[PL_nexttoke]);
2448 /* interpolated case modifiers like \L \U, including \Q and \E.
2449 when we get here, PL_bufptr is at the \
2451 case LEX_INTERPCASEMOD:
2453 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2454 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2456 /* handle \E or end of string */
2457 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2459 if (PL_lex_casemods) {
2460 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
2461 PL_lex_casestack[PL_lex_casemods] = '\0';
2463 if (PL_bufptr != PL_bufend
2464 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2466 PL_lex_state = LEX_INTERPCONCAT;
2470 if (PL_bufptr != PL_bufend)
2472 PL_lex_state = LEX_INTERPCONCAT;
2476 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2477 "### Saw case modifier\n"); });
2479 if (s[1] == '\\' && s[2] == 'E') {
2481 PL_lex_state = LEX_INTERPCONCAT;
2485 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2486 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2487 if ((*s == 'L' || *s == 'U') &&
2488 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2489 PL_lex_casestack[--PL_lex_casemods] = '\0';
2492 if (PL_lex_casemods > 10)
2493 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2494 PL_lex_casestack[PL_lex_casemods++] = *s;
2495 PL_lex_casestack[PL_lex_casemods] = '\0';
2496 PL_lex_state = LEX_INTERPCONCAT;
2497 PL_nextval[PL_nexttoke].ival = 0;
2500 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2502 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2504 PL_nextval[PL_nexttoke].ival = OP_LC;
2506 PL_nextval[PL_nexttoke].ival = OP_UC;
2508 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2510 Perl_croak(aTHX_ "panic: yylex");
2514 if (PL_lex_starts) {
2517 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2518 if (PL_lex_casemods == 1 && PL_lex_inpat)
2527 case LEX_INTERPPUSH:
2528 return REPORT(sublex_push());
2530 case LEX_INTERPSTART:
2531 if (PL_bufptr == PL_bufend)
2532 return REPORT(sublex_done());
2533 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2534 "### Interpolated variable\n"); });
2536 PL_lex_dojoin = (*PL_bufptr == '@');
2537 PL_lex_state = LEX_INTERPNORMAL;
2538 if (PL_lex_dojoin) {
2539 PL_nextval[PL_nexttoke].ival = 0;
2541 force_ident("\"", '$');
2542 PL_nextval[PL_nexttoke].ival = 0;
2544 PL_nextval[PL_nexttoke].ival = 0;
2546 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2549 if (PL_lex_starts++) {
2551 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2552 if (!PL_lex_casemods && PL_lex_inpat)
2559 case LEX_INTERPENDMAYBE:
2560 if (intuit_more(PL_bufptr)) {
2561 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2567 if (PL_lex_dojoin) {
2568 PL_lex_dojoin = FALSE;
2569 PL_lex_state = LEX_INTERPCONCAT;
2572 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2573 && SvEVALED(PL_lex_repl))
2575 if (PL_bufptr != PL_bufend)
2576 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2577 PL_lex_repl = Nullsv;
2580 case LEX_INTERPCONCAT:
2582 if (PL_lex_brackets)
2583 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2585 if (PL_bufptr == PL_bufend)
2586 return REPORT(sublex_done());
2588 if (SvIVX(PL_linestr) == '\'') {
2589 SV *sv = newSVsv(PL_linestr);
2592 else if ( PL_hints & HINT_NEW_RE )
2593 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2594 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2598 s = scan_const(PL_bufptr);
2600 PL_lex_state = LEX_INTERPCASEMOD;
2602 PL_lex_state = LEX_INTERPSTART;
2605 if (s != PL_bufptr) {
2606 PL_nextval[PL_nexttoke] = yylval;
2609 if (PL_lex_starts++) {
2610 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2611 if (!PL_lex_casemods && PL_lex_inpat)
2624 PL_lex_state = LEX_NORMAL;
2625 s = scan_formline(PL_bufptr);
2626 if (!PL_lex_formbrack)
2632 PL_oldoldbufptr = PL_oldbufptr;
2638 if (isIDFIRST_lazy_if(s,UTF))
2640 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2643 goto fake_eof; /* emulate EOF on ^D or ^Z */
2648 if (PL_lex_brackets) {
2649 yyerror(PL_lex_formbrack
2650 ? "Format not terminated"
2651 : "Missing right curly or square bracket");
2653 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2654 "### Tokener got EOF\n");
2658 if (s++ < PL_bufend)
2659 goto retry; /* ignore stray nulls */
2662 if (!PL_in_eval && !PL_preambled) {
2663 PL_preambled = TRUE;
2664 sv_setpv(PL_linestr,incl_perldb());
2665 if (SvCUR(PL_linestr))
2666 sv_catpvn(PL_linestr,";", 1);
2668 while(AvFILLp(PL_preambleav) >= 0) {
2669 SV *tmpsv = av_shift(PL_preambleav);
2670 sv_catsv(PL_linestr, tmpsv);
2671 sv_catpvn(PL_linestr, ";", 1);
2674 sv_free((SV*)PL_preambleav);
2675 PL_preambleav = NULL;
2677 if (PL_minus_n || PL_minus_p) {
2678 sv_catpv(PL_linestr, "LINE: while (<>) {");
2680 sv_catpv(PL_linestr,"chomp;");
2683 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2684 || *PL_splitstr == '"')
2685 && strchr(PL_splitstr + 1, *PL_splitstr))
2686 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2688 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2689 bytes can be used as quoting characters. :-) */
2690 /* The count here deliberately includes the NUL
2691 that terminates the C string constant. This
2692 embeds the opening NUL into the string. */
2693 const char *splits = PL_splitstr;
2694 sv_catpvn(PL_linestr, "our @F=split(q", 15);
2697 if (*splits == '\\')
2698 sv_catpvn(PL_linestr, splits, 1);
2699 sv_catpvn(PL_linestr, splits, 1);
2700 } while (*splits++);
2701 /* This loop will embed the trailing NUL of
2702 PL_linestr as the last thing it does before
2704 sv_catpvn(PL_linestr, ");", 2);
2708 sv_catpv(PL_linestr,"our @F=split(' ');");
2711 sv_catpvn(PL_linestr, "\n", 1);
2712 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2713 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2714 PL_last_lop = PL_last_uni = Nullch;
2715 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2716 SV * const sv = NEWSV(85,0);
2718 sv_upgrade(sv, SVt_PVMG);
2719 sv_setsv(sv,PL_linestr);
2722 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2727 bof = PL_rsfp ? TRUE : FALSE;
2728 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2731 if (PL_preprocess && !PL_in_eval)
2732 (void)PerlProc_pclose(PL_rsfp);
2733 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2734 PerlIO_clearerr(PL_rsfp);
2736 (void)PerlIO_close(PL_rsfp);
2738 PL_doextract = FALSE;
2740 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2741 sv_setpv(PL_linestr,PL_minus_p
2742 ? ";}continue{print;}" : ";}");
2743 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2744 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2745 PL_last_lop = PL_last_uni = Nullch;
2746 PL_minus_n = PL_minus_p = 0;
2749 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2750 PL_last_lop = PL_last_uni = Nullch;
2751 sv_setpvn(PL_linestr,"",0);
2752 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2754 /* If it looks like the start of a BOM or raw UTF-16,
2755 * check if it in fact is. */
2761 #ifdef PERLIO_IS_STDIO
2762 # ifdef __GNU_LIBRARY__
2763 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2764 # define FTELL_FOR_PIPE_IS_BROKEN
2768 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2769 # define FTELL_FOR_PIPE_IS_BROKEN
2774 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2775 /* This loses the possibility to detect the bof
2776 * situation on perl -P when the libc5 is being used.
2777 * Workaround? Maybe attach some extra state to PL_rsfp?
2780 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2782 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2785 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2786 s = swallow_bom((U8*)s);
2790 /* Incest with pod. */
2791 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2792 sv_setpvn(PL_linestr, "", 0);
2793 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2794 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2795 PL_last_lop = PL_last_uni = Nullch;
2796 PL_doextract = FALSE;
2800 } while (PL_doextract);
2801 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2802 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2803 SV * const sv = NEWSV(85,0);
2805 sv_upgrade(sv, SVt_PVMG);
2806 sv_setsv(sv,PL_linestr);
2809 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2811 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2812 PL_last_lop = PL_last_uni = Nullch;
2813 if (CopLINE(PL_curcop) == 1) {
2814 while (s < PL_bufend && isSPACE(*s))
2816 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2820 if (*s == '#' && *(s+1) == '!')
2822 #ifdef ALTERNATE_SHEBANG
2824 static char const as[] = ALTERNATE_SHEBANG;
2825 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2826 d = s + (sizeof(as) - 1);
2828 #endif /* ALTERNATE_SHEBANG */
2837 while (*d && !isSPACE(*d))
2841 #ifdef ARG_ZERO_IS_SCRIPT
2842 if (ipathend > ipath) {
2844 * HP-UX (at least) sets argv[0] to the script name,
2845 * which makes $^X incorrect. And Digital UNIX and Linux,
2846 * at least, set argv[0] to the basename of the Perl
2847 * interpreter. So, having found "#!", we'll set it right.
2849 SV * const x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2850 assert(SvPOK(x) || SvGMAGICAL(x));
2851 if (sv_eq(x, CopFILESV(PL_curcop))) {
2852 sv_setpvn(x, ipath, ipathend - ipath);
2858 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
2859 const char * const lstart = SvPV_const(x,llen);
2861 bstart += blen - llen;
2862 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2863 sv_setpvn(x, ipath, ipathend - ipath);
2868 TAINT_NOT; /* $^X is always tainted, but that's OK */
2870 #endif /* ARG_ZERO_IS_SCRIPT */
2875 d = instr(s,"perl -");
2877 d = instr(s,"perl");
2879 /* avoid getting into infinite loops when shebang
2880 * line contains "Perl" rather than "perl" */
2882 for (d = ipathend-4; d >= ipath; --d) {
2883 if ((*d == 'p' || *d == 'P')
2884 && !ibcmp(d, "perl", 4))
2894 #ifdef ALTERNATE_SHEBANG
2896 * If the ALTERNATE_SHEBANG on this system starts with a
2897 * character that can be part of a Perl expression, then if
2898 * we see it but not "perl", we're probably looking at the
2899 * start of Perl code, not a request to hand off to some
2900 * other interpreter. Similarly, if "perl" is there, but
2901 * not in the first 'word' of the line, we assume the line
2902 * contains the start of the Perl program.
2904 if (d && *s != '#') {
2905 const char *c = ipath;
2906 while (*c && !strchr("; \t\r\n\f\v#", *c))
2909 d = Nullch; /* "perl" not in first word; ignore */
2911 *s = '#'; /* Don't try to parse shebang line */
2913 #endif /* ALTERNATE_SHEBANG */
2914 #ifndef MACOS_TRADITIONAL
2919 !instr(s,"indir") &&
2920 instr(PL_origargv[0],"perl"))
2927 while (s < PL_bufend && isSPACE(*s))
2929 if (s < PL_bufend) {
2930 Newxz(newargv,PL_origargc+3,char*);
2932 while (s < PL_bufend && !isSPACE(*s))
2935 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2938 newargv = PL_origargv;
2941 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2943 Perl_croak(aTHX_ "Can't exec %s", ipath);
2947 const U32 oldpdb = PL_perldb;
2948 const bool oldn = PL_minus_n;
2949 const bool oldp = PL_minus_p;
2951 while (*d && !isSPACE(*d)) d++;
2952 while (SPACE_OR_TAB(*d)) d++;
2955 const bool switches_done = PL_doswitches;
2957 if (*d == 'M' || *d == 'm' || *d == 'C') {
2958 const char * const m = d;
2959 while (*d && !isSPACE(*d)) d++;
2960 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2963 d = moreswitches(d);
2965 if (PL_doswitches && !switches_done) {
2966 int argc = PL_origargc;
2967 char **argv = PL_origargv;
2970 } while (argc && argv[0][0] == '-' && argv[0][1]);
2971 init_argv_symbols(argc,argv);
2973 if ((PERLDB_LINE && !oldpdb) ||
2974 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2975 /* if we have already added "LINE: while (<>) {",
2976 we must not do it again */
2978 sv_setpvn(PL_linestr, "", 0);
2979 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2980 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2981 PL_last_lop = PL_last_uni = Nullch;
2982 PL_preambled = FALSE;
2984 (void)gv_fetchfile(PL_origfilename);
2987 if (PL_doswitches && !switches_done) {
2988 int argc = PL_origargc;
2989 char **argv = PL_origargv;
2992 } while (argc && argv[0][0] == '-' && argv[0][1]);
2993 init_argv_symbols(argc,argv);
2999 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3001 PL_lex_state = LEX_FORMLINE;
3006 #ifdef PERL_STRICT_CR
3007 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3009 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3011 case ' ': case '\t': case '\f': case 013:
3012 #ifdef MACOS_TRADITIONAL
3019 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3020 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3021 /* handle eval qq[#line 1 "foo"\n ...] */
3022 CopLINE_dec(PL_curcop);
3026 while (s < d && *s != '\n')
3030 else if (s > d) /* Found by Ilya: feed random input to Perl. */
3031 Perl_croak(aTHX_ "panic: input overflow");
3033 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3035 PL_lex_state = LEX_FORMLINE;
3045 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3052 while (s < PL_bufend && SPACE_OR_TAB(*s))
3055 if (strnEQ(s,"=>",2)) {
3056 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3057 DEBUG_T( { S_printbuf(aTHX_
3058 "### Saw unary minus before =>, forcing word %s\n", s);
3060 OPERATOR('-'); /* unary minus */
3062 PL_last_uni = PL_oldbufptr;
3064 case 'r': ftst = OP_FTEREAD; break;
3065 case 'w': ftst = OP_FTEWRITE; break;
3066 case 'x': ftst = OP_FTEEXEC; break;
3067 case 'o': ftst = OP_FTEOWNED; break;
3068 case 'R': ftst = OP_FTRREAD; break;
3069 case 'W': ftst = OP_FTRWRITE; break;
3070 case 'X': ftst = OP_FTREXEC; break;
3071 case 'O': ftst = OP_FTROWNED; break;
3072 case 'e': ftst = OP_FTIS; break;
3073 case 'z': ftst = OP_FTZERO; break;
3074 case 's': ftst = OP_FTSIZE; break;
3075 case 'f': ftst = OP_FTFILE; break;
3076 case 'd': ftst = OP_FTDIR; break;
3077 case 'l': ftst = OP_FTLINK; break;
3078 case 'p': ftst = OP_FTPIPE; break;
3079 case 'S': ftst = OP_FTSOCK; break;
3080 case 'u': ftst = OP_FTSUID; break;
3081 case 'g': ftst = OP_FTSGID; break;
3082 case 'k': ftst = OP_FTSVTX; break;
3083 case 'b': ftst = OP_FTBLK; break;
3084 case 'c': ftst = OP_FTCHR; break;
3085 case 't': ftst = OP_FTTTY; break;
3086 case 'T': ftst = OP_FTTEXT; break;
3087 case 'B': ftst = OP_FTBINARY; break;
3088 case 'M': case 'A': case 'C':
3089 gv_fetchpv("\024",TRUE, SVt_PV);
3091 case 'M': ftst = OP_FTMTIME; break;
3092 case 'A': ftst = OP_FTATIME; break;
3093 case 'C': ftst = OP_FTCTIME; break;
3101 PL_last_lop_op = (OPCODE)ftst;
3102 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3103 "### Saw file test %c\n", (int)tmp);
3108 /* Assume it was a minus followed by a one-letter named
3109 * subroutine call (or a -bareword), then. */
3110 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3111 "### '-%c' looked like a file test but was not\n",
3120 if (PL_expect == XOPERATOR)
3125 else if (*s == '>') {
3128 if (isIDFIRST_lazy_if(s,UTF)) {
3129 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3137 if (PL_expect == XOPERATOR)
3140 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3142 OPERATOR('-'); /* unary minus */
3149 if (PL_expect == XOPERATOR)
3154 if (PL_expect == XOPERATOR)
3157 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3163 if (PL_expect != XOPERATOR) {
3164 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3165 PL_expect = XOPERATOR;
3166 force_ident(PL_tokenbuf, '*');
3179 if (PL_expect == XOPERATOR) {
3183 PL_tokenbuf[0] = '%';
3184 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3185 if (!PL_tokenbuf[1]) {
3188 PL_pending_ident = '%';
3207 switch (PL_expect) {
3210 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3212 PL_bufptr = s; /* update in case we back off */
3218 PL_expect = XTERMBLOCK;
3222 while (isIDFIRST_lazy_if(s,UTF)) {
3223 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3224 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3225 if (tmp < 0) tmp = -tmp;
3241 d = scan_str(d,TRUE,TRUE);
3243 /* MUST advance bufptr here to avoid bogus
3244 "at end of line" context messages from yyerror().
3246 PL_bufptr = s + len;
3247 yyerror("Unterminated attribute parameter in attribute list");
3250 return REPORT(0); /* EOF indicator */
3254 SV *sv = newSVpvn(s, len);
3255 sv_catsv(sv, PL_lex_stuff);
3256 attrs = append_elem(OP_LIST, attrs,
3257 newSVOP(OP_CONST, 0, sv));
3258 SvREFCNT_dec(PL_lex_stuff);
3259 PL_lex_stuff = Nullsv;
3262 if (len == 6 && strnEQ(s, "unique", len)) {
3263 if (PL_in_my == KEY_our)
3265 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3267 ; /* skip to avoid loading attributes.pm */
3270 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3273 /* NOTE: any CV attrs applied here need to be part of
3274 the CVf_BUILTIN_ATTRS define in cv.h! */
3275 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3276 CvLVALUE_on(PL_compcv);
3277 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3278 CvLOCKED_on(PL_compcv);
3279 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3280 CvMETHOD_on(PL_compcv);
3281 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3282 CvASSERTION_on(PL_compcv);
3283 /* After we've set the flags, it could be argued that
3284 we don't need to do the attributes.pm-based setting
3285 process, and shouldn't bother appending recognized
3286 flags. To experiment with that, uncomment the
3287 following "else". (Note that's already been
3288 uncommented. That keeps the above-applied built-in
3289 attributes from being intercepted (and possibly
3290 rejected) by a package's attribute routines, but is
3291 justified by the performance win for the common case
3292 of applying only built-in attributes.) */
3294 attrs = append_elem(OP_LIST, attrs,
3295 newSVOP(OP_CONST, 0,
3299 if (*s == ':' && s[1] != ':')
3302 break; /* require real whitespace or :'s */
3304 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3305 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3306 const char q = ((*s == '\'') ? '"' : '\'');
3307 /* If here for an expression, and parsed no attrs, back off. */
3308 if (tmp == '=' && !attrs) {
3312 /* MUST advance bufptr here to avoid bogus "at end of line"
3313 context messages from yyerror().
3317 ? Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list", q, *s, q)
3318 : "Unterminated attribute list" );
3325 PL_nextval[PL_nexttoke].opval = attrs;
3333 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3334 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3351 if (PL_lex_brackets <= 0)
3352 yyerror("Unmatched right square bracket");
3355 if (PL_lex_state == LEX_INTERPNORMAL) {
3356 if (PL_lex_brackets == 0) {
3357 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3358 PL_lex_state = LEX_INTERPEND;
3365 if (PL_lex_brackets > 100) {
3366 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3368 switch (PL_expect) {
3370 if (PL_lex_formbrack) {
3374 if (PL_oldoldbufptr == PL_last_lop)
3375 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3377 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3378 OPERATOR(HASHBRACK);
3380 while (s < PL_bufend && SPACE_OR_TAB(*s))
3383 PL_tokenbuf[0] = '\0';
3384 if (d < PL_bufend && *d == '-') {
3385 PL_tokenbuf[0] = '-';
3387 while (d < PL_bufend && SPACE_OR_TAB(*d))
3390 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3391 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3393 while (d < PL_bufend && SPACE_OR_TAB(*d))
3396 const char minus = (PL_tokenbuf[0] == '-');
3397 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3405 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3410 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3415 if (PL_oldoldbufptr == PL_last_lop)
3416 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3418 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3421 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3423 /* This hack is to get the ${} in the message. */
3425 yyerror("syntax error");
3428 OPERATOR(HASHBRACK);
3430 /* This hack serves to disambiguate a pair of curlies
3431 * as being a block or an anon hash. Normally, expectation
3432 * determines that, but in cases where we're not in a
3433 * position to expect anything in particular (like inside
3434 * eval"") we have to resolve the ambiguity. This code
3435 * covers the case where the first term in the curlies is a
3436 * quoted string. Most other cases need to be explicitly
3437 * disambiguated by prepending a "+" before the opening
3438 * curly in order to force resolution as an anon hash.
3440 * XXX should probably propagate the outer expectation
3441 * into eval"" to rely less on this hack, but that could
3442 * potentially break current behavior of eval"".
3446 if (*s == '\'' || *s == '"' || *s == '`') {
3447 /* common case: get past first string, handling escapes */
3448 for (t++; t < PL_bufend && *t != *s;)
3449 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3453 else if (*s == 'q') {
3456 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3459 /* skip q//-like construct */
3461 char open, close, term;
3464 while (t < PL_bufend && isSPACE(*t))
3466 /* check for q => */
3467 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3468 OPERATOR(HASHBRACK);
3472 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3476 for (t++; t < PL_bufend; t++) {
3477 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3479 else if (*t == open)
3483 for (t++; t < PL_bufend; t++) {
3484 if (*t == '\\' && t+1 < PL_bufend)
3486 else if (*t == close && --brackets <= 0)
3488 else if (*t == open)
3495 /* skip plain q word */
3496 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3499 else if (isALNUM_lazy_if(t,UTF)) {
3501 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3504 while (t < PL_bufend && isSPACE(*t))
3506 /* if comma follows first term, call it an anon hash */
3507 /* XXX it could be a comma expression with loop modifiers */
3508 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3509 || (*t == '=' && t[1] == '>')))
3510 OPERATOR(HASHBRACK);
3511 if (PL_expect == XREF)
3514 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3520 yylval.ival = CopLINE(PL_curcop);
3521 if (isSPACE(*s) || *s == '#')
3522 PL_copline = NOLINE; /* invalidate current command line number */
3527 if (PL_lex_brackets <= 0)
3528 yyerror("Unmatched right curly bracket");
3530 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3531 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3532 PL_lex_formbrack = 0;
3533 if (PL_lex_state == LEX_INTERPNORMAL) {
3534 if (PL_lex_brackets == 0) {
3535 if (PL_expect & XFAKEBRACK) {
3536 PL_expect &= XENUMMASK;
3537 PL_lex_state = LEX_INTERPEND;
3539 return yylex(); /* ignore fake brackets */
3541 if (*s == '-' && s[1] == '>')
3542 PL_lex_state = LEX_INTERPENDMAYBE;
3543 else if (*s != '[' && *s != '{')
3544 PL_lex_state = LEX_INTERPEND;
3547 if (PL_expect & XFAKEBRACK) {
3548 PL_expect &= XENUMMASK;
3550 return yylex(); /* ignore fake brackets */
3560 if (PL_expect == XOPERATOR) {
3561 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
3562 && isIDFIRST_lazy_if(s,UTF))
3564 CopLINE_dec(PL_curcop);
3565 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3566 CopLINE_inc(PL_curcop);
3571 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3573 PL_expect = XOPERATOR;
3574 force_ident(PL_tokenbuf, '&');
3578 yylval.ival = (OPpENTERSUB_AMPER<<8);
3597 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
3598 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3600 if (PL_expect == XSTATE && isALPHA(tmp) &&
3601 (s == PL_linestart+1 || s[-2] == '\n') )
3603 if (PL_in_eval && !PL_rsfp) {
3608 if (strnEQ(s,"=cut",4)) {
3622 PL_doextract = TRUE;
3625 if (PL_lex_brackets < PL_lex_formbrack) {
3627 #ifdef PERL_STRICT_CR
3628 for (t = s; SPACE_OR_TAB(*t); t++) ;
3630 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3632 if (*t == '\n' || *t == '#') {
3644 /* was this !=~ where !~ was meant?
3645 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3647 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3648 const char *t = s+1;
3650 while (t < PL_bufend && isSPACE(*t))
3653 if (*t == '/' || *t == '?' ||
3654 ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3655 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3656 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3657 "!=~ should be !~");
3666 if (PL_expect != XOPERATOR) {
3667 if (s[1] != '<' && !strchr(s,'>'))
3670 s = scan_heredoc(s);
3672 s = scan_inputsymbol(s);
3673 TERM(sublex_start());
3678 SHop(OP_LEFT_SHIFT);
3692 SHop(OP_RIGHT_SHIFT);
3701 if (PL_expect == XOPERATOR) {
3702 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3705 return REPORT(','); /* grandfather non-comma-format format */
3709 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3710 PL_tokenbuf[0] = '@';
3711 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3712 sizeof PL_tokenbuf - 1, FALSE);
3713 if (PL_expect == XOPERATOR)
3714 no_op("Array length", s);
3715 if (!PL_tokenbuf[1])
3717 PL_expect = XOPERATOR;
3718 PL_pending_ident = '#';
3722 PL_tokenbuf[0] = '$';
3723 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3724 sizeof PL_tokenbuf - 1, FALSE);
3725 if (PL_expect == XOPERATOR)
3727 if (!PL_tokenbuf[1]) {
3729 yyerror("Final $ should be \\$ or $name");
3733 /* This kludge not intended to be bulletproof. */
3734 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3735 yylval.opval = newSVOP(OP_CONST, 0,
3736 newSViv(PL_compiling.cop_arybase));
3737 yylval.opval->op_private = OPpCONST_ARYBASE;
3743 if (PL_lex_state == LEX_NORMAL)
3746 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3748 PL_tokenbuf[0] = '@';
3749 if (ckWARN(WARN_SYNTAX)) {
3752 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3755 PL_bufptr = skipspace(PL_bufptr);
3756 while (t < PL_bufend && *t != ']')
3758 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3759 "Multidimensional syntax %.*s not supported",
3760 (t - PL_bufptr) + 1, PL_bufptr);
3764 else if (*s == '{') {
3766 PL_tokenbuf[0] = '%';
3767 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
3768 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
3770 char tmpbuf[sizeof PL_tokenbuf];
3771 for (t++; isSPACE(*t); t++) ;
3772 if (isIDFIRST_lazy_if(t,UTF)) {
3774 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3775 for (; isSPACE(*t); t++) ;
3776 if (*t == ';' && get_cv(tmpbuf, FALSE))
3777 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3778 "You need to quote \"%s\"", tmpbuf);
3784 PL_expect = XOPERATOR;
3785 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3786 const bool islop = (PL_last_lop == PL_oldoldbufptr);
3787 if (!islop || PL_last_lop_op == OP_GREPSTART)
3788 PL_expect = XOPERATOR;
3789 else if (strchr("$@\"'`q", *s))
3790 PL_expect = XTERM; /* e.g. print $fh "foo" */
3791 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3792 PL_expect = XTERM; /* e.g. print $fh &sub */
3793 else if (isIDFIRST_lazy_if(s,UTF)) {
3794 char tmpbuf[sizeof PL_tokenbuf];
3795 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3796 if ((tmp = keyword(tmpbuf, len))) {
3797 /* binary operators exclude handle interpretations */
3809 PL_expect = XTERM; /* e.g. print $fh length() */
3814 PL_expect = XTERM; /* e.g. print $fh subr() */
3817 else if (isDIGIT(*s))
3818 PL_expect = XTERM; /* e.g. print $fh 3 */
3819 else if (*s == '.' && isDIGIT(s[1]))
3820 PL_expect = XTERM; /* e.g. print $fh .3 */
3821 else if ((*s == '?' || *s == '-' || *s == '+')
3822 && !isSPACE(s[1]) && s[1] != '=')
3823 PL_expect = XTERM; /* e.g. print $fh -1 */
3824 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3825 PL_expect = XTERM; /* e.g. print $fh /.../
3826 XXX except DORDOR operator */
3827 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3828 PL_expect = XTERM; /* print $fh <<"EOF" */
3830 PL_pending_ident = '$';
3834 if (PL_expect == XOPERATOR)
3836 PL_tokenbuf[0] = '@';
3837 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3838 if (!PL_tokenbuf[1]) {
3841 if (PL_lex_state == LEX_NORMAL)
3843 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3845 PL_tokenbuf[0] = '%';
3847 /* Warn about @ where they meant $. */
3848 if (*s == '[' || *s == '{') {
3849 if (ckWARN(WARN_SYNTAX)) {
3850 const char *t = s + 1;
3851 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3853 if (*t == '}' || *t == ']') {
3855 PL_bufptr = skipspace(PL_bufptr);
3856 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3857 "Scalar value %.*s better written as $%.*s",
3858 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3863 PL_pending_ident = '@';
3866 case '/': /* may be division, defined-or, or pattern */
3867 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3871 case '?': /* may either be conditional or pattern */
3872 if(PL_expect == XOPERATOR) {
3880 /* A // operator. */
3890 /* Disable warning on "study /blah/" */
3891 if (PL_oldoldbufptr == PL_last_uni
3892 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3893 || memNE(PL_last_uni, "study", 5)
3894 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3897 s = scan_pat(s,OP_MATCH);
3898 TERM(sublex_start());
3902 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3903 #ifdef PERL_STRICT_CR
3906 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3908 && (s == PL_linestart || s[-1] == '\n') )
3910 PL_lex_formbrack = 0;
3914 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3920 yylval.ival = OPf_SPECIAL;
3926 if (PL_expect != XOPERATOR)
3931 case '0': case '1': case '2': case '3': case '4':
3932 case '5': case '6': case '7': case '8': case '9':
3933 s = scan_num(s, &yylval);
3934 DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
3935 if (PL_expect == XOPERATOR)
3940 s = scan_str(s,FALSE,FALSE);
3941 DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
3942 if (PL_expect == XOPERATOR) {
3943 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3946 return REPORT(','); /* grandfather non-comma-format format */
3952 missingterm((char*)0);
3953 yylval.ival = OP_CONST;
3954 TERM(sublex_start());
3957 s = scan_str(s,FALSE,FALSE);
3958 DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
3959 if (PL_expect == XOPERATOR) {
3960 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3963 return REPORT(','); /* grandfather non-comma-format format */
3969 missingterm((char*)0);
3970 yylval.ival = OP_CONST;
3971 /* FIXME. I think that this can be const if char *d is replaced by
3972 more localised variables. */
3973 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3974 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3975 yylval.ival = OP_STRINGIFY;
3979 TERM(sublex_start());
3982 s = scan_str(s,FALSE,FALSE);
3983 DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
3984 if (PL_expect == XOPERATOR)
3985 no_op("Backticks",s);
3987 missingterm((char*)0);
3988 yylval.ival = OP_BACKTICK;
3990 TERM(sublex_start());
3994 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
3995 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3997 if (PL_expect == XOPERATOR)
3998 no_op("Backslash",s);
4002 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4003 char *start = s + 2;
4004 while (isDIGIT(*start) || *start == '_')
4006 if (*start == '.' && isDIGIT(start[1])) {
4007 s = scan_num(s, &yylval);
4010 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4011 else if (!isALPHA(*start) && (PL_expect == XTERM
4012 || PL_expect == XREF || PL_expect == XSTATE
4013 || PL_expect == XTERMORDORDOR)) {
4014 const char c = *start;
4017 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
4020 s = scan_num(s, &yylval);
4027 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4067 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4069 /* Some keywords can be followed by any delimiter, including ':' */
4070 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4071 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4072 (PL_tokenbuf[0] == 'q' &&
4073 strchr("qwxr", PL_tokenbuf[1])))));
4075 /* x::* is just a word, unless x is "CORE" */
4076 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4080 while (d < PL_bufend && isSPACE(*d))
4081 d++; /* no comments skipped here, or s### is misparsed */
4083 /* Is this a label? */
4084 if (!tmp && PL_expect == XSTATE
4085 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4087 yylval.pval = savepv(PL_tokenbuf);
4092 /* Check for keywords */
4093 tmp = keyword(PL_tokenbuf, len);
4095 /* Is this a word before a => operator? */
4096 if (*d == '=' && d[1] == '>') {
4099 = (OP*)newSVOP(OP_CONST, 0,
4100 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4101 yylval.opval->op_private = OPpCONST_BARE;
4105 if (tmp < 0) { /* second-class keyword? */
4106 GV *ogv = Nullgv; /* override (winner) */
4107 GV *hgv = Nullgv; /* hidden (loser) */
4108 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4110 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4113 if (GvIMPORTED_CV(gv))
4115 else if (! CvMETHOD(cv))
4119 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4120 (gv = *gvp) != (GV*)&PL_sv_undef &&
4121 GvCVu(gv) && GvIMPORTED_CV(gv))
4128 tmp = 0; /* overridden by import or by GLOBAL */
4131 && -tmp==KEY_lock /* XXX generalizable kludge */
4133 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4135 tmp = 0; /* any sub overrides "weak" keyword */
4140 && PL_expect != XOPERATOR
4141 && PL_expect != XTERMORDORDOR)
4143 /* any sub overrides the "err" keyword, except when really an
4144 * operator is expected */
4147 else { /* no override */
4149 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4150 Perl_warner(aTHX_ packWARN(WARN_MISC),
4151 "dump() better written as CORE::dump()");
4155 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4156 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
4157 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4158 "Ambiguous call resolved as CORE::%s(), %s",
4159 GvENAME(hgv), "qualify as such or use &");
4166 default: /* not a keyword */
4170 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4172 /* Get the rest if it looks like a package qualifier */
4174 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4176 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4179 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4180 *s == '\'' ? "'" : "::");
4185 if (PL_expect == XOPERATOR) {
4186 if (PL_bufptr == PL_linestart) {
4187 CopLINE_dec(PL_curcop);
4188 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4189 CopLINE_inc(PL_curcop);
4192 no_op("Bareword",s);
4195 /* Look for a subroutine with this name in current package,
4196 unless name is "Foo::", in which case Foo is a bearword
4197 (and a package name). */
4200 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4202 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4203 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4204 "Bareword \"%s\" refers to nonexistent package",
4207 PL_tokenbuf[len] = '\0';
4214 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4217 /* if we saw a global override before, get the right name */
4220 sv = newSVpvn("CORE::GLOBAL::",14);
4221 sv_catpv(sv,PL_tokenbuf);
4224 /* If len is 0, newSVpv does strlen(), which is correct.
4225 If len is non-zero, then it will be the true length,
4226 and so the scalar will be created correctly. */
4227 sv = newSVpv(PL_tokenbuf,len);
4230 /* Presume this is going to be a bareword of some sort. */
4233 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4234 yylval.opval->op_private = OPpCONST_BARE;
4235 /* UTF-8 package name? */
4236 if (UTF && !IN_BYTES &&
4237 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4240 /* And if "Foo::", then that's what it certainly is. */
4245 /* See if it's the indirect object for a list operator. */
4247 if (PL_oldoldbufptr &&
4248 PL_oldoldbufptr < PL_bufptr &&
4249 (PL_oldoldbufptr == PL_last_lop
4250 || PL_oldoldbufptr == PL_last_uni) &&
4251 /* NO SKIPSPACE BEFORE HERE! */
4252 (PL_expect == XREF ||
4253 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4255 bool immediate_paren = *s == '(';
4257 /* (Now we can afford to cross potential line boundary.) */
4260 /* Two barewords in a row may indicate method call. */
4262 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4265 /* If not a declared subroutine, it's an indirect object. */
4266 /* (But it's an indir obj regardless for sort.) */
4267 /* Also, if "_" follows a filetest operator, it's a bareword */
4270 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4271 ((!gv || !GvCVu(gv)) &&
4272 (PL_last_lop_op != OP_MAPSTART &&
4273 PL_last_lop_op != OP_GREPSTART))))
4274 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
4275 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
4278 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4283 PL_expect = XOPERATOR;
4286 /* Is this a word before a => operator? */
4287 if (*s == '=' && s[1] == '>' && !pkgname) {
4289 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4290 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4291 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4295 /* If followed by a paren, it's certainly a subroutine. */
4298 if (gv && GvCVu(gv)) {
4299 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4300 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4305 PL_nextval[PL_nexttoke].opval = yylval.opval;
4306 PL_expect = XOPERATOR;
4312 /* If followed by var or block, call it a method (unless sub) */
4314 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4315 PL_last_lop = PL_oldbufptr;
4316 PL_last_lop_op = OP_METHOD;
4320 /* If followed by a bareword, see if it looks like indir obj. */
4323 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4324 && (tmp = intuit_method(s,gv)))
4327 /* Not a method, so call it a subroutine (if defined) */
4329 if (gv && GvCVu(gv)) {
4331 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4332 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4333 "Ambiguous use of -%s resolved as -&%s()",
4334 PL_tokenbuf, PL_tokenbuf);
4335 /* Check for a constant sub */
4337 if ((sv = cv_const_sv(cv))) {
4339 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4340 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4341 yylval.opval->op_private = 0;
4345 /* Resolve to GV now. */
4346 op_free(yylval.opval);
4347 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4348 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4349 PL_last_lop = PL_oldbufptr;
4350 PL_last_lop_op = OP_ENTERSUB;
4351 /* Is there a prototype? */
4354 const char *proto = SvPV_const((SV*)cv, len);
4357 if (*proto == '$' && proto[1] == '\0')
4359 while (*proto == ';')
4361 if (*proto == '&' && *s == '{') {
4362 sv_setpv(PL_subname, PL_curstash ?
4363 "__ANON__" : "__ANON__::__ANON__");
4367 PL_nextval[PL_nexttoke].opval = yylval.opval;
4373 /* Call it a bare word */
4375 if (PL_hints & HINT_STRICT_SUBS)
4376 yylval.opval->op_private |= OPpCONST_STRICT;
4379 if (lastchar != '-') {
4380 if (ckWARN(WARN_RESERVED)) {
4381 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4382 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4383 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4390 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4391 && ckWARN_d(WARN_AMBIGUOUS)) {
4392 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4393 "Operator or semicolon missing before %c%s",
4394 lastchar, PL_tokenbuf);
4395 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4396 "Ambiguous use of %c resolved as operator %c",
4397 lastchar, lastchar);
4403 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4404 newSVpv(CopFILE(PL_curcop),0));
4408 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4409 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4412 case KEY___PACKAGE__:
4413 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4415 ? newSVhek(HvNAME_HEK(PL_curstash))
4422 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4423 const char *pname = "main";
4424 if (PL_tokenbuf[2] == 'D')
4425 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
4426 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4429 GvIOp(gv) = newIO();
4430 IoIFP(GvIOp(gv)) = PL_rsfp;
4431 #if defined(HAS_FCNTL) && defined(F_SETFD)
4433 const int fd = PerlIO_fileno(PL_rsfp);
4434 fcntl(fd,F_SETFD,fd >= 3);
4437 /* Mark this internal pseudo-handle as clean */
4438 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4440 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4441 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4442 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4444 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4445 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4446 /* if the script was opened in binmode, we need to revert
4447 * it to text mode for compatibility; but only iff it has CRs
4448 * XXX this is a questionable hack at best. */
4449 if (PL_bufend-PL_bufptr > 2
4450 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4453 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4454 loc = PerlIO_tell(PL_rsfp);
4455 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4458 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4460 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4461 #endif /* NETWARE */
4462 #ifdef PERLIO_IS_STDIO /* really? */
4463 # if defined(__BORLANDC__)
4464 /* XXX see note in do_binmode() */
4465 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4469 PerlIO_seek(PL_rsfp, loc, 0);
4473 #ifdef PERLIO_LAYERS
4476 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4477 else if (PL_encoding) {
4484 XPUSHs(PL_encoding);
4486 call_method("name", G_SCALAR);
4490 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4491 Perl_form(aTHX_ ":encoding(%"SVf")",
4509 if (PL_expect == XSTATE) {
4516 if (*s == ':' && s[1] == ':') {
4519 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4520 if (!(tmp = keyword(PL_tokenbuf, len)))
4521 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4524 else if (tmp == KEY_require || tmp == KEY_do)
4525 /* that's a way to remember we saw "CORE::" */
4538 LOP(OP_ACCEPT,XTERM);
4544 LOP(OP_ATAN2,XTERM);
4550 LOP(OP_BINMODE,XTERM);
4553 LOP(OP_BLESS,XTERM);
4562 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4579 if (!PL_cryptseen) {
4580 PL_cryptseen = TRUE;
4584 LOP(OP_CRYPT,XTERM);
4587 LOP(OP_CHMOD,XTERM);
4590 LOP(OP_CHOWN,XTERM);
4593 LOP(OP_CONNECT,XTERM);
4609 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4610 if (orig_keyword == KEY_do) {
4619 PL_hints |= HINT_BLOCK_SCOPE;
4629 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4630 LOP(OP_DBMOPEN,XTERM);
4636 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4643 yylval.ival = CopLINE(PL_curcop);
4657 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4658 UNIBRACK(OP_ENTEREVAL);
4676 case KEY_endhostent:
4682 case KEY_endservent:
4685 case KEY_endprotoent:
4696 yylval.ival = CopLINE(PL_curcop);
4698 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4700 if ((PL_bufend - p) >= 3 &&
4701 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4703 else if ((PL_bufend - p) >= 4 &&
4704 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4707 if (isIDFIRST_lazy_if(p,UTF)) {
4708 p = scan_ident(p, PL_bufend,
4709 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4713 Perl_croak(aTHX_ "Missing $ on loop variable");
4718 LOP(OP_FORMLINE,XTERM);
4724 LOP(OP_FCNTL,XTERM);
4730 LOP(OP_FLOCK,XTERM);
4739 LOP(OP_GREPSTART, XREF);
4742 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4757 case KEY_getpriority:
4758 LOP(OP_GETPRIORITY,XTERM);
4760 case KEY_getprotobyname:
4763 case KEY_getprotobynumber:
4764 LOP(OP_GPBYNUMBER,XTERM);
4766 case KEY_getprotoent:
4778 case KEY_getpeername:
4779 UNI(OP_GETPEERNAME);
4781 case KEY_gethostbyname:
4784 case KEY_gethostbyaddr:
4785 LOP(OP_GHBYADDR,XTERM);
4787 case KEY_gethostent:
4790 case KEY_getnetbyname:
4793 case KEY_getnetbyaddr:
4794 LOP(OP_GNBYADDR,XTERM);
4799 case KEY_getservbyname:
4800 LOP(OP_GSBYNAME,XTERM);
4802 case KEY_getservbyport:
4803 LOP(OP_GSBYPORT,XTERM);
4805 case KEY_getservent:
4808 case KEY_getsockname:
4809 UNI(OP_GETSOCKNAME);
4811 case KEY_getsockopt:
4812 LOP(OP_GSOCKOPT,XTERM);
4834 yylval.ival = CopLINE(PL_curcop);
4838 LOP(OP_INDEX,XTERM);
4844 LOP(OP_IOCTL,XTERM);
4856 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4888 LOP(OP_LISTEN,XTERM);
4897 s = scan_pat(s,OP_MATCH);
4898 TERM(sublex_start());
4901 LOP(OP_MAPSTART, XREF);
4904 LOP(OP_MKDIR,XTERM);
4907 LOP(OP_MSGCTL,XTERM);
4910 LOP(OP_MSGGET,XTERM);
4913 LOP(OP_MSGRCV,XTERM);
4916 LOP(OP_MSGSND,XTERM);
4922 if (isIDFIRST_lazy_if(s,UTF)) {
4923 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4924 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4926 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4927 if (!PL_in_my_stash) {
4930 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4938 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4945 s = tokenize_use(0, s);
4949 if (*s == '(' || (s = skipspace(s), *s == '('))
4956 if (isIDFIRST_lazy_if(s,UTF)) {
4958 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4959 for (t=d; *t && isSPACE(*t); t++) ;
4960 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4962 && !(t[0] == '=' && t[1] == '>')
4964 int len = (int)(d-s);
4965 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4966 "Precedence problem: open %.*s should be open(%.*s)",
4973 yylval.ival = OP_OR;
4983 LOP(OP_OPEN_DIR,XTERM);
4986 checkcomma(s,PL_tokenbuf,"filehandle");
4990 checkcomma(s,PL_tokenbuf,"filehandle");
5009 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5013 LOP(OP_PIPE_OP,XTERM);
5016 s = scan_str(s,FALSE,FALSE);
5018 missingterm((char*)0);
5019 yylval.ival = OP_CONST;
5020 TERM(sublex_start());
5026 s = scan_str(s,FALSE,FALSE);
5028 missingterm((char*)0);
5029 PL_expect = XOPERATOR;
5031 if (SvCUR(PL_lex_stuff)) {
5034 d = SvPV_force(PL_lex_stuff, len);
5037 for (; isSPACE(*d) && len; --len, ++d) ;
5040 if (!warned && ckWARN(WARN_QW)) {
5041 for (; !isSPACE(*d) && len; --len, ++d) {
5043 Perl_warner(aTHX_ packWARN(WARN_QW),
5044 "Possible attempt to separate words with commas");
5047 else if (*d == '#') {
5048 Perl_warner(aTHX_ packWARN(WARN_QW),
5049 "Possible attempt to put comments in qw() list");
5055 for (; !isSPACE(*d) && len; --len, ++d) ;
5057 sv = newSVpvn(b, d-b);
5058 if (DO_UTF8(PL_lex_stuff))
5060 words = append_elem(OP_LIST, words,
5061 newSVOP(OP_CONST, 0, tokeq(sv)));
5065 PL_nextval[PL_nexttoke].opval = words;
5070 SvREFCNT_dec(PL_lex_stuff);
5071 PL_lex_stuff = Nullsv;
5077 s = scan_str(s,FALSE,FALSE);
5079 missingterm((char*)0);
5080 yylval.ival = OP_STRINGIFY;
5081 if (SvIVX(PL_lex_stuff) == '\'')
5082 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
5083 TERM(sublex_start());
5086 s = scan_pat(s,OP_QR);
5087 TERM(sublex_start());
5090 s = scan_str(s,FALSE,FALSE);
5092 missingterm((char*)0);
5093 yylval.ival = OP_BACKTICK;
5095 TERM(sublex_start());
5103 s = force_version(s, FALSE);
5105 else if (*s != 'v' || !isDIGIT(s[1])
5106 || (s = force_version(s, TRUE), *s == 'v'))
5108 *PL_tokenbuf = '\0';
5109 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5110 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5111 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5113 yyerror("<> should be quotes");
5115 if (orig_keyword == KEY_require) {
5123 PL_last_uni = PL_oldbufptr;
5124 PL_last_lop_op = OP_REQUIRE;
5126 return REPORT( (int)REQUIRE );
5132 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5136 LOP(OP_RENAME,XTERM);
5145 LOP(OP_RINDEX,XTERM);
5155 UNIDOR(OP_READLINE);
5168 LOP(OP_REVERSE,XTERM);
5171 UNIDOR(OP_READLINK);
5179 TERM(sublex_start());
5181 TOKEN(1); /* force error */
5190 LOP(OP_SELECT,XTERM);
5196 LOP(OP_SEMCTL,XTERM);
5199 LOP(OP_SEMGET,XTERM);
5202 LOP(OP_SEMOP,XTERM);
5208 LOP(OP_SETPGRP,XTERM);
5210 case KEY_setpriority:
5211 LOP(OP_SETPRIORITY,XTERM);
5213 case KEY_sethostent:
5219 case KEY_setservent:
5222 case KEY_setprotoent:
5232 LOP(OP_SEEKDIR,XTERM);
5234 case KEY_setsockopt:
5235 LOP(OP_SSOCKOPT,XTERM);
5241 LOP(OP_SHMCTL,XTERM);
5244 LOP(OP_SHMGET,XTERM);
5247 LOP(OP_SHMREAD,XTERM);
5250 LOP(OP_SHMWRITE,XTERM);
5253 LOP(OP_SHUTDOWN,XTERM);
5262 LOP(OP_SOCKET,XTERM);
5264 case KEY_socketpair:
5265 LOP(OP_SOCKPAIR,XTERM);
5268 checkcomma(s,PL_tokenbuf,"subroutine name");
5270 if (*s == ';' || *s == ')') /* probably a close */
5271 Perl_croak(aTHX_ "sort is now a reserved word");
5273 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5277 LOP(OP_SPLIT,XTERM);
5280 LOP(OP_SPRINTF,XTERM);
5283 LOP(OP_SPLICE,XTERM);
5298 LOP(OP_SUBSTR,XTERM);
5304 char tmpbuf[sizeof PL_tokenbuf];
5305 SSize_t tboffset = 0;
5306 expectation attrful;
5307 bool have_name, have_proto, bad_proto;
5308 const int key = tmp;
5312 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5313 (*s == ':' && s[1] == ':'))
5316 attrful = XATTRBLOCK;
5317 /* remember buffer pos'n for later force_word */
5318 tboffset = s - PL_oldbufptr;
5319 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5320 if (strchr(tmpbuf, ':'))
5321 sv_setpv(PL_subname, tmpbuf);
5323 sv_setsv(PL_subname,PL_curstname);
5324 sv_catpvn(PL_subname,"::",2);
5325 sv_catpvn(PL_subname,tmpbuf,len);
5332 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5333 PL_expect = XTERMBLOCK;
5334 attrful = XATTRTERM;
5335 sv_setpvn(PL_subname,"?",1);
5339 if (key == KEY_format) {
5341 PL_lex_formbrack = PL_lex_brackets + 1;
5343 (void) force_word(PL_oldbufptr + tboffset, WORD,
5348 /* Look for a prototype */
5352 s = scan_str(s,FALSE,FALSE);
5354 Perl_croak(aTHX_ "Prototype not terminated");
5355 /* strip spaces and check for bad characters */
5356 d = SvPVX(PL_lex_stuff);
5359 for (p = d; *p; ++p) {
5362 if (!strchr("$@%*;[]&\\", *p))
5367 if (bad_proto && ckWARN(WARN_SYNTAX))
5368 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5369 "Illegal character in prototype for %"SVf" : %s",
5371 SvCUR_set(PL_lex_stuff, tmp);
5379 if (*s == ':' && s[1] != ':')
5380 PL_expect = attrful;
5381 else if (*s != '{' && key == KEY_sub) {
5383 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5385 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5389 PL_nextval[PL_nexttoke].opval =
5390 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5391 PL_lex_stuff = Nullsv;
5395 sv_setpv(PL_subname,
5396 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5399 (void) force_word(PL_oldbufptr + tboffset, WORD,
5408 LOP(OP_SYSTEM,XREF);
5411 LOP(OP_SYMLINK,XTERM);
5414 LOP(OP_SYSCALL,XTERM);
5417 LOP(OP_SYSOPEN,XTERM);
5420 LOP(OP_SYSSEEK,XTERM);
5423 LOP(OP_SYSREAD,XTERM);
5426 LOP(OP_SYSWRITE,XTERM);
5430 TERM(sublex_start());
5451 LOP(OP_TRUNCATE,XTERM);
5463 yylval.ival = CopLINE(PL_curcop);
5467 yylval.ival = CopLINE(PL_curcop);
5471 LOP(OP_UNLINK,XTERM);
5477 LOP(OP_UNPACK,XTERM);
5480 LOP(OP_UTIME,XTERM);
5486 LOP(OP_UNSHIFT,XTERM);
5489 s = tokenize_use(1, s);
5499 yylval.ival = CopLINE(PL_curcop);
5503 PL_hints |= HINT_BLOCK_SCOPE;
5510 LOP(OP_WAITPID,XTERM);
5519 ctl_l[0] = toCTRL('L');
5521 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5524 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5529 if (PL_expect == XOPERATOR)
5535 yylval.ival = OP_XOR;
5540 TERM(sublex_start());
5545 #pragma segment Main
5549 S_pending_ident(pTHX)
5552 register I32 tmp = 0;
5553 /* pit holds the identifier we read and pending_ident is reset */
5554 char pit = PL_pending_ident;
5555 PL_pending_ident = 0;
5557 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5558 "### Pending identifier '%s'\n", PL_tokenbuf); });
5560 /* if we're in a my(), we can't allow dynamics here.
5561 $foo'bar has already been turned into $foo::bar, so
5562 just check for colons.
5564 if it's a legal name, the OP is a PADANY.
5567 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5568 if (strchr(PL_tokenbuf,':'))
5569 yyerror(Perl_form(aTHX_ "No package name allowed for "
5570 "variable %s in \"our\"",
5572 tmp = allocmy(PL_tokenbuf);
5575 if (strchr(PL_tokenbuf,':'))
5576 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5578 yylval.opval = newOP(OP_PADANY, 0);
5579 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5585 build the ops for accesses to a my() variable.
5587 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5588 then used in a comparison. This catches most, but not
5589 all cases. For instance, it catches
5590 sort { my($a); $a <=> $b }
5592 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5593 (although why you'd do that is anyone's guess).
5596 if (!strchr(PL_tokenbuf,':')) {
5598 tmp = pad_findmy(PL_tokenbuf);
5599 if (tmp != NOT_IN_PAD) {
5600 /* might be an "our" variable" */
5601 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5602 /* build ops for a bareword */
5603 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
5604 HEK * const stashname = HvNAME_HEK(stash);
5605 SV * const sym = newSVhek(stashname);
5606 sv_catpvn(sym, "::", 2);
5607 sv_catpv(sym, PL_tokenbuf+1);
5608 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5609 yylval.opval->op_private = OPpCONST_ENTERED;
5612 ? (GV_ADDMULTI | GV_ADDINEVAL)
5615 ((PL_tokenbuf[0] == '$') ? SVt_PV
5616 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5621 /* if it's a sort block and they're naming $a or $b */
5622 if (PL_last_lop_op == OP_SORT &&
5623 PL_tokenbuf[0] == '$' &&
5624 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5627 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5628 d < PL_bufend && *d != '\n';
5631 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5632 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5638 yylval.opval = newOP(OP_PADANY, 0);
5639 yylval.opval->op_targ = tmp;
5645 Whine if they've said @foo in a doublequoted string,
5646 and @foo isn't a variable we can find in the symbol
5649 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5650 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5651 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5652 && ckWARN(WARN_AMBIGUOUS))
5654 /* Downgraded from fatal to warning 20000522 mjd */
5655 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5656 "Possible unintended interpolation of %s in string",
5661 /* build ops for a bareword */
5662 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5663 yylval.opval->op_private = OPpCONST_ENTERED;
5664 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5665 ((PL_tokenbuf[0] == '$') ? SVt_PV
5666 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5672 * The following code was generated by perl_keyword.pl.
5676 Perl_keyword (pTHX_ const char *name, I32 len)
5680 case 1: /* 5 tokens of length 1 */
5712 case 2: /* 18 tokens of length 2 */
5858 case 3: /* 28 tokens of length 3 */
5862 if (name[1] == 'N' &&
5925 if (name[1] == 'i' &&
5965 if (name[1] == 'o' &&
5974 if (name[1] == 'e' &&
5983 if (name[1] == 'n' &&
5992 if (name[1] == 'o' &&
6001 if (name[1] == 'a' &&
6010 if (name[1] == 'o' &&
6072 if (name[1] == 'e' &&
6104 if (name[1] == 'i' &&
6113 if (name[1] == 's' &&
6122 if (name[1] == 'e' &&
6131 if (name[1] == 'o' &&
6143 case 4: /* 40 tokens of length 4 */
6147 if (name[1] == 'O' &&
6157 if (name[1] == 'N' &&
6167 if (name[1] == 'i' &&
6177 if (name[1] == 'h' &&
6187 if (name[1] == 'u' &&
6200 if (name[2] == 'c' &&
6209 if (name[2] == 's' &&
6218 if (name[2] == 'a' &&
6254 if (name[1] == 'o' &&
6267 if (name[2] == 't' &&
6276 if (name[2] == 'o' &&
6285 if (name[2] == 't' &&
6294 if (name[2] == 'e' &&
6307 if (name[1] == 'o' &&
6320 if (name[2] == 'y' &&
6329 if (name[2] == 'l' &&
6345 if (name[2] == 's' &&
6354 if (name[2] == 'n' &&
6363 if (name[2] == 'c' &&
6376 if (name[1] == 'e' &&
6386 if (name[1] == 'p' &&
6399 if (name[2] == 'c' &&
6408 if (name[2] == 'p' &&
6417 if (name[2] == 's' &&
6433 if (name[2] == 'n' &&
6503 if (name[2] == 'r' &&
6512 if (name[2] == 'r' &&
6521 if (name[2] == 'a' &&
6537 if (name[2] == 'l' &&
6604 case 5: /* 36 tokens of length 5 */
6608 if (name[1] == 'E' &&
6619 if (name[1] == 'H' &&
6633 if (name[2] == 'a' &&
6643 if (name[2] == 'a' &&
6657 if (name[1] == 'l' &&
6674 if (name[3] == 'i' &&
6683 if (name[3] == 'o' &&
6719 if (name[2] == 'o' &&
6729 if (name[2] == 'y' &&
6743 if (name[1] == 'l' &&
6757 if (name[2] == 'n' &&
6767 if (name[2] == 'o' &&
6784 if (name[2] == 'd' &&
6794 if (name[2] == 'c' &&
6811 if (name[2] == 'c' &&
6821 if (name[2] == 't' &&
6835 if (name[1] == 'k' &&
6846 if (name[1] == 'r' &&
6860 if (name[2] == 's' &&
6870 if (name[2] == 'd' &&
6887 if (name[2] == 'm' &&
6897 if (name[2] == 'i' &&
6907 if (name[2] == 'e' &&
6917 if (name[2] == 'l' &&
6927 if (name[2] == 'a' &&
6937 if (name[2] == 'u' &&
6951 if (name[1] == 'i' &&
6965 if (name[2] == 'a' &&
6978 if (name[3] == 'e' &&
7013 if (name[2] == 'i' &&
7030 if (name[2] == 'i' &&
7040 if (name[2] == 'i' &&
7057 case 6: /* 33 tokens of length 6 */
7061 if (name[1] == 'c' &&
7076 if (name[2] == 'l' &&
7087 if (name[2] == 'r' &&
7102 if (name[1] == 'e' &&
7117 if (name[2] == 's' &&
7122 if(ckWARN_d(WARN_SYNTAX))
7123 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7129 if (name[2] == 'i' &&
7147 if (name[2] == 'l' &&
7158 if (name[2] == 'r' &&
7173 if (name[1] == 'm' &&
7188 if (name[2] == 'n' &&
7199 if (name[2] == 's' &&
7214 if (name[1] == 's' &&
7220 if (name[4] == 't' &&
7229 if (name[4] == 'e' &&
7238 if (name[4] == 'c' &&
7247 if (name[4] == 'n' &&
7263 if (name[1] == 'r' &&
7281 if (name[3] == 'a' &&
7291 if (name[3] == 'u' &&
7305 if (name[2] == 'n' &&
7323 if (name[2] == 'a' &&
7337 if (name[3] == 'e' &&
7350 if (name[4] == 't' &&
7359 if (name[4] == 'e' &&
7381 if (name[4] == 't' &&
7390 if (name[4] == 'e' &&
7406 if (name[2] == 'c' &&
7417 if (name[2] == 'l' &&
7428 if (name[2] == 'b' &&
7439 if (name[2] == 's' &&
7462 if (name[4] == 's' &&
7471 if (name[4] == 'n' &&
7484 if (name[3] == 'a' &&
7501 if (name[1] == 'a' &&
7516 case 7: /* 28 tokens of length 7 */
7520 if (name[1] == 'E' &&
7533 if (name[1] == '_' &&
7546 if (name[1] == 'i' &&
7553 return -KEY_binmode;
7559 if (name[1] == 'o' &&
7566 return -KEY_connect;
7575 if (name[2] == 'm' &&
7581 return -KEY_dbmopen;
7587 if (name[2] == 'f' &&
7603 if (name[1] == 'o' &&
7616 if (name[1] == 'e' &&
7623 if (name[5] == 'r' &&
7626 return -KEY_getpgrp;
7632 if (name[5] == 'i' &&
7635 return -KEY_getppid;
7648 if (name[1] == 'c' &&
7655 return -KEY_lcfirst;
7661 if (name[1] == 'p' &&
7668 return -KEY_opendir;
7674 if (name[1] == 'a' &&
7692 if (name[3] == 'd' &&
7697 return -KEY_readdir;
7703 if (name[3] == 'u' &&
7714 if (name[3] == 'e' &&
7719 return -KEY_reverse;
7738 if (name[3] == 'k' &&
7743 return -KEY_seekdir;
7749 if (name[3] == 'p' &&
7754 return -KEY_setpgrp;
7764 if (name[2] == 'm' &&
7770 return -KEY_shmread;
7776 if (name[2] == 'r' &&
7782 return -KEY_sprintf;
7791 if (name[3] == 'l' &&
7796 return -KEY_symlink;
7805 if (name[4] == 'a' &&
7809 return -KEY_syscall;
7815 if (name[4] == 'p' &&
7819 return -KEY_sysopen;
7825 if (name[4] == 'e' &&
7829 return -KEY_sysread;
7835 if (name[4] == 'e' &&
7839 return -KEY_sysseek;
7857 if (name[1] == 'e' &&
7864 return -KEY_telldir;
7873 if (name[2] == 'f' &&
7879 return -KEY_ucfirst;
7885 if (name[2] == 's' &&
7891 return -KEY_unshift;
7901 if (name[1] == 'a' &&
7908 return -KEY_waitpid;
7917 case 8: /* 26 tokens of length 8 */
7921 if (name[1] == 'U' &&
7929 return KEY_AUTOLOAD;
7940 if (name[3] == 'A' &&
7946 return KEY___DATA__;
7952 if (name[3] == 'I' &&
7958 return -KEY___FILE__;
7964 if (name[3] == 'I' &&
7970 return -KEY___LINE__;
7986 if (name[2] == 'o' &&
7993 return -KEY_closedir;
7999 if (name[2] == 'n' &&
8006 return -KEY_continue;
8016 if (name[1] == 'b' &&
8024 return -KEY_dbmclose;
8030 if (name[1] == 'n' &&
8036 if (name[4] == 'r' &&
8041 return -KEY_endgrent;
8047 if (name[4] == 'w' &&
8052 return -KEY_endpwent;
8065 if (name[1] == 'o' &&
8073 return -KEY_formline;
8079 if (name[1] == 'e' &&
8090 if (name[6] == 'n' &&
8093 return -KEY_getgrent;
8099 if (name[6] == 'i' &&
8102 return -KEY_getgrgid;
8108 if (name[6] == 'a' &&
8111 return -KEY_getgrnam;
8124 if (name[4] == 'o' &&
8129 return -KEY_getlogin;
8140 if (name[6] == 'n' &&
8143 return -KEY_getpwent;
8149 if (name[6] == 'a' &&
8152 return -KEY_getpwnam;
8158 if (name[6] == 'i' &&
8161 return -KEY_getpwuid;
8181 if (name[1] == 'e' &&
8188 if (name[5] == 'i' &&
8195 return -KEY_readline;
8200 return -KEY_readlink;
8211 if (name[5] == 'i' &&
8215 return -KEY_readpipe;
8236 if (name[4] == 'r' &&
8241 return -KEY_setgrent;
8247 if (name[4] == 'w' &&
8252 return -KEY_setpwent;
8268 if (name[3] == 'w' &&
8274 return -KEY_shmwrite;
8280 if (name[3] == 't' &&
8286 return -KEY_shutdown;
8296 if (name[2] == 's' &&
8303 return -KEY_syswrite;
8313 if (name[1] == 'r' &&
8321 return -KEY_truncate;
8330 case 9: /* 8 tokens of length 9 */
8334 if (name[1] == 'n' &&
8343 return -KEY_endnetent;
8349 if (name[1] == 'e' &&
8358 return -KEY_getnetent;
8364 if (name[1] == 'o' &&
8373 return -KEY_localtime;
8379 if (name[1] == 'r' &&
8388 return KEY_prototype;
8394 if (name[1] == 'u' &&
8403 return -KEY_quotemeta;
8409 if (name[1] == 'e' &&
8418 return -KEY_rewinddir;
8424 if (name[1] == 'e' &&
8433 return -KEY_setnetent;
8439 if (name[1] == 'a' &&
8448 return -KEY_wantarray;
8457 case 10: /* 9 tokens of length 10 */
8461 if (name[1] == 'n' &&
8467 if (name[4] == 'o' &&
8474 return -KEY_endhostent;
8480 if (name[4] == 'e' &&
8487 return -KEY_endservent;
8500 if (name[1] == 'e' &&
8506 if (name[4] == 'o' &&
8513 return -KEY_gethostent;
8522 if (name[5] == 'r' &&
8528 return -KEY_getservent;
8534 if (name[5] == 'c' &&
8540 return -KEY_getsockopt;
8565 if (name[4] == 'o' &&
8572 return -KEY_sethostent;
8581 if (name[5] == 'r' &&
8587 return -KEY_setservent;
8593 if (name[5] == 'c' &&
8599 return -KEY_setsockopt;
8616 if (name[2] == 'c' &&
8625 return -KEY_socketpair;
8638 case 11: /* 8 tokens of length 11 */
8642 if (name[1] == '_' &&
8653 return -KEY___PACKAGE__;
8659 if (name[1] == 'n' &&
8670 return -KEY_endprotoent;
8676 if (name[1] == 'e' &&
8685 if (name[5] == 'e' &&
8692 return -KEY_getpeername;
8701 if (name[6] == 'o' &&
8707 return -KEY_getpriority;
8713 if (name[6] == 't' &&
8719 return -KEY_getprotoent;
8733 if (name[4] == 'o' &&
8741 return -KEY_getsockname;
8754 if (name[1] == 'e' &&
8762 if (name[6] == 'o' &&
8768 return -KEY_setpriority;
8774 if (name[6] == 't' &&
8780 return -KEY_setprotoent;
8796 case 12: /* 2 tokens of length 12 */
8797 if (name[0] == 'g' &&
8809 if (name[9] == 'd' &&
8812 { /* getnetbyaddr */
8813 return -KEY_getnetbyaddr;
8819 if (name[9] == 'a' &&
8822 { /* getnetbyname */
8823 return -KEY_getnetbyname;
8835 case 13: /* 4 tokens of length 13 */
8836 if (name[0] == 'g' &&
8843 if (name[4] == 'o' &&
8852 if (name[10] == 'd' &&
8855 { /* gethostbyaddr */
8856 return -KEY_gethostbyaddr;
8862 if (name[10] == 'a' &&
8865 { /* gethostbyname */
8866 return -KEY_gethostbyname;
8879 if (name[4] == 'e' &&
8888 if (name[10] == 'a' &&
8891 { /* getservbyname */
8892 return -KEY_getservbyname;
8898 if (name[10] == 'o' &&
8901 { /* getservbyport */
8902 return -KEY_getservbyport;
8921 case 14: /* 1 tokens of length 14 */
8922 if (name[0] == 'g' &&
8936 { /* getprotobyname */
8937 return -KEY_getprotobyname;
8942 case 16: /* 1 tokens of length 16 */
8943 if (name[0] == 'g' &&
8959 { /* getprotobynumber */
8960 return -KEY_getprotobynumber;
8974 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
8978 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8979 if (ckWARN(WARN_SYNTAX)) {
8981 for (w = s+2; *w && level; w++) {
8988 for (; *w && isSPACE(*w); w++) ;
8989 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
8990 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8991 "%s (...) interpreted as function",name);
8994 while (s < PL_bufend && isSPACE(*s))
8998 while (s < PL_bufend && isSPACE(*s))
9000 if (isIDFIRST_lazy_if(s,UTF)) {
9002 while (isALNUM_lazy_if(s,UTF))
9004 while (s < PL_bufend && isSPACE(*s))
9008 *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9009 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9013 Perl_croak(aTHX_ "No comma allowed after %s", what);
9018 /* Either returns sv, or mortalizes sv and returns a new SV*.
9019 Best used as sv=new_constant(..., sv, ...).
9020 If s, pv are NULL, calls subroutine with one argument,
9021 and type is used with error messages only. */
9024 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9028 HV * const table = GvHV(PL_hintgv); /* ^H */
9032 const char *why1 = "", *why2 = "", *why3 = "";
9034 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9037 why2 = strEQ(key,"charnames")
9038 ? "(possibly a missing \"use charnames ...\")"
9040 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9041 (type ? type: "undef"), why2);
9043 /* This is convoluted and evil ("goto considered harmful")
9044 * but I do not understand the intricacies of all the different
9045 * failure modes of %^H in here. The goal here is to make
9046 * the most probable error message user-friendly. --jhi */
9051 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9052 (type ? type: "undef"), why1, why2, why3);
9054 yyerror(SvPVX_const(msg));
9058 cvp = hv_fetch(table, key, strlen(key), FALSE);
9059 if (!cvp || !SvOK(*cvp)) {
9062 why3 = "} is not defined";
9065 sv_2mortal(sv); /* Parent created it permanently */
9068 pv = sv_2mortal(newSVpvn(s, len));
9070 typesv = sv_2mortal(newSVpv(type, 0));
9072 typesv = &PL_sv_undef;
9074 PUSHSTACKi(PERLSI_OVERLOAD);
9086 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9090 /* Check the eval first */
9091 if (!PL_in_eval && SvTRUE(ERRSV)) {
9092 sv_catpv(ERRSV, "Propagated");
9093 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9095 res = SvREFCNT_inc(sv);
9099 (void)SvREFCNT_inc(res);
9108 why1 = "Call to &{$^H{";
9110 why3 = "}} did not return a defined value";
9118 /* Returns a NUL terminated string, with the length of the string written to
9122 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9124 register char *d = dest;
9125 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
9128 Perl_croak(aTHX_ ident_too_long);
9129 if (isALNUM(*s)) /* UTF handled below */
9131 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9136 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9140 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9141 char *t = s + UTF8SKIP(s);
9142 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9144 if (d + (t - s) > e)
9145 Perl_croak(aTHX_ ident_too_long);
9146 Copy(s, d, t - s, char);
9159 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9163 char *bracket = Nullch;
9169 e = d + destlen - 3; /* two-character token, ending NUL */
9171 while (isDIGIT(*s)) {
9173 Perl_croak(aTHX_ ident_too_long);
9180 Perl_croak(aTHX_ ident_too_long);
9181 if (isALNUM(*s)) /* UTF handled below */
9183 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9188 else if (*s == ':' && s[1] == ':') {
9192 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9193 char *t = s + UTF8SKIP(s);
9194 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9196 if (d + (t - s) > e)
9197 Perl_croak(aTHX_ ident_too_long);
9198 Copy(s, d, t - s, char);
9209 if (PL_lex_state != LEX_NORMAL)
9210 PL_lex_state = LEX_INTERPENDMAYBE;
9213 if (*s == '$' && s[1] &&
9214 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9227 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9232 if (isSPACE(s[-1])) {
9234 const char ch = *s++;
9235 if (!SPACE_OR_TAB(ch)) {
9241 if (isIDFIRST_lazy_if(d,UTF)) {
9245 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9247 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9250 Copy(s, d, e - s, char);
9255 while ((isALNUM(*s) || *s == ':') && d < e)
9258 Perl_croak(aTHX_ ident_too_long);
9261 while (s < send && SPACE_OR_TAB(*s)) s++;
9262 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9263 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9264 const char *brack = *s == '[' ? "[...]" : "{...}";
9265 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9266 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9267 funny, dest, brack, funny, dest, brack);
9270 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9274 /* Handle extended ${^Foo} variables
9275 * 1999-02-27 mjd-perl-patch@plover.com */
9276 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9280 while (isALNUM(*s) && d < e) {
9284 Perl_croak(aTHX_ ident_too_long);
9289 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9290 PL_lex_state = LEX_INTERPEND;
9295 if (PL_lex_state == LEX_NORMAL) {
9296 if (ckWARN(WARN_AMBIGUOUS) &&
9297 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9299 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9300 "Ambiguous use of %c{%s} resolved to %c%s",
9301 funny, dest, funny, dest);
9306 s = bracket; /* let the parser handle it */
9310 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9311 PL_lex_state = LEX_INTERPEND;
9316 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9321 *pmfl |= PMf_GLOBAL;
9323 *pmfl |= PMf_CONTINUE;
9327 *pmfl |= PMf_MULTILINE;
9329 *pmfl |= PMf_SINGLELINE;
9331 *pmfl |= PMf_EXTENDED;
9335 S_scan_pat(pTHX_ char *start, I32 type)
9338 char *s = scan_str(start,FALSE,FALSE);
9341 char * const delimiter = skipspace(start);
9342 Perl_croak(aTHX_ *delimiter == '?'
9343 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9344 : "Search pattern not terminated" );
9347 pm = (PMOP*)newPMOP(type, 0);
9348 if (PL_multi_open == '?')
9349 pm->op_pmflags |= PMf_ONCE;
9351 while (*s && strchr("iomsx", *s))
9352 pmflag(&pm->op_pmflags,*s++);
9355 while (*s && strchr("iogcmsx", *s))
9356 pmflag(&pm->op_pmflags,*s++);
9358 /* issue a warning if /c is specified,but /g is not */
9359 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9360 && ckWARN(WARN_REGEXP))
9362 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
9365 pm->op_pmpermflags = pm->op_pmflags;
9367 PL_lex_op = (OP*)pm;
9368 yylval.ival = OP_MATCH;
9373 S_scan_subst(pTHX_ char *start)
9381 yylval.ival = OP_NULL;
9383 s = scan_str(start,FALSE,FALSE);
9386 Perl_croak(aTHX_ "Substitution pattern not terminated");
9388 if (s[-1] == PL_multi_open)
9391 first_start = PL_multi_start;
9392 s = scan_str(s,FALSE,FALSE);
9395 SvREFCNT_dec(PL_lex_stuff);
9396 PL_lex_stuff = Nullsv;
9398 Perl_croak(aTHX_ "Substitution replacement not terminated");
9400 PL_multi_start = first_start; /* so whole substitution is taken together */
9402 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9408 else if (strchr("iogcmsx", *s))
9409 pmflag(&pm->op_pmflags,*s++);
9414 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
9415 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9420 PL_sublex_info.super_bufptr = s;
9421 PL_sublex_info.super_bufend = PL_bufend;
9423 pm->op_pmflags |= PMf_EVAL;
9424 repl = newSVpvn("",0);
9426 sv_catpv(repl, es ? "eval " : "do ");
9427 sv_catpvn(repl, "{ ", 2);
9428 sv_catsv(repl, PL_lex_repl);
9429 sv_catpvn(repl, " };", 2);
9431 SvREFCNT_dec(PL_lex_repl);
9435 pm->op_pmpermflags = pm->op_pmflags;
9436 PL_lex_op = (OP*)pm;
9437 yylval.ival = OP_SUBST;
9442 S_scan_trans(pTHX_ char *start)
9451 yylval.ival = OP_NULL;
9453 s = scan_str(start,FALSE,FALSE);
9455 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9456 if (s[-1] == PL_multi_open)
9459 s = scan_str(s,FALSE,FALSE);
9462 SvREFCNT_dec(PL_lex_stuff);
9463 PL_lex_stuff = Nullsv;
9465 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9468 complement = del = squash = 0;
9472 complement = OPpTRANS_COMPLEMENT;
9475 del = OPpTRANS_DELETE;
9478 squash = OPpTRANS_SQUASH;
9487 Newx(tbl, complement&&!del?258:256, short);
9488 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9489 o->op_private &= ~OPpTRANS_ALL;
9490 o->op_private |= del|squash|complement|
9491 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9492 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9495 yylval.ival = OP_TRANS;
9500 S_scan_heredoc(pTHX_ register char *s)
9503 I32 op_type = OP_SCALAR;
9507 const char newline[] = "\n";
9508 const char *found_newline;
9512 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9516 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9519 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9520 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9523 s = delimcpy(d, e, s, PL_bufend, term, &len);
9533 if (!isALNUM_lazy_if(s,UTF))
9534 deprecate_old("bare << to mean <<\"\"");
9535 for (; isALNUM_lazy_if(s,UTF); s++) {
9540 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9541 Perl_croak(aTHX_ "Delimiter for here document is too long");
9544 len = d - PL_tokenbuf;
9545 #ifndef PERL_STRICT_CR
9546 d = strchr(s, '\r');
9548 char * const olds = s;
9550 while (s < PL_bufend) {
9556 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9565 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9569 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9570 herewas = newSVpvn(s,PL_bufend-s);
9574 herewas = newSVpvn(s,found_newline-s);
9576 s += SvCUR(herewas);
9578 tmpstr = NEWSV(87,79);
9579 sv_upgrade(tmpstr, SVt_PVIV);
9582 SvIV_set(tmpstr, -1);
9584 else if (term == '`') {
9585 op_type = OP_BACKTICK;
9586 SvIV_set(tmpstr, '\\');
9590 PL_multi_start = CopLINE(PL_curcop);
9591 PL_multi_open = PL_multi_close = '<';
9592 term = *PL_tokenbuf;
9593 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9594 char *bufptr = PL_sublex_info.super_bufptr;
9595 char *bufend = PL_sublex_info.super_bufend;
9596 char * const olds = s - SvCUR(herewas);
9597 s = strchr(bufptr, '\n');
9601 while (s < bufend &&
9602 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9604 CopLINE_inc(PL_curcop);
9607 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9608 missingterm(PL_tokenbuf);
9610 sv_setpvn(herewas,bufptr,d-bufptr+1);
9611 sv_setpvn(tmpstr,d+1,s-d);
9613 sv_catpvn(herewas,s,bufend-s);
9614 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9621 while (s < PL_bufend &&
9622 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9624 CopLINE_inc(PL_curcop);
9626 if (s >= PL_bufend) {
9627 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9628 missingterm(PL_tokenbuf);
9630 sv_setpvn(tmpstr,d+1,s-d);
9632 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9634 sv_catpvn(herewas,s,PL_bufend-s);
9635 sv_setsv(PL_linestr,herewas);
9636 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9637 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9638 PL_last_lop = PL_last_uni = Nullch;
9641 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9642 while (s >= PL_bufend) { /* multiple line string? */
9644 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9645 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9646 missingterm(PL_tokenbuf);
9648 CopLINE_inc(PL_curcop);
9649 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9650 PL_last_lop = PL_last_uni = Nullch;
9651 #ifndef PERL_STRICT_CR
9652 if (PL_bufend - PL_linestart >= 2) {
9653 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9654 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9656 PL_bufend[-2] = '\n';
9658 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9660 else if (PL_bufend[-1] == '\r')
9661 PL_bufend[-1] = '\n';
9663 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9664 PL_bufend[-1] = '\n';
9666 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9667 SV *sv = NEWSV(88,0);
9669 sv_upgrade(sv, SVt_PVMG);
9670 sv_setsv(sv,PL_linestr);
9673 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9675 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9676 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9677 *(SvPVX(PL_linestr) + off ) = ' ';
9678 sv_catsv(PL_linestr,herewas);
9679 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9680 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9684 sv_catsv(tmpstr,PL_linestr);
9689 PL_multi_end = CopLINE(PL_curcop);
9690 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9691 SvPV_shrink_to_cur(tmpstr);
9693 SvREFCNT_dec(herewas);
9695 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9697 else if (PL_encoding)
9698 sv_recode_to_utf8(tmpstr, PL_encoding);
9700 PL_lex_stuff = tmpstr;
9701 yylval.ival = op_type;
9706 takes: current position in input buffer
9707 returns: new position in input buffer
9708 side-effects: yylval and lex_op are set.
9713 <FH> read from filehandle
9714 <pkg::FH> read from package qualified filehandle
9715 <pkg'FH> read from package qualified filehandle
9716 <$fh> read from filehandle in $fh
9722 S_scan_inputsymbol(pTHX_ char *start)
9724 register char *s = start; /* current position in buffer */
9730 d = PL_tokenbuf; /* start of temp holding space */
9731 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9732 end = strchr(s, '\n');
9735 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9737 /* die if we didn't have space for the contents of the <>,
9738 or if it didn't end, or if we see a newline
9741 if (len >= sizeof PL_tokenbuf)
9742 Perl_croak(aTHX_ "Excessively long <> operator");
9744 Perl_croak(aTHX_ "Unterminated <> operator");
9749 Remember, only scalar variables are interpreted as filehandles by
9750 this code. Anything more complex (e.g., <$fh{$num}>) will be
9751 treated as a glob() call.
9752 This code makes use of the fact that except for the $ at the front,
9753 a scalar variable and a filehandle look the same.
9755 if (*d == '$' && d[1]) d++;
9757 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9758 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9761 /* If we've tried to read what we allow filehandles to look like, and
9762 there's still text left, then it must be a glob() and not a getline.
9763 Use scan_str to pull out the stuff between the <> and treat it
9764 as nothing more than a string.
9767 if (d - PL_tokenbuf != len) {
9768 yylval.ival = OP_GLOB;
9770 s = scan_str(start,FALSE,FALSE);
9772 Perl_croak(aTHX_ "Glob not terminated");
9776 bool readline_overriden = FALSE;
9777 GV *gv_readline = Nullgv;
9779 /* we're in a filehandle read situation */
9782 /* turn <> into <ARGV> */
9784 Copy("ARGV",d,5,char);
9786 /* Check whether readline() is overriden */
9787 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9788 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9790 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9791 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9792 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9793 readline_overriden = TRUE;
9795 /* if <$fh>, create the ops to turn the variable into a
9801 /* try to find it in the pad for this block, otherwise find
9802 add symbol table ops
9804 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9805 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9806 HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9807 HEK *stashname = HvNAME_HEK(stash);
9808 SV *sym = sv_2mortal(newSVhek(stashname));
9809 sv_catpvn(sym, "::", 2);
9815 OP *o = newOP(OP_PADSV, 0);
9817 PL_lex_op = readline_overriden
9818 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9819 append_elem(OP_LIST, o,
9820 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9821 : (OP*)newUNOP(OP_READLINE, 0, o);
9830 ? (GV_ADDMULTI | GV_ADDINEVAL)
9833 PL_lex_op = readline_overriden
9834 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9835 append_elem(OP_LIST,
9836 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9837 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9838 : (OP*)newUNOP(OP_READLINE, 0,
9839 newUNOP(OP_RV2SV, 0,
9840 newGVOP(OP_GV, 0, gv)));
9842 if (!readline_overriden)
9843 PL_lex_op->op_flags |= OPf_SPECIAL;
9844 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9845 yylval.ival = OP_NULL;
9848 /* If it's none of the above, it must be a literal filehandle
9849 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9851 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9852 PL_lex_op = readline_overriden
9853 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9854 append_elem(OP_LIST,
9855 newGVOP(OP_GV, 0, gv),
9856 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9857 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9858 yylval.ival = OP_NULL;
9867 takes: start position in buffer
9868 keep_quoted preserve \ on the embedded delimiter(s)
9869 keep_delims preserve the delimiters around the string
9870 returns: position to continue reading from buffer
9871 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9872 updates the read buffer.
9874 This subroutine pulls a string out of the input. It is called for:
9875 q single quotes q(literal text)
9876 ' single quotes 'literal text'
9877 qq double quotes qq(interpolate $here please)
9878 " double quotes "interpolate $here please"
9879 qx backticks qx(/bin/ls -l)
9880 ` backticks `/bin/ls -l`
9881 qw quote words @EXPORT_OK = qw( func() $spam )
9882 m// regexp match m/this/
9883 s/// regexp substitute s/this/that/
9884 tr/// string transliterate tr/this/that/
9885 y/// string transliterate y/this/that/
9886 ($*@) sub prototypes sub foo ($)
9887 (stuff) sub attr parameters sub foo : attr(stuff)
9888 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9890 In most of these cases (all but <>, patterns and transliterate)
9891 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9892 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9893 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9896 It skips whitespace before the string starts, and treats the first
9897 character as the delimiter. If the delimiter is one of ([{< then
9898 the corresponding "close" character )]}> is used as the closing
9899 delimiter. It allows quoting of delimiters, and if the string has
9900 balanced delimiters ([{<>}]) it allows nesting.
9902 On success, the SV with the resulting string is put into lex_stuff or,
9903 if that is already non-NULL, into lex_repl. The second case occurs only
9904 when parsing the RHS of the special constructs s/// and tr/// (y///).
9905 For convenience, the terminating delimiter character is stuffed into
9910 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9912 SV *sv; /* scalar value: string */
9913 char *tmps; /* temp string, used for delimiter matching */
9914 register char *s = start; /* current position in the buffer */
9915 register char term; /* terminating character */
9916 register char *to; /* current position in the sv's data */
9917 I32 brackets = 1; /* bracket nesting level */
9918 bool has_utf8 = FALSE; /* is there any utf8 content? */
9919 I32 termcode; /* terminating char. code */
9920 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9921 STRLEN termlen; /* length of terminating string */
9922 char *last = NULL; /* last position for nesting bracket */
9924 /* skip space before the delimiter */
9928 /* mark where we are, in case we need to report errors */
9931 /* after skipping whitespace, the next character is the terminator */
9934 termcode = termstr[0] = term;
9938 termcode = utf8_to_uvchr((U8*)s, &termlen);
9939 Copy(s, termstr, termlen, U8);
9940 if (!UTF8_IS_INVARIANT(term))
9944 /* mark where we are */
9945 PL_multi_start = CopLINE(PL_curcop);
9946 PL_multi_open = term;
9948 /* find corresponding closing delimiter */
9949 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9950 termcode = termstr[0] = term = tmps[5];
9952 PL_multi_close = term;
9954 /* create a new SV to hold the contents. 87 is leak category, I'm
9955 assuming. 79 is the SV's initial length. What a random number. */
9957 sv_upgrade(sv, SVt_PVIV);
9958 SvIV_set(sv, termcode);
9959 (void)SvPOK_only(sv); /* validate pointer */
9961 /* move past delimiter and try to read a complete string */
9963 sv_catpvn(sv, s, termlen);
9966 if (PL_encoding && !UTF) {
9970 int offset = s - SvPVX_const(PL_linestr);
9971 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9972 &offset, (char*)termstr, termlen);
9973 const char *ns = SvPVX_const(PL_linestr) + offset;
9974 char *svlast = SvEND(sv) - 1;
9976 for (; s < ns; s++) {
9977 if (*s == '\n' && !PL_rsfp)
9978 CopLINE_inc(PL_curcop);
9981 goto read_more_line;
9983 /* handle quoted delimiters */
9984 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9986 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9988 if ((svlast-1 - t) % 2) {
9992 SvCUR_set(sv, SvCUR(sv) - 1);
9997 if (PL_multi_open == PL_multi_close) {
10005 for (t = w = last; t < svlast; w++, t++) {
10006 /* At here, all closes are "was quoted" one,
10007 so we don't check PL_multi_close. */
10009 if (!keep_quoted && *(t+1) == PL_multi_open)
10014 else if (*t == PL_multi_open)
10022 SvCUR_set(sv, w - SvPVX_const(sv));
10025 if (--brackets <= 0)
10030 if (!keep_delims) {
10031 SvCUR_set(sv, SvCUR(sv) - 1);
10037 /* extend sv if need be */
10038 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10039 /* set 'to' to the next character in the sv's string */
10040 to = SvPVX(sv)+SvCUR(sv);
10042 /* if open delimiter is the close delimiter read unbridle */
10043 if (PL_multi_open == PL_multi_close) {
10044 for (; s < PL_bufend; s++,to++) {
10045 /* embedded newlines increment the current line number */
10046 if (*s == '\n' && !PL_rsfp)
10047 CopLINE_inc(PL_curcop);
10048 /* handle quoted delimiters */
10049 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10050 if (!keep_quoted && s[1] == term)
10052 /* any other quotes are simply copied straight through */
10056 /* terminate when run out of buffer (the for() condition), or
10057 have found the terminator */
10058 else if (*s == term) {
10061 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10064 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10070 /* if the terminator isn't the same as the start character (e.g.,
10071 matched brackets), we have to allow more in the quoting, and
10072 be prepared for nested brackets.
10075 /* read until we run out of string, or we find the terminator */
10076 for (; s < PL_bufend; s++,to++) {
10077 /* embedded newlines increment the line count */
10078 if (*s == '\n' && !PL_rsfp)
10079 CopLINE_inc(PL_curcop);
10080 /* backslashes can escape the open or closing characters */
10081 if (*s == '\\' && s+1 < PL_bufend) {
10082 if (!keep_quoted &&
10083 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10088 /* allow nested opens and closes */
10089 else if (*s == PL_multi_close && --brackets <= 0)
10091 else if (*s == PL_multi_open)
10093 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10098 /* terminate the copied string and update the sv's end-of-string */
10100 SvCUR_set(sv, to - SvPVX_const(sv));
10103 * this next chunk reads more into the buffer if we're not done yet
10107 break; /* handle case where we are done yet :-) */
10109 #ifndef PERL_STRICT_CR
10110 if (to - SvPVX_const(sv) >= 2) {
10111 if ((to[-2] == '\r' && to[-1] == '\n') ||
10112 (to[-2] == '\n' && to[-1] == '\r'))
10116 SvCUR_set(sv, to - SvPVX_const(sv));
10118 else if (to[-1] == '\r')
10121 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10126 /* if we're out of file, or a read fails, bail and reset the current
10127 line marker so we can report where the unterminated string began
10130 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10132 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10135 /* we read a line, so increment our line counter */
10136 CopLINE_inc(PL_curcop);
10138 /* update debugger info */
10139 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10140 SV *sv = NEWSV(88,0);
10142 sv_upgrade(sv, SVt_PVMG);
10143 sv_setsv(sv,PL_linestr);
10144 (void)SvIOK_on(sv);
10146 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10149 /* having changed the buffer, we must update PL_bufend */
10150 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10151 PL_last_lop = PL_last_uni = Nullch;
10154 /* at this point, we have successfully read the delimited string */
10156 if (!PL_encoding || UTF) {
10158 sv_catpvn(sv, s, termlen);
10161 if (has_utf8 || PL_encoding)
10164 PL_multi_end = CopLINE(PL_curcop);
10166 /* if we allocated too much space, give some back */
10167 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10168 SvLEN_set(sv, SvCUR(sv) + 1);
10169 SvPV_renew(sv, SvLEN(sv));
10172 /* decide whether this is the first or second quoted string we've read
10185 takes: pointer to position in buffer
10186 returns: pointer to new position in buffer
10187 side-effects: builds ops for the constant in yylval.op
10189 Read a number in any of the formats that Perl accepts:
10191 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10192 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10195 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10197 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10200 If it reads a number without a decimal point or an exponent, it will
10201 try converting the number to an integer and see if it can do so
10202 without loss of precision.
10206 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10208 register const char *s = start; /* current position in buffer */
10209 register char *d; /* destination in temp buffer */
10210 register char *e; /* end of temp buffer */
10211 NV nv; /* number read, as a double */
10212 SV *sv = Nullsv; /* place to put the converted number */
10213 bool floatit; /* boolean: int or float? */
10214 const char *lastub = 0; /* position of last underbar */
10215 static char const number_too_long[] = "Number too long";
10217 /* We use the first character to decide what type of number this is */
10221 Perl_croak(aTHX_ "panic: scan_num");
10223 /* if it starts with a 0, it could be an octal number, a decimal in
10224 0.13 disguise, or a hexadecimal number, or a binary number. */
10228 u holds the "number so far"
10229 shift the power of 2 of the base
10230 (hex == 4, octal == 3, binary == 1)
10231 overflowed was the number more than we can hold?
10233 Shift is used when we add a digit. It also serves as an "are
10234 we in octal/hex/binary?" indicator to disallow hex characters
10235 when in octal mode.
10240 bool overflowed = FALSE;
10241 bool just_zero = TRUE; /* just plain 0 or binary number? */
10242 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10243 static const char* const bases[5] =
10244 { "", "binary", "", "octal", "hexadecimal" };
10245 static const char* const Bases[5] =
10246 { "", "Binary", "", "Octal", "Hexadecimal" };
10247 static const char* const maxima[5] =
10249 "0b11111111111111111111111111111111",
10253 const char *base, *Base, *max;
10255 /* check for hex */
10260 } else if (s[1] == 'b') {
10265 /* check for a decimal in disguise */
10266 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10268 /* so it must be octal */
10275 if (ckWARN(WARN_SYNTAX))
10276 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10277 "Misplaced _ in number");
10281 base = bases[shift];
10282 Base = Bases[shift];
10283 max = maxima[shift];
10285 /* read the rest of the number */
10287 /* x is used in the overflow test,
10288 b is the digit we're adding on. */
10293 /* if we don't mention it, we're done */
10297 /* _ are ignored -- but warned about if consecutive */
10299 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10300 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10301 "Misplaced _ in number");
10305 /* 8 and 9 are not octal */
10306 case '8': case '9':
10308 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10312 case '2': case '3': case '4':
10313 case '5': case '6': case '7':
10315 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10318 case '0': case '1':
10319 b = *s++ & 15; /* ASCII digit -> value of digit */
10323 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10324 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10325 /* make sure they said 0x */
10328 b = (*s++ & 7) + 9;
10330 /* Prepare to put the digit we have onto the end
10331 of the number so far. We check for overflows.
10337 x = u << shift; /* make room for the digit */
10339 if ((x >> shift) != u
10340 && !(PL_hints & HINT_NEW_BINARY)) {
10343 if (ckWARN_d(WARN_OVERFLOW))
10344 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10345 "Integer overflow in %s number",
10348 u = x | b; /* add the digit to the end */
10351 n *= nvshift[shift];
10352 /* If an NV has not enough bits in its
10353 * mantissa to represent an UV this summing of
10354 * small low-order numbers is a waste of time
10355 * (because the NV cannot preserve the
10356 * low-order bits anyway): we could just
10357 * remember when did we overflow and in the
10358 * end just multiply n by the right
10366 /* if we get here, we had success: make a scalar value from
10371 /* final misplaced underbar check */
10372 if (s[-1] == '_') {
10373 if (ckWARN(WARN_SYNTAX))
10374 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10379 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10380 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10381 "%s number > %s non-portable",
10387 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10388 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10389 "%s number > %s non-portable",
10394 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10395 sv = new_constant(start, s - start, "integer",
10397 else if (PL_hints & HINT_NEW_BINARY)
10398 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10403 handle decimal numbers.
10404 we're also sent here when we read a 0 as the first digit
10406 case '1': case '2': case '3': case '4': case '5':
10407 case '6': case '7': case '8': case '9': case '.':
10410 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10413 /* read next group of digits and _ and copy into d */
10414 while (isDIGIT(*s) || *s == '_') {
10415 /* skip underscores, checking for misplaced ones
10419 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10420 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10421 "Misplaced _ in number");
10425 /* check for end of fixed-length buffer */
10427 Perl_croak(aTHX_ number_too_long);
10428 /* if we're ok, copy the character */
10433 /* final misplaced underbar check */
10434 if (lastub && s == lastub + 1) {
10435 if (ckWARN(WARN_SYNTAX))
10436 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10439 /* read a decimal portion if there is one. avoid
10440 3..5 being interpreted as the number 3. followed
10443 if (*s == '.' && s[1] != '.') {
10448 if (ckWARN(WARN_SYNTAX))
10449 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10450 "Misplaced _ in number");
10454 /* copy, ignoring underbars, until we run out of digits.
10456 for (; isDIGIT(*s) || *s == '_'; s++) {
10457 /* fixed length buffer check */
10459 Perl_croak(aTHX_ number_too_long);
10461 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10462 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10463 "Misplaced _ in number");
10469 /* fractional part ending in underbar? */
10470 if (s[-1] == '_') {
10471 if (ckWARN(WARN_SYNTAX))
10472 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10473 "Misplaced _ in number");
10475 if (*s == '.' && isDIGIT(s[1])) {
10476 /* oops, it's really a v-string, but without the "v" */
10482 /* read exponent part, if present */
10483 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10487 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10488 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10490 /* stray preinitial _ */
10492 if (ckWARN(WARN_SYNTAX))
10493 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10494 "Misplaced _ in number");
10498 /* allow positive or negative exponent */
10499 if (*s == '+' || *s == '-')
10502 /* stray initial _ */
10504 if (ckWARN(WARN_SYNTAX))
10505 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10506 "Misplaced _ in number");
10510 /* read digits of exponent */
10511 while (isDIGIT(*s) || *s == '_') {
10514 Perl_croak(aTHX_ number_too_long);
10518 if (((lastub && s == lastub + 1) ||
10519 (!isDIGIT(s[1]) && s[1] != '_'))
10520 && ckWARN(WARN_SYNTAX))
10521 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10522 "Misplaced _ in number");
10529 /* make an sv from the string */
10533 We try to do an integer conversion first if no characters
10534 indicating "float" have been found.
10539 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10541 if (flags == IS_NUMBER_IN_UV) {
10543 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10546 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10547 if (uv <= (UV) IV_MIN)
10548 sv_setiv(sv, -(IV)uv);
10555 /* terminate the string */
10557 nv = Atof(PL_tokenbuf);
10561 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10562 (PL_hints & HINT_NEW_INTEGER) )
10563 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10564 (floatit ? "float" : "integer"),
10568 /* if it starts with a v, it could be a v-string */
10571 sv = NEWSV(92,5); /* preallocate storage space */
10572 s = scan_vstring(s,sv);
10576 /* make the op for the constant and return */
10579 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10581 lvalp->opval = Nullop;
10587 S_scan_formline(pTHX_ register char *s)
10589 register char *eol;
10591 SV *stuff = newSVpvn("",0);
10592 bool needargs = FALSE;
10593 bool eofmt = FALSE;
10595 while (!needargs) {
10597 #ifdef PERL_STRICT_CR
10598 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10600 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10602 if (*t == '\n' || t == PL_bufend) {
10607 if (PL_in_eval && !PL_rsfp) {
10608 eol = (char *) memchr(s,'\n',PL_bufend-s);
10613 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10615 for (t = s; t < eol; t++) {
10616 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10618 goto enough; /* ~~ must be first line in formline */
10620 if (*t == '@' || *t == '^')
10624 sv_catpvn(stuff, s, eol-s);
10625 #ifndef PERL_STRICT_CR
10626 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10627 char *end = SvPVX(stuff) + SvCUR(stuff);
10630 SvCUR_set(stuff, SvCUR(stuff) - 1);
10639 s = filter_gets(PL_linestr, PL_rsfp, 0);
10640 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10641 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10642 PL_last_lop = PL_last_uni = Nullch;
10651 if (SvCUR(stuff)) {
10654 PL_lex_state = LEX_NORMAL;
10655 PL_nextval[PL_nexttoke].ival = 0;
10659 PL_lex_state = LEX_FORMLINE;
10661 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10663 else if (PL_encoding)
10664 sv_recode_to_utf8(stuff, PL_encoding);
10666 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10668 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10672 SvREFCNT_dec(stuff);
10674 PL_lex_formbrack = 0;
10685 PL_cshlen = strlen(PL_cshname);
10690 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10692 const I32 oldsavestack_ix = PL_savestack_ix;
10693 CV* outsidecv = PL_compcv;
10696 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10698 SAVEI32(PL_subline);
10699 save_item(PL_subname);
10700 SAVESPTR(PL_compcv);
10702 PL_compcv = (CV*)NEWSV(1104,0);
10703 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10704 CvFLAGS(PL_compcv) |= flags;
10706 PL_subline = CopLINE(PL_curcop);
10707 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10708 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10709 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10711 return oldsavestack_ix;
10715 #pragma segment Perl_yylex
10718 Perl_yywarn(pTHX_ const char *s)
10720 PL_in_eval |= EVAL_WARNONLY;
10722 PL_in_eval &= ~EVAL_WARNONLY;
10727 Perl_yyerror(pTHX_ const char *s)
10729 const char *where = NULL;
10730 const char *context = NULL;
10734 if (!yychar || (yychar == ';' && !PL_rsfp))
10736 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10737 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10738 PL_oldbufptr != PL_bufptr) {
10741 The code below is removed for NetWare because it abends/crashes on NetWare
10742 when the script has error such as not having the closing quotes like:
10743 if ($var eq "value)
10744 Checking of white spaces is anyway done in NetWare code.
10747 while (isSPACE(*PL_oldoldbufptr))
10750 context = PL_oldoldbufptr;
10751 contlen = PL_bufptr - PL_oldoldbufptr;
10753 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10754 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10757 The code below is removed for NetWare because it abends/crashes on NetWare
10758 when the script has error such as not having the closing quotes like:
10759 if ($var eq "value)
10760 Checking of white spaces is anyway done in NetWare code.
10763 while (isSPACE(*PL_oldbufptr))
10766 context = PL_oldbufptr;
10767 contlen = PL_bufptr - PL_oldbufptr;
10769 else if (yychar > 255)
10770 where = "next token ???";
10771 else if (yychar == -2) { /* YYEMPTY */
10772 if (PL_lex_state == LEX_NORMAL ||
10773 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10774 where = "at end of line";
10775 else if (PL_lex_inpat)
10776 where = "within pattern";
10778 where = "within string";
10781 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10783 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10784 else if (isPRINT_LC(yychar))
10785 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10787 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10788 where = SvPVX_const(where_sv);
10790 msg = sv_2mortal(newSVpv(s, 0));
10791 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10792 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10794 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10796 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10797 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10798 Perl_sv_catpvf(aTHX_ msg,
10799 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10800 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10803 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10804 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10807 if (PL_error_count >= 10) {
10808 if (PL_in_eval && SvCUR(ERRSV))
10809 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10810 ERRSV, OutCopFILE(PL_curcop));
10812 Perl_croak(aTHX_ "%s has too many errors.\n",
10813 OutCopFILE(PL_curcop));
10816 PL_in_my_stash = Nullhv;
10820 #pragma segment Main
10824 S_swallow_bom(pTHX_ U8 *s)
10826 const STRLEN slen = SvCUR(PL_linestr);
10829 if (s[1] == 0xFE) {
10830 /* UTF-16 little-endian? (or UTF32-LE?) */
10831 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10832 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10833 #ifndef PERL_NO_UTF16_FILTER
10834 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10837 if (PL_bufend > (char*)s) {
10841 filter_add(utf16rev_textfilter, NULL);
10842 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10843 utf16_to_utf8_reversed(s, news,
10844 PL_bufend - (char*)s - 1,
10846 sv_setpvn(PL_linestr, (const char*)news, newlen);
10848 SvUTF8_on(PL_linestr);
10849 s = (U8*)SvPVX(PL_linestr);
10850 PL_bufend = SvPVX(PL_linestr) + newlen;
10853 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10858 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10859 #ifndef PERL_NO_UTF16_FILTER
10860 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10863 if (PL_bufend > (char *)s) {
10867 filter_add(utf16_textfilter, NULL);
10868 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10869 utf16_to_utf8(s, news,
10870 PL_bufend - (char*)s,
10872 sv_setpvn(PL_linestr, (const char*)news, newlen);
10874 SvUTF8_on(PL_linestr);
10875 s = (U8*)SvPVX(PL_linestr);
10876 PL_bufend = SvPVX(PL_linestr) + newlen;
10879 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10884 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10885 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10886 s += 3; /* UTF-8 */
10892 if (s[2] == 0xFE && s[3] == 0xFF) {
10893 /* UTF-32 big-endian */
10894 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10897 else if (s[2] == 0 && s[3] != 0) {
10900 * are a good indicator of UTF-16BE. */
10901 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10906 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10909 * are a good indicator of UTF-16LE. */
10910 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10919 * Restore a source filter.
10923 restore_rsfp(pTHX_ void *f)
10925 PerlIO * const fp = (PerlIO*)f;
10927 if (PL_rsfp == PerlIO_stdin())
10928 PerlIO_clearerr(PL_rsfp);
10929 else if (PL_rsfp && (PL_rsfp != fp))
10930 PerlIO_close(PL_rsfp);
10934 #ifndef PERL_NO_UTF16_FILTER
10936 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10938 const STRLEN old = SvCUR(sv);
10939 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10940 DEBUG_P(PerlIO_printf(Perl_debug_log,
10941 "utf16_textfilter(%p): %d %d (%d)\n",
10942 utf16_textfilter, idx, maxlen, (int) count));
10946 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10947 Copy(SvPVX_const(sv), tmps, old, char);
10948 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10949 SvCUR(sv) - old, &newlen);
10950 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10952 DEBUG_P({sv_dump(sv);});
10957 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10959 const STRLEN old = SvCUR(sv);
10960 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10961 DEBUG_P(PerlIO_printf(Perl_debug_log,
10962 "utf16rev_textfilter(%p): %d %d (%d)\n",
10963 utf16rev_textfilter, idx, maxlen, (int) count));
10967 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10968 Copy(SvPVX_const(sv), tmps, old, char);
10969 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10970 SvCUR(sv) - old, &newlen);
10971 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10973 DEBUG_P({ sv_dump(sv); });
10979 Returns a pointer to the next character after the parsed
10980 vstring, as well as updating the passed in sv.
10982 Function must be called like
10985 s = scan_vstring(s,sv);
10987 The sv should already be large enough to store the vstring
10988 passed in, for performance reasons.
10993 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
10995 const char *pos = s;
10996 const char *start = s;
10997 if (*pos == 'v') pos++; /* get past 'v' */
10998 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11000 if ( *pos != '.') {
11001 /* this may not be a v-string if followed by => */
11002 const char *next = pos;
11003 while (next < PL_bufend && isSPACE(*next))
11005 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11006 /* return string not v-string */
11007 sv_setpvn(sv,(char *)s,pos-s);
11008 return (char *)pos;
11012 if (!isALPHA(*pos)) {
11013 U8 tmpbuf[UTF8_MAXBYTES+1];
11015 if (*s == 'v') s++; /* get past 'v' */
11017 sv_setpvn(sv, "", 0);
11023 /* this is atoi() that tolerates underscores */
11024 const char *end = pos;
11026 while (--end >= s) {
11031 rev += (*end - '0') * mult;
11033 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11034 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11035 "Integer overflow in decimal number");
11039 if (rev > 0x7FFFFFFF)
11040 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11042 /* Append native character for the rev point */
11043 tmpend = uvchr_to_utf8(tmpbuf, rev);
11044 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11045 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11047 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11053 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11057 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11065 * c-indentation-style: bsd
11066 * c-basic-offset: 4
11067 * indent-tabs-mode: t
11070 * ex: set ts=8 sts=4 sw=4 noet: