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 : !(*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'),
5670 ((PL_tokenbuf[0] == '$') ? SVt_PV
5671 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5677 * The following code was generated by perl_keyword.pl.
5681 Perl_keyword (pTHX_ const char *name, I32 len)
5685 case 1: /* 5 tokens of length 1 */
5717 case 2: /* 18 tokens of length 2 */
5863 case 3: /* 28 tokens of length 3 */
5867 if (name[1] == 'N' &&
5930 if (name[1] == 'i' &&
5970 if (name[1] == 'o' &&
5979 if (name[1] == 'e' &&
5988 if (name[1] == 'n' &&
5997 if (name[1] == 'o' &&
6006 if (name[1] == 'a' &&
6015 if (name[1] == 'o' &&
6077 if (name[1] == 'e' &&
6109 if (name[1] == 'i' &&
6118 if (name[1] == 's' &&
6127 if (name[1] == 'e' &&
6136 if (name[1] == 'o' &&
6148 case 4: /* 40 tokens of length 4 */
6152 if (name[1] == 'O' &&
6162 if (name[1] == 'N' &&
6172 if (name[1] == 'i' &&
6182 if (name[1] == 'h' &&
6192 if (name[1] == 'u' &&
6205 if (name[2] == 'c' &&
6214 if (name[2] == 's' &&
6223 if (name[2] == 'a' &&
6259 if (name[1] == 'o' &&
6272 if (name[2] == 't' &&
6281 if (name[2] == 'o' &&
6290 if (name[2] == 't' &&
6299 if (name[2] == 'e' &&
6312 if (name[1] == 'o' &&
6325 if (name[2] == 'y' &&
6334 if (name[2] == 'l' &&
6350 if (name[2] == 's' &&
6359 if (name[2] == 'n' &&
6368 if (name[2] == 'c' &&
6381 if (name[1] == 'e' &&
6391 if (name[1] == 'p' &&
6404 if (name[2] == 'c' &&
6413 if (name[2] == 'p' &&
6422 if (name[2] == 's' &&
6438 if (name[2] == 'n' &&
6508 if (name[2] == 'r' &&
6517 if (name[2] == 'r' &&
6526 if (name[2] == 'a' &&
6542 if (name[2] == 'l' &&
6609 case 5: /* 36 tokens of length 5 */
6613 if (name[1] == 'E' &&
6624 if (name[1] == 'H' &&
6638 if (name[2] == 'a' &&
6648 if (name[2] == 'a' &&
6662 if (name[1] == 'l' &&
6679 if (name[3] == 'i' &&
6688 if (name[3] == 'o' &&
6724 if (name[2] == 'o' &&
6734 if (name[2] == 'y' &&
6748 if (name[1] == 'l' &&
6762 if (name[2] == 'n' &&
6772 if (name[2] == 'o' &&
6789 if (name[2] == 'd' &&
6799 if (name[2] == 'c' &&
6816 if (name[2] == 'c' &&
6826 if (name[2] == 't' &&
6840 if (name[1] == 'k' &&
6851 if (name[1] == 'r' &&
6865 if (name[2] == 's' &&
6875 if (name[2] == 'd' &&
6892 if (name[2] == 'm' &&
6902 if (name[2] == 'i' &&
6912 if (name[2] == 'e' &&
6922 if (name[2] == 'l' &&
6932 if (name[2] == 'a' &&
6942 if (name[2] == 'u' &&
6956 if (name[1] == 'i' &&
6970 if (name[2] == 'a' &&
6983 if (name[3] == 'e' &&
7018 if (name[2] == 'i' &&
7035 if (name[2] == 'i' &&
7045 if (name[2] == 'i' &&
7062 case 6: /* 33 tokens of length 6 */
7066 if (name[1] == 'c' &&
7081 if (name[2] == 'l' &&
7092 if (name[2] == 'r' &&
7107 if (name[1] == 'e' &&
7122 if (name[2] == 's' &&
7127 if(ckWARN_d(WARN_SYNTAX))
7128 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7134 if (name[2] == 'i' &&
7152 if (name[2] == 'l' &&
7163 if (name[2] == 'r' &&
7178 if (name[1] == 'm' &&
7193 if (name[2] == 'n' &&
7204 if (name[2] == 's' &&
7219 if (name[1] == 's' &&
7225 if (name[4] == 't' &&
7234 if (name[4] == 'e' &&
7243 if (name[4] == 'c' &&
7252 if (name[4] == 'n' &&
7268 if (name[1] == 'r' &&
7286 if (name[3] == 'a' &&
7296 if (name[3] == 'u' &&
7310 if (name[2] == 'n' &&
7328 if (name[2] == 'a' &&
7342 if (name[3] == 'e' &&
7355 if (name[4] == 't' &&
7364 if (name[4] == 'e' &&
7386 if (name[4] == 't' &&
7395 if (name[4] == 'e' &&
7411 if (name[2] == 'c' &&
7422 if (name[2] == 'l' &&
7433 if (name[2] == 'b' &&
7444 if (name[2] == 's' &&
7467 if (name[4] == 's' &&
7476 if (name[4] == 'n' &&
7489 if (name[3] == 'a' &&
7506 if (name[1] == 'a' &&
7521 case 7: /* 28 tokens of length 7 */
7525 if (name[1] == 'E' &&
7538 if (name[1] == '_' &&
7551 if (name[1] == 'i' &&
7558 return -KEY_binmode;
7564 if (name[1] == 'o' &&
7571 return -KEY_connect;
7580 if (name[2] == 'm' &&
7586 return -KEY_dbmopen;
7592 if (name[2] == 'f' &&
7608 if (name[1] == 'o' &&
7621 if (name[1] == 'e' &&
7628 if (name[5] == 'r' &&
7631 return -KEY_getpgrp;
7637 if (name[5] == 'i' &&
7640 return -KEY_getppid;
7653 if (name[1] == 'c' &&
7660 return -KEY_lcfirst;
7666 if (name[1] == 'p' &&
7673 return -KEY_opendir;
7679 if (name[1] == 'a' &&
7697 if (name[3] == 'd' &&
7702 return -KEY_readdir;
7708 if (name[3] == 'u' &&
7719 if (name[3] == 'e' &&
7724 return -KEY_reverse;
7743 if (name[3] == 'k' &&
7748 return -KEY_seekdir;
7754 if (name[3] == 'p' &&
7759 return -KEY_setpgrp;
7769 if (name[2] == 'm' &&
7775 return -KEY_shmread;
7781 if (name[2] == 'r' &&
7787 return -KEY_sprintf;
7796 if (name[3] == 'l' &&
7801 return -KEY_symlink;
7810 if (name[4] == 'a' &&
7814 return -KEY_syscall;
7820 if (name[4] == 'p' &&
7824 return -KEY_sysopen;
7830 if (name[4] == 'e' &&
7834 return -KEY_sysread;
7840 if (name[4] == 'e' &&
7844 return -KEY_sysseek;
7862 if (name[1] == 'e' &&
7869 return -KEY_telldir;
7878 if (name[2] == 'f' &&
7884 return -KEY_ucfirst;
7890 if (name[2] == 's' &&
7896 return -KEY_unshift;
7906 if (name[1] == 'a' &&
7913 return -KEY_waitpid;
7922 case 8: /* 26 tokens of length 8 */
7926 if (name[1] == 'U' &&
7934 return KEY_AUTOLOAD;
7945 if (name[3] == 'A' &&
7951 return KEY___DATA__;
7957 if (name[3] == 'I' &&
7963 return -KEY___FILE__;
7969 if (name[3] == 'I' &&
7975 return -KEY___LINE__;
7991 if (name[2] == 'o' &&
7998 return -KEY_closedir;
8004 if (name[2] == 'n' &&
8011 return -KEY_continue;
8021 if (name[1] == 'b' &&
8029 return -KEY_dbmclose;
8035 if (name[1] == 'n' &&
8041 if (name[4] == 'r' &&
8046 return -KEY_endgrent;
8052 if (name[4] == 'w' &&
8057 return -KEY_endpwent;
8070 if (name[1] == 'o' &&
8078 return -KEY_formline;
8084 if (name[1] == 'e' &&
8095 if (name[6] == 'n' &&
8098 return -KEY_getgrent;
8104 if (name[6] == 'i' &&
8107 return -KEY_getgrgid;
8113 if (name[6] == 'a' &&
8116 return -KEY_getgrnam;
8129 if (name[4] == 'o' &&
8134 return -KEY_getlogin;
8145 if (name[6] == 'n' &&
8148 return -KEY_getpwent;
8154 if (name[6] == 'a' &&
8157 return -KEY_getpwnam;
8163 if (name[6] == 'i' &&
8166 return -KEY_getpwuid;
8186 if (name[1] == 'e' &&
8193 if (name[5] == 'i' &&
8200 return -KEY_readline;
8205 return -KEY_readlink;
8216 if (name[5] == 'i' &&
8220 return -KEY_readpipe;
8241 if (name[4] == 'r' &&
8246 return -KEY_setgrent;
8252 if (name[4] == 'w' &&
8257 return -KEY_setpwent;
8273 if (name[3] == 'w' &&
8279 return -KEY_shmwrite;
8285 if (name[3] == 't' &&
8291 return -KEY_shutdown;
8301 if (name[2] == 's' &&
8308 return -KEY_syswrite;
8318 if (name[1] == 'r' &&
8326 return -KEY_truncate;
8335 case 9: /* 8 tokens of length 9 */
8339 if (name[1] == 'n' &&
8348 return -KEY_endnetent;
8354 if (name[1] == 'e' &&
8363 return -KEY_getnetent;
8369 if (name[1] == 'o' &&
8378 return -KEY_localtime;
8384 if (name[1] == 'r' &&
8393 return KEY_prototype;
8399 if (name[1] == 'u' &&
8408 return -KEY_quotemeta;
8414 if (name[1] == 'e' &&
8423 return -KEY_rewinddir;
8429 if (name[1] == 'e' &&
8438 return -KEY_setnetent;
8444 if (name[1] == 'a' &&
8453 return -KEY_wantarray;
8462 case 10: /* 9 tokens of length 10 */
8466 if (name[1] == 'n' &&
8472 if (name[4] == 'o' &&
8479 return -KEY_endhostent;
8485 if (name[4] == 'e' &&
8492 return -KEY_endservent;
8505 if (name[1] == 'e' &&
8511 if (name[4] == 'o' &&
8518 return -KEY_gethostent;
8527 if (name[5] == 'r' &&
8533 return -KEY_getservent;
8539 if (name[5] == 'c' &&
8545 return -KEY_getsockopt;
8570 if (name[4] == 'o' &&
8577 return -KEY_sethostent;
8586 if (name[5] == 'r' &&
8592 return -KEY_setservent;
8598 if (name[5] == 'c' &&
8604 return -KEY_setsockopt;
8621 if (name[2] == 'c' &&
8630 return -KEY_socketpair;
8643 case 11: /* 8 tokens of length 11 */
8647 if (name[1] == '_' &&
8658 return -KEY___PACKAGE__;
8664 if (name[1] == 'n' &&
8675 return -KEY_endprotoent;
8681 if (name[1] == 'e' &&
8690 if (name[5] == 'e' &&
8697 return -KEY_getpeername;
8706 if (name[6] == 'o' &&
8712 return -KEY_getpriority;
8718 if (name[6] == 't' &&
8724 return -KEY_getprotoent;
8738 if (name[4] == 'o' &&
8746 return -KEY_getsockname;
8759 if (name[1] == 'e' &&
8767 if (name[6] == 'o' &&
8773 return -KEY_setpriority;
8779 if (name[6] == 't' &&
8785 return -KEY_setprotoent;
8801 case 12: /* 2 tokens of length 12 */
8802 if (name[0] == 'g' &&
8814 if (name[9] == 'd' &&
8817 { /* getnetbyaddr */
8818 return -KEY_getnetbyaddr;
8824 if (name[9] == 'a' &&
8827 { /* getnetbyname */
8828 return -KEY_getnetbyname;
8840 case 13: /* 4 tokens of length 13 */
8841 if (name[0] == 'g' &&
8848 if (name[4] == 'o' &&
8857 if (name[10] == 'd' &&
8860 { /* gethostbyaddr */
8861 return -KEY_gethostbyaddr;
8867 if (name[10] == 'a' &&
8870 { /* gethostbyname */
8871 return -KEY_gethostbyname;
8884 if (name[4] == 'e' &&
8893 if (name[10] == 'a' &&
8896 { /* getservbyname */
8897 return -KEY_getservbyname;
8903 if (name[10] == 'o' &&
8906 { /* getservbyport */
8907 return -KEY_getservbyport;
8926 case 14: /* 1 tokens of length 14 */
8927 if (name[0] == 'g' &&
8941 { /* getprotobyname */
8942 return -KEY_getprotobyname;
8947 case 16: /* 1 tokens of length 16 */
8948 if (name[0] == 'g' &&
8964 { /* getprotobynumber */
8965 return -KEY_getprotobynumber;
8979 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
8983 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8984 if (ckWARN(WARN_SYNTAX)) {
8986 for (w = s+2; *w && level; w++) {
8993 for (; *w && isSPACE(*w); w++) ;
8994 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
8995 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8996 "%s (...) interpreted as function",name);
8999 while (s < PL_bufend && isSPACE(*s))
9003 while (s < PL_bufend && isSPACE(*s))
9005 if (isIDFIRST_lazy_if(s,UTF)) {
9007 while (isALNUM_lazy_if(s,UTF))
9009 while (s < PL_bufend && isSPACE(*s))
9013 *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9014 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9018 Perl_croak(aTHX_ "No comma allowed after %s", what);
9023 /* Either returns sv, or mortalizes sv and returns a new SV*.
9024 Best used as sv=new_constant(..., sv, ...).
9025 If s, pv are NULL, calls subroutine with one argument,
9026 and type is used with error messages only. */
9029 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9033 HV * const table = GvHV(PL_hintgv); /* ^H */
9037 const char *why1 = "", *why2 = "", *why3 = "";
9039 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9042 why2 = strEQ(key,"charnames")
9043 ? "(possibly a missing \"use charnames ...\")"
9045 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9046 (type ? type: "undef"), why2);
9048 /* This is convoluted and evil ("goto considered harmful")
9049 * but I do not understand the intricacies of all the different
9050 * failure modes of %^H in here. The goal here is to make
9051 * the most probable error message user-friendly. --jhi */
9056 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9057 (type ? type: "undef"), why1, why2, why3);
9059 yyerror(SvPVX_const(msg));
9063 cvp = hv_fetch(table, key, strlen(key), FALSE);
9064 if (!cvp || !SvOK(*cvp)) {
9067 why3 = "} is not defined";
9070 sv_2mortal(sv); /* Parent created it permanently */
9073 pv = sv_2mortal(newSVpvn(s, len));
9075 typesv = sv_2mortal(newSVpv(type, 0));
9077 typesv = &PL_sv_undef;
9079 PUSHSTACKi(PERLSI_OVERLOAD);
9091 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9095 /* Check the eval first */
9096 if (!PL_in_eval && SvTRUE(ERRSV)) {
9097 sv_catpv(ERRSV, "Propagated");
9098 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9100 res = SvREFCNT_inc(sv);
9104 (void)SvREFCNT_inc(res);
9113 why1 = "Call to &{$^H{";
9115 why3 = "}} did not return a defined value";
9123 /* Returns a NUL terminated string, with the length of the string written to
9127 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9129 register char *d = dest;
9130 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
9133 Perl_croak(aTHX_ ident_too_long);
9134 if (isALNUM(*s)) /* UTF handled below */
9136 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9141 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9145 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9146 char *t = s + UTF8SKIP(s);
9147 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9149 if (d + (t - s) > e)
9150 Perl_croak(aTHX_ ident_too_long);
9151 Copy(s, d, t - s, char);
9164 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9168 char *bracket = Nullch;
9174 e = d + destlen - 3; /* two-character token, ending NUL */
9176 while (isDIGIT(*s)) {
9178 Perl_croak(aTHX_ ident_too_long);
9185 Perl_croak(aTHX_ ident_too_long);
9186 if (isALNUM(*s)) /* UTF handled below */
9188 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9193 else if (*s == ':' && s[1] == ':') {
9197 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9198 char *t = s + UTF8SKIP(s);
9199 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9201 if (d + (t - s) > e)
9202 Perl_croak(aTHX_ ident_too_long);
9203 Copy(s, d, t - s, char);
9214 if (PL_lex_state != LEX_NORMAL)
9215 PL_lex_state = LEX_INTERPENDMAYBE;
9218 if (*s == '$' && s[1] &&
9219 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9232 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9237 if (isSPACE(s[-1])) {
9239 const char ch = *s++;
9240 if (!SPACE_OR_TAB(ch)) {
9246 if (isIDFIRST_lazy_if(d,UTF)) {
9250 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9252 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9255 Copy(s, d, e - s, char);
9260 while ((isALNUM(*s) || *s == ':') && d < e)
9263 Perl_croak(aTHX_ ident_too_long);
9266 while (s < send && SPACE_OR_TAB(*s)) s++;
9267 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9268 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9269 const char *brack = *s == '[' ? "[...]" : "{...}";
9270 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9271 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9272 funny, dest, brack, funny, dest, brack);
9275 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9279 /* Handle extended ${^Foo} variables
9280 * 1999-02-27 mjd-perl-patch@plover.com */
9281 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9285 while (isALNUM(*s) && d < e) {
9289 Perl_croak(aTHX_ ident_too_long);
9294 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9295 PL_lex_state = LEX_INTERPEND;
9300 if (PL_lex_state == LEX_NORMAL) {
9301 if (ckWARN(WARN_AMBIGUOUS) &&
9302 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9304 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9305 "Ambiguous use of %c{%s} resolved to %c%s",
9306 funny, dest, funny, dest);
9311 s = bracket; /* let the parser handle it */
9315 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9316 PL_lex_state = LEX_INTERPEND;
9321 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9326 *pmfl |= PMf_GLOBAL;
9328 *pmfl |= PMf_CONTINUE;
9332 *pmfl |= PMf_MULTILINE;
9334 *pmfl |= PMf_SINGLELINE;
9336 *pmfl |= PMf_EXTENDED;
9340 S_scan_pat(pTHX_ char *start, I32 type)
9343 char *s = scan_str(start,FALSE,FALSE);
9346 char * const delimiter = skipspace(start);
9347 Perl_croak(aTHX_ *delimiter == '?'
9348 ? "Search pattern not terminated or ternary operator parsed as search pattern"
9349 : "Search pattern not terminated" );
9352 pm = (PMOP*)newPMOP(type, 0);
9353 if (PL_multi_open == '?')
9354 pm->op_pmflags |= PMf_ONCE;
9356 while (*s && strchr("iomsx", *s))
9357 pmflag(&pm->op_pmflags,*s++);
9360 while (*s && strchr("iogcmsx", *s))
9361 pmflag(&pm->op_pmflags,*s++);
9363 /* issue a warning if /c is specified,but /g is not */
9364 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9365 && ckWARN(WARN_REGEXP))
9367 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
9370 pm->op_pmpermflags = pm->op_pmflags;
9372 PL_lex_op = (OP*)pm;
9373 yylval.ival = OP_MATCH;
9378 S_scan_subst(pTHX_ char *start)
9386 yylval.ival = OP_NULL;
9388 s = scan_str(start,FALSE,FALSE);
9391 Perl_croak(aTHX_ "Substitution pattern not terminated");
9393 if (s[-1] == PL_multi_open)
9396 first_start = PL_multi_start;
9397 s = scan_str(s,FALSE,FALSE);
9400 SvREFCNT_dec(PL_lex_stuff);
9401 PL_lex_stuff = Nullsv;
9403 Perl_croak(aTHX_ "Substitution replacement not terminated");
9405 PL_multi_start = first_start; /* so whole substitution is taken together */
9407 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9413 else if (strchr("iogcmsx", *s))
9414 pmflag(&pm->op_pmflags,*s++);
9419 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
9420 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9425 PL_sublex_info.super_bufptr = s;
9426 PL_sublex_info.super_bufend = PL_bufend;
9428 pm->op_pmflags |= PMf_EVAL;
9429 repl = newSVpvn("",0);
9431 sv_catpv(repl, es ? "eval " : "do ");
9432 sv_catpvn(repl, "{ ", 2);
9433 sv_catsv(repl, PL_lex_repl);
9434 sv_catpvn(repl, " };", 2);
9436 SvREFCNT_dec(PL_lex_repl);
9440 pm->op_pmpermflags = pm->op_pmflags;
9441 PL_lex_op = (OP*)pm;
9442 yylval.ival = OP_SUBST;
9447 S_scan_trans(pTHX_ char *start)
9456 yylval.ival = OP_NULL;
9458 s = scan_str(start,FALSE,FALSE);
9460 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9461 if (s[-1] == PL_multi_open)
9464 s = scan_str(s,FALSE,FALSE);
9467 SvREFCNT_dec(PL_lex_stuff);
9468 PL_lex_stuff = Nullsv;
9470 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9473 complement = del = squash = 0;
9477 complement = OPpTRANS_COMPLEMENT;
9480 del = OPpTRANS_DELETE;
9483 squash = OPpTRANS_SQUASH;
9492 Newx(tbl, complement&&!del?258:256, short);
9493 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9494 o->op_private &= ~OPpTRANS_ALL;
9495 o->op_private |= del|squash|complement|
9496 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9497 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9500 yylval.ival = OP_TRANS;
9505 S_scan_heredoc(pTHX_ register char *s)
9508 I32 op_type = OP_SCALAR;
9512 const char newline[] = "\n";
9513 const char *found_newline;
9517 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9521 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9524 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9525 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9528 s = delimcpy(d, e, s, PL_bufend, term, &len);
9538 if (!isALNUM_lazy_if(s,UTF))
9539 deprecate_old("bare << to mean <<\"\"");
9540 for (; isALNUM_lazy_if(s,UTF); s++) {
9545 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9546 Perl_croak(aTHX_ "Delimiter for here document is too long");
9549 len = d - PL_tokenbuf;
9550 #ifndef PERL_STRICT_CR
9551 d = strchr(s, '\r');
9553 char * const olds = s;
9555 while (s < PL_bufend) {
9561 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9570 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9574 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9575 herewas = newSVpvn(s,PL_bufend-s);
9579 herewas = newSVpvn(s,found_newline-s);
9581 s += SvCUR(herewas);
9583 tmpstr = NEWSV(87,79);
9584 sv_upgrade(tmpstr, SVt_PVIV);
9587 SvIV_set(tmpstr, -1);
9589 else if (term == '`') {
9590 op_type = OP_BACKTICK;
9591 SvIV_set(tmpstr, '\\');
9595 PL_multi_start = CopLINE(PL_curcop);
9596 PL_multi_open = PL_multi_close = '<';
9597 term = *PL_tokenbuf;
9598 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9599 char *bufptr = PL_sublex_info.super_bufptr;
9600 char *bufend = PL_sublex_info.super_bufend;
9601 char * const olds = s - SvCUR(herewas);
9602 s = strchr(bufptr, '\n');
9606 while (s < bufend &&
9607 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9609 CopLINE_inc(PL_curcop);
9612 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9613 missingterm(PL_tokenbuf);
9615 sv_setpvn(herewas,bufptr,d-bufptr+1);
9616 sv_setpvn(tmpstr,d+1,s-d);
9618 sv_catpvn(herewas,s,bufend-s);
9619 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9626 while (s < PL_bufend &&
9627 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9629 CopLINE_inc(PL_curcop);
9631 if (s >= PL_bufend) {
9632 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9633 missingterm(PL_tokenbuf);
9635 sv_setpvn(tmpstr,d+1,s-d);
9637 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9639 sv_catpvn(herewas,s,PL_bufend-s);
9640 sv_setsv(PL_linestr,herewas);
9641 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9642 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9643 PL_last_lop = PL_last_uni = Nullch;
9646 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9647 while (s >= PL_bufend) { /* multiple line string? */
9649 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9650 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9651 missingterm(PL_tokenbuf);
9653 CopLINE_inc(PL_curcop);
9654 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9655 PL_last_lop = PL_last_uni = Nullch;
9656 #ifndef PERL_STRICT_CR
9657 if (PL_bufend - PL_linestart >= 2) {
9658 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9659 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9661 PL_bufend[-2] = '\n';
9663 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9665 else if (PL_bufend[-1] == '\r')
9666 PL_bufend[-1] = '\n';
9668 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9669 PL_bufend[-1] = '\n';
9671 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9672 SV *sv = NEWSV(88,0);
9674 sv_upgrade(sv, SVt_PVMG);
9675 sv_setsv(sv,PL_linestr);
9678 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9680 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9681 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9682 *(SvPVX(PL_linestr) + off ) = ' ';
9683 sv_catsv(PL_linestr,herewas);
9684 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9685 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9689 sv_catsv(tmpstr,PL_linestr);
9694 PL_multi_end = CopLINE(PL_curcop);
9695 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9696 SvPV_shrink_to_cur(tmpstr);
9698 SvREFCNT_dec(herewas);
9700 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9702 else if (PL_encoding)
9703 sv_recode_to_utf8(tmpstr, PL_encoding);
9705 PL_lex_stuff = tmpstr;
9706 yylval.ival = op_type;
9711 takes: current position in input buffer
9712 returns: new position in input buffer
9713 side-effects: yylval and lex_op are set.
9718 <FH> read from filehandle
9719 <pkg::FH> read from package qualified filehandle
9720 <pkg'FH> read from package qualified filehandle
9721 <$fh> read from filehandle in $fh
9727 S_scan_inputsymbol(pTHX_ char *start)
9729 register char *s = start; /* current position in buffer */
9735 d = PL_tokenbuf; /* start of temp holding space */
9736 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9737 end = strchr(s, '\n');
9740 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9742 /* die if we didn't have space for the contents of the <>,
9743 or if it didn't end, or if we see a newline
9746 if (len >= sizeof PL_tokenbuf)
9747 Perl_croak(aTHX_ "Excessively long <> operator");
9749 Perl_croak(aTHX_ "Unterminated <> operator");
9754 Remember, only scalar variables are interpreted as filehandles by
9755 this code. Anything more complex (e.g., <$fh{$num}>) will be
9756 treated as a glob() call.
9757 This code makes use of the fact that except for the $ at the front,
9758 a scalar variable and a filehandle look the same.
9760 if (*d == '$' && d[1]) d++;
9762 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9763 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9766 /* If we've tried to read what we allow filehandles to look like, and
9767 there's still text left, then it must be a glob() and not a getline.
9768 Use scan_str to pull out the stuff between the <> and treat it
9769 as nothing more than a string.
9772 if (d - PL_tokenbuf != len) {
9773 yylval.ival = OP_GLOB;
9775 s = scan_str(start,FALSE,FALSE);
9777 Perl_croak(aTHX_ "Glob not terminated");
9781 bool readline_overriden = FALSE;
9782 GV *gv_readline = Nullgv;
9784 /* we're in a filehandle read situation */
9787 /* turn <> into <ARGV> */
9789 Copy("ARGV",d,5,char);
9791 /* Check whether readline() is overriden */
9792 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9793 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9795 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9796 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9797 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9798 readline_overriden = TRUE;
9800 /* if <$fh>, create the ops to turn the variable into a
9806 /* try to find it in the pad for this block, otherwise find
9807 add symbol table ops
9809 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9810 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9811 HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9812 HEK *stashname = HvNAME_HEK(stash);
9813 SV *sym = sv_2mortal(newSVhek(stashname));
9814 sv_catpvn(sym, "::", 2);
9820 OP *o = newOP(OP_PADSV, 0);
9822 PL_lex_op = readline_overriden
9823 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9824 append_elem(OP_LIST, o,
9825 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9826 : (OP*)newUNOP(OP_READLINE, 0, o);
9835 ? (GV_ADDMULTI | GV_ADDINEVAL)
9838 PL_lex_op = readline_overriden
9839 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9840 append_elem(OP_LIST,
9841 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9842 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9843 : (OP*)newUNOP(OP_READLINE, 0,
9844 newUNOP(OP_RV2SV, 0,
9845 newGVOP(OP_GV, 0, gv)));
9847 if (!readline_overriden)
9848 PL_lex_op->op_flags |= OPf_SPECIAL;
9849 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9850 yylval.ival = OP_NULL;
9853 /* If it's none of the above, it must be a literal filehandle
9854 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9856 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9857 PL_lex_op = readline_overriden
9858 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9859 append_elem(OP_LIST,
9860 newGVOP(OP_GV, 0, gv),
9861 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9862 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9863 yylval.ival = OP_NULL;
9872 takes: start position in buffer
9873 keep_quoted preserve \ on the embedded delimiter(s)
9874 keep_delims preserve the delimiters around the string
9875 returns: position to continue reading from buffer
9876 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9877 updates the read buffer.
9879 This subroutine pulls a string out of the input. It is called for:
9880 q single quotes q(literal text)
9881 ' single quotes 'literal text'
9882 qq double quotes qq(interpolate $here please)
9883 " double quotes "interpolate $here please"
9884 qx backticks qx(/bin/ls -l)
9885 ` backticks `/bin/ls -l`
9886 qw quote words @EXPORT_OK = qw( func() $spam )
9887 m// regexp match m/this/
9888 s/// regexp substitute s/this/that/
9889 tr/// string transliterate tr/this/that/
9890 y/// string transliterate y/this/that/
9891 ($*@) sub prototypes sub foo ($)
9892 (stuff) sub attr parameters sub foo : attr(stuff)
9893 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9895 In most of these cases (all but <>, patterns and transliterate)
9896 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9897 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9898 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9901 It skips whitespace before the string starts, and treats the first
9902 character as the delimiter. If the delimiter is one of ([{< then
9903 the corresponding "close" character )]}> is used as the closing
9904 delimiter. It allows quoting of delimiters, and if the string has
9905 balanced delimiters ([{<>}]) it allows nesting.
9907 On success, the SV with the resulting string is put into lex_stuff or,
9908 if that is already non-NULL, into lex_repl. The second case occurs only
9909 when parsing the RHS of the special constructs s/// and tr/// (y///).
9910 For convenience, the terminating delimiter character is stuffed into
9915 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9917 SV *sv; /* scalar value: string */
9918 char *tmps; /* temp string, used for delimiter matching */
9919 register char *s = start; /* current position in the buffer */
9920 register char term; /* terminating character */
9921 register char *to; /* current position in the sv's data */
9922 I32 brackets = 1; /* bracket nesting level */
9923 bool has_utf8 = FALSE; /* is there any utf8 content? */
9924 I32 termcode; /* terminating char. code */
9925 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9926 STRLEN termlen; /* length of terminating string */
9927 char *last = NULL; /* last position for nesting bracket */
9929 /* skip space before the delimiter */
9933 /* mark where we are, in case we need to report errors */
9936 /* after skipping whitespace, the next character is the terminator */
9939 termcode = termstr[0] = term;
9943 termcode = utf8_to_uvchr((U8*)s, &termlen);
9944 Copy(s, termstr, termlen, U8);
9945 if (!UTF8_IS_INVARIANT(term))
9949 /* mark where we are */
9950 PL_multi_start = CopLINE(PL_curcop);
9951 PL_multi_open = term;
9953 /* find corresponding closing delimiter */
9954 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9955 termcode = termstr[0] = term = tmps[5];
9957 PL_multi_close = term;
9959 /* create a new SV to hold the contents. 87 is leak category, I'm
9960 assuming. 79 is the SV's initial length. What a random number. */
9962 sv_upgrade(sv, SVt_PVIV);
9963 SvIV_set(sv, termcode);
9964 (void)SvPOK_only(sv); /* validate pointer */
9966 /* move past delimiter and try to read a complete string */
9968 sv_catpvn(sv, s, termlen);
9971 if (PL_encoding && !UTF) {
9975 int offset = s - SvPVX_const(PL_linestr);
9976 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9977 &offset, (char*)termstr, termlen);
9978 const char *ns = SvPVX_const(PL_linestr) + offset;
9979 char *svlast = SvEND(sv) - 1;
9981 for (; s < ns; s++) {
9982 if (*s == '\n' && !PL_rsfp)
9983 CopLINE_inc(PL_curcop);
9986 goto read_more_line;
9988 /* handle quoted delimiters */
9989 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9991 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9993 if ((svlast-1 - t) % 2) {
9997 SvCUR_set(sv, SvCUR(sv) - 1);
10002 if (PL_multi_open == PL_multi_close) {
10010 for (t = w = last; t < svlast; w++, t++) {
10011 /* At here, all closes are "was quoted" one,
10012 so we don't check PL_multi_close. */
10014 if (!keep_quoted && *(t+1) == PL_multi_open)
10019 else if (*t == PL_multi_open)
10027 SvCUR_set(sv, w - SvPVX_const(sv));
10030 if (--brackets <= 0)
10035 if (!keep_delims) {
10036 SvCUR_set(sv, SvCUR(sv) - 1);
10042 /* extend sv if need be */
10043 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10044 /* set 'to' to the next character in the sv's string */
10045 to = SvPVX(sv)+SvCUR(sv);
10047 /* if open delimiter is the close delimiter read unbridle */
10048 if (PL_multi_open == PL_multi_close) {
10049 for (; s < PL_bufend; s++,to++) {
10050 /* embedded newlines increment the current line number */
10051 if (*s == '\n' && !PL_rsfp)
10052 CopLINE_inc(PL_curcop);
10053 /* handle quoted delimiters */
10054 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10055 if (!keep_quoted && s[1] == term)
10057 /* any other quotes are simply copied straight through */
10061 /* terminate when run out of buffer (the for() condition), or
10062 have found the terminator */
10063 else if (*s == term) {
10066 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10069 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10075 /* if the terminator isn't the same as the start character (e.g.,
10076 matched brackets), we have to allow more in the quoting, and
10077 be prepared for nested brackets.
10080 /* read until we run out of string, or we find the terminator */
10081 for (; s < PL_bufend; s++,to++) {
10082 /* embedded newlines increment the line count */
10083 if (*s == '\n' && !PL_rsfp)
10084 CopLINE_inc(PL_curcop);
10085 /* backslashes can escape the open or closing characters */
10086 if (*s == '\\' && s+1 < PL_bufend) {
10087 if (!keep_quoted &&
10088 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10093 /* allow nested opens and closes */
10094 else if (*s == PL_multi_close && --brackets <= 0)
10096 else if (*s == PL_multi_open)
10098 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10103 /* terminate the copied string and update the sv's end-of-string */
10105 SvCUR_set(sv, to - SvPVX_const(sv));
10108 * this next chunk reads more into the buffer if we're not done yet
10112 break; /* handle case where we are done yet :-) */
10114 #ifndef PERL_STRICT_CR
10115 if (to - SvPVX_const(sv) >= 2) {
10116 if ((to[-2] == '\r' && to[-1] == '\n') ||
10117 (to[-2] == '\n' && to[-1] == '\r'))
10121 SvCUR_set(sv, to - SvPVX_const(sv));
10123 else if (to[-1] == '\r')
10126 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10131 /* if we're out of file, or a read fails, bail and reset the current
10132 line marker so we can report where the unterminated string began
10135 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10137 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10140 /* we read a line, so increment our line counter */
10141 CopLINE_inc(PL_curcop);
10143 /* update debugger info */
10144 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10145 SV *sv = NEWSV(88,0);
10147 sv_upgrade(sv, SVt_PVMG);
10148 sv_setsv(sv,PL_linestr);
10149 (void)SvIOK_on(sv);
10151 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10154 /* having changed the buffer, we must update PL_bufend */
10155 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10156 PL_last_lop = PL_last_uni = Nullch;
10159 /* at this point, we have successfully read the delimited string */
10161 if (!PL_encoding || UTF) {
10163 sv_catpvn(sv, s, termlen);
10166 if (has_utf8 || PL_encoding)
10169 PL_multi_end = CopLINE(PL_curcop);
10171 /* if we allocated too much space, give some back */
10172 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10173 SvLEN_set(sv, SvCUR(sv) + 1);
10174 SvPV_renew(sv, SvLEN(sv));
10177 /* decide whether this is the first or second quoted string we've read
10190 takes: pointer to position in buffer
10191 returns: pointer to new position in buffer
10192 side-effects: builds ops for the constant in yylval.op
10194 Read a number in any of the formats that Perl accepts:
10196 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10197 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10200 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10202 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10205 If it reads a number without a decimal point or an exponent, it will
10206 try converting the number to an integer and see if it can do so
10207 without loss of precision.
10211 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10213 register const char *s = start; /* current position in buffer */
10214 register char *d; /* destination in temp buffer */
10215 register char *e; /* end of temp buffer */
10216 NV nv; /* number read, as a double */
10217 SV *sv = Nullsv; /* place to put the converted number */
10218 bool floatit; /* boolean: int or float? */
10219 const char *lastub = 0; /* position of last underbar */
10220 static char const number_too_long[] = "Number too long";
10222 /* We use the first character to decide what type of number this is */
10226 Perl_croak(aTHX_ "panic: scan_num");
10228 /* if it starts with a 0, it could be an octal number, a decimal in
10229 0.13 disguise, or a hexadecimal number, or a binary number. */
10233 u holds the "number so far"
10234 shift the power of 2 of the base
10235 (hex == 4, octal == 3, binary == 1)
10236 overflowed was the number more than we can hold?
10238 Shift is used when we add a digit. It also serves as an "are
10239 we in octal/hex/binary?" indicator to disallow hex characters
10240 when in octal mode.
10245 bool overflowed = FALSE;
10246 bool just_zero = TRUE; /* just plain 0 or binary number? */
10247 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10248 static const char* const bases[5] =
10249 { "", "binary", "", "octal", "hexadecimal" };
10250 static const char* const Bases[5] =
10251 { "", "Binary", "", "Octal", "Hexadecimal" };
10252 static const char* const maxima[5] =
10254 "0b11111111111111111111111111111111",
10258 const char *base, *Base, *max;
10260 /* check for hex */
10265 } else if (s[1] == 'b') {
10270 /* check for a decimal in disguise */
10271 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10273 /* so it must be octal */
10280 if (ckWARN(WARN_SYNTAX))
10281 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10282 "Misplaced _ in number");
10286 base = bases[shift];
10287 Base = Bases[shift];
10288 max = maxima[shift];
10290 /* read the rest of the number */
10292 /* x is used in the overflow test,
10293 b is the digit we're adding on. */
10298 /* if we don't mention it, we're done */
10302 /* _ are ignored -- but warned about if consecutive */
10304 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10305 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10306 "Misplaced _ in number");
10310 /* 8 and 9 are not octal */
10311 case '8': case '9':
10313 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10317 case '2': case '3': case '4':
10318 case '5': case '6': case '7':
10320 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10323 case '0': case '1':
10324 b = *s++ & 15; /* ASCII digit -> value of digit */
10328 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10329 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10330 /* make sure they said 0x */
10333 b = (*s++ & 7) + 9;
10335 /* Prepare to put the digit we have onto the end
10336 of the number so far. We check for overflows.
10342 x = u << shift; /* make room for the digit */
10344 if ((x >> shift) != u
10345 && !(PL_hints & HINT_NEW_BINARY)) {
10348 if (ckWARN_d(WARN_OVERFLOW))
10349 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10350 "Integer overflow in %s number",
10353 u = x | b; /* add the digit to the end */
10356 n *= nvshift[shift];
10357 /* If an NV has not enough bits in its
10358 * mantissa to represent an UV this summing of
10359 * small low-order numbers is a waste of time
10360 * (because the NV cannot preserve the
10361 * low-order bits anyway): we could just
10362 * remember when did we overflow and in the
10363 * end just multiply n by the right
10371 /* if we get here, we had success: make a scalar value from
10376 /* final misplaced underbar check */
10377 if (s[-1] == '_') {
10378 if (ckWARN(WARN_SYNTAX))
10379 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10384 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10385 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10386 "%s number > %s non-portable",
10392 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10393 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10394 "%s number > %s non-portable",
10399 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10400 sv = new_constant(start, s - start, "integer",
10402 else if (PL_hints & HINT_NEW_BINARY)
10403 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10408 handle decimal numbers.
10409 we're also sent here when we read a 0 as the first digit
10411 case '1': case '2': case '3': case '4': case '5':
10412 case '6': case '7': case '8': case '9': case '.':
10415 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10418 /* read next group of digits and _ and copy into d */
10419 while (isDIGIT(*s) || *s == '_') {
10420 /* skip underscores, checking for misplaced ones
10424 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10425 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10426 "Misplaced _ in number");
10430 /* check for end of fixed-length buffer */
10432 Perl_croak(aTHX_ number_too_long);
10433 /* if we're ok, copy the character */
10438 /* final misplaced underbar check */
10439 if (lastub && s == lastub + 1) {
10440 if (ckWARN(WARN_SYNTAX))
10441 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10444 /* read a decimal portion if there is one. avoid
10445 3..5 being interpreted as the number 3. followed
10448 if (*s == '.' && s[1] != '.') {
10453 if (ckWARN(WARN_SYNTAX))
10454 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10455 "Misplaced _ in number");
10459 /* copy, ignoring underbars, until we run out of digits.
10461 for (; isDIGIT(*s) || *s == '_'; s++) {
10462 /* fixed length buffer check */
10464 Perl_croak(aTHX_ number_too_long);
10466 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10467 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10468 "Misplaced _ in number");
10474 /* fractional part ending in underbar? */
10475 if (s[-1] == '_') {
10476 if (ckWARN(WARN_SYNTAX))
10477 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10478 "Misplaced _ in number");
10480 if (*s == '.' && isDIGIT(s[1])) {
10481 /* oops, it's really a v-string, but without the "v" */
10487 /* read exponent part, if present */
10488 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10492 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10493 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10495 /* stray preinitial _ */
10497 if (ckWARN(WARN_SYNTAX))
10498 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10499 "Misplaced _ in number");
10503 /* allow positive or negative exponent */
10504 if (*s == '+' || *s == '-')
10507 /* stray initial _ */
10509 if (ckWARN(WARN_SYNTAX))
10510 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10511 "Misplaced _ in number");
10515 /* read digits of exponent */
10516 while (isDIGIT(*s) || *s == '_') {
10519 Perl_croak(aTHX_ number_too_long);
10523 if (((lastub && s == lastub + 1) ||
10524 (!isDIGIT(s[1]) && s[1] != '_'))
10525 && ckWARN(WARN_SYNTAX))
10526 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10527 "Misplaced _ in number");
10534 /* make an sv from the string */
10538 We try to do an integer conversion first if no characters
10539 indicating "float" have been found.
10544 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10546 if (flags == IS_NUMBER_IN_UV) {
10548 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10551 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10552 if (uv <= (UV) IV_MIN)
10553 sv_setiv(sv, -(IV)uv);
10560 /* terminate the string */
10562 nv = Atof(PL_tokenbuf);
10566 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10567 (PL_hints & HINT_NEW_INTEGER) )
10568 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10569 (floatit ? "float" : "integer"),
10573 /* if it starts with a v, it could be a v-string */
10576 sv = NEWSV(92,5); /* preallocate storage space */
10577 s = scan_vstring(s,sv);
10581 /* make the op for the constant and return */
10584 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10586 lvalp->opval = Nullop;
10592 S_scan_formline(pTHX_ register char *s)
10594 register char *eol;
10596 SV *stuff = newSVpvn("",0);
10597 bool needargs = FALSE;
10598 bool eofmt = FALSE;
10600 while (!needargs) {
10602 #ifdef PERL_STRICT_CR
10603 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10605 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10607 if (*t == '\n' || t == PL_bufend) {
10612 if (PL_in_eval && !PL_rsfp) {
10613 eol = (char *) memchr(s,'\n',PL_bufend-s);
10618 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10620 for (t = s; t < eol; t++) {
10621 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10623 goto enough; /* ~~ must be first line in formline */
10625 if (*t == '@' || *t == '^')
10629 sv_catpvn(stuff, s, eol-s);
10630 #ifndef PERL_STRICT_CR
10631 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10632 char *end = SvPVX(stuff) + SvCUR(stuff);
10635 SvCUR_set(stuff, SvCUR(stuff) - 1);
10644 s = filter_gets(PL_linestr, PL_rsfp, 0);
10645 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10646 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10647 PL_last_lop = PL_last_uni = Nullch;
10656 if (SvCUR(stuff)) {
10659 PL_lex_state = LEX_NORMAL;
10660 PL_nextval[PL_nexttoke].ival = 0;
10664 PL_lex_state = LEX_FORMLINE;
10666 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10668 else if (PL_encoding)
10669 sv_recode_to_utf8(stuff, PL_encoding);
10671 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10673 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10677 SvREFCNT_dec(stuff);
10679 PL_lex_formbrack = 0;
10690 PL_cshlen = strlen(PL_cshname);
10695 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10697 const I32 oldsavestack_ix = PL_savestack_ix;
10698 CV* outsidecv = PL_compcv;
10701 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10703 SAVEI32(PL_subline);
10704 save_item(PL_subname);
10705 SAVESPTR(PL_compcv);
10707 PL_compcv = (CV*)NEWSV(1104,0);
10708 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10709 CvFLAGS(PL_compcv) |= flags;
10711 PL_subline = CopLINE(PL_curcop);
10712 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10713 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10714 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10716 return oldsavestack_ix;
10720 #pragma segment Perl_yylex
10723 Perl_yywarn(pTHX_ const char *s)
10725 PL_in_eval |= EVAL_WARNONLY;
10727 PL_in_eval &= ~EVAL_WARNONLY;
10732 Perl_yyerror(pTHX_ const char *s)
10734 const char *where = NULL;
10735 const char *context = NULL;
10739 if (!yychar || (yychar == ';' && !PL_rsfp))
10741 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10742 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10743 PL_oldbufptr != PL_bufptr) {
10746 The code below is removed for NetWare because it abends/crashes on NetWare
10747 when the script has error such as not having the closing quotes like:
10748 if ($var eq "value)
10749 Checking of white spaces is anyway done in NetWare code.
10752 while (isSPACE(*PL_oldoldbufptr))
10755 context = PL_oldoldbufptr;
10756 contlen = PL_bufptr - PL_oldoldbufptr;
10758 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10759 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10762 The code below is removed for NetWare because it abends/crashes on NetWare
10763 when the script has error such as not having the closing quotes like:
10764 if ($var eq "value)
10765 Checking of white spaces is anyway done in NetWare code.
10768 while (isSPACE(*PL_oldbufptr))
10771 context = PL_oldbufptr;
10772 contlen = PL_bufptr - PL_oldbufptr;
10774 else if (yychar > 255)
10775 where = "next token ???";
10776 else if (yychar == -2) { /* YYEMPTY */
10777 if (PL_lex_state == LEX_NORMAL ||
10778 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10779 where = "at end of line";
10780 else if (PL_lex_inpat)
10781 where = "within pattern";
10783 where = "within string";
10786 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10788 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10789 else if (isPRINT_LC(yychar))
10790 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10792 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10793 where = SvPVX_const(where_sv);
10795 msg = sv_2mortal(newSVpv(s, 0));
10796 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10797 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10799 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10801 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10802 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10803 Perl_sv_catpvf(aTHX_ msg,
10804 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10805 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10808 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10809 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10812 if (PL_error_count >= 10) {
10813 if (PL_in_eval && SvCUR(ERRSV))
10814 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10815 ERRSV, OutCopFILE(PL_curcop));
10817 Perl_croak(aTHX_ "%s has too many errors.\n",
10818 OutCopFILE(PL_curcop));
10821 PL_in_my_stash = Nullhv;
10825 #pragma segment Main
10829 S_swallow_bom(pTHX_ U8 *s)
10831 const STRLEN slen = SvCUR(PL_linestr);
10834 if (s[1] == 0xFE) {
10835 /* UTF-16 little-endian? (or UTF32-LE?) */
10836 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10837 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10838 #ifndef PERL_NO_UTF16_FILTER
10839 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10842 if (PL_bufend > (char*)s) {
10846 filter_add(utf16rev_textfilter, NULL);
10847 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10848 utf16_to_utf8_reversed(s, news,
10849 PL_bufend - (char*)s - 1,
10851 sv_setpvn(PL_linestr, (const char*)news, newlen);
10853 SvUTF8_on(PL_linestr);
10854 s = (U8*)SvPVX(PL_linestr);
10855 PL_bufend = SvPVX(PL_linestr) + newlen;
10858 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10863 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10864 #ifndef PERL_NO_UTF16_FILTER
10865 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10868 if (PL_bufend > (char *)s) {
10872 filter_add(utf16_textfilter, NULL);
10873 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10874 utf16_to_utf8(s, news,
10875 PL_bufend - (char*)s,
10877 sv_setpvn(PL_linestr, (const char*)news, newlen);
10879 SvUTF8_on(PL_linestr);
10880 s = (U8*)SvPVX(PL_linestr);
10881 PL_bufend = SvPVX(PL_linestr) + newlen;
10884 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10889 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10890 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10891 s += 3; /* UTF-8 */
10897 if (s[2] == 0xFE && s[3] == 0xFF) {
10898 /* UTF-32 big-endian */
10899 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10902 else if (s[2] == 0 && s[3] != 0) {
10905 * are a good indicator of UTF-16BE. */
10906 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10911 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10914 * are a good indicator of UTF-16LE. */
10915 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10924 * Restore a source filter.
10928 restore_rsfp(pTHX_ void *f)
10930 PerlIO * const fp = (PerlIO*)f;
10932 if (PL_rsfp == PerlIO_stdin())
10933 PerlIO_clearerr(PL_rsfp);
10934 else if (PL_rsfp && (PL_rsfp != fp))
10935 PerlIO_close(PL_rsfp);
10939 #ifndef PERL_NO_UTF16_FILTER
10941 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10943 const STRLEN old = SvCUR(sv);
10944 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10945 DEBUG_P(PerlIO_printf(Perl_debug_log,
10946 "utf16_textfilter(%p): %d %d (%d)\n",
10947 utf16_textfilter, idx, maxlen, (int) count));
10951 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10952 Copy(SvPVX_const(sv), tmps, old, char);
10953 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10954 SvCUR(sv) - old, &newlen);
10955 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10957 DEBUG_P({sv_dump(sv);});
10962 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10964 const STRLEN old = SvCUR(sv);
10965 const I32 count = FILTER_READ(idx+1, sv, maxlen);
10966 DEBUG_P(PerlIO_printf(Perl_debug_log,
10967 "utf16rev_textfilter(%p): %d %d (%d)\n",
10968 utf16rev_textfilter, idx, maxlen, (int) count));
10972 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10973 Copy(SvPVX_const(sv), tmps, old, char);
10974 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10975 SvCUR(sv) - old, &newlen);
10976 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10978 DEBUG_P({ sv_dump(sv); });
10984 Returns a pointer to the next character after the parsed
10985 vstring, as well as updating the passed in sv.
10987 Function must be called like
10990 s = scan_vstring(s,sv);
10992 The sv should already be large enough to store the vstring
10993 passed in, for performance reasons.
10998 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
11000 const char *pos = s;
11001 const char *start = s;
11002 if (*pos == 'v') pos++; /* get past 'v' */
11003 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11005 if ( *pos != '.') {
11006 /* this may not be a v-string if followed by => */
11007 const char *next = pos;
11008 while (next < PL_bufend && isSPACE(*next))
11010 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11011 /* return string not v-string */
11012 sv_setpvn(sv,(char *)s,pos-s);
11013 return (char *)pos;
11017 if (!isALPHA(*pos)) {
11018 U8 tmpbuf[UTF8_MAXBYTES+1];
11020 if (*s == 'v') s++; /* get past 'v' */
11022 sv_setpvn(sv, "", 0);
11028 /* this is atoi() that tolerates underscores */
11029 const char *end = pos;
11031 while (--end >= s) {
11036 rev += (*end - '0') * mult;
11038 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11039 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11040 "Integer overflow in decimal number");
11044 if (rev > 0x7FFFFFFF)
11045 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11047 /* Append native character for the rev point */
11048 tmpend = uvchr_to_utf8(tmpbuf, rev);
11049 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11050 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11052 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11058 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11062 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11070 * c-indentation-style: bsd
11071 * c-basic-offset: 4
11072 * indent-tabs-mode: t
11075 * ex: set ts=8 sts=4 sw=4 noet: