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;
5667 ? (GV_ADDMULTI | GV_ADDINEVAL)
5668 /* If the identifier refers to a stash, don't autovivify it.
5669 * Change 24660 had the side effect of causing symbol table
5670 * hashes to always be defined, even if they were freshly
5671 * created and the only reference in the entire program was
5672 * the single statement with the defined %foo::bar:: test.
5673 * It appears that all code in the wild doing this actually
5674 * wants to know whether sub-packages have been loaded, so
5675 * by avoiding auto-vivifying symbol tables, we ensure that
5676 * defined %foo::bar:: continues to be false, and the existing
5677 * tests still give the expected answers, even though what
5678 * they're actually testing has now changed subtly.
5680 : !(*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'),
5681 ((PL_tokenbuf[0] == '$') ? SVt_PV
5682 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5688 * The following code was generated by perl_keyword.pl.
5692 Perl_keyword (pTHX_ const char *name, I32 len)
5696 case 1: /* 5 tokens of length 1 */
5728 case 2: /* 18 tokens of length 2 */
5874 case 3: /* 28 tokens of length 3 */
5878 if (name[1] == 'N' &&
5941 if (name[1] == 'i' &&
5981 if (name[1] == 'o' &&
5990 if (name[1] == 'e' &&
5999 if (name[1] == 'n' &&
6008 if (name[1] == 'o' &&
6017 if (name[1] == 'a' &&
6026 if (name[1] == 'o' &&
6088 if (name[1] == 'e' &&
6120 if (name[1] == 'i' &&
6129 if (name[1] == 's' &&
6138 if (name[1] == 'e' &&
6147 if (name[1] == 'o' &&
6159 case 4: /* 40 tokens of length 4 */
6163 if (name[1] == 'O' &&
6173 if (name[1] == 'N' &&
6183 if (name[1] == 'i' &&
6193 if (name[1] == 'h' &&
6203 if (name[1] == 'u' &&
6216 if (name[2] == 'c' &&
6225 if (name[2] == 's' &&
6234 if (name[2] == 'a' &&
6270 if (name[1] == 'o' &&
6283 if (name[2] == 't' &&
6292 if (name[2] == 'o' &&
6301 if (name[2] == 't' &&
6310 if (name[2] == 'e' &&
6323 if (name[1] == 'o' &&
6336 if (name[2] == 'y' &&
6345 if (name[2] == 'l' &&
6361 if (name[2] == 's' &&
6370 if (name[2] == 'n' &&
6379 if (name[2] == 'c' &&
6392 if (name[1] == 'e' &&
6402 if (name[1] == 'p' &&
6415 if (name[2] == 'c' &&
6424 if (name[2] == 'p' &&
6433 if (name[2] == 's' &&
6449 if (name[2] == 'n' &&
6519 if (name[2] == 'r' &&
6528 if (name[2] == 'r' &&
6537 if (name[2] == 'a' &&
6553 if (name[2] == 'l' &&
6620 case 5: /* 36 tokens of length 5 */
6624 if (name[1] == 'E' &&
6635 if (name[1] == 'H' &&
6649 if (name[2] == 'a' &&
6659 if (name[2] == 'a' &&
6673 if (name[1] == 'l' &&
6690 if (name[3] == 'i' &&
6699 if (name[3] == 'o' &&
6735 if (name[2] == 'o' &&
6745 if (name[2] == 'y' &&
6759 if (name[1] == 'l' &&
6773 if (name[2] == 'n' &&
6783 if (name[2] == 'o' &&
6800 if (name[2] == 'd' &&
6810 if (name[2] == 'c' &&
6827 if (name[2] == 'c' &&
6837 if (name[2] == 't' &&
6851 if (name[1] == 'k' &&
6862 if (name[1] == 'r' &&
6876 if (name[2] == 's' &&
6886 if (name[2] == 'd' &&
6903 if (name[2] == 'm' &&
6913 if (name[2] == 'i' &&
6923 if (name[2] == 'e' &&
6933 if (name[2] == 'l' &&
6943 if (name[2] == 'a' &&
6953 if (name[2] == 'u' &&
6967 if (name[1] == 'i' &&
6981 if (name[2] == 'a' &&
6994 if (name[3] == 'e' &&
7029 if (name[2] == 'i' &&
7046 if (name[2] == 'i' &&
7056 if (name[2] == 'i' &&
7073 case 6: /* 33 tokens of length 6 */
7077 if (name[1] == 'c' &&
7092 if (name[2] == 'l' &&
7103 if (name[2] == 'r' &&
7118 if (name[1] == 'e' &&
7133 if (name[2] == 's' &&
7138 if(ckWARN_d(WARN_SYNTAX))
7139 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7145 if (name[2] == 'i' &&
7163 if (name[2] == 'l' &&
7174 if (name[2] == 'r' &&
7189 if (name[1] == 'm' &&
7204 if (name[2] == 'n' &&
7215 if (name[2] == 's' &&
7230 if (name[1] == 's' &&
7236 if (name[4] == 't' &&
7245 if (name[4] == 'e' &&
7254 if (name[4] == 'c' &&
7263 if (name[4] == 'n' &&
7279 if (name[1] == 'r' &&
7297 if (name[3] == 'a' &&
7307 if (name[3] == 'u' &&
7321 if (name[2] == 'n' &&
7339 if (name[2] == 'a' &&
7353 if (name[3] == 'e' &&
7366 if (name[4] == 't' &&
7375 if (name[4] == 'e' &&
7397 if (name[4] == 't' &&
7406 if (name[4] == 'e' &&
7422 if (name[2] == 'c' &&
7433 if (name[2] == 'l' &&
7444 if (name[2] == 'b' &&
7455 if (name[2] == 's' &&
7478 if (name[4] == 's' &&
7487 if (name[4] == 'n' &&
7500 if (name[3] == 'a' &&
7517 if (name[1] == 'a' &&
7532 case 7: /* 28 tokens of length 7 */
7536 if (name[1] == 'E' &&
7549 if (name[1] == '_' &&
7562 if (name[1] == 'i' &&
7569 return -KEY_binmode;
7575 if (name[1] == 'o' &&
7582 return -KEY_connect;
7591 if (name[2] == 'm' &&
7597 return -KEY_dbmopen;
7603 if (name[2] == 'f' &&
7619 if (name[1] == 'o' &&
7632 if (name[1] == 'e' &&
7639 if (name[5] == 'r' &&
7642 return -KEY_getpgrp;
7648 if (name[5] == 'i' &&
7651 return -KEY_getppid;
7664 if (name[1] == 'c' &&
7671 return -KEY_lcfirst;
7677 if (name[1] == 'p' &&
7684 return -KEY_opendir;
7690 if (name[1] == 'a' &&
7708 if (name[3] == 'd' &&
7713 return -KEY_readdir;
7719 if (name[3] == 'u' &&
7730 if (name[3] == 'e' &&
7735 return -KEY_reverse;
7754 if (name[3] == 'k' &&
7759 return -KEY_seekdir;
7765 if (name[3] == 'p' &&
7770 return -KEY_setpgrp;
7780 if (name[2] == 'm' &&
7786 return -KEY_shmread;
7792 if (name[2] == 'r' &&
7798 return -KEY_sprintf;
7807 if (name[3] == 'l' &&
7812 return -KEY_symlink;
7821 if (name[4] == 'a' &&
7825 return -KEY_syscall;
7831 if (name[4] == 'p' &&
7835 return -KEY_sysopen;
7841 if (name[4] == 'e' &&
7845 return -KEY_sysread;
7851 if (name[4] == 'e' &&
7855 return -KEY_sysseek;
7873 if (name[1] == 'e' &&
7880 return -KEY_telldir;
7889 if (name[2] == 'f' &&
7895 return -KEY_ucfirst;
7901 if (name[2] == 's' &&
7907 return -KEY_unshift;
7917 if (name[1] == 'a' &&
7924 return -KEY_waitpid;
7933 case 8: /* 26 tokens of length 8 */
7937 if (name[1] == 'U' &&
7945 return KEY_AUTOLOAD;
7956 if (name[3] == 'A' &&
7962 return KEY___DATA__;
7968 if (name[3] == 'I' &&
7974 return -KEY___FILE__;
7980 if (name[3] == 'I' &&
7986 return -KEY___LINE__;
8002 if (name[2] == 'o' &&
8009 return -KEY_closedir;
8015 if (name[2] == 'n' &&
8022 return -KEY_continue;
8032 if (name[1] == 'b' &&
8040 return -KEY_dbmclose;
8046 if (name[1] == 'n' &&
8052 if (name[4] == 'r' &&
8057 return -KEY_endgrent;
8063 if (name[4] == 'w' &&
8068 return -KEY_endpwent;
8081 if (name[1] == 'o' &&
8089 return -KEY_formline;
8095 if (name[1] == 'e' &&
8106 if (name[6] == 'n' &&
8109 return -KEY_getgrent;
8115 if (name[6] == 'i' &&
8118 return -KEY_getgrgid;
8124 if (name[6] == 'a' &&
8127 return -KEY_getgrnam;
8140 if (name[4] == 'o' &&
8145 return -KEY_getlogin;
8156 if (name[6] == 'n' &&
8159 return -KEY_getpwent;
8165 if (name[6] == 'a' &&
8168 return -KEY_getpwnam;
8174 if (name[6] == 'i' &&
8177 return -KEY_getpwuid;
8197 if (name[1] == 'e' &&
8204 if (name[5] == 'i' &&
8211 return -KEY_readline;
8216 return -KEY_readlink;
8227 if (name[5] == 'i' &&
8231 return -KEY_readpipe;
8252 if (name[4] == 'r' &&
8257 return -KEY_setgrent;
8263 if (name[4] == 'w' &&
8268 return -KEY_setpwent;
8284 if (name[3] == 'w' &&
8290 return -KEY_shmwrite;
8296 if (name[3] == 't' &&
8302 return -KEY_shutdown;
8312 if (name[2] == 's' &&
8319 return -KEY_syswrite;
8329 if (name[1] == 'r' &&
8337 return -KEY_truncate;
8346 case 9: /* 8 tokens of length 9 */
8350 if (name[1] == 'n' &&
8359 return -KEY_endnetent;
8365 if (name[1] == 'e' &&
8374 return -KEY_getnetent;
8380 if (name[1] == 'o' &&
8389 return -KEY_localtime;
8395 if (name[1] == 'r' &&
8404 return KEY_prototype;
8410 if (name[1] == 'u' &&
8419 return -KEY_quotemeta;
8425 if (name[1] == 'e' &&
8434 return -KEY_rewinddir;
8440 if (name[1] == 'e' &&
8449 return -KEY_setnetent;
8455 if (name[1] == 'a' &&
8464 return -KEY_wantarray;
8473 case 10: /* 9 tokens of length 10 */
8477 if (name[1] == 'n' &&
8483 if (name[4] == 'o' &&
8490 return -KEY_endhostent;
8496 if (name[4] == 'e' &&
8503 return -KEY_endservent;
8516 if (name[1] == 'e' &&
8522 if (name[4] == 'o' &&
8529 return -KEY_gethostent;
8538 if (name[5] == 'r' &&
8544 return -KEY_getservent;
8550 if (name[5] == 'c' &&
8556 return -KEY_getsockopt;
8581 if (name[4] == 'o' &&
8588 return -KEY_sethostent;
8597 if (name[5] == 'r' &&
8603 return -KEY_setservent;
8609 if (name[5] == 'c' &&
8615 return -KEY_setsockopt;
8632 if (name[2] == 'c' &&
8641 return -KEY_socketpair;
8654 case 11: /* 8 tokens of length 11 */
8658 if (name[1] == '_' &&
8669 return -KEY___PACKAGE__;
8675 if (name[1] == 'n' &&
8686 return -KEY_endprotoent;
8692 if (name[1] == 'e' &&
8701 if (name[5] == 'e' &&
8708 return -KEY_getpeername;
8717 if (name[6] == 'o' &&
8723 return -KEY_getpriority;
8729 if (name[6] == 't' &&
8735 return -KEY_getprotoent;
8749 if (name[4] == 'o' &&
8757 return -KEY_getsockname;
8770 if (name[1] == 'e' &&
8778 if (name[6] == 'o' &&
8784 return -KEY_setpriority;
8790 if (name[6] == 't' &&
8796 return -KEY_setprotoent;
8812 case 12: /* 2 tokens of length 12 */
8813 if (name[0] == 'g' &&
8825 if (name[9] == 'd' &&
8828 { /* getnetbyaddr */
8829 return -KEY_getnetbyaddr;
8835 if (name[9] == 'a' &&
8838 { /* getnetbyname */
8839 return -KEY_getnetbyname;
8851 case 13: /* 4 tokens of length 13 */
8852 if (name[0] == 'g' &&
8859 if (name[4] == 'o' &&
8868 if (name[10] == 'd' &&
8871 { /* gethostbyaddr */
8872 return -KEY_gethostbyaddr;
8878 if (name[10] == 'a' &&
8881 { /* gethostbyname */
8882 return -KEY_gethostbyname;
8895 if (name[4] == 'e' &&
8904 if (name[10] == 'a' &&
8907 { /* getservbyname */
8908 return -KEY_getservbyname;
8914 if (name[10] == 'o' &&
8917 { /* getservbyport */
8918 return -KEY_getservbyport;
8937 case 14: /* 1 tokens of length 14 */
8938 if (name[0] == 'g' &&
8952 { /* getprotobyname */
8953 return -KEY_getprotobyname;
8958 case 16: /* 1 tokens of length 16 */
8959 if (name[0] == 'g' &&
8975 { /* getprotobynumber */
8976 return -KEY_getprotobynumber;
8990 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
8994 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8995 if (ckWARN(WARN_SYNTAX)) {
8997 for (w = s+2; *w && level; w++) {
9004 for (; *w && isSPACE(*w); w++) ;
9005 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
9006 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9007 "%s (...) interpreted as function",name);
9010 while (s < PL_bufend && isSPACE(*s))
9014 while (s < PL_bufend && isSPACE(*s))
9016 if (isIDFIRST_lazy_if(s,UTF)) {
9018 while (isALNUM_lazy_if(s,UTF))
9020 while (s < PL_bufend && isSPACE(*s))
9024 *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9025 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9029 Perl_croak(aTHX_ "No comma allowed after %s", what);
9034 /* Either returns sv, or mortalizes sv and returns a new SV*.
9035 Best used as sv=new_constant(..., sv, ...).
9036 If s, pv are NULL, calls subroutine with one argument,
9037 and type is used with error messages only. */
9040 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9044 HV * const table = GvHV(PL_hintgv); /* ^H */
9048 const char *why1 = "", *why2 = "", *why3 = "";
9050 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9053 why2 = strEQ(key,"charnames")
9054 ? "(possibly a missing \"use charnames ...\")"
9056 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9057 (type ? type: "undef"), why2);
9059 /* This is convoluted and evil ("goto considered harmful")
9060 * but I do not understand the intricacies of all the different
9061 * failure modes of %^H in here. The goal here is to make
9062 * the most probable error message user-friendly. --jhi */
9067 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9068 (type ? type: "undef"), why1, why2, why3);
9070 yyerror(SvPVX_const(msg));
9074 cvp = hv_fetch(table, key, strlen(key), FALSE);
9075 if (!cvp || !SvOK(*cvp)) {
9078 why3 = "} is not defined";
9081 sv_2mortal(sv); /* Parent created it permanently */
9084 pv = sv_2mortal(newSVpvn(s, len));
9086 typesv = sv_2mortal(newSVpv(type, 0));
9088 typesv = &PL_sv_undef;
9090 PUSHSTACKi(PERLSI_OVERLOAD);
9102 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9106 /* Check the eval first */
9107 if (!PL_in_eval && SvTRUE(ERRSV)) {
9108 sv_catpv(ERRSV, "Propagated");
9109 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9111 res = SvREFCNT_inc(sv);
9115 (void)SvREFCNT_inc(res);
9124 why1 = "Call to &{$^H{";
9126 why3 = "}} did not return a defined value";
9134 /* Returns a NUL terminated string, with the length of the string written to
9138 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9140 register char *d = dest;
9141 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
9144 Perl_croak(aTHX_ ident_too_long);
9145 if (isALNUM(*s)) /* UTF handled below */
9147 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9152 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9156 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9157 char *t = s + UTF8SKIP(s);
9158 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9160 if (d + (t - s) > e)
9161 Perl_croak(aTHX_ ident_too_long);
9162 Copy(s, d, t - s, char);
9175 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9179 char *bracket = Nullch;
9185 e = d + destlen - 3; /* two-character token, ending NUL */
9187 while (isDIGIT(*s)) {
9189 Perl_croak(aTHX_ ident_too_long);
9196 Perl_croak(aTHX_ ident_too_long);
9197 if (isALNUM(*s)) /* UTF handled below */
9199 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9204 else if (*s == ':' && s[1] == ':') {
9208 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9209 char *t = s + UTF8SKIP(s);
9210 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9212 if (d + (t - s) > e)
9213 Perl_croak(aTHX_ ident_too_long);
9214 Copy(s, d, t - s, char);
9225 if (PL_lex_state != LEX_NORMAL)
9226 PL_lex_state = LEX_INTERPENDMAYBE;
9229 if (*s == '$' && s[1] &&
9230 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9243 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9248 if (isSPACE(s[-1])) {
9250 const char ch = *s++;
9251 if (!SPACE_OR_TAB(ch)) {
9257 if (isIDFIRST_lazy_if(d,UTF)) {
9261 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9263 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9266 Copy(s, d, e - s, char);
9271 while ((isALNUM(*s) || *s == ':') && d < e)
9274 Perl_croak(aTHX_ ident_too_long);
9277 while (s < send && SPACE_OR_TAB(*s)) s++;
9278 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9279 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9280 const char *brack = *s == '[' ? "[...]" : "{...}";
9281 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9282 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9283 funny, dest, brack, funny, dest, brack);
9286 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9290 /* Handle extended ${^Foo} variables
9291 * 1999-02-27 mjd-perl-patch@plover.com */
9292 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9296 while (isALNUM(*s) && d < e) {
9300 Perl_croak(aTHX_ ident_too_long);
9305 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9306 PL_lex_state = LEX_INTERPEND;
9311 if (PL_lex_state == LEX_NORMAL) {
9312 if (ckWARN(WARN_AMBIGUOUS) &&
9313 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9315 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9316 "Ambiguous use of %c{%s} resolved to %c%s",
9317 funny, dest, funny, dest);
9322 s = bracket; /* let the parser handle it */
9326 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9327 PL_lex_state = LEX_INTERPEND;
9332 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9337 *pmfl |= PMf_GLOBAL;
9339 *pmfl |= PMf_CONTINUE;
9343 *pmfl |= PMf_MULTILINE;
9345 *pmfl |= PMf_SINGLELINE;
9347 *pmfl |= PMf_EXTENDED;
9351 S_scan_pat(pTHX_ char *start, I32 type)
9354 char *s = scan_str(start,FALSE,FALSE);
9357 char * const delimiter = skipspace(start);
9358 Perl_croak(aTHX_ *delimiter == '?'
9359 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9360 : "Search pattern not terminated" );
9363 pm = (PMOP*)newPMOP(type, 0);
9364 if (PL_multi_open == '?')
9365 pm->op_pmflags |= PMf_ONCE;
9367 while (*s && strchr("iomsx", *s))
9368 pmflag(&pm->op_pmflags,*s++);
9371 while (*s && strchr("iogcmsx", *s))
9372 pmflag(&pm->op_pmflags,*s++);
9374 /* issue a warning if /c is specified,but /g is not */
9375 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9376 && ckWARN(WARN_REGEXP))
9378 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
9381 pm->op_pmpermflags = pm->op_pmflags;
9383 PL_lex_op = (OP*)pm;
9384 yylval.ival = OP_MATCH;
9389 S_scan_subst(pTHX_ char *start)
9397 yylval.ival = OP_NULL;
9399 s = scan_str(start,FALSE,FALSE);
9402 Perl_croak(aTHX_ "Substitution pattern not terminated");
9404 if (s[-1] == PL_multi_open)
9407 first_start = PL_multi_start;
9408 s = scan_str(s,FALSE,FALSE);
9411 SvREFCNT_dec(PL_lex_stuff);
9412 PL_lex_stuff = Nullsv;
9414 Perl_croak(aTHX_ "Substitution replacement not terminated");
9416 PL_multi_start = first_start; /* so whole substitution is taken together */
9418 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9424 else if (strchr("iogcmsx", *s))
9425 pmflag(&pm->op_pmflags,*s++);
9430 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
9431 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9436 PL_sublex_info.super_bufptr = s;
9437 PL_sublex_info.super_bufend = PL_bufend;
9439 pm->op_pmflags |= PMf_EVAL;
9440 repl = newSVpvn("",0);
9442 sv_catpv(repl, es ? "eval " : "do ");
9443 sv_catpvn(repl, "{ ", 2);
9444 sv_catsv(repl, PL_lex_repl);
9445 sv_catpvn(repl, " };", 2);
9447 SvREFCNT_dec(PL_lex_repl);
9451 pm->op_pmpermflags = pm->op_pmflags;
9452 PL_lex_op = (OP*)pm;
9453 yylval.ival = OP_SUBST;
9458 S_scan_trans(pTHX_ char *start)
9467 yylval.ival = OP_NULL;
9469 s = scan_str(start,FALSE,FALSE);
9471 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9472 if (s[-1] == PL_multi_open)
9475 s = scan_str(s,FALSE,FALSE);
9478 SvREFCNT_dec(PL_lex_stuff);
9479 PL_lex_stuff = Nullsv;
9481 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9484 complement = del = squash = 0;
9488 complement = OPpTRANS_COMPLEMENT;
9491 del = OPpTRANS_DELETE;
9494 squash = OPpTRANS_SQUASH;
9503 Newx(tbl, complement&&!del?258:256, short);
9504 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9505 o->op_private &= ~OPpTRANS_ALL;
9506 o->op_private |= del|squash|complement|
9507 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9508 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9511 yylval.ival = OP_TRANS;
9516 S_scan_heredoc(pTHX_ register char *s)
9519 I32 op_type = OP_SCALAR;
9523 const char newline[] = "\n";
9524 const char *found_newline;
9528 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9532 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9535 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9536 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9539 s = delimcpy(d, e, s, PL_bufend, term, &len);
9549 if (!isALNUM_lazy_if(s,UTF))
9550 deprecate_old("bare << to mean <<\"\"");
9551 for (; isALNUM_lazy_if(s,UTF); s++) {
9556 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9557 Perl_croak(aTHX_ "Delimiter for here document is too long");
9560 len = d - PL_tokenbuf;
9561 #ifndef PERL_STRICT_CR
9562 d = strchr(s, '\r');
9564 char * const olds = s;
9566 while (s < PL_bufend) {
9572 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9581 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9585 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9586 herewas = newSVpvn(s,PL_bufend-s);
9590 herewas = newSVpvn(s,found_newline-s);
9592 s += SvCUR(herewas);
9594 tmpstr = NEWSV(87,79);
9595 sv_upgrade(tmpstr, SVt_PVIV);
9598 SvIV_set(tmpstr, -1);
9600 else if (term == '`') {
9601 op_type = OP_BACKTICK;
9602 SvIV_set(tmpstr, '\\');
9606 PL_multi_start = CopLINE(PL_curcop);
9607 PL_multi_open = PL_multi_close = '<';
9608 term = *PL_tokenbuf;
9609 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9610 char *bufptr = PL_sublex_info.super_bufptr;
9611 char *bufend = PL_sublex_info.super_bufend;
9612 char * const olds = s - SvCUR(herewas);
9613 s = strchr(bufptr, '\n');
9617 while (s < bufend &&
9618 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9620 CopLINE_inc(PL_curcop);
9623 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9624 missingterm(PL_tokenbuf);
9626 sv_setpvn(herewas,bufptr,d-bufptr+1);
9627 sv_setpvn(tmpstr,d+1,s-d);
9629 sv_catpvn(herewas,s,bufend-s);
9630 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9637 while (s < PL_bufend &&
9638 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9640 CopLINE_inc(PL_curcop);
9642 if (s >= PL_bufend) {
9643 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9644 missingterm(PL_tokenbuf);
9646 sv_setpvn(tmpstr,d+1,s-d);
9648 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9650 sv_catpvn(herewas,s,PL_bufend-s);
9651 sv_setsv(PL_linestr,herewas);
9652 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9653 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9654 PL_last_lop = PL_last_uni = Nullch;
9657 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9658 while (s >= PL_bufend) { /* multiple line string? */
9660 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9661 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9662 missingterm(PL_tokenbuf);
9664 CopLINE_inc(PL_curcop);
9665 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9666 PL_last_lop = PL_last_uni = Nullch;
9667 #ifndef PERL_STRICT_CR
9668 if (PL_bufend - PL_linestart >= 2) {
9669 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9670 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9672 PL_bufend[-2] = '\n';
9674 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9676 else if (PL_bufend[-1] == '\r')
9677 PL_bufend[-1] = '\n';
9679 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9680 PL_bufend[-1] = '\n';
9682 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9683 SV *sv = NEWSV(88,0);
9685 sv_upgrade(sv, SVt_PVMG);
9686 sv_setsv(sv,PL_linestr);
9689 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9691 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9692 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9693 *(SvPVX(PL_linestr) + off ) = ' ';
9694 sv_catsv(PL_linestr,herewas);
9695 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9696 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9700 sv_catsv(tmpstr,PL_linestr);
9705 PL_multi_end = CopLINE(PL_curcop);
9706 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9707 SvPV_shrink_to_cur(tmpstr);
9709 SvREFCNT_dec(herewas);
9711 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9713 else if (PL_encoding)
9714 sv_recode_to_utf8(tmpstr, PL_encoding);
9716 PL_lex_stuff = tmpstr;
9717 yylval.ival = op_type;
9722 takes: current position in input buffer
9723 returns: new position in input buffer
9724 side-effects: yylval and lex_op are set.
9729 <FH> read from filehandle
9730 <pkg::FH> read from package qualified filehandle
9731 <pkg'FH> read from package qualified filehandle
9732 <$fh> read from filehandle in $fh
9738 S_scan_inputsymbol(pTHX_ char *start)
9740 register char *s = start; /* current position in buffer */
9746 d = PL_tokenbuf; /* start of temp holding space */
9747 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9748 end = strchr(s, '\n');
9751 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9753 /* die if we didn't have space for the contents of the <>,
9754 or if it didn't end, or if we see a newline
9757 if (len >= sizeof PL_tokenbuf)
9758 Perl_croak(aTHX_ "Excessively long <> operator");
9760 Perl_croak(aTHX_ "Unterminated <> operator");
9765 Remember, only scalar variables are interpreted as filehandles by
9766 this code. Anything more complex (e.g., <$fh{$num}>) will be
9767 treated as a glob() call.
9768 This code makes use of the fact that except for the $ at the front,
9769 a scalar variable and a filehandle look the same.
9771 if (*d == '$' && d[1]) d++;
9773 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9774 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9777 /* If we've tried to read what we allow filehandles to look like, and
9778 there's still text left, then it must be a glob() and not a getline.
9779 Use scan_str to pull out the stuff between the <> and treat it
9780 as nothing more than a string.
9783 if (d - PL_tokenbuf != len) {
9784 yylval.ival = OP_GLOB;
9786 s = scan_str(start,FALSE,FALSE);
9788 Perl_croak(aTHX_ "Glob not terminated");
9792 bool readline_overriden = FALSE;
9793 GV *gv_readline = Nullgv;
9795 /* we're in a filehandle read situation */
9798 /* turn <> into <ARGV> */
9800 Copy("ARGV",d,5,char);
9802 /* Check whether readline() is overriden */
9803 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9804 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9806 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9807 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9808 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9809 readline_overriden = TRUE;
9811 /* if <$fh>, create the ops to turn the variable into a
9817 /* try to find it in the pad for this block, otherwise find
9818 add symbol table ops
9820 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9821 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9822 HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9823 HEK *stashname = HvNAME_HEK(stash);
9824 SV *sym = sv_2mortal(newSVhek(stashname));
9825 sv_catpvn(sym, "::", 2);
9831 OP *o = newOP(OP_PADSV, 0);
9833 PL_lex_op = readline_overriden
9834 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9835 append_elem(OP_LIST, o,
9836 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9837 : (OP*)newUNOP(OP_READLINE, 0, o);
9846 ? (GV_ADDMULTI | GV_ADDINEVAL)
9849 PL_lex_op = readline_overriden
9850 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9851 append_elem(OP_LIST,
9852 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9853 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9854 : (OP*)newUNOP(OP_READLINE, 0,
9855 newUNOP(OP_RV2SV, 0,
9856 newGVOP(OP_GV, 0, gv)));
9858 if (!readline_overriden)
9859 PL_lex_op->op_flags |= OPf_SPECIAL;
9860 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9861 yylval.ival = OP_NULL;
9864 /* If it's none of the above, it must be a literal filehandle
9865 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9867 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9868 PL_lex_op = readline_overriden
9869 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9870 append_elem(OP_LIST,
9871 newGVOP(OP_GV, 0, gv),
9872 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9873 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9874 yylval.ival = OP_NULL;
9883 takes: start position in buffer
9884 keep_quoted preserve \ on the embedded delimiter(s)
9885 keep_delims preserve the delimiters around the string
9886 returns: position to continue reading from buffer
9887 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9888 updates the read buffer.
9890 This subroutine pulls a string out of the input. It is called for:
9891 q single quotes q(literal text)
9892 ' single quotes 'literal text'
9893 qq double quotes qq(interpolate $here please)
9894 " double quotes "interpolate $here please"
9895 qx backticks qx(/bin/ls -l)
9896 ` backticks `/bin/ls -l`
9897 qw quote words @EXPORT_OK = qw( func() $spam )
9898 m// regexp match m/this/
9899 s/// regexp substitute s/this/that/
9900 tr/// string transliterate tr/this/that/
9901 y/// string transliterate y/this/that/
9902 ($*@) sub prototypes sub foo ($)
9903 (stuff) sub attr parameters sub foo : attr(stuff)
9904 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9906 In most of these cases (all but <>, patterns and transliterate)
9907 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9908 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9909 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9912 It skips whitespace before the string starts, and treats the first
9913 character as the delimiter. If the delimiter is one of ([{< then
9914 the corresponding "close" character )]}> is used as the closing
9915 delimiter. It allows quoting of delimiters, and if the string has
9916 balanced delimiters ([{<>}]) it allows nesting.
9918 On success, the SV with the resulting string is put into lex_stuff or,
9919 if that is already non-NULL, into lex_repl. The second case occurs only
9920 when parsing the RHS of the special constructs s/// and tr/// (y///).
9921 For convenience, the terminating delimiter character is stuffed into
9926 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9928 SV *sv; /* scalar value: string */
9929 char *tmps; /* temp string, used for delimiter matching */
9930 register char *s = start; /* current position in the buffer */
9931 register char term; /* terminating character */
9932 register char *to; /* current position in the sv's data */
9933 I32 brackets = 1; /* bracket nesting level */
9934 bool has_utf8 = FALSE; /* is there any utf8 content? */
9935 I32 termcode; /* terminating char. code */
9936 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9937 STRLEN termlen; /* length of terminating string */
9938 char *last = NULL; /* last position for nesting bracket */
9940 /* skip space before the delimiter */
9944 /* mark where we are, in case we need to report errors */
9947 /* after skipping whitespace, the next character is the terminator */
9950 termcode = termstr[0] = term;
9954 termcode = utf8_to_uvchr((U8*)s, &termlen);
9955 Copy(s, termstr, termlen, U8);
9956 if (!UTF8_IS_INVARIANT(term))
9960 /* mark where we are */
9961 PL_multi_start = CopLINE(PL_curcop);
9962 PL_multi_open = term;
9964 /* find corresponding closing delimiter */
9965 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9966 termcode = termstr[0] = term = tmps[5];
9968 PL_multi_close = term;
9970 /* create a new SV to hold the contents. 87 is leak category, I'm
9971 assuming. 79 is the SV's initial length. What a random number. */
9973 sv_upgrade(sv, SVt_PVIV);
9974 SvIV_set(sv, termcode);
9975 (void)SvPOK_only(sv); /* validate pointer */
9977 /* move past delimiter and try to read a complete string */
9979 sv_catpvn(sv, s, termlen);
9982 if (PL_encoding && !UTF) {
9986 int offset = s - SvPVX_const(PL_linestr);
9987 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9988 &offset, (char*)termstr, termlen);
9989 const char *ns = SvPVX_const(PL_linestr) + offset;
9990 char *svlast = SvEND(sv) - 1;
9992 for (; s < ns; s++) {
9993 if (*s == '\n' && !PL_rsfp)
9994 CopLINE_inc(PL_curcop);
9997 goto read_more_line;
9999 /* handle quoted delimiters */
10000 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
10002 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
10004 if ((svlast-1 - t) % 2) {
10005 if (!keep_quoted) {
10006 *(svlast-1) = term;
10008 SvCUR_set(sv, SvCUR(sv) - 1);
10013 if (PL_multi_open == PL_multi_close) {
10021 for (t = w = last; t < svlast; w++, t++) {
10022 /* At here, all closes are "was quoted" one,
10023 so we don't check PL_multi_close. */
10025 if (!keep_quoted && *(t+1) == PL_multi_open)
10030 else if (*t == PL_multi_open)
10038 SvCUR_set(sv, w - SvPVX_const(sv));
10041 if (--brackets <= 0)
10046 if (!keep_delims) {
10047 SvCUR_set(sv, SvCUR(sv) - 1);
10053 /* extend sv if need be */
10054 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10055 /* set 'to' to the next character in the sv's string */
10056 to = SvPVX(sv)+SvCUR(sv);
10058 /* if open delimiter is the close delimiter read unbridle */
10059 if (PL_multi_open == PL_multi_close) {
10060 for (; s < PL_bufend; s++,to++) {
10061 /* embedded newlines increment the current line number */
10062 if (*s == '\n' && !PL_rsfp)
10063 CopLINE_inc(PL_curcop);
10064 /* handle quoted delimiters */
10065 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10066 if (!keep_quoted && s[1] == term)
10068 /* any other quotes are simply copied straight through */
10072 /* terminate when run out of buffer (the for() condition), or
10073 have found the terminator */
10074 else if (*s == term) {
10077 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10080 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10086 /* if the terminator isn't the same as the start character (e.g.,
10087 matched brackets), we have to allow more in the quoting, and
10088 be prepared for nested brackets.
10091 /* read until we run out of string, or we find the terminator */
10092 for (; s < PL_bufend; s++,to++) {
10093 /* embedded newlines increment the line count */
10094 if (*s == '\n' && !PL_rsfp)
10095 CopLINE_inc(PL_curcop);
10096 /* backslashes can escape the open or closing characters */
10097 if (*s == '\\' && s+1 < PL_bufend) {
10098 if (!keep_quoted &&
10099 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10104 /* allow nested opens and closes */
10105 else if (*s == PL_multi_close && --brackets <= 0)
10107 else if (*s == PL_multi_open)
10109 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10114 /* terminate the copied string and update the sv's end-of-string */
10116 SvCUR_set(sv, to - SvPVX_const(sv));
10119 * this next chunk reads more into the buffer if we're not done yet
10123 break; /* handle case where we are done yet :-) */
10125 #ifndef PERL_STRICT_CR
10126 if (to - SvPVX_const(sv) >= 2) {
10127 if ((to[-2] == '\r' && to[-1] == '\n') ||
10128 (to[-2] == '\n' && to[-1] == '\r'))
10132 SvCUR_set(sv, to - SvPVX_const(sv));
10134 else if (to[-1] == '\r')
10137 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10142 /* if we're out of file, or a read fails, bail and reset the current
10143 line marker so we can report where the unterminated string began
10146 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10148 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10151 /* we read a line, so increment our line counter */
10152 CopLINE_inc(PL_curcop);
10154 /* update debugger info */
10155 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10156 SV *sv = NEWSV(88,0);
10158 sv_upgrade(sv, SVt_PVMG);
10159 sv_setsv(sv,PL_linestr);
10160 (void)SvIOK_on(sv);
10162 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10165 /* having changed the buffer, we must update PL_bufend */
10166 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10167 PL_last_lop = PL_last_uni = Nullch;
10170 /* at this point, we have successfully read the delimited string */
10172 if (!PL_encoding || UTF) {
10174 sv_catpvn(sv, s, termlen);
10177 if (has_utf8 || PL_encoding)
10180 PL_multi_end = CopLINE(PL_curcop);
10182 /* if we allocated too much space, give some back */
10183 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10184 SvLEN_set(sv, SvCUR(sv) + 1);
10185 SvPV_renew(sv, SvLEN(sv));
10188 /* decide whether this is the first or second quoted string we've read
10201 takes: pointer to position in buffer
10202 returns: pointer to new position in buffer
10203 side-effects: builds ops for the constant in yylval.op
10205 Read a number in any of the formats that Perl accepts:
10207 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10208 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10211 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10213 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10216 If it reads a number without a decimal point or an exponent, it will
10217 try converting the number to an integer and see if it can do so
10218 without loss of precision.
10222 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10224 register const char *s = start; /* current position in buffer */
10225 register char *d; /* destination in temp buffer */
10226 register char *e; /* end of temp buffer */
10227 NV nv; /* number read, as a double */
10228 SV *sv = Nullsv; /* place to put the converted number */
10229 bool floatit; /* boolean: int or float? */
10230 const char *lastub = 0; /* position of last underbar */
10231 static char const number_too_long[] = "Number too long";
10233 /* We use the first character to decide what type of number this is */
10237 Perl_croak(aTHX_ "panic: scan_num");
10239 /* if it starts with a 0, it could be an octal number, a decimal in
10240 0.13 disguise, or a hexadecimal number, or a binary number. */
10244 u holds the "number so far"
10245 shift the power of 2 of the base
10246 (hex == 4, octal == 3, binary == 1)
10247 overflowed was the number more than we can hold?
10249 Shift is used when we add a digit. It also serves as an "are
10250 we in octal/hex/binary?" indicator to disallow hex characters
10251 when in octal mode.
10256 bool overflowed = FALSE;
10257 bool just_zero = TRUE; /* just plain 0 or binary number? */
10258 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10259 static const char* const bases[5] =
10260 { "", "binary", "", "octal", "hexadecimal" };
10261 static const char* const Bases[5] =
10262 { "", "Binary", "", "Octal", "Hexadecimal" };
10263 static const char* const maxima[5] =
10265 "0b11111111111111111111111111111111",
10269 const char *base, *Base, *max;
10271 /* check for hex */
10276 } else if (s[1] == 'b') {
10281 /* check for a decimal in disguise */
10282 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10284 /* so it must be octal */
10291 if (ckWARN(WARN_SYNTAX))
10292 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10293 "Misplaced _ in number");
10297 base = bases[shift];
10298 Base = Bases[shift];
10299 max = maxima[shift];
10301 /* read the rest of the number */
10303 /* x is used in the overflow test,
10304 b is the digit we're adding on. */
10309 /* if we don't mention it, we're done */
10313 /* _ are ignored -- but warned about if consecutive */
10315 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10316 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10317 "Misplaced _ in number");
10321 /* 8 and 9 are not octal */
10322 case '8': case '9':
10324 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10328 case '2': case '3': case '4':
10329 case '5': case '6': case '7':
10331 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10334 case '0': case '1':
10335 b = *s++ & 15; /* ASCII digit -> value of digit */
10339 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10340 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10341 /* make sure they said 0x */
10344 b = (*s++ & 7) + 9;
10346 /* Prepare to put the digit we have onto the end
10347 of the number so far. We check for overflows.
10353 x = u << shift; /* make room for the digit */
10355 if ((x >> shift) != u
10356 && !(PL_hints & HINT_NEW_BINARY)) {
10359 if (ckWARN_d(WARN_OVERFLOW))
10360 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10361 "Integer overflow in %s number",
10364 u = x | b; /* add the digit to the end */
10367 n *= nvshift[shift];
10368 /* If an NV has not enough bits in its
10369 * mantissa to represent an UV this summing of
10370 * small low-order numbers is a waste of time
10371 * (because the NV cannot preserve the
10372 * low-order bits anyway): we could just
10373 * remember when did we overflow and in the
10374 * end just multiply n by the right
10382 /* if we get here, we had success: make a scalar value from
10387 /* final misplaced underbar check */
10388 if (s[-1] == '_') {
10389 if (ckWARN(WARN_SYNTAX))
10390 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10395 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10396 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10397 "%s number > %s non-portable",
10403 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10404 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10405 "%s number > %s non-portable",
10410 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10411 sv = new_constant(start, s - start, "integer",
10413 else if (PL_hints & HINT_NEW_BINARY)
10414 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10419 handle decimal numbers.
10420 we're also sent here when we read a 0 as the first digit
10422 case '1': case '2': case '3': case '4': case '5':
10423 case '6': case '7': case '8': case '9': case '.':
10426 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10429 /* read next group of digits and _ and copy into d */
10430 while (isDIGIT(*s) || *s == '_') {
10431 /* skip underscores, checking for misplaced ones
10435 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10436 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10437 "Misplaced _ in number");
10441 /* check for end of fixed-length buffer */
10443 Perl_croak(aTHX_ number_too_long);
10444 /* if we're ok, copy the character */
10449 /* final misplaced underbar check */
10450 if (lastub && s == lastub + 1) {
10451 if (ckWARN(WARN_SYNTAX))
10452 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10455 /* read a decimal portion if there is one. avoid
10456 3..5 being interpreted as the number 3. followed
10459 if (*s == '.' && s[1] != '.') {
10464 if (ckWARN(WARN_SYNTAX))
10465 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10466 "Misplaced _ in number");
10470 /* copy, ignoring underbars, until we run out of digits.
10472 for (; isDIGIT(*s) || *s == '_'; s++) {
10473 /* fixed length buffer check */
10475 Perl_croak(aTHX_ number_too_long);
10477 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10478 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10479 "Misplaced _ in number");
10485 /* fractional part ending in underbar? */
10486 if (s[-1] == '_') {
10487 if (ckWARN(WARN_SYNTAX))
10488 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10489 "Misplaced _ in number");
10491 if (*s == '.' && isDIGIT(s[1])) {
10492 /* oops, it's really a v-string, but without the "v" */
10498 /* read exponent part, if present */
10499 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10503 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10504 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10506 /* stray preinitial _ */
10508 if (ckWARN(WARN_SYNTAX))
10509 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10510 "Misplaced _ in number");
10514 /* allow positive or negative exponent */
10515 if (*s == '+' || *s == '-')
10518 /* stray initial _ */
10520 if (ckWARN(WARN_SYNTAX))
10521 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10522 "Misplaced _ in number");
10526 /* read digits of exponent */
10527 while (isDIGIT(*s) || *s == '_') {
10530 Perl_croak(aTHX_ number_too_long);
10534 if (((lastub && s == lastub + 1) ||
10535 (!isDIGIT(s[1]) && s[1] != '_'))
10536 && ckWARN(WARN_SYNTAX))
10537 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10538 "Misplaced _ in number");
10545 /* make an sv from the string */
10549 We try to do an integer conversion first if no characters
10550 indicating "float" have been found.
10555 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10557 if (flags == IS_NUMBER_IN_UV) {
10559 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10562 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10563 if (uv <= (UV) IV_MIN)
10564 sv_setiv(sv, -(IV)uv);
10571 /* terminate the string */
10573 nv = Atof(PL_tokenbuf);
10577 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10578 (PL_hints & HINT_NEW_INTEGER) )
10579 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10580 (floatit ? "float" : "integer"),
10584 /* if it starts with a v, it could be a v-string */
10587 sv = NEWSV(92,5); /* preallocate storage space */
10588 s = scan_vstring(s,sv);
10592 /* make the op for the constant and return */
10595 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10597 lvalp->opval = Nullop;
10603 S_scan_formline(pTHX_ register char *s)
10605 register char *eol;
10607 SV *stuff = newSVpvn("",0);
10608 bool needargs = FALSE;
10609 bool eofmt = FALSE;
10611 while (!needargs) {
10613 #ifdef PERL_STRICT_CR
10614 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10616 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10618 if (*t == '\n' || t == PL_bufend) {
10623 if (PL_in_eval && !PL_rsfp) {
10624 eol = (char *) memchr(s,'\n',PL_bufend-s);
10629 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10631 for (t = s; t < eol; t++) {
10632 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10634 goto enough; /* ~~ must be first line in formline */
10636 if (*t == '@' || *t == '^')
10640 sv_catpvn(stuff, s, eol-s);
10641 #ifndef PERL_STRICT_CR
10642 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10643 char *end = SvPVX(stuff) + SvCUR(stuff);
10646 SvCUR_set(stuff, SvCUR(stuff) - 1);
10655 s = filter_gets(PL_linestr, PL_rsfp, 0);
10656 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10657 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10658 PL_last_lop = PL_last_uni = Nullch;
10667 if (SvCUR(stuff)) {
10670 PL_lex_state = LEX_NORMAL;
10671 PL_nextval[PL_nexttoke].ival = 0;
10675 PL_lex_state = LEX_FORMLINE;
10677 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10679 else if (PL_encoding)
10680 sv_recode_to_utf8(stuff, PL_encoding);
10682 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10684 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10688 SvREFCNT_dec(stuff);
10690 PL_lex_formbrack = 0;
10701 PL_cshlen = strlen(PL_cshname);
10706 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10708 const I32 oldsavestack_ix = PL_savestack_ix;
10709 CV* outsidecv = PL_compcv;
10712 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10714 SAVEI32(PL_subline);
10715 save_item(PL_subname);
10716 SAVESPTR(PL_compcv);
10718 PL_compcv = (CV*)NEWSV(1104,0);
10719 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10720 CvFLAGS(PL_compcv) |= flags;
10722 PL_subline = CopLINE(PL_curcop);
10723 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10724 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10725 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10727 return oldsavestack_ix;
10731 #pragma segment Perl_yylex
10734 Perl_yywarn(pTHX_ const char *s)
10736 PL_in_eval |= EVAL_WARNONLY;
10738 PL_in_eval &= ~EVAL_WARNONLY;
10743 Perl_yyerror(pTHX_ const char *s)
10745 const char *where = NULL;
10746 const char *context = NULL;
10750 if (!yychar || (yychar == ';' && !PL_rsfp))
10752 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10753 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10754 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_oldoldbufptr))
10766 context = PL_oldoldbufptr;
10767 contlen = PL_bufptr - PL_oldoldbufptr;
10769 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10770 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10773 The code below is removed for NetWare because it abends/crashes on NetWare
10774 when the script has error such as not having the closing quotes like:
10775 if ($var eq "value)
10776 Checking of white spaces is anyway done in NetWare code.
10779 while (isSPACE(*PL_oldbufptr))
10782 context = PL_oldbufptr;
10783 contlen = PL_bufptr - PL_oldbufptr;
10785 else if (yychar > 255)
10786 where = "next token ???";
10787 else if (yychar == -2) { /* YYEMPTY */
10788 if (PL_lex_state == LEX_NORMAL ||
10789 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10790 where = "at end of line";
10791 else if (PL_lex_inpat)
10792 where = "within pattern";
10794 where = "within string";
10797 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10799 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10800 else if (isPRINT_LC(yychar))
10801 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10803 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10804 where = SvPVX_const(where_sv);
10806 msg = sv_2mortal(newSVpv(s, 0));
10807 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10808 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10810 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10812 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10813 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10814 Perl_sv_catpvf(aTHX_ msg,
10815 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10816 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10819 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10820 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10823 if (PL_error_count >= 10) {
10824 if (PL_in_eval && SvCUR(ERRSV))
10825 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10826 ERRSV, OutCopFILE(PL_curcop));
10828 Perl_croak(aTHX_ "%s has too many errors.\n",
10829 OutCopFILE(PL_curcop));
10832 PL_in_my_stash = NULL;
10836 #pragma segment Main
10840 S_swallow_bom(pTHX_ U8 *s)
10842 const STRLEN slen = SvCUR(PL_linestr);
10845 if (s[1] == 0xFE) {
10846 /* UTF-16 little-endian? (or UTF32-LE?) */
10847 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10848 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10849 #ifndef PERL_NO_UTF16_FILTER
10850 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10853 if (PL_bufend > (char*)s) {
10857 filter_add(utf16rev_textfilter, NULL);
10858 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10859 utf16_to_utf8_reversed(s, news,
10860 PL_bufend - (char*)s - 1,
10862 sv_setpvn(PL_linestr, (const char*)news, newlen);
10864 SvUTF8_on(PL_linestr);
10865 s = (U8*)SvPVX(PL_linestr);
10866 PL_bufend = SvPVX(PL_linestr) + newlen;
10869 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10874 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10875 #ifndef PERL_NO_UTF16_FILTER
10876 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10879 if (PL_bufend > (char *)s) {
10883 filter_add(utf16_textfilter, NULL);
10884 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10885 utf16_to_utf8(s, news,
10886 PL_bufend - (char*)s,
10888 sv_setpvn(PL_linestr, (const char*)news, newlen);
10890 SvUTF8_on(PL_linestr);
10891 s = (U8*)SvPVX(PL_linestr);
10892 PL_bufend = SvPVX(PL_linestr) + newlen;
10895 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10900 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10901 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10902 s += 3; /* UTF-8 */
10908 if (s[2] == 0xFE && s[3] == 0xFF) {
10909 /* UTF-32 big-endian */
10910 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10913 else if (s[2] == 0 && s[3] != 0) {
10916 * are a good indicator of UTF-16BE. */
10917 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10922 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10925 * are a good indicator of UTF-16LE. */
10926 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10935 * Restore a source filter.
10939 restore_rsfp(pTHX_ void *f)
10941 PerlIO * const fp = (PerlIO*)f;
10943 if (PL_rsfp == PerlIO_stdin())
10944 PerlIO_clearerr(PL_rsfp);
10945 else if (PL_rsfp && (PL_rsfp != fp))
10946 PerlIO_close(PL_rsfp);
10950 #ifndef PERL_NO_UTF16_FILTER
10952 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10954 const STRLEN old = SvCUR(sv);
10955 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10956 DEBUG_P(PerlIO_printf(Perl_debug_log,
10957 "utf16_textfilter(%p): %d %d (%d)\n",
10958 utf16_textfilter, idx, maxlen, (int) count));
10962 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10963 Copy(SvPVX_const(sv), tmps, old, char);
10964 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10965 SvCUR(sv) - old, &newlen);
10966 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10968 DEBUG_P({sv_dump(sv);});
10973 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10975 const STRLEN old = SvCUR(sv);
10976 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10977 DEBUG_P(PerlIO_printf(Perl_debug_log,
10978 "utf16rev_textfilter(%p): %d %d (%d)\n",
10979 utf16rev_textfilter, idx, maxlen, (int) count));
10983 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10984 Copy(SvPVX_const(sv), tmps, old, char);
10985 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10986 SvCUR(sv) - old, &newlen);
10987 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10989 DEBUG_P({ sv_dump(sv); });
10995 Returns a pointer to the next character after the parsed
10996 vstring, as well as updating the passed in sv.
10998 Function must be called like
11001 s = scan_vstring(s,sv);
11003 The sv should already be large enough to store the vstring
11004 passed in, for performance reasons.
11009 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
11011 const char *pos = s;
11012 const char *start = s;
11013 if (*pos == 'v') pos++; /* get past 'v' */
11014 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11016 if ( *pos != '.') {
11017 /* this may not be a v-string if followed by => */
11018 const char *next = pos;
11019 while (next < PL_bufend && isSPACE(*next))
11021 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11022 /* return string not v-string */
11023 sv_setpvn(sv,(char *)s,pos-s);
11024 return (char *)pos;
11028 if (!isALPHA(*pos)) {
11029 U8 tmpbuf[UTF8_MAXBYTES+1];
11031 if (*s == 'v') s++; /* get past 'v' */
11033 sv_setpvn(sv, "", 0);
11039 /* this is atoi() that tolerates underscores */
11040 const char *end = pos;
11042 while (--end >= s) {
11047 rev += (*end - '0') * mult;
11049 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11050 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11051 "Integer overflow in decimal number");
11055 if (rev > 0x7FFFFFFF)
11056 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11058 /* Append native character for the rev point */
11059 tmpend = uvchr_to_utf8(tmpbuf, rev);
11060 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11061 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11063 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11069 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11073 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11081 * c-indentation-style: bsd
11082 * c-basic-offset: 4
11083 * indent-tabs-mode: t
11086 * ex: set ts=8 sts=4 sw=4 noet: