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 char const ident_too_long[] = "Identifier too long";
30 static char const c_without_g[] = "Use of /c modifier is meaningless without /g";
31 static char const c_in_subst[] = "Use of /c modifier is meaningless in s///";
33 static void restore_rsfp(pTHX_ void *f);
34 #ifndef PERL_NO_UTF16_FILTER
35 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
36 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
39 #define XFAKEBRACK 128
42 #ifdef USE_UTF8_SCRIPTS
43 # define UTF (!IN_BYTES)
45 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
48 /* In variables named $^X, these are the legal values for X.
49 * 1999-02-27 mjd-perl-patch@plover.com */
50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
52 /* On MacOS, respect nonbreaking spaces */
53 #ifdef MACOS_TRADITIONAL
54 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
56 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
59 /* LEX_* are values for PL_lex_state, the state of the lexer.
60 * They are arranged oddly so that the guard on the switch statement
61 * can get by with a single comparison (if the compiler is smart enough).
64 /* #define LEX_NOTPARSING 11 is done in perl.h. */
67 #define LEX_INTERPNORMAL 9
68 #define LEX_INTERPCASEMOD 8
69 #define LEX_INTERPPUSH 7
70 #define LEX_INTERPSTART 6
71 #define LEX_INTERPEND 5
72 #define LEX_INTERPENDMAYBE 4
73 #define LEX_INTERPCONCAT 3
74 #define LEX_INTERPCONST 2
75 #define LEX_FORMLINE 1
76 #define LEX_KNOWNEXT 0
79 static char const* lex_state_names[] = {
100 /* CLINE is a macro that ensures PL_copline has a sane value */
105 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
108 * Convenience functions to return different tokens and prime the
109 * lexer for the next token. They all take an argument.
111 * TOKEN : generic token (used for '(', DOLSHARP, etc)
112 * OPERATOR : generic operator
113 * AOPERATOR : assignment operator
114 * PREBLOCK : beginning the block after an if, while, foreach, ...
115 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
116 * PREREF : *EXPR where EXPR is not a simple identifier
117 * TERM : expression term
118 * LOOPX : loop exiting command (goto, last, dump, etc)
119 * FTST : file test operator
120 * FUN0 : zero-argument function
121 * FUN1 : not used, except for not, which isn't a UNIOP
122 * BOop : bitwise or or xor
124 * SHop : shift operator
125 * PWop : power operator
126 * PMop : pattern-matching operator
127 * Aop : addition-level operator
128 * Mop : multiplication-level operator
129 * Eop : equality-testing operator
130 * Rop : relational operator <= != gt
132 * Also see LOP and lop() below.
135 #ifdef DEBUGGING /* Serve -DT. */
136 # define REPORT(retval) tokereport(s,(int)retval)
138 # define REPORT(retval) (retval)
141 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
142 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
143 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
144 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
145 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
146 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
147 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
148 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
149 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
150 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
151 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
152 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
153 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
154 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
155 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
156 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
157 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
158 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
159 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
160 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
162 /* This bit of chicanery makes a unary function followed by
163 * a parenthesis into a function with one argument, highest precedence.
164 * The UNIDOR macro is for unary functions that can be followed by the //
165 * operator (such as C<shift // 0>).
167 #define UNI2(f,x) return ( \
171 PL_last_uni = PL_oldbufptr, \
172 PL_last_lop_op = f, \
174 (*s == '(' || (s = skipspace(s), *s == '(') \
175 ? (int)FUNC1 : (int)UNIOP)))
176 #define UNI(f) UNI2(f,XTERM)
177 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
179 #define UNIBRACK(f) return ( \
182 PL_last_uni = PL_oldbufptr, \
184 (*s == '(' || (s = skipspace(s), *s == '(') \
185 ? (int)FUNC1 : (int)UNIOP)))
187 /* grandfather return to old style */
188 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
192 /* how to interpret the yylval associated with the token */
196 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
202 static struct debug_tokens { const int token, type; const char *name; } debug_tokens[] =
204 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
205 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
206 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
207 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
208 { ARROW, TOKENTYPE_NONE, "ARROW" },
209 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
210 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
211 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
212 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
213 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
214 { DO, TOKENTYPE_NONE, "DO" },
215 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
216 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
217 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
218 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
219 { ELSE, TOKENTYPE_NONE, "ELSE" },
220 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
221 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
222 { FOR, TOKENTYPE_IVAL, "FOR" },
223 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
224 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
225 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
226 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
227 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
228 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
229 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
230 { IF, TOKENTYPE_IVAL, "IF" },
231 { LABEL, TOKENTYPE_PVAL, "LABEL" },
232 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
233 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
234 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
235 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
236 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
237 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
238 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
239 { MY, TOKENTYPE_IVAL, "MY" },
240 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
241 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
242 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
243 { OROP, TOKENTYPE_IVAL, "OROP" },
244 { OROR, TOKENTYPE_NONE, "OROR" },
245 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
246 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
247 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
248 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
249 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
250 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
251 { PREINC, TOKENTYPE_NONE, "PREINC" },
252 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
253 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
254 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
255 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
256 { SUB, TOKENTYPE_NONE, "SUB" },
257 { THING, TOKENTYPE_OPVAL, "THING" },
258 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
259 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
260 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
261 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
262 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
263 { USE, TOKENTYPE_IVAL, "USE" },
264 { WHILE, TOKENTYPE_IVAL, "WHILE" },
265 { WORD, TOKENTYPE_OPVAL, "WORD" },
266 { 0, TOKENTYPE_NONE, 0 }
269 /* dump the returned token in rv, plus any optional arg in yylval */
272 S_tokereport(pTHX_ const char* s, I32 rv)
275 const char *name = Nullch;
276 enum token_type type = TOKENTYPE_NONE;
277 struct debug_tokens *p;
278 SV* report = newSVpvn("<== ", 4);
280 for (p = debug_tokens; p->token; p++) {
281 if (p->token == (int)rv) {
288 Perl_sv_catpv(aTHX_ report, name);
289 else if ((char)rv > ' ' && (char)rv < '~')
290 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
292 Perl_sv_catpv(aTHX_ report, "EOF");
294 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
297 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
300 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", yylval.ival);
302 case TOKENTYPE_OPNUM:
303 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
304 PL_op_name[yylval.ival]);
307 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
309 case TOKENTYPE_OPVAL:
311 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
312 PL_op_name[yylval.opval->op_type]);
314 Perl_sv_catpv(aTHX_ report, "(opval=null)");
317 Perl_sv_catpvf(aTHX_ report, " at line %d [", CopLINE(PL_curcop));
318 if (s - PL_bufptr > 0)
319 sv_catpvn(report, PL_bufptr, s - PL_bufptr);
321 if (PL_oldbufptr && *PL_oldbufptr)
322 sv_catpv(report, PL_tokenbuf);
324 PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen(report));
334 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
335 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
339 S_ao(pTHX_ int toketype)
341 if (*PL_bufptr == '=') {
343 if (toketype == ANDAND)
344 yylval.ival = OP_ANDASSIGN;
345 else if (toketype == OROR)
346 yylval.ival = OP_ORASSIGN;
347 else if (toketype == DORDOR)
348 yylval.ival = OP_DORASSIGN;
356 * When Perl expects an operator and finds something else, no_op
357 * prints the warning. It always prints "<something> found where
358 * operator expected. It prints "Missing semicolon on previous line?"
359 * if the surprise occurs at the start of the line. "do you need to
360 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
361 * where the compiler doesn't know if foo is a method call or a function.
362 * It prints "Missing operator before end of line" if there's nothing
363 * after the missing operator, or "... before <...>" if there is something
364 * after the missing operator.
368 S_no_op(pTHX_ const char *what, char *s)
370 char *oldbp = PL_bufptr;
371 bool is_first = (PL_oldbufptr == PL_linestart);
377 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
378 if (ckWARN_d(WARN_SYNTAX)) {
380 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
381 "\t(Missing semicolon on previous line?)\n");
382 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
384 for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
385 if (t < PL_bufptr && isSPACE(*t))
386 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
387 "\t(Do you need to predeclare %.*s?)\n",
388 t - PL_oldoldbufptr, PL_oldoldbufptr);
392 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
393 "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
401 * Complain about missing quote/regexp/heredoc terminator.
402 * If it's called with (char *)NULL then it cauterizes the line buffer.
403 * If we're in a delimited string and the delimiter is a control
404 * character, it's reformatted into a two-char sequence like ^C.
409 S_missingterm(pTHX_ char *s)
414 char *nl = strrchr(s,'\n');
420 iscntrl(PL_multi_close)
422 PL_multi_close < 32 || PL_multi_close == 127
426 tmpbuf[1] = toCTRL(PL_multi_close);
431 *tmpbuf = (char)PL_multi_close;
435 q = strchr(s,'"') ? '\'' : '"';
436 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
444 Perl_deprecate(pTHX_ const char *s)
446 if (ckWARN(WARN_DEPRECATED))
447 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
451 Perl_deprecate_old(pTHX_ const char *s)
453 /* This function should NOT be called for any new deprecated warnings */
454 /* Use Perl_deprecate instead */
456 /* It is here to maintain backward compatibility with the pre-5.8 */
457 /* warnings category hierarchy. The "deprecated" category used to */
458 /* live under the "syntax" category. It is now a top-level category */
459 /* in its own right. */
461 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
462 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
463 "Use of %s is deprecated", s);
468 * Deprecate a comma-less variable list.
474 deprecate_old("comma-less variable list");
478 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
479 * utf16-to-utf8-reversed.
482 #ifdef PERL_CR_FILTER
486 register char *s = SvPVX(sv);
487 register char *e = s + SvCUR(sv);
488 /* outer loop optimized to do nothing if there are no CR-LFs */
490 if (*s++ == '\r' && *s == '\n') {
491 /* hit a CR-LF, need to copy the rest */
492 register char *d = s - 1;
495 if (*s == '\r' && s[1] == '\n')
506 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
508 I32 count = FILTER_READ(idx+1, sv, maxlen);
509 if (count > 0 && !maxlen)
517 * Initialize variables. Uses the Perl save_stack to save its state (for
518 * recursive calls to the parser).
522 Perl_lex_start(pTHX_ SV *line)
527 SAVEI32(PL_lex_dojoin);
528 SAVEI32(PL_lex_brackets);
529 SAVEI32(PL_lex_casemods);
530 SAVEI32(PL_lex_starts);
531 SAVEI32(PL_lex_state);
532 SAVEVPTR(PL_lex_inpat);
533 SAVEI32(PL_lex_inwhat);
534 if (PL_lex_state == LEX_KNOWNEXT) {
535 I32 toke = PL_nexttoke;
536 while (--toke >= 0) {
537 SAVEI32(PL_nexttype[toke]);
538 SAVEVPTR(PL_nextval[toke]);
540 SAVEI32(PL_nexttoke);
542 SAVECOPLINE(PL_curcop);
545 SAVEPPTR(PL_oldbufptr);
546 SAVEPPTR(PL_oldoldbufptr);
547 SAVEPPTR(PL_last_lop);
548 SAVEPPTR(PL_last_uni);
549 SAVEPPTR(PL_linestart);
550 SAVESPTR(PL_linestr);
551 SAVEGENERICPV(PL_lex_brackstack);
552 SAVEGENERICPV(PL_lex_casestack);
553 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
554 SAVESPTR(PL_lex_stuff);
555 SAVEI32(PL_lex_defer);
556 SAVEI32(PL_sublex_info.sub_inwhat);
557 SAVESPTR(PL_lex_repl);
559 SAVEINT(PL_lex_expect);
561 PL_lex_state = LEX_NORMAL;
565 New(899, PL_lex_brackstack, 120, char);
566 New(899, PL_lex_casestack, 12, char);
568 *PL_lex_casestack = '\0';
571 PL_lex_stuff = Nullsv;
572 PL_lex_repl = Nullsv;
576 PL_sublex_info.sub_inwhat = 0;
578 if (SvREADONLY(PL_linestr))
579 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
580 s = SvPV(PL_linestr, len);
581 if (!len || s[len-1] != ';') {
582 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
583 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
584 sv_catpvn(PL_linestr, "\n;", 2);
586 SvTEMP_off(PL_linestr);
587 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
588 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
589 PL_last_lop = PL_last_uni = Nullch;
595 * Finalizer for lexing operations. Must be called when the parser is
596 * done with the lexer.
602 PL_doextract = FALSE;
607 * This subroutine has nothing to do with tilting, whether at windmills
608 * or pinball tables. Its name is short for "increment line". It
609 * increments the current line number in CopLINE(PL_curcop) and checks
610 * to see whether the line starts with a comment of the form
611 * # line 500 "foo.pm"
612 * If so, it sets the current line number and file to the values in the comment.
616 S_incline(pTHX_ char *s)
623 CopLINE_inc(PL_curcop);
626 while (SPACE_OR_TAB(*s)) s++;
627 if (strnEQ(s, "line", 4))
631 if (SPACE_OR_TAB(*s))
635 while (SPACE_OR_TAB(*s)) s++;
641 while (SPACE_OR_TAB(*s))
643 if (*s == '"' && (t = strchr(s+1, '"'))) {
648 for (t = s; !isSPACE(*t); t++) ;
651 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
653 if (*e != '\n' && *e != '\0')
654 return; /* false alarm */
659 CopFILE_free(PL_curcop);
660 CopFILE_set(PL_curcop, s);
663 CopLINE_set(PL_curcop, atoi(n)-1);
668 * Called to gobble the appropriate amount and type of whitespace.
669 * Skips comments as well.
673 S_skipspace(pTHX_ register char *s)
675 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
676 while (s < PL_bufend && SPACE_OR_TAB(*s))
682 SSize_t oldprevlen, oldoldprevlen;
683 SSize_t oldloplen = 0, oldunilen = 0;
684 while (s < PL_bufend && isSPACE(*s)) {
685 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
690 if (s < PL_bufend && *s == '#') {
691 while (s < PL_bufend && *s != '\n')
695 if (PL_in_eval && !PL_rsfp) {
702 /* only continue to recharge the buffer if we're at the end
703 * of the buffer, we're not reading from a source filter, and
704 * we're in normal lexing mode
706 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
707 PL_lex_state == LEX_FORMLINE)
710 /* try to recharge the buffer */
711 if ((s = filter_gets(PL_linestr, PL_rsfp,
712 (prevlen = SvCUR(PL_linestr)))) == Nullch)
714 /* end of file. Add on the -p or -n magic */
717 ";}continue{print or die qq(-p destination: $!\\n);}");
718 PL_minus_n = PL_minus_p = 0;
720 else if (PL_minus_n) {
721 sv_setpvn(PL_linestr, ";}", 2);
725 sv_setpvn(PL_linestr,";", 1);
727 /* reset variables for next time we lex */
728 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
730 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
731 PL_last_lop = PL_last_uni = Nullch;
733 /* Close the filehandle. Could be from -P preprocessor,
734 * STDIN, or a regular file. If we were reading code from
735 * STDIN (because the commandline held no -e or filename)
736 * then we don't close it, we reset it so the code can
737 * read from STDIN too.
740 if (PL_preprocess && !PL_in_eval)
741 (void)PerlProc_pclose(PL_rsfp);
742 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
743 PerlIO_clearerr(PL_rsfp);
745 (void)PerlIO_close(PL_rsfp);
750 /* not at end of file, so we only read another line */
751 /* make corresponding updates to old pointers, for yyerror() */
752 oldprevlen = PL_oldbufptr - PL_bufend;
753 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
755 oldunilen = PL_last_uni - PL_bufend;
757 oldloplen = PL_last_lop - PL_bufend;
758 PL_linestart = PL_bufptr = s + prevlen;
759 PL_bufend = s + SvCUR(PL_linestr);
761 PL_oldbufptr = s + oldprevlen;
762 PL_oldoldbufptr = s + oldoldprevlen;
764 PL_last_uni = s + oldunilen;
766 PL_last_lop = s + oldloplen;
769 /* debugger active and we're not compiling the debugger code,
770 * so store the line into the debugger's array of lines
772 if (PERLDB_LINE && PL_curstash != PL_debstash) {
773 SV *sv = NEWSV(85,0);
775 sv_upgrade(sv, SVt_PVMG);
776 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
779 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
786 * Check the unary operators to ensure there's no ambiguity in how they're
787 * used. An ambiguous piece of code would be:
789 * This doesn't mean rand() + 5. Because rand() is a unary operator,
790 * the +5 is its argument.
799 if (PL_oldoldbufptr != PL_last_uni)
801 while (isSPACE(*PL_last_uni))
803 for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
804 if ((t = strchr(s, '(')) && t < PL_bufptr)
806 if (ckWARN_d(WARN_AMBIGUOUS)){
809 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
810 "Warning: Use of \"%s\" without parentheses is ambiguous",
817 * LOP : macro to build a list operator. Its behaviour has been replaced
818 * with a subroutine, S_lop() for which LOP is just another name.
821 #define LOP(f,x) return lop(f,x,s)
825 * Build a list operator (or something that might be one). The rules:
826 * - if we have a next token, then it's a list operator [why?]
827 * - if the next thing is an opening paren, then it's a function
828 * - else it's a list operator
832 S_lop(pTHX_ I32 f, int x, char *s)
838 PL_last_lop = PL_oldbufptr;
839 PL_last_lop_op = (OPCODE)f;
841 return REPORT(LSTOP);
848 return REPORT(LSTOP);
853 * When the lexer realizes it knows the next token (for instance,
854 * it is reordering tokens for the parser) then it can call S_force_next
855 * to know what token to return the next time the lexer is called. Caller
856 * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
857 * handles the token correctly.
861 S_force_next(pTHX_ I32 type)
863 PL_nexttype[PL_nexttoke] = type;
865 if (PL_lex_state != LEX_KNOWNEXT) {
866 PL_lex_defer = PL_lex_state;
867 PL_lex_expect = PL_expect;
868 PL_lex_state = LEX_KNOWNEXT;
873 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
875 SV *sv = newSVpvn(start,len);
876 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
883 * When the lexer knows the next thing is a word (for instance, it has
884 * just seen -> and it knows that the next char is a word char, then
885 * it calls S_force_word to stick the next word into the PL_next lookahead.
888 * char *start : buffer position (must be within PL_linestr)
889 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
890 * int check_keyword : if true, Perl checks to make sure the word isn't
891 * a keyword (do this if the word is a label, e.g. goto FOO)
892 * int allow_pack : if true, : characters will also be allowed (require,
894 * int allow_initial_tick : used by the "sub" lexer only.
898 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
903 start = skipspace(start);
905 if (isIDFIRST_lazy_if(s,UTF) ||
906 (allow_pack && *s == ':') ||
907 (allow_initial_tick && *s == '\'') )
909 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
910 if (check_keyword && keyword(PL_tokenbuf, len))
912 if (token == METHOD) {
917 PL_expect = XOPERATOR;
920 PL_nextval[PL_nexttoke].opval
921 = (OP*)newSVOP(OP_CONST,0,
922 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
923 PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
931 * Called when the lexer wants $foo *foo &foo etc, but the program
932 * text only contains the "foo" portion. The first argument is a pointer
933 * to the "foo", and the second argument is the type symbol to prefix.
934 * Forces the next token to be a "WORD".
935 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
939 S_force_ident(pTHX_ register const char *s, int kind)
942 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
943 PL_nextval[PL_nexttoke].opval = o;
946 o->op_private = OPpCONST_ENTERED;
947 /* XXX see note in pp_entereval() for why we forgo typo
948 warnings if the symbol must be introduced in an eval.
950 gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
951 kind == '$' ? SVt_PV :
952 kind == '@' ? SVt_PVAV :
953 kind == '%' ? SVt_PVHV :
961 Perl_str_to_version(pTHX_ SV *sv)
966 char *start = SvPVx(sv,len);
967 bool utf = SvUTF8(sv) ? TRUE : FALSE;
968 char *end = start + len;
969 while (start < end) {
973 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
978 retval += ((NV)n)/nshift;
987 * Forces the next token to be a version number.
988 * If the next token appears to be an invalid version number, (e.g. "v2b"),
989 * and if "guessing" is TRUE, then no new token is created (and the caller
990 * must use an alternative parsing method).
994 S_force_version(pTHX_ char *s, int guessing)
996 OP *version = Nullop;
1005 while (isDIGIT(*d) || *d == '_' || *d == '.')
1007 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1009 s = scan_num(s, &yylval);
1010 version = yylval.opval;
1011 ver = cSVOPx(version)->op_sv;
1012 if (SvPOK(ver) && !SvNIOK(ver)) {
1013 (void)SvUPGRADE(ver, SVt_PVNV);
1014 SvNVX(ver) = str_to_version(ver);
1015 SvNOK_on(ver); /* hint that it is a version */
1022 /* NOTE: The parser sees the package name and the VERSION swapped */
1023 PL_nextval[PL_nexttoke].opval = version;
1031 * Tokenize a quoted string passed in as an SV. It finds the next
1032 * chunk, up to end of string or a backslash. It may make a new
1033 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1038 S_tokeq(pTHX_ SV *sv)
1041 register char *send;
1049 s = SvPV_force(sv, len);
1050 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1053 while (s < send && *s != '\\')
1058 if ( PL_hints & HINT_NEW_STRING ) {
1059 pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
1065 if (s + 1 < send && (s[1] == '\\'))
1066 s++; /* all that, just for this */
1071 SvCUR_set(sv, d - SvPVX(sv));
1073 if ( PL_hints & HINT_NEW_STRING )
1074 return new_constant(NULL, 0, "q", sv, pv, "q");
1079 * Now come three functions related to double-quote context,
1080 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1081 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1082 * interact with PL_lex_state, and create fake ( ... ) argument lists
1083 * to handle functions and concatenation.
1084 * They assume that whoever calls them will be setting up a fake
1085 * join call, because each subthing puts a ',' after it. This lets
1088 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1090 * (I'm not sure whether the spurious commas at the end of lcfirst's
1091 * arguments and join's arguments are created or not).
1096 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1098 * Pattern matching will set PL_lex_op to the pattern-matching op to
1099 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1101 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1103 * Everything else becomes a FUNC.
1105 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1106 * had an OP_CONST or OP_READLINE). This just sets us up for a
1107 * call to S_sublex_push().
1111 S_sublex_start(pTHX)
1113 register I32 op_type = yylval.ival;
1115 if (op_type == OP_NULL) {
1116 yylval.opval = PL_lex_op;
1120 if (op_type == OP_CONST || op_type == OP_READLINE) {
1121 SV *sv = tokeq(PL_lex_stuff);
1123 if (SvTYPE(sv) == SVt_PVIV) {
1124 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1130 nsv = newSVpvn(p, len);
1136 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1137 PL_lex_stuff = Nullsv;
1138 /* Allow <FH> // "foo" */
1139 if (op_type == OP_READLINE)
1140 PL_expect = XTERMORDORDOR;
1144 PL_sublex_info.super_state = PL_lex_state;
1145 PL_sublex_info.sub_inwhat = op_type;
1146 PL_sublex_info.sub_op = PL_lex_op;
1147 PL_lex_state = LEX_INTERPPUSH;
1151 yylval.opval = PL_lex_op;
1161 * Create a new scope to save the lexing state. The scope will be
1162 * ended in S_sublex_done. Returns a '(', starting the function arguments
1163 * to the uc, lc, etc. found before.
1164 * Sets PL_lex_state to LEX_INTERPCONCAT.
1172 PL_lex_state = PL_sublex_info.super_state;
1173 SAVEI32(PL_lex_dojoin);
1174 SAVEI32(PL_lex_brackets);
1175 SAVEI32(PL_lex_casemods);
1176 SAVEI32(PL_lex_starts);
1177 SAVEI32(PL_lex_state);
1178 SAVEVPTR(PL_lex_inpat);
1179 SAVEI32(PL_lex_inwhat);
1180 SAVECOPLINE(PL_curcop);
1181 SAVEPPTR(PL_bufptr);
1182 SAVEPPTR(PL_bufend);
1183 SAVEPPTR(PL_oldbufptr);
1184 SAVEPPTR(PL_oldoldbufptr);
1185 SAVEPPTR(PL_last_lop);
1186 SAVEPPTR(PL_last_uni);
1187 SAVEPPTR(PL_linestart);
1188 SAVESPTR(PL_linestr);
1189 SAVEGENERICPV(PL_lex_brackstack);
1190 SAVEGENERICPV(PL_lex_casestack);
1192 PL_linestr = PL_lex_stuff;
1193 PL_lex_stuff = Nullsv;
1195 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1196 = SvPVX(PL_linestr);
1197 PL_bufend += SvCUR(PL_linestr);
1198 PL_last_lop = PL_last_uni = Nullch;
1199 SAVEFREESV(PL_linestr);
1201 PL_lex_dojoin = FALSE;
1202 PL_lex_brackets = 0;
1203 New(899, PL_lex_brackstack, 120, char);
1204 New(899, PL_lex_casestack, 12, char);
1205 PL_lex_casemods = 0;
1206 *PL_lex_casestack = '\0';
1208 PL_lex_state = LEX_INTERPCONCAT;
1209 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1211 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1212 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1213 PL_lex_inpat = PL_sublex_info.sub_op;
1215 PL_lex_inpat = Nullop;
1222 * Restores lexer state after a S_sublex_push.
1228 if (!PL_lex_starts++) {
1229 SV *sv = newSVpvn("",0);
1230 if (SvUTF8(PL_linestr))
1232 PL_expect = XOPERATOR;
1233 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1237 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1238 PL_lex_state = LEX_INTERPCASEMOD;
1242 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1243 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1244 PL_linestr = PL_lex_repl;
1246 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1247 PL_bufend += SvCUR(PL_linestr);
1248 PL_last_lop = PL_last_uni = Nullch;
1249 SAVEFREESV(PL_linestr);
1250 PL_lex_dojoin = FALSE;
1251 PL_lex_brackets = 0;
1252 PL_lex_casemods = 0;
1253 *PL_lex_casestack = '\0';
1255 if (SvEVALED(PL_lex_repl)) {
1256 PL_lex_state = LEX_INTERPNORMAL;
1258 /* we don't clear PL_lex_repl here, so that we can check later
1259 whether this is an evalled subst; that means we rely on the
1260 logic to ensure sublex_done() is called again only via the
1261 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1264 PL_lex_state = LEX_INTERPCONCAT;
1265 PL_lex_repl = Nullsv;
1271 PL_bufend = SvPVX(PL_linestr);
1272 PL_bufend += SvCUR(PL_linestr);
1273 PL_expect = XOPERATOR;
1274 PL_sublex_info.sub_inwhat = 0;
1282 Extracts a pattern, double-quoted string, or transliteration. This
1285 It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1286 processing a pattern (PL_lex_inpat is true), a transliteration
1287 (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1289 Returns a pointer to the character scanned up to. Iff this is
1290 advanced from the start pointer supplied (ie if anything was
1291 successfully parsed), will leave an OP for the substring scanned
1292 in yylval. Caller must intuit reason for not parsing further
1293 by looking at the next characters herself.
1297 double-quoted style: \r and \n
1298 regexp special ones: \D \s
1300 backrefs: \1 (deprecated in substitution replacements)
1301 case and quoting: \U \Q \E
1302 stops on @ and $, but not for $ as tail anchor
1304 In transliterations:
1305 characters are VERY literal, except for - not at the start or end
1306 of the string, which indicates a range. scan_const expands the
1307 range to the full set of intermediate characters.
1309 In double-quoted strings:
1311 double-quoted style: \r and \n
1313 backrefs: \1 (deprecated)
1314 case and quoting: \U \Q \E
1317 scan_const does *not* construct ops to handle interpolated strings.
1318 It stops processing as soon as it finds an embedded $ or @ variable
1319 and leaves it to the caller to work out what's going on.
1321 @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1323 $ in pattern could be $foo or could be tail anchor. Assumption:
1324 it's a tail anchor if $ is the last thing in the string, or if it's
1325 followed by one of ")| \n\t"
1327 \1 (backreferences) are turned into $1
1329 The structure of the code is
1330 while (there's a character to process) {
1331 handle transliteration ranges
1332 skip regexp comments
1333 skip # initiated comments in //x patterns
1334 check for embedded @foo
1335 check for embedded scalars
1337 leave intact backslashes from leave (below)
1338 deprecate \1 in strings and sub replacements
1339 handle string-changing backslashes \l \U \Q \E, etc.
1340 switch (what was escaped) {
1341 handle - in a transliteration (becomes a literal -)
1342 handle \132 octal characters
1343 handle 0x15 hex characters
1344 handle \cV (control V)
1345 handle printf backslashes (\f, \r, \n, etc)
1347 } (end if backslash)
1348 } (end while character to read)
1353 S_scan_const(pTHX_ char *start)
1355 register char *send = PL_bufend; /* end of the constant */
1356 SV *sv = NEWSV(93, send - start); /* sv for the constant */
1357 register char *s = start; /* start of the constant */
1358 register char *d = SvPVX(sv); /* destination for copies */
1359 bool dorange = FALSE; /* are we in a translit range? */
1360 bool didrange = FALSE; /* did we just finish a range? */
1361 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1362 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1365 const char *leaveit = /* set of acceptably-backslashed characters */
1367 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1370 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1371 /* If we are doing a trans and we know we want UTF8 set expectation */
1372 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1373 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1377 while (s < send || dorange) {
1378 /* get transliterations out of the way (they're most literal) */
1379 if (PL_lex_inwhat == OP_TRANS) {
1380 /* expand a range A-Z to the full set of characters. AIE! */
1382 I32 i; /* current expanded character */
1383 I32 min; /* first character in range */
1384 I32 max; /* last character in range */
1387 char *c = (char*)utf8_hop((U8*)d, -1);
1391 *c = (char)UTF_TO_NATIVE(0xff);
1392 /* mark the range as done, and continue */
1398 i = d - SvPVX(sv); /* remember current offset */
1399 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1400 d = SvPVX(sv) + i; /* refresh d after realloc */
1401 d -= 2; /* eat the first char and the - */
1403 min = (U8)*d; /* first char in range */
1404 max = (U8)d[1]; /* last char in range */
1408 "Invalid range \"%c-%c\" in transliteration operator",
1409 (char)min, (char)max);
1413 if ((isLOWER(min) && isLOWER(max)) ||
1414 (isUPPER(min) && isUPPER(max))) {
1416 for (i = min; i <= max; i++)
1418 *d++ = NATIVE_TO_NEED(has_utf8,i);
1420 for (i = min; i <= max; i++)
1422 *d++ = NATIVE_TO_NEED(has_utf8,i);
1427 for (i = min; i <= max; i++)
1430 /* mark the range as done, and continue */
1436 /* range begins (ignore - as first or last char) */
1437 else if (*s == '-' && s+1 < send && s != start) {
1439 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1442 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1454 /* if we get here, we're not doing a transliteration */
1456 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1457 except for the last char, which will be done separately. */
1458 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1460 while (s+1 < send && *s != ')')
1461 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1463 else if (s[2] == '{' /* This should match regcomp.c */
1464 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1467 char *regparse = s + (s[2] == '{' ? 3 : 4);
1470 while (count && (c = *regparse)) {
1471 if (c == '\\' && regparse[1])
1479 if (*regparse != ')')
1480 regparse--; /* Leave one char for continuation. */
1481 while (s < regparse)
1482 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1486 /* likewise skip #-initiated comments in //x patterns */
1487 else if (*s == '#' && PL_lex_inpat &&
1488 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1489 while (s+1 < send && *s != '\n')
1490 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1493 /* check for embedded arrays
1494 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1496 else if (*s == '@' && s[1]
1497 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1500 /* check for embedded scalars. only stop if we're sure it's a
1503 else if (*s == '$') {
1504 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
1506 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1507 break; /* in regexp, $ might be tail anchor */
1510 /* End of else if chain - OP_TRANS rejoin rest */
1513 if (*s == '\\' && s+1 < send) {
1516 /* some backslashes we leave behind */
1517 if (*leaveit && *s && strchr(leaveit, *s)) {
1518 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1519 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1523 /* deprecate \1 in strings and substitution replacements */
1524 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1525 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1527 if (ckWARN(WARN_SYNTAX))
1528 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1533 /* string-change backslash escapes */
1534 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1539 /* if we get here, it's either a quoted -, or a digit */
1542 /* quoted - in transliterations */
1544 if (PL_lex_inwhat == OP_TRANS) {
1551 if (ckWARN(WARN_MISC) &&
1554 Perl_warner(aTHX_ packWARN(WARN_MISC),
1555 "Unrecognized escape \\%c passed through",
1557 /* default action is to copy the quoted character */
1558 goto default_action;
1561 /* \132 indicates an octal constant */
1562 case '0': case '1': case '2': case '3':
1563 case '4': case '5': case '6': case '7':
1567 uv = grok_oct(s, &len, &flags, NULL);
1570 goto NUM_ESCAPE_INSERT;
1572 /* \x24 indicates a hex constant */
1576 char* e = strchr(s, '}');
1577 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1578 PERL_SCAN_DISALLOW_PREFIX;
1583 yyerror("Missing right brace on \\x{}");
1587 uv = grok_hex(s, &len, &flags, NULL);
1593 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1594 uv = grok_hex(s, &len, &flags, NULL);
1600 /* Insert oct or hex escaped character.
1601 * There will always enough room in sv since such
1602 * escapes will be longer than any UTF-8 sequence
1603 * they can end up as. */
1605 /* We need to map to chars to ASCII before doing the tests
1608 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1609 if (!has_utf8 && uv > 255) {
1610 /* Might need to recode whatever we have
1611 * accumulated so far if it contains any
1614 * (Can't we keep track of that and avoid
1615 * this rescan? --jhi)
1619 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1620 if (!NATIVE_IS_INVARIANT(*c)) {
1625 STRLEN offset = d - SvPVX(sv);
1627 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1631 while (src >= (U8 *)SvPVX(sv)) {
1632 if (!NATIVE_IS_INVARIANT(*src)) {
1633 U8 ch = NATIVE_TO_ASCII(*src);
1634 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1635 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1645 if (has_utf8 || uv > 255) {
1646 d = (char*)uvchr_to_utf8((U8*)d, uv);
1648 if (PL_lex_inwhat == OP_TRANS &&
1649 PL_sublex_info.sub_op) {
1650 PL_sublex_info.sub_op->op_private |=
1651 (PL_lex_repl ? OPpTRANS_FROM_UTF
1664 /* \N{LATIN SMALL LETTER A} is a named character */
1668 char* e = strchr(s, '}');
1674 yyerror("Missing right brace on \\N{}");
1678 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1680 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1681 PERL_SCAN_DISALLOW_PREFIX;
1684 uv = grok_hex(s, &len, &flags, NULL);
1686 goto NUM_ESCAPE_INSERT;
1688 res = newSVpvn(s + 1, e - s - 1);
1689 res = new_constant( Nullch, 0, "charnames",
1690 res, Nullsv, "\\N{...}" );
1692 sv_utf8_upgrade(res);
1693 str = SvPV(res,len);
1694 #ifdef EBCDIC_NEVER_MIND
1695 /* charnames uses pack U and that has been
1696 * recently changed to do the below uni->native
1697 * mapping, so this would be redundant (and wrong,
1698 * the code point would be doubly converted).
1699 * But leave this in just in case the pack U change
1700 * gets revoked, but the semantics is still
1701 * desireable for charnames. --jhi */
1703 UV uv = utf8_to_uvchr((U8*)str, 0);
1706 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1708 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1709 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1710 str = SvPV(res, len);
1714 if (!has_utf8 && SvUTF8(res)) {
1715 char *ostart = SvPVX(sv);
1716 SvCUR_set(sv, d - ostart);
1719 sv_utf8_upgrade(sv);
1720 /* this just broke our allocation above... */
1721 SvGROW(sv, (STRLEN)(send - start));
1722 d = SvPVX(sv) + SvCUR(sv);
1725 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1726 char *odest = SvPVX(sv);
1728 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1729 d = SvPVX(sv) + (d - odest);
1731 Copy(str, d, len, char);
1738 yyerror("Missing braces on \\N{}");
1741 /* \c is a control character */
1750 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1753 yyerror("Missing control char name in \\c");
1757 /* printf-style backslashes, formfeeds, newlines, etc */
1759 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1762 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1765 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1768 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1771 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1774 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1777 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1783 } /* end if (backslash) */
1786 /* If we started with encoded form, or already know we want it
1787 and then encode the next character */
1788 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1790 UV uv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1791 STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1794 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1795 STRLEN off = d - SvPVX(sv);
1796 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1798 d = (char*)uvchr_to_utf8((U8*)d, uv);
1802 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1804 } /* while loop to process each character */
1806 /* terminate the string and set up the sv */
1808 SvCUR_set(sv, d - SvPVX(sv));
1809 if (SvCUR(sv) >= SvLEN(sv))
1810 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1813 if (PL_encoding && !has_utf8) {
1814 sv_recode_to_utf8(sv, PL_encoding);
1820 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1821 PL_sublex_info.sub_op->op_private |=
1822 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1826 /* shrink the sv if we allocated more than we used */
1827 if (SvCUR(sv) + 5 < SvLEN(sv)) {
1828 SvLEN_set(sv, SvCUR(sv) + 1);
1829 Renew(SvPVX(sv), SvLEN(sv), char);
1832 /* return the substring (via yylval) only if we parsed anything */
1833 if (s > PL_bufptr) {
1834 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1835 sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1837 ( PL_lex_inwhat == OP_TRANS
1839 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1842 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1849 * Returns TRUE if there's more to the expression (e.g., a subscript),
1852 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1854 * ->[ and ->{ return TRUE
1855 * { and [ outside a pattern are always subscripts, so return TRUE
1856 * if we're outside a pattern and it's not { or [, then return FALSE
1857 * if we're in a pattern and the first char is a {
1858 * {4,5} (any digits around the comma) returns FALSE
1859 * if we're in a pattern and the first char is a [
1861 * [SOMETHING] has a funky algorithm to decide whether it's a
1862 * character class or not. It has to deal with things like
1863 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1864 * anything else returns TRUE
1867 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1870 S_intuit_more(pTHX_ register char *s)
1872 if (PL_lex_brackets)
1874 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1876 if (*s != '{' && *s != '[')
1881 /* In a pattern, so maybe we have {n,m}. */
1898 /* On the other hand, maybe we have a character class */
1901 if (*s == ']' || *s == '^')
1904 /* this is terrifying, and it works */
1905 int weight = 2; /* let's weigh the evidence */
1907 unsigned char un_char = 255, last_un_char;
1908 char *send = strchr(s,']');
1909 char tmpbuf[sizeof PL_tokenbuf * 4];
1911 if (!send) /* has to be an expression */
1914 Zero(seen,256,char);
1917 else if (isDIGIT(*s)) {
1919 if (isDIGIT(s[1]) && s[2] == ']')
1925 for (; s < send; s++) {
1926 last_un_char = un_char;
1927 un_char = (unsigned char)*s;
1932 weight -= seen[un_char] * 10;
1933 if (isALNUM_lazy_if(s+1,UTF)) {
1934 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1935 if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1940 else if (*s == '$' && s[1] &&
1941 strchr("[#!%*<>()-=",s[1])) {
1942 if (/*{*/ strchr("])} =",s[2]))
1951 if (strchr("wds]",s[1]))
1953 else if (seen['\''] || seen['"'])
1955 else if (strchr("rnftbxcav",s[1]))
1957 else if (isDIGIT(s[1])) {
1959 while (s[1] && isDIGIT(s[1]))
1969 if (strchr("aA01! ",last_un_char))
1971 if (strchr("zZ79~",s[1]))
1973 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1974 weight -= 5; /* cope with negative subscript */
1977 if (!isALNUM(last_un_char)
1978 && !(last_un_char == '$' || last_un_char == '@'
1979 || last_un_char == '&')
1980 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
1985 if (keyword(tmpbuf, d - tmpbuf))
1988 if (un_char == last_un_char + 1)
1990 weight -= seen[un_char];
1995 if (weight >= 0) /* probably a character class */
2005 * Does all the checking to disambiguate
2007 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2008 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2010 * First argument is the stuff after the first token, e.g. "bar".
2012 * Not a method if bar is a filehandle.
2013 * Not a method if foo is a subroutine prototyped to take a filehandle.
2014 * Not a method if it's really "Foo $bar"
2015 * Method if it's "foo $bar"
2016 * Not a method if it's really "print foo $bar"
2017 * Method if it's really "foo package::" (interpreted as package->foo)
2018 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2019 * Not a method if bar is a filehandle or package, but is quoted with
2024 S_intuit_method(pTHX_ char *start, GV *gv)
2026 char *s = start + (*start == '$');
2027 char tmpbuf[sizeof PL_tokenbuf];
2035 if ((cv = GvCVu(gv))) {
2036 char *proto = SvPVX(cv);
2046 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2047 /* start is the beginning of the possible filehandle/object,
2048 * and s is the end of it
2049 * tmpbuf is a copy of it
2052 if (*start == '$') {
2053 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2058 return *s == '(' ? FUNCMETH : METHOD;
2060 if (!keyword(tmpbuf, len)) {
2061 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2066 indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2067 if (indirgv && GvCVu(indirgv))
2069 /* filehandle or package name makes it a method */
2070 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2072 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2073 return 0; /* no assumptions -- "=>" quotes bearword */
2075 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2076 newSVpvn(tmpbuf,len));
2077 PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2081 return *s == '(' ? FUNCMETH : METHOD;
2089 * Return a string of Perl code to load the debugger. If PERL5DB
2090 * is set, it will return the contents of that, otherwise a
2091 * compile-time require of perl5db.pl.
2098 const char *pdb = PerlEnv_getenv("PERL5DB");
2102 SETERRNO(0,SS_NORMAL);
2103 return "BEGIN { require 'perl5db.pl' }";
2109 /* Encoded script support. filter_add() effectively inserts a
2110 * 'pre-processing' function into the current source input stream.
2111 * Note that the filter function only applies to the current source file
2112 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2114 * The datasv parameter (which may be NULL) can be used to pass
2115 * private data to this instance of the filter. The filter function
2116 * can recover the SV using the FILTER_DATA macro and use it to
2117 * store private buffers and state information.
2119 * The supplied datasv parameter is upgraded to a PVIO type
2120 * and the IoDIRP/IoANY field is used to store the function pointer,
2121 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2122 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2123 * private use must be set using malloc'd pointers.
2127 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2132 if (!PL_rsfp_filters)
2133 PL_rsfp_filters = newAV();
2135 datasv = NEWSV(255,0);
2136 if (!SvUPGRADE(datasv, SVt_PVIO))
2137 Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
2138 IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
2139 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2140 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2141 (void*)funcp, SvPV_nolen(datasv)));
2142 av_unshift(PL_rsfp_filters, 1);
2143 av_store(PL_rsfp_filters, 0, datasv) ;
2148 /* Delete most recently added instance of this filter function. */
2150 Perl_filter_del(pTHX_ filter_t funcp)
2153 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2154 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2156 /* if filter is on top of stack (usual case) just pop it off */
2157 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2158 if (IoANY(datasv) == (void *)funcp) {
2159 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2160 IoANY(datasv) = (void *)NULL;
2161 sv_free(av_pop(PL_rsfp_filters));
2165 /* we need to search for the correct entry and clear it */
2166 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2170 /* Invoke the idxth filter function for the current rsfp. */
2171 /* maxlen 0 = read one text line */
2173 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2178 if (!PL_rsfp_filters)
2180 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2181 /* Provide a default input filter to make life easy. */
2182 /* Note that we append to the line. This is handy. */
2183 DEBUG_P(PerlIO_printf(Perl_debug_log,
2184 "filter_read %d: from rsfp\n", idx));
2188 int old_len = SvCUR(buf_sv) ;
2190 /* ensure buf_sv is large enough */
2191 SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2192 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2193 if (PerlIO_error(PL_rsfp))
2194 return -1; /* error */
2196 return 0 ; /* end of file */
2198 SvCUR_set(buf_sv, old_len + len) ;
2201 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2202 if (PerlIO_error(PL_rsfp))
2203 return -1; /* error */
2205 return 0 ; /* end of file */
2208 return SvCUR(buf_sv);
2210 /* Skip this filter slot if filter has been deleted */
2211 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2212 DEBUG_P(PerlIO_printf(Perl_debug_log,
2213 "filter_read %d: skipped (filter deleted)\n",
2215 return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2217 /* Get function pointer hidden within datasv */
2218 funcp = (filter_t)IoANY(datasv);
2219 DEBUG_P(PerlIO_printf(Perl_debug_log,
2220 "filter_read %d: via function %p (%s)\n",
2221 idx, (void*)funcp, SvPV_nolen(datasv)));
2222 /* Call function. The function is expected to */
2223 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2224 /* Return: <0:error, =0:eof, >0:not eof */
2225 return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2229 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2231 #ifdef PERL_CR_FILTER
2232 if (!PL_rsfp_filters) {
2233 filter_add(S_cr_textfilter,NULL);
2236 if (PL_rsfp_filters) {
2238 SvCUR_set(sv, 0); /* start with empty line */
2239 if (FILTER_READ(0, sv, 0) > 0)
2240 return ( SvPVX(sv) ) ;
2245 return (sv_gets(sv, fp, append));
2249 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2253 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2257 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2258 (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2260 return GvHV(gv); /* Foo:: */
2263 /* use constant CLASS => 'MyClass' */
2264 if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2266 if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2267 pkgname = SvPV_nolen(sv);
2271 return gv_stashpv(pkgname, FALSE);
2275 static char const* exp_name[] =
2276 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2277 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2284 Works out what to call the token just pulled out of the input
2285 stream. The yacc parser takes care of taking the ops we return and
2286 stitching them into a tree.
2292 if read an identifier
2293 if we're in a my declaration
2294 croak if they tried to say my($foo::bar)
2295 build the ops for a my() declaration
2296 if it's an access to a my() variable
2297 are we in a sort block?
2298 croak if my($a); $a <=> $b
2299 build ops for access to a my() variable
2300 if in a dq string, and they've said @foo and we can't find @foo
2302 build ops for a bareword
2303 if we already built the token before, use it.
2308 #pragma segment Perl_yylex
2313 register char *s = PL_bufptr;
2320 I32 orig_keyword = 0;
2323 PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2324 lex_state_names[PL_lex_state]);
2326 /* check if there's an identifier for us to look at */
2327 if (PL_pending_ident)
2328 return REPORT(S_pending_ident(aTHX));
2330 /* no identifier pending identification */
2332 switch (PL_lex_state) {
2334 case LEX_NORMAL: /* Some compilers will produce faster */
2335 case LEX_INTERPNORMAL: /* code if we comment these out. */
2339 /* when we've already built the next token, just pull it out of the queue */
2342 yylval = PL_nextval[PL_nexttoke];
2344 PL_lex_state = PL_lex_defer;
2345 PL_expect = PL_lex_expect;
2346 PL_lex_defer = LEX_NORMAL;
2348 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2349 "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2350 (IV)PL_nexttype[PL_nexttoke]); });
2352 return REPORT(PL_nexttype[PL_nexttoke]);
2354 /* interpolated case modifiers like \L \U, including \Q and \E.
2355 when we get here, PL_bufptr is at the \
2357 case LEX_INTERPCASEMOD:
2359 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2360 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2362 /* handle \E or end of string */
2363 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2367 if (PL_lex_casemods) {
2368 oldmod = PL_lex_casestack[--PL_lex_casemods];
2369 PL_lex_casestack[PL_lex_casemods] = '\0';
2371 if (PL_bufptr != PL_bufend
2372 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2374 PL_lex_state = LEX_INTERPCONCAT;
2378 if (PL_bufptr != PL_bufend)
2380 PL_lex_state = LEX_INTERPCONCAT;
2384 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2385 "### Saw case modifier at '%s'\n", PL_bufptr); });
2387 if (s[1] == '\\' && s[2] == 'E') {
2389 PL_lex_state = LEX_INTERPCONCAT;
2393 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2394 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
2395 if ((*s == 'L' || *s == 'U') &&
2396 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2397 PL_lex_casestack[--PL_lex_casemods] = '\0';
2400 if (PL_lex_casemods > 10)
2401 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2402 PL_lex_casestack[PL_lex_casemods++] = *s;
2403 PL_lex_casestack[PL_lex_casemods] = '\0';
2404 PL_lex_state = LEX_INTERPCONCAT;
2405 PL_nextval[PL_nexttoke].ival = 0;
2408 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2410 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2412 PL_nextval[PL_nexttoke].ival = OP_LC;
2414 PL_nextval[PL_nexttoke].ival = OP_UC;
2416 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2418 Perl_croak(aTHX_ "panic: yylex");
2422 if (PL_lex_starts) {
2425 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2426 if (PL_lex_casemods == 1 && PL_lex_inpat)
2435 case LEX_INTERPPUSH:
2436 return REPORT(sublex_push());
2438 case LEX_INTERPSTART:
2439 if (PL_bufptr == PL_bufend)
2440 return REPORT(sublex_done());
2441 DEBUG_T({ PerlIO_printf(Perl_debug_log,
2442 "### Interpolated variable at '%s'\n", PL_bufptr); });
2444 PL_lex_dojoin = (*PL_bufptr == '@');
2445 PL_lex_state = LEX_INTERPNORMAL;
2446 if (PL_lex_dojoin) {
2447 PL_nextval[PL_nexttoke].ival = 0;
2449 force_ident("\"", '$');
2450 PL_nextval[PL_nexttoke].ival = 0;
2452 PL_nextval[PL_nexttoke].ival = 0;
2454 PL_nextval[PL_nexttoke].ival = OP_JOIN; /* emulate join($", ...) */
2457 if (PL_lex_starts++) {
2459 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2460 if (!PL_lex_casemods && PL_lex_inpat)
2467 case LEX_INTERPENDMAYBE:
2468 if (intuit_more(PL_bufptr)) {
2469 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
2475 if (PL_lex_dojoin) {
2476 PL_lex_dojoin = FALSE;
2477 PL_lex_state = LEX_INTERPCONCAT;
2480 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2481 && SvEVALED(PL_lex_repl))
2483 if (PL_bufptr != PL_bufend)
2484 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2485 PL_lex_repl = Nullsv;
2488 case LEX_INTERPCONCAT:
2490 if (PL_lex_brackets)
2491 Perl_croak(aTHX_ "panic: INTERPCONCAT");
2493 if (PL_bufptr == PL_bufend)
2494 return REPORT(sublex_done());
2496 if (SvIVX(PL_linestr) == '\'') {
2497 SV *sv = newSVsv(PL_linestr);
2500 else if ( PL_hints & HINT_NEW_RE )
2501 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2502 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2506 s = scan_const(PL_bufptr);
2508 PL_lex_state = LEX_INTERPCASEMOD;
2510 PL_lex_state = LEX_INTERPSTART;
2513 if (s != PL_bufptr) {
2514 PL_nextval[PL_nexttoke] = yylval;
2517 if (PL_lex_starts++) {
2518 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2519 if (!PL_lex_casemods && PL_lex_inpat)
2532 PL_lex_state = LEX_NORMAL;
2533 s = scan_formline(PL_bufptr);
2534 if (!PL_lex_formbrack)
2540 PL_oldoldbufptr = PL_oldbufptr;
2543 PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2544 exp_name[PL_expect], s);
2550 if (isIDFIRST_lazy_if(s,UTF))
2552 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2555 goto fake_eof; /* emulate EOF on ^D or ^Z */
2560 if (PL_lex_brackets) {
2561 if (PL_lex_formbrack)
2562 yyerror("Format not terminated");
2564 yyerror("Missing right curly or square bracket");
2566 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2567 "### Tokener got EOF\n");
2571 if (s++ < PL_bufend)
2572 goto retry; /* ignore stray nulls */
2575 if (!PL_in_eval && !PL_preambled) {
2576 PL_preambled = TRUE;
2577 sv_setpv(PL_linestr,incl_perldb());
2578 if (SvCUR(PL_linestr))
2579 sv_catpvn(PL_linestr,";", 1);
2581 while(AvFILLp(PL_preambleav) >= 0) {
2582 SV *tmpsv = av_shift(PL_preambleav);
2583 sv_catsv(PL_linestr, tmpsv);
2584 sv_catpvn(PL_linestr, ";", 1);
2587 sv_free((SV*)PL_preambleav);
2588 PL_preambleav = NULL;
2590 if (PL_minus_n || PL_minus_p) {
2591 sv_catpv(PL_linestr, "LINE: while (<>) {");
2593 sv_catpv(PL_linestr,"chomp;");
2596 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2597 || *PL_splitstr == '"')
2598 && strchr(PL_splitstr + 1, *PL_splitstr))
2599 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2601 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2602 bytes can be used as quoting characters. :-) */
2603 /* The count here deliberately includes the NUL
2604 that terminates the C string constant. This
2605 embeds the opening NUL into the string. */
2606 const char *splits = PL_splitstr;
2607 sv_catpvn(PL_linestr, "our @F=split(q", 15);
2610 if (*splits == '\\')
2611 sv_catpvn(PL_linestr, splits, 1);
2612 sv_catpvn(PL_linestr, splits, 1);
2613 } while (*splits++);
2614 /* This loop will embed the trailing NUL of
2615 PL_linestr as the last thing it does before
2617 sv_catpvn(PL_linestr, ");", 2);
2621 sv_catpv(PL_linestr,"our @F=split(' ');");
2624 sv_catpvn(PL_linestr, "\n", 1);
2625 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2626 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2627 PL_last_lop = PL_last_uni = Nullch;
2628 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2629 SV *sv = NEWSV(85,0);
2631 sv_upgrade(sv, SVt_PVMG);
2632 sv_setsv(sv,PL_linestr);
2635 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2640 bof = PL_rsfp ? TRUE : FALSE;
2641 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2644 if (PL_preprocess && !PL_in_eval)
2645 (void)PerlProc_pclose(PL_rsfp);
2646 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2647 PerlIO_clearerr(PL_rsfp);
2649 (void)PerlIO_close(PL_rsfp);
2651 PL_doextract = FALSE;
2653 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2654 sv_setpv(PL_linestr,PL_minus_p
2655 ? ";}continue{print;}" : ";}");
2656 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2657 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2658 PL_last_lop = PL_last_uni = Nullch;
2659 PL_minus_n = PL_minus_p = 0;
2662 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2663 PL_last_lop = PL_last_uni = Nullch;
2664 sv_setpv(PL_linestr,"");
2665 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
2667 /* If it looks like the start of a BOM or raw UTF-16,
2668 * check if it in fact is. */
2674 #ifdef PERLIO_IS_STDIO
2675 # ifdef __GNU_LIBRARY__
2676 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2677 # define FTELL_FOR_PIPE_IS_BROKEN
2681 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2682 # define FTELL_FOR_PIPE_IS_BROKEN
2687 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2688 /* This loses the possibility to detect the bof
2689 * situation on perl -P when the libc5 is being used.
2690 * Workaround? Maybe attach some extra state to PL_rsfp?
2693 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2695 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2698 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2699 s = swallow_bom((U8*)s);
2703 /* Incest with pod. */
2704 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2705 sv_setpv(PL_linestr, "");
2706 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2707 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2708 PL_last_lop = PL_last_uni = Nullch;
2709 PL_doextract = FALSE;
2713 } while (PL_doextract);
2714 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2715 if (PERLDB_LINE && PL_curstash != PL_debstash) {
2716 SV *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);
2724 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2725 PL_last_lop = PL_last_uni = Nullch;
2726 if (CopLINE(PL_curcop) == 1) {
2727 while (s < PL_bufend && isSPACE(*s))
2729 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2733 if (*s == '#' && *(s+1) == '!')
2735 #ifdef ALTERNATE_SHEBANG
2737 static char const as[] = ALTERNATE_SHEBANG;
2738 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2739 d = s + (sizeof(as) - 1);
2741 #endif /* ALTERNATE_SHEBANG */
2750 while (*d && !isSPACE(*d))
2754 #ifdef ARG_ZERO_IS_SCRIPT
2755 if (ipathend > ipath) {
2757 * HP-UX (at least) sets argv[0] to the script name,
2758 * which makes $^X incorrect. And Digital UNIX and Linux,
2759 * at least, set argv[0] to the basename of the Perl
2760 * interpreter. So, having found "#!", we'll set it right.
2762 SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2763 assert(SvPOK(x) || SvGMAGICAL(x));
2764 if (sv_eq(x, CopFILESV(PL_curcop))) {
2765 sv_setpvn(x, ipath, ipathend - ipath);
2771 char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2772 char *lstart = SvPV(x,llen);
2774 bstart += blen - llen;
2775 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2776 sv_setpvn(x, ipath, ipathend - ipath);
2781 TAINT_NOT; /* $^X is always tainted, but that's OK */
2783 #endif /* ARG_ZERO_IS_SCRIPT */
2788 d = instr(s,"perl -");
2790 d = instr(s,"perl");
2792 /* avoid getting into infinite loops when shebang
2793 * line contains "Perl" rather than "perl" */
2795 for (d = ipathend-4; d >= ipath; --d) {
2796 if ((*d == 'p' || *d == 'P')
2797 && !ibcmp(d, "perl", 4))
2807 #ifdef ALTERNATE_SHEBANG
2809 * If the ALTERNATE_SHEBANG on this system starts with a
2810 * character that can be part of a Perl expression, then if
2811 * we see it but not "perl", we're probably looking at the
2812 * start of Perl code, not a request to hand off to some
2813 * other interpreter. Similarly, if "perl" is there, but
2814 * not in the first 'word' of the line, we assume the line
2815 * contains the start of the Perl program.
2817 if (d && *s != '#') {
2819 while (*c && !strchr("; \t\r\n\f\v#", *c))
2822 d = Nullch; /* "perl" not in first word; ignore */
2824 *s = '#'; /* Don't try to parse shebang line */
2826 #endif /* ALTERNATE_SHEBANG */
2827 #ifndef MACOS_TRADITIONAL
2832 !instr(s,"indir") &&
2833 instr(PL_origargv[0],"perl"))
2839 while (s < PL_bufend && isSPACE(*s))
2841 if (s < PL_bufend) {
2842 Newz(899,newargv,PL_origargc+3,char*);
2844 while (s < PL_bufend && !isSPACE(*s))
2847 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2850 newargv = PL_origargv;
2853 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2855 Perl_croak(aTHX_ "Can't exec %s", ipath);
2859 U32 oldpdb = PL_perldb;
2860 bool oldn = PL_minus_n;
2861 bool oldp = PL_minus_p;
2863 while (*d && !isSPACE(*d)) d++;
2864 while (SPACE_OR_TAB(*d)) d++;
2867 bool switches_done = PL_doswitches;
2869 if (*d == 'M' || *d == 'm' || *d == 'C') {
2871 while (*d && !isSPACE(*d)) d++;
2872 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2875 d = moreswitches(d);
2877 if (PL_doswitches && !switches_done) {
2878 int argc = PL_origargc;
2879 char **argv = PL_origargv;
2882 } while (argc && argv[0][0] == '-' && argv[0][1]);
2883 init_argv_symbols(argc,argv);
2885 if ((PERLDB_LINE && !oldpdb) ||
2886 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2887 /* if we have already added "LINE: while (<>) {",
2888 we must not do it again */
2890 sv_setpv(PL_linestr, "");
2891 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2892 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2893 PL_last_lop = PL_last_uni = Nullch;
2894 PL_preambled = FALSE;
2896 (void)gv_fetchfile(PL_origfilename);
2899 if (PL_doswitches && !switches_done) {
2900 int argc = PL_origargc;
2901 char **argv = PL_origargv;
2904 } while (argc && argv[0][0] == '-' && argv[0][1]);
2905 init_argv_symbols(argc,argv);
2911 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2913 PL_lex_state = LEX_FORMLINE;
2918 #ifdef PERL_STRICT_CR
2919 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2921 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2923 case ' ': case '\t': case '\f': case 013:
2924 #ifdef MACOS_TRADITIONAL
2931 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2932 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2933 /* handle eval qq[#line 1 "foo"\n ...] */
2934 CopLINE_dec(PL_curcop);
2938 while (s < d && *s != '\n')
2942 else if (s > d) /* Found by Ilya: feed random input to Perl. */
2943 Perl_croak(aTHX_ "panic: input overflow");
2945 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2947 PL_lex_state = LEX_FORMLINE;
2957 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2964 while (s < PL_bufend && SPACE_OR_TAB(*s))
2967 if (strnEQ(s,"=>",2)) {
2968 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2969 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2970 "### Saw unary minus before =>, forcing word '%s'\n", s);
2972 OPERATOR('-'); /* unary minus */
2974 PL_last_uni = PL_oldbufptr;
2976 case 'r': ftst = OP_FTEREAD; break;
2977 case 'w': ftst = OP_FTEWRITE; break;
2978 case 'x': ftst = OP_FTEEXEC; break;
2979 case 'o': ftst = OP_FTEOWNED; break;
2980 case 'R': ftst = OP_FTRREAD; break;
2981 case 'W': ftst = OP_FTRWRITE; break;
2982 case 'X': ftst = OP_FTREXEC; break;
2983 case 'O': ftst = OP_FTROWNED; break;
2984 case 'e': ftst = OP_FTIS; break;
2985 case 'z': ftst = OP_FTZERO; break;
2986 case 's': ftst = OP_FTSIZE; break;
2987 case 'f': ftst = OP_FTFILE; break;
2988 case 'd': ftst = OP_FTDIR; break;
2989 case 'l': ftst = OP_FTLINK; break;
2990 case 'p': ftst = OP_FTPIPE; break;
2991 case 'S': ftst = OP_FTSOCK; break;
2992 case 'u': ftst = OP_FTSUID; break;
2993 case 'g': ftst = OP_FTSGID; break;
2994 case 'k': ftst = OP_FTSVTX; break;
2995 case 'b': ftst = OP_FTBLK; break;
2996 case 'c': ftst = OP_FTCHR; break;
2997 case 't': ftst = OP_FTTTY; break;
2998 case 'T': ftst = OP_FTTEXT; break;
2999 case 'B': ftst = OP_FTBINARY; break;
3000 case 'M': case 'A': case 'C':
3001 gv_fetchpv("\024",TRUE, SVt_PV);
3003 case 'M': ftst = OP_FTMTIME; break;
3004 case 'A': ftst = OP_FTATIME; break;
3005 case 'C': ftst = OP_FTCTIME; break;
3013 PL_last_lop_op = (OPCODE)ftst;
3014 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3015 "### Saw file test %c\n", (int)ftst);
3020 /* Assume it was a minus followed by a one-letter named
3021 * subroutine call (or a -bareword), then. */
3022 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3023 "### '-%c' looked like a file test but was not\n",
3032 if (PL_expect == XOPERATOR)
3037 else if (*s == '>') {
3040 if (isIDFIRST_lazy_if(s,UTF)) {
3041 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3049 if (PL_expect == XOPERATOR)
3052 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3054 OPERATOR('-'); /* unary minus */
3061 if (PL_expect == XOPERATOR)
3066 if (PL_expect == XOPERATOR)
3069 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3075 if (PL_expect != XOPERATOR) {
3076 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3077 PL_expect = XOPERATOR;
3078 force_ident(PL_tokenbuf, '*');
3091 if (PL_expect == XOPERATOR) {
3095 PL_tokenbuf[0] = '%';
3096 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3097 if (!PL_tokenbuf[1]) {
3100 PL_pending_ident = '%';
3119 switch (PL_expect) {
3122 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3124 PL_bufptr = s; /* update in case we back off */
3130 PL_expect = XTERMBLOCK;
3134 while (isIDFIRST_lazy_if(s,UTF)) {
3135 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3136 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3137 if (tmp < 0) tmp = -tmp;
3153 d = scan_str(d,TRUE,TRUE);
3155 /* MUST advance bufptr here to avoid bogus
3156 "at end of line" context messages from yyerror().
3158 PL_bufptr = s + len;
3159 yyerror("Unterminated attribute parameter in attribute list");
3162 return REPORT(0); /* EOF indicator */
3166 SV *sv = newSVpvn(s, len);
3167 sv_catsv(sv, PL_lex_stuff);
3168 attrs = append_elem(OP_LIST, attrs,
3169 newSVOP(OP_CONST, 0, sv));
3170 SvREFCNT_dec(PL_lex_stuff);
3171 PL_lex_stuff = Nullsv;
3174 if (len == 6 && strnEQ(s, "unique", len)) {
3175 if (PL_in_my == KEY_our)
3177 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3179 ; /* skip to avoid loading attributes.pm */
3182 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3185 /* NOTE: any CV attrs applied here need to be part of
3186 the CVf_BUILTIN_ATTRS define in cv.h! */
3187 else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3188 CvLVALUE_on(PL_compcv);
3189 else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3190 CvLOCKED_on(PL_compcv);
3191 else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3192 CvMETHOD_on(PL_compcv);
3193 else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3194 CvASSERTION_on(PL_compcv);
3195 /* After we've set the flags, it could be argued that
3196 we don't need to do the attributes.pm-based setting
3197 process, and shouldn't bother appending recognized
3198 flags. To experiment with that, uncomment the
3199 following "else". (Note that's already been
3200 uncommented. That keeps the above-applied built-in
3201 attributes from being intercepted (and possibly
3202 rejected) by a package's attribute routines, but is
3203 justified by the performance win for the common case
3204 of applying only built-in attributes.) */
3206 attrs = append_elem(OP_LIST, attrs,
3207 newSVOP(OP_CONST, 0,
3211 if (*s == ':' && s[1] != ':')
3214 break; /* require real whitespace or :'s */
3216 tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3217 if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3218 char q = ((*s == '\'') ? '"' : '\'');
3219 /* If here for an expression, and parsed no attrs, back off. */
3220 if (tmp == '=' && !attrs) {
3224 /* MUST advance bufptr here to avoid bogus "at end of line"
3225 context messages from yyerror().
3229 yyerror("Unterminated attribute list");
3231 yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3239 PL_nextval[PL_nexttoke].opval = attrs;
3247 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3248 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
3265 if (PL_lex_brackets <= 0)
3266 yyerror("Unmatched right square bracket");
3269 if (PL_lex_state == LEX_INTERPNORMAL) {
3270 if (PL_lex_brackets == 0) {
3271 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3272 PL_lex_state = LEX_INTERPEND;
3279 if (PL_lex_brackets > 100) {
3280 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3282 switch (PL_expect) {
3284 if (PL_lex_formbrack) {
3288 if (PL_oldoldbufptr == PL_last_lop)
3289 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3291 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3292 OPERATOR(HASHBRACK);
3294 while (s < PL_bufend && SPACE_OR_TAB(*s))
3297 PL_tokenbuf[0] = '\0';
3298 if (d < PL_bufend && *d == '-') {
3299 PL_tokenbuf[0] = '-';
3301 while (d < PL_bufend && SPACE_OR_TAB(*d))
3304 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3305 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3307 while (d < PL_bufend && SPACE_OR_TAB(*d))
3310 char minus = (PL_tokenbuf[0] == '-');
3311 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3319 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3324 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3329 if (PL_oldoldbufptr == PL_last_lop)
3330 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3332 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3335 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3337 /* This hack is to get the ${} in the message. */
3339 yyerror("syntax error");
3342 OPERATOR(HASHBRACK);
3344 /* This hack serves to disambiguate a pair of curlies
3345 * as being a block or an anon hash. Normally, expectation
3346 * determines that, but in cases where we're not in a
3347 * position to expect anything in particular (like inside
3348 * eval"") we have to resolve the ambiguity. This code
3349 * covers the case where the first term in the curlies is a
3350 * quoted string. Most other cases need to be explicitly
3351 * disambiguated by prepending a `+' before the opening
3352 * curly in order to force resolution as an anon hash.
3354 * XXX should probably propagate the outer expectation
3355 * into eval"" to rely less on this hack, but that could
3356 * potentially break current behavior of eval"".
3360 if (*s == '\'' || *s == '"' || *s == '`') {
3361 /* common case: get past first string, handling escapes */
3362 for (t++; t < PL_bufend && *t != *s;)
3363 if (*t++ == '\\' && (*t == '\\' || *t == *s))
3367 else if (*s == 'q') {
3370 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3373 /* skip q//-like construct */
3375 char open, close, term;
3378 while (t < PL_bufend && isSPACE(*t))
3380 /* check for q => */
3381 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3382 OPERATOR(HASHBRACK);
3386 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3390 for (t++; t < PL_bufend; t++) {
3391 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3393 else if (*t == open)
3397 for (t++; t < PL_bufend; t++) {
3398 if (*t == '\\' && t+1 < PL_bufend)
3400 else if (*t == close && --brackets <= 0)
3402 else if (*t == open)
3409 /* skip plain q word */
3410 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3413 else if (isALNUM_lazy_if(t,UTF)) {
3415 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3418 while (t < PL_bufend && isSPACE(*t))
3420 /* if comma follows first term, call it an anon hash */
3421 /* XXX it could be a comma expression with loop modifiers */
3422 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3423 || (*t == '=' && t[1] == '>')))
3424 OPERATOR(HASHBRACK);
3425 if (PL_expect == XREF)
3428 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3434 yylval.ival = CopLINE(PL_curcop);
3435 if (isSPACE(*s) || *s == '#')
3436 PL_copline = NOLINE; /* invalidate current command line number */
3441 if (PL_lex_brackets <= 0)
3442 yyerror("Unmatched right curly bracket");
3444 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3445 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3446 PL_lex_formbrack = 0;
3447 if (PL_lex_state == LEX_INTERPNORMAL) {
3448 if (PL_lex_brackets == 0) {
3449 if (PL_expect & XFAKEBRACK) {
3450 PL_expect &= XENUMMASK;
3451 PL_lex_state = LEX_INTERPEND;
3453 return yylex(); /* ignore fake brackets */
3455 if (*s == '-' && s[1] == '>')
3456 PL_lex_state = LEX_INTERPENDMAYBE;
3457 else if (*s != '[' && *s != '{')
3458 PL_lex_state = LEX_INTERPEND;
3461 if (PL_expect & XFAKEBRACK) {
3462 PL_expect &= XENUMMASK;
3464 return yylex(); /* ignore fake brackets */
3474 if (PL_expect == XOPERATOR) {
3475 if (ckWARN(WARN_SEMICOLON)
3476 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3478 CopLINE_dec(PL_curcop);
3479 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3480 CopLINE_inc(PL_curcop);
3485 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3487 PL_expect = XOPERATOR;
3488 force_ident(PL_tokenbuf, '&');
3492 yylval.ival = (OPpENTERSUB_AMPER<<8);
3511 if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3512 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3514 if (PL_expect == XSTATE && isALPHA(tmp) &&
3515 (s == PL_linestart+1 || s[-2] == '\n') )
3517 if (PL_in_eval && !PL_rsfp) {
3522 if (strnEQ(s,"=cut",4)) {
3536 PL_doextract = TRUE;
3539 if (PL_lex_brackets < PL_lex_formbrack) {
3541 #ifdef PERL_STRICT_CR
3542 for (t = s; SPACE_OR_TAB(*t); t++) ;
3544 for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3546 if (*t == '\n' || *t == '#') {
3558 /* was this !=~ where !~ was meant?
3559 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3561 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3564 while (t < PL_bufend && isSPACE(*t))
3567 if (*t == '/' || *t == '?' ||
3568 ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3569 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3570 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3571 "!=~ should be !~");
3580 if (PL_expect != XOPERATOR) {
3581 if (s[1] != '<' && !strchr(s,'>'))
3584 s = scan_heredoc(s);
3586 s = scan_inputsymbol(s);
3587 TERM(sublex_start());
3592 SHop(OP_LEFT_SHIFT);
3606 SHop(OP_RIGHT_SHIFT);
3615 if (PL_expect == XOPERATOR) {
3616 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3619 return REPORT(','); /* grandfather non-comma-format format */
3623 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3624 PL_tokenbuf[0] = '@';
3625 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3626 sizeof PL_tokenbuf - 1, FALSE);
3627 if (PL_expect == XOPERATOR)
3628 no_op("Array length", s);
3629 if (!PL_tokenbuf[1])
3631 PL_expect = XOPERATOR;
3632 PL_pending_ident = '#';
3636 PL_tokenbuf[0] = '$';
3637 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3638 sizeof PL_tokenbuf - 1, FALSE);
3639 if (PL_expect == XOPERATOR)
3641 if (!PL_tokenbuf[1]) {
3643 yyerror("Final $ should be \\$ or $name");
3647 /* This kludge not intended to be bulletproof. */
3648 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3649 yylval.opval = newSVOP(OP_CONST, 0,
3650 newSViv(PL_compiling.cop_arybase));
3651 yylval.opval->op_private = OPpCONST_ARYBASE;
3657 if (PL_lex_state == LEX_NORMAL)
3660 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3663 PL_tokenbuf[0] = '@';
3664 if (ckWARN(WARN_SYNTAX)) {
3666 isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3669 PL_bufptr = skipspace(PL_bufptr);
3670 while (t < PL_bufend && *t != ']')
3672 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3673 "Multidimensional syntax %.*s not supported",
3674 (t - PL_bufptr) + 1, PL_bufptr);
3678 else if (*s == '{') {
3679 PL_tokenbuf[0] = '%';
3680 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3681 (t = strchr(s, '}')) && (t = strchr(t, '=')))
3683 char tmpbuf[sizeof PL_tokenbuf];
3685 for (t++; isSPACE(*t); t++) ;
3686 if (isIDFIRST_lazy_if(t,UTF)) {
3687 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3688 for (; isSPACE(*t); t++) ;
3689 if (*t == ';' && get_cv(tmpbuf, FALSE))
3690 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3691 "You need to quote \"%s\"", tmpbuf);
3697 PL_expect = XOPERATOR;
3698 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3699 bool islop = (PL_last_lop == PL_oldoldbufptr);
3700 if (!islop || PL_last_lop_op == OP_GREPSTART)
3701 PL_expect = XOPERATOR;
3702 else if (strchr("$@\"'`q", *s))
3703 PL_expect = XTERM; /* e.g. print $fh "foo" */
3704 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3705 PL_expect = XTERM; /* e.g. print $fh &sub */
3706 else if (isIDFIRST_lazy_if(s,UTF)) {
3707 char tmpbuf[sizeof PL_tokenbuf];
3708 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3709 if ((tmp = keyword(tmpbuf, len))) {
3710 /* binary operators exclude handle interpretations */
3722 PL_expect = XTERM; /* e.g. print $fh length() */
3727 PL_expect = XTERM; /* e.g. print $fh subr() */
3730 else if (isDIGIT(*s))
3731 PL_expect = XTERM; /* e.g. print $fh 3 */
3732 else if (*s == '.' && isDIGIT(s[1]))
3733 PL_expect = XTERM; /* e.g. print $fh .3 */
3734 else if ((*s == '?' || *s == '-' || *s == '+')
3735 && !isSPACE(s[1]) && s[1] != '=')
3736 PL_expect = XTERM; /* e.g. print $fh -1 */
3737 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3738 PL_expect = XTERM; /* e.g. print $fh /.../
3739 XXX except DORDOR operator */
3740 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3741 PL_expect = XTERM; /* print $fh <<"EOF" */
3743 PL_pending_ident = '$';
3747 if (PL_expect == XOPERATOR)
3749 PL_tokenbuf[0] = '@';
3750 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3751 if (!PL_tokenbuf[1]) {
3754 if (PL_lex_state == LEX_NORMAL)
3756 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3758 PL_tokenbuf[0] = '%';
3760 /* Warn about @ where they meant $. */
3761 if (ckWARN(WARN_SYNTAX)) {
3762 if (*s == '[' || *s == '{') {
3764 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3766 if (*t == '}' || *t == ']') {
3768 PL_bufptr = skipspace(PL_bufptr);
3769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3770 "Scalar value %.*s better written as $%.*s",
3771 t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3776 PL_pending_ident = '@';
3779 case '/': /* may be division, defined-or, or pattern */
3780 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3784 case '?': /* may either be conditional or pattern */
3785 if(PL_expect == XOPERATOR) {
3793 /* A // operator. */
3803 /* Disable warning on "study /blah/" */
3804 if (PL_oldoldbufptr == PL_last_uni
3805 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3806 || memNE(PL_last_uni, "study", 5)
3807 || isALNUM_lazy_if(PL_last_uni+5,UTF)
3810 s = scan_pat(s,OP_MATCH);
3811 TERM(sublex_start());
3815 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3816 #ifdef PERL_STRICT_CR
3819 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3821 && (s == PL_linestart || s[-1] == '\n') )
3823 PL_lex_formbrack = 0;
3827 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3833 yylval.ival = OPf_SPECIAL;
3839 if (PL_expect != XOPERATOR)
3844 case '0': case '1': case '2': case '3': case '4':
3845 case '5': case '6': case '7': case '8': case '9':
3846 s = scan_num(s, &yylval);
3847 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3848 "### Saw number in '%s'\n", s);
3850 if (PL_expect == XOPERATOR)
3855 s = scan_str(s,FALSE,FALSE);
3856 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3857 "### Saw string before '%s'\n", s);
3859 if (PL_expect == XOPERATOR) {
3860 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3863 return REPORT(','); /* grandfather non-comma-format format */
3869 missingterm((char*)0);
3870 yylval.ival = OP_CONST;
3871 TERM(sublex_start());
3874 s = scan_str(s,FALSE,FALSE);
3875 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3876 "### Saw string before '%s'\n", s);
3878 if (PL_expect == XOPERATOR) {
3879 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3882 return REPORT(','); /* grandfather non-comma-format format */
3888 missingterm((char*)0);
3889 yylval.ival = OP_CONST;
3890 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3891 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3892 yylval.ival = OP_STRINGIFY;
3896 TERM(sublex_start());
3899 s = scan_str(s,FALSE,FALSE);
3900 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3901 "### Saw backtick string before '%s'\n", s);
3903 if (PL_expect == XOPERATOR)
3904 no_op("Backticks",s);
3906 missingterm((char*)0);
3907 yylval.ival = OP_BACKTICK;
3909 TERM(sublex_start());
3913 if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3914 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3916 if (PL_expect == XOPERATOR)
3917 no_op("Backslash",s);
3921 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3925 while (isDIGIT(*start) || *start == '_')
3927 if (*start == '.' && isDIGIT(start[1])) {
3928 s = scan_num(s, &yylval);
3931 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3932 else if (!isALPHA(*start) && (PL_expect == XTERM
3933 || PL_expect == XREF || PL_expect == XSTATE
3934 || PL_expect == XTERMORDORDOR)) {
3938 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3941 s = scan_num(s, &yylval);
3948 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3988 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3990 /* Some keywords can be followed by any delimiter, including ':' */
3991 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3992 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3993 (PL_tokenbuf[0] == 'q' &&
3994 strchr("qwxr", PL_tokenbuf[1])))));
3996 /* x::* is just a word, unless x is "CORE" */
3997 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4001 while (d < PL_bufend && isSPACE(*d))
4002 d++; /* no comments skipped here, or s### is misparsed */
4004 /* Is this a label? */
4005 if (!tmp && PL_expect == XSTATE
4006 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4008 yylval.pval = savepv(PL_tokenbuf);
4013 /* Check for keywords */
4014 tmp = keyword(PL_tokenbuf, len);
4016 /* Is this a word before a => operator? */
4017 if (*d == '=' && d[1] == '>') {
4020 = (OP*)newSVOP(OP_CONST, 0,
4021 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4022 yylval.opval->op_private = OPpCONST_BARE;
4026 if (tmp < 0) { /* second-class keyword? */
4027 GV *ogv = Nullgv; /* override (winner) */
4028 GV *hgv = Nullgv; /* hidden (loser) */
4029 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4031 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4034 if (GvIMPORTED_CV(gv))
4036 else if (! CvMETHOD(cv))
4040 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4041 (gv = *gvp) != (GV*)&PL_sv_undef &&
4042 GvCVu(gv) && GvIMPORTED_CV(gv))
4049 tmp = 0; /* overridden by import or by GLOBAL */
4052 && -tmp==KEY_lock /* XXX generalizable kludge */
4054 && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4056 tmp = 0; /* any sub overrides "weak" keyword */
4061 && PL_expect != XOPERATOR
4062 && PL_expect != XTERMORDORDOR)
4064 /* any sub overrides the "err" keyword, except when really an
4065 * operator is expected */
4068 else { /* no override */
4070 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4071 Perl_warner(aTHX_ packWARN(WARN_MISC),
4072 "dump() better written as CORE::dump()");
4076 if (ckWARN(WARN_AMBIGUOUS) && hgv
4077 && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
4078 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4079 "Ambiguous call resolved as CORE::%s(), %s",
4080 GvENAME(hgv), "qualify as such or use &");
4087 default: /* not a keyword */
4091 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4093 /* Get the rest if it looks like a package qualifier */
4095 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4097 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4100 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4101 *s == '\'' ? "'" : "::");
4106 if (PL_expect == XOPERATOR) {
4107 if (PL_bufptr == PL_linestart) {
4108 CopLINE_dec(PL_curcop);
4109 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4110 CopLINE_inc(PL_curcop);
4113 no_op("Bareword",s);
4116 /* Look for a subroutine with this name in current package,
4117 unless name is "Foo::", in which case Foo is a bearword
4118 (and a package name). */
4121 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4123 if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4124 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4125 "Bareword \"%s\" refers to nonexistent package",
4128 PL_tokenbuf[len] = '\0';
4135 gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4138 /* if we saw a global override before, get the right name */
4141 sv = newSVpvn("CORE::GLOBAL::",14);
4142 sv_catpv(sv,PL_tokenbuf);
4145 /* If len is 0, newSVpv does strlen(), which is correct.
4146 If len is non-zero, then it will be the true length,
4147 and so the scalar will be created correctly. */
4148 sv = newSVpv(PL_tokenbuf,len);
4151 /* Presume this is going to be a bareword of some sort. */
4154 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4155 yylval.opval->op_private = OPpCONST_BARE;
4156 /* UTF-8 package name? */
4157 if (UTF && !IN_BYTES &&
4158 is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
4161 /* And if "Foo::", then that's what it certainly is. */
4166 /* See if it's the indirect object for a list operator. */
4168 if (PL_oldoldbufptr &&
4169 PL_oldoldbufptr < PL_bufptr &&
4170 (PL_oldoldbufptr == PL_last_lop
4171 || PL_oldoldbufptr == PL_last_uni) &&
4172 /* NO SKIPSPACE BEFORE HERE! */
4173 (PL_expect == XREF ||
4174 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4176 bool immediate_paren = *s == '(';
4178 /* (Now we can afford to cross potential line boundary.) */
4181 /* Two barewords in a row may indicate method call. */
4183 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4186 /* If not a declared subroutine, it's an indirect object. */
4187 /* (But it's an indir obj regardless for sort.) */
4189 if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4190 ((!gv || !GvCVu(gv)) &&
4191 (PL_last_lop_op != OP_MAPSTART &&
4192 PL_last_lop_op != OP_GREPSTART))))
4194 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4199 PL_expect = XOPERATOR;
4202 /* Is this a word before a => operator? */
4203 if (*s == '=' && s[1] == '>' && !pkgname) {
4205 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4206 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4207 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4211 /* If followed by a paren, it's certainly a subroutine. */
4214 if (gv && GvCVu(gv)) {
4215 for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4216 if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4221 PL_nextval[PL_nexttoke].opval = yylval.opval;
4222 PL_expect = XOPERATOR;
4228 /* If followed by var or block, call it a method (unless sub) */
4230 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4231 PL_last_lop = PL_oldbufptr;
4232 PL_last_lop_op = OP_METHOD;
4236 /* If followed by a bareword, see if it looks like indir obj. */
4239 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4240 && (tmp = intuit_method(s,gv)))
4243 /* Not a method, so call it a subroutine (if defined) */
4245 if (gv && GvCVu(gv)) {
4247 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4248 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4249 "Ambiguous use of -%s resolved as -&%s()",
4250 PL_tokenbuf, PL_tokenbuf);
4251 /* Check for a constant sub */
4253 if ((sv = cv_const_sv(cv))) {
4255 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4256 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4257 yylval.opval->op_private = 0;
4261 /* Resolve to GV now. */
4262 op_free(yylval.opval);
4263 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4264 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4265 PL_last_lop = PL_oldbufptr;
4266 PL_last_lop_op = OP_ENTERSUB;
4267 /* Is there a prototype? */
4270 char *proto = SvPV((SV*)cv, len);
4273 if (*proto == '$' && proto[1] == '\0')
4275 while (*proto == ';')
4277 if (*proto == '&' && *s == '{') {
4278 sv_setpv(PL_subname, PL_curstash ?
4279 "__ANON__" : "__ANON__::__ANON__");
4283 PL_nextval[PL_nexttoke].opval = yylval.opval;
4289 /* Call it a bare word */
4291 if (PL_hints & HINT_STRICT_SUBS)
4292 yylval.opval->op_private |= OPpCONST_STRICT;
4295 if (ckWARN(WARN_RESERVED)) {
4296 if (lastchar != '-') {
4297 for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4298 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4299 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4306 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4307 && ckWARN_d(WARN_AMBIGUOUS)) {
4308 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4309 "Operator or semicolon missing before %c%s",
4310 lastchar, PL_tokenbuf);
4311 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4312 "Ambiguous use of %c resolved as operator %c",
4313 lastchar, lastchar);
4319 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4320 newSVpv(CopFILE(PL_curcop),0));
4324 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4325 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4328 case KEY___PACKAGE__:
4329 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4331 ? newSVpv(HvNAME(PL_curstash), 0)
4340 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4341 const char *pname = "main";
4342 if (PL_tokenbuf[2] == 'D')
4343 pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4344 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4347 GvIOp(gv) = newIO();
4348 IoIFP(GvIOp(gv)) = PL_rsfp;
4349 #if defined(HAS_FCNTL) && defined(F_SETFD)
4351 int fd = PerlIO_fileno(PL_rsfp);
4352 fcntl(fd,F_SETFD,fd >= 3);
4355 /* Mark this internal pseudo-handle as clean */
4356 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4358 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4359 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4360 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4362 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4363 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4364 /* if the script was opened in binmode, we need to revert
4365 * it to text mode for compatibility; but only iff it has CRs
4366 * XXX this is a questionable hack at best. */
4367 if (PL_bufend-PL_bufptr > 2
4368 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4371 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4372 loc = PerlIO_tell(PL_rsfp);
4373 (void)PerlIO_seek(PL_rsfp, 0L, 0);
4376 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4378 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4379 #endif /* NETWARE */
4380 #ifdef PERLIO_IS_STDIO /* really? */
4381 # if defined(__BORLANDC__)
4382 /* XXX see note in do_binmode() */
4383 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4387 PerlIO_seek(PL_rsfp, loc, 0);
4391 #ifdef PERLIO_LAYERS
4394 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4395 else if (PL_encoding) {
4402 XPUSHs(PL_encoding);
4404 call_method("name", G_SCALAR);
4408 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4409 Perl_form(aTHX_ ":encoding(%"SVf")",
4427 if (PL_expect == XSTATE) {
4434 if (*s == ':' && s[1] == ':') {
4437 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4438 if (!(tmp = keyword(PL_tokenbuf, len)))
4439 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4453 LOP(OP_ACCEPT,XTERM);
4459 LOP(OP_ATAN2,XTERM);
4465 LOP(OP_BINMODE,XTERM);
4468 LOP(OP_BLESS,XTERM);
4477 (void)gv_fetchpv("ENV",TRUE, SVt_PVHV); /* may use HOME */
4494 if (!PL_cryptseen) {
4495 PL_cryptseen = TRUE;
4499 LOP(OP_CRYPT,XTERM);
4502 LOP(OP_CHMOD,XTERM);
4505 LOP(OP_CHOWN,XTERM);
4508 LOP(OP_CONNECT,XTERM);
4524 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4528 PL_hints |= HINT_BLOCK_SCOPE;
4538 gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4539 LOP(OP_DBMOPEN,XTERM);
4545 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4552 yylval.ival = CopLINE(PL_curcop);
4566 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4567 UNIBRACK(OP_ENTEREVAL);
4585 case KEY_endhostent:
4591 case KEY_endservent:
4594 case KEY_endprotoent:
4605 yylval.ival = CopLINE(PL_curcop);
4607 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4609 if ((PL_bufend - p) >= 3 &&
4610 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4612 else if ((PL_bufend - p) >= 4 &&
4613 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4616 if (isIDFIRST_lazy_if(p,UTF)) {
4617 p = scan_ident(p, PL_bufend,
4618 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4622 Perl_croak(aTHX_ "Missing $ on loop variable");
4627 LOP(OP_FORMLINE,XTERM);
4633 LOP(OP_FCNTL,XTERM);
4639 LOP(OP_FLOCK,XTERM);
4648 LOP(OP_GREPSTART, XREF);
4651 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4666 case KEY_getpriority:
4667 LOP(OP_GETPRIORITY,XTERM);
4669 case KEY_getprotobyname:
4672 case KEY_getprotobynumber:
4673 LOP(OP_GPBYNUMBER,XTERM);
4675 case KEY_getprotoent:
4687 case KEY_getpeername:
4688 UNI(OP_GETPEERNAME);
4690 case KEY_gethostbyname:
4693 case KEY_gethostbyaddr:
4694 LOP(OP_GHBYADDR,XTERM);
4696 case KEY_gethostent:
4699 case KEY_getnetbyname:
4702 case KEY_getnetbyaddr:
4703 LOP(OP_GNBYADDR,XTERM);
4708 case KEY_getservbyname:
4709 LOP(OP_GSBYNAME,XTERM);
4711 case KEY_getservbyport:
4712 LOP(OP_GSBYPORT,XTERM);
4714 case KEY_getservent:
4717 case KEY_getsockname:
4718 UNI(OP_GETSOCKNAME);
4720 case KEY_getsockopt:
4721 LOP(OP_GSOCKOPT,XTERM);
4743 yylval.ival = CopLINE(PL_curcop);
4747 LOP(OP_INDEX,XTERM);
4753 LOP(OP_IOCTL,XTERM);
4765 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4797 LOP(OP_LISTEN,XTERM);
4806 s = scan_pat(s,OP_MATCH);
4807 TERM(sublex_start());
4810 LOP(OP_MAPSTART, XREF);
4813 LOP(OP_MKDIR,XTERM);
4816 LOP(OP_MSGCTL,XTERM);
4819 LOP(OP_MSGGET,XTERM);
4822 LOP(OP_MSGRCV,XTERM);
4825 LOP(OP_MSGSND,XTERM);
4831 if (isIDFIRST_lazy_if(s,UTF)) {
4832 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4833 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4835 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4836 if (!PL_in_my_stash) {
4839 sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4847 s = force_word(s,WORD,TRUE,FALSE,FALSE);
4854 if (PL_expect != XSTATE)
4855 yyerror("\"no\" not allowed in expression");
4856 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4857 s = force_version(s, FALSE);
4862 if (*s == '(' || (s = skipspace(s), *s == '('))
4869 if (isIDFIRST_lazy_if(s,UTF)) {
4871 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4872 for (t=d; *t && isSPACE(*t); t++) ;
4873 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4875 && !(t[0] == '=' && t[1] == '>')
4877 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4878 "Precedence problem: open %.*s should be open(%.*s)",
4879 d - s, s, d - s, s);
4885 yylval.ival = OP_OR;
4895 LOP(OP_OPEN_DIR,XTERM);
4898 checkcomma(s,PL_tokenbuf,"filehandle");
4902 checkcomma(s,PL_tokenbuf,"filehandle");
4921 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4925 LOP(OP_PIPE_OP,XTERM);
4928 s = scan_str(s,FALSE,FALSE);
4930 missingterm((char*)0);
4931 yylval.ival = OP_CONST;
4932 TERM(sublex_start());
4938 s = scan_str(s,FALSE,FALSE);
4940 missingterm((char*)0);
4942 if (SvCUR(PL_lex_stuff)) {
4945 d = SvPV_force(PL_lex_stuff, len);
4948 for (; isSPACE(*d) && len; --len, ++d) ;
4951 if (!warned && ckWARN(WARN_QW)) {
4952 for (; !isSPACE(*d) && len; --len, ++d) {
4954 Perl_warner(aTHX_ packWARN(WARN_QW),
4955 "Possible attempt to separate words with commas");
4958 else if (*d == '#') {
4959 Perl_warner(aTHX_ packWARN(WARN_QW),
4960 "Possible attempt to put comments in qw() list");
4966 for (; !isSPACE(*d) && len; --len, ++d) ;
4968 sv = newSVpvn(b, d-b);
4969 if (DO_UTF8(PL_lex_stuff))
4971 words = append_elem(OP_LIST, words,
4972 newSVOP(OP_CONST, 0, tokeq(sv)));
4976 PL_nextval[PL_nexttoke].opval = words;
4981 SvREFCNT_dec(PL_lex_stuff);
4982 PL_lex_stuff = Nullsv;
4988 s = scan_str(s,FALSE,FALSE);
4990 missingterm((char*)0);
4991 yylval.ival = OP_STRINGIFY;
4992 if (SvIVX(PL_lex_stuff) == '\'')
4993 SvIVX(PL_lex_stuff) = 0; /* qq'$foo' should intepolate */
4994 TERM(sublex_start());
4997 s = scan_pat(s,OP_QR);
4998 TERM(sublex_start());
5001 s = scan_str(s,FALSE,FALSE);
5003 missingterm((char*)0);
5004 yylval.ival = OP_BACKTICK;
5006 TERM(sublex_start());
5014 s = force_version(s, FALSE);
5016 else if (*s != 'v' || !isDIGIT(s[1])
5017 || (s = force_version(s, TRUE), *s == 'v'))
5019 *PL_tokenbuf = '\0';
5020 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5021 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5022 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5024 yyerror("<> should be quotes");
5032 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5036 LOP(OP_RENAME,XTERM);
5045 LOP(OP_RINDEX,XTERM);
5055 UNIDOR(OP_READLINE);
5068 LOP(OP_REVERSE,XTERM);
5071 UNIDOR(OP_READLINK);
5079 TERM(sublex_start());
5081 TOKEN(1); /* force error */
5090 LOP(OP_SELECT,XTERM);
5096 LOP(OP_SEMCTL,XTERM);
5099 LOP(OP_SEMGET,XTERM);
5102 LOP(OP_SEMOP,XTERM);
5108 LOP(OP_SETPGRP,XTERM);
5110 case KEY_setpriority:
5111 LOP(OP_SETPRIORITY,XTERM);
5113 case KEY_sethostent:
5119 case KEY_setservent:
5122 case KEY_setprotoent:
5132 LOP(OP_SEEKDIR,XTERM);
5134 case KEY_setsockopt:
5135 LOP(OP_SSOCKOPT,XTERM);
5141 LOP(OP_SHMCTL,XTERM);
5144 LOP(OP_SHMGET,XTERM);
5147 LOP(OP_SHMREAD,XTERM);
5150 LOP(OP_SHMWRITE,XTERM);
5153 LOP(OP_SHUTDOWN,XTERM);
5162 LOP(OP_SOCKET,XTERM);
5164 case KEY_socketpair:
5165 LOP(OP_SOCKPAIR,XTERM);
5168 checkcomma(s,PL_tokenbuf,"subroutine name");
5170 if (*s == ';' || *s == ')') /* probably a close */
5171 Perl_croak(aTHX_ "sort is now a reserved word");
5173 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5177 LOP(OP_SPLIT,XTERM);
5180 LOP(OP_SPRINTF,XTERM);
5183 LOP(OP_SPLICE,XTERM);
5198 LOP(OP_SUBSTR,XTERM);
5204 char tmpbuf[sizeof PL_tokenbuf];
5205 SSize_t tboffset = 0;
5206 expectation attrful;
5207 bool have_name, have_proto, bad_proto;
5212 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5213 (*s == ':' && s[1] == ':'))
5216 attrful = XATTRBLOCK;
5217 /* remember buffer pos'n for later force_word */
5218 tboffset = s - PL_oldbufptr;
5219 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5220 if (strchr(tmpbuf, ':'))
5221 sv_setpv(PL_subname, tmpbuf);
5223 sv_setsv(PL_subname,PL_curstname);
5224 sv_catpvn(PL_subname,"::",2);
5225 sv_catpvn(PL_subname,tmpbuf,len);
5232 Perl_croak(aTHX_ "Missing name in \"my sub\"");
5233 PL_expect = XTERMBLOCK;
5234 attrful = XATTRTERM;
5235 sv_setpv(PL_subname,"?");
5239 if (key == KEY_format) {
5241 PL_lex_formbrack = PL_lex_brackets + 1;
5243 (void) force_word(PL_oldbufptr + tboffset, WORD,
5248 /* Look for a prototype */
5252 s = scan_str(s,FALSE,FALSE);
5254 Perl_croak(aTHX_ "Prototype not terminated");
5255 /* strip spaces and check for bad characters */
5256 d = SvPVX(PL_lex_stuff);
5259 for (p = d; *p; ++p) {
5262 if (!strchr("$@%*;[]&\\", *p))
5267 if (bad_proto && ckWARN(WARN_SYNTAX))
5268 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5269 "Illegal character in prototype for %"SVf" : %s",
5271 SvCUR(PL_lex_stuff) = tmp;
5279 if (*s == ':' && s[1] != ':')
5280 PL_expect = attrful;
5281 else if (*s != '{' && key == KEY_sub) {
5283 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5285 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5289 PL_nextval[PL_nexttoke].opval =
5290 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5291 PL_lex_stuff = Nullsv;
5295 sv_setpv(PL_subname,
5296 PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5299 (void) force_word(PL_oldbufptr + tboffset, WORD,
5308 LOP(OP_SYSTEM,XREF);
5311 LOP(OP_SYMLINK,XTERM);
5314 LOP(OP_SYSCALL,XTERM);
5317 LOP(OP_SYSOPEN,XTERM);
5320 LOP(OP_SYSSEEK,XTERM);
5323 LOP(OP_SYSREAD,XTERM);
5326 LOP(OP_SYSWRITE,XTERM);
5330 TERM(sublex_start());
5351 LOP(OP_TRUNCATE,XTERM);
5363 yylval.ival = CopLINE(PL_curcop);
5367 yylval.ival = CopLINE(PL_curcop);
5371 LOP(OP_UNLINK,XTERM);
5377 LOP(OP_UNPACK,XTERM);
5380 LOP(OP_UTIME,XTERM);
5386 LOP(OP_UNSHIFT,XTERM);
5389 if (PL_expect != XSTATE)
5390 yyerror("\"use\" not allowed in expression");
5392 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5393 s = force_version(s, TRUE);
5394 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5395 PL_nextval[PL_nexttoke].opval = Nullop;
5398 else if (*s == 'v') {
5399 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5400 s = force_version(s, FALSE);
5404 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5405 s = force_version(s, FALSE);
5417 yylval.ival = CopLINE(PL_curcop);
5421 PL_hints |= HINT_BLOCK_SCOPE;
5428 LOP(OP_WAITPID,XTERM);
5437 ctl_l[0] = toCTRL('L');
5439 gv_fetchpv(ctl_l,TRUE, SVt_PV);
5442 gv_fetchpv("\f",TRUE, SVt_PV); /* Make sure $^L is defined */
5447 if (PL_expect == XOPERATOR)
5453 yylval.ival = OP_XOR;
5458 TERM(sublex_start());
5463 #pragma segment Main
5467 S_pending_ident(pTHX)
5470 register I32 tmp = 0;
5471 /* pit holds the identifier we read and pending_ident is reset */
5472 char pit = PL_pending_ident;
5473 PL_pending_ident = 0;
5475 DEBUG_T({ PerlIO_printf(Perl_debug_log,
5476 "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5478 /* if we're in a my(), we can't allow dynamics here.
5479 $foo'bar has already been turned into $foo::bar, so
5480 just check for colons.
5482 if it's a legal name, the OP is a PADANY.
5485 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
5486 if (strchr(PL_tokenbuf,':'))
5487 yyerror(Perl_form(aTHX_ "No package name allowed for "
5488 "variable %s in \"our\"",
5490 tmp = allocmy(PL_tokenbuf);
5493 if (strchr(PL_tokenbuf,':'))
5494 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5496 yylval.opval = newOP(OP_PADANY, 0);
5497 yylval.opval->op_targ = allocmy(PL_tokenbuf);
5503 build the ops for accesses to a my() variable.
5505 Deny my($a) or my($b) in a sort block, *if* $a or $b is
5506 then used in a comparison. This catches most, but not
5507 all cases. For instance, it catches
5508 sort { my($a); $a <=> $b }
5510 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5511 (although why you'd do that is anyone's guess).
5514 if (!strchr(PL_tokenbuf,':')) {
5516 tmp = pad_findmy(PL_tokenbuf);
5517 if (tmp != NOT_IN_PAD) {
5518 /* might be an "our" variable" */
5519 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5520 /* build ops for a bareword */
5521 SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
5522 sv_catpvn(sym, "::", 2);
5523 sv_catpv(sym, PL_tokenbuf+1);
5524 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5525 yylval.opval->op_private = OPpCONST_ENTERED;
5528 ? (GV_ADDMULTI | GV_ADDINEVAL)
5531 ((PL_tokenbuf[0] == '$') ? SVt_PV
5532 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5537 /* if it's a sort block and they're naming $a or $b */
5538 if (PL_last_lop_op == OP_SORT &&
5539 PL_tokenbuf[0] == '$' &&
5540 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5543 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5544 d < PL_bufend && *d != '\n';
5547 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5548 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5554 yylval.opval = newOP(OP_PADANY, 0);
5555 yylval.opval->op_targ = tmp;
5561 Whine if they've said @foo in a doublequoted string,
5562 and @foo isn't a variable we can find in the symbol
5565 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5566 GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5567 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5568 && ckWARN(WARN_AMBIGUOUS))
5570 /* Downgraded from fatal to warning 20000522 mjd */
5571 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5572 "Possible unintended interpolation of %s in string",
5577 /* build ops for a bareword */
5578 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5579 yylval.opval->op_private = OPpCONST_ENTERED;
5580 gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5581 ((PL_tokenbuf[0] == '$') ? SVt_PV
5582 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5588 * The following code was generated by perl_keyword.pl.
5592 Perl_keyword (pTHX_ char *name, I32 len)
5596 case 1: /* 5 tokens of length 1 */
5628 case 2: /* 18 tokens of length 2 */
5774 case 3: /* 28 tokens of length 3 */
5778 if (name[1] == 'N' &&
5841 if (name[1] == 'i' &&
5881 if (name[1] == 'o' &&
5890 if (name[1] == 'e' &&
5899 if (name[1] == 'n' &&
5908 if (name[1] == 'o' &&
5917 if (name[1] == 'a' &&
5926 if (name[1] == 'o' &&
5988 if (name[1] == 'e' &&
6020 if (name[1] == 'i' &&
6029 if (name[1] == 's' &&
6038 if (name[1] == 'e' &&
6047 if (name[1] == 'o' &&
6059 case 4: /* 40 tokens of length 4 */
6063 if (name[1] == 'O' &&
6073 if (name[1] == 'N' &&
6083 if (name[1] == 'i' &&
6093 if (name[1] == 'h' &&
6103 if (name[1] == 'u' &&
6116 if (name[2] == 'c' &&
6125 if (name[2] == 's' &&
6134 if (name[2] == 'a' &&
6170 if (name[1] == 'o' &&
6183 if (name[2] == 't' &&
6192 if (name[2] == 'o' &&
6201 if (name[2] == 't' &&
6210 if (name[2] == 'e' &&
6223 if (name[1] == 'o' &&
6236 if (name[2] == 'y' &&
6245 if (name[2] == 'l' &&
6261 if (name[2] == 's' &&
6270 if (name[2] == 'n' &&
6279 if (name[2] == 'c' &&
6292 if (name[1] == 'e' &&
6302 if (name[1] == 'p' &&
6315 if (name[2] == 'c' &&
6324 if (name[2] == 'p' &&
6333 if (name[2] == 's' &&
6349 if (name[2] == 'n' &&
6419 if (name[2] == 'r' &&
6428 if (name[2] == 'r' &&
6437 if (name[2] == 'a' &&
6453 if (name[2] == 'l' &&
6520 case 5: /* 36 tokens of length 5 */
6524 if (name[1] == 'E' &&
6535 if (name[1] == 'H' &&
6549 if (name[2] == 'a' &&
6559 if (name[2] == 'a' &&
6573 if (name[1] == 'l' &&
6590 if (name[3] == 'i' &&
6599 if (name[3] == 'o' &&
6635 if (name[2] == 'o' &&
6645 if (name[2] == 'y' &&
6659 if (name[1] == 'l' &&
6673 if (name[2] == 'n' &&
6683 if (name[2] == 'o' &&
6700 if (name[2] == 'd' &&
6710 if (name[2] == 'c' &&
6727 if (name[2] == 'c' &&
6737 if (name[2] == 't' &&
6751 if (name[1] == 'k' &&
6762 if (name[1] == 'r' &&
6776 if (name[2] == 's' &&
6786 if (name[2] == 'd' &&
6803 if (name[2] == 'm' &&
6813 if (name[2] == 'i' &&
6823 if (name[2] == 'e' &&
6833 if (name[2] == 'l' &&
6843 if (name[2] == 'a' &&
6853 if (name[2] == 'u' &&
6867 if (name[1] == 'i' &&
6881 if (name[2] == 'a' &&
6894 if (name[3] == 'e' &&
6929 if (name[2] == 'i' &&
6946 if (name[2] == 'i' &&
6956 if (name[2] == 'i' &&
6973 case 6: /* 33 tokens of length 6 */
6977 if (name[1] == 'c' &&
6992 if (name[2] == 'l' &&
7003 if (name[2] == 'r' &&
7018 if (name[1] == 'e' &&
7033 if (name[2] == 's' &&
7038 if(ckWARN_d(WARN_SYNTAX))
7039 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7045 if (name[2] == 'i' &&
7063 if (name[2] == 'l' &&
7074 if (name[2] == 'r' &&
7089 if (name[1] == 'm' &&
7104 if (name[2] == 'n' &&
7115 if (name[2] == 's' &&
7130 if (name[1] == 's' &&
7136 if (name[4] == 't' &&
7145 if (name[4] == 'e' &&
7154 if (name[4] == 'c' &&
7163 if (name[4] == 'n' &&
7179 if (name[1] == 'r' &&
7197 if (name[3] == 'a' &&
7207 if (name[3] == 'u' &&
7221 if (name[2] == 'n' &&
7239 if (name[2] == 'a' &&
7253 if (name[3] == 'e' &&
7266 if (name[4] == 't' &&
7275 if (name[4] == 'e' &&
7297 if (name[4] == 't' &&
7306 if (name[4] == 'e' &&
7322 if (name[2] == 'c' &&
7333 if (name[2] == 'l' &&
7344 if (name[2] == 'b' &&
7355 if (name[2] == 's' &&
7378 if (name[4] == 's' &&
7387 if (name[4] == 'n' &&
7400 if (name[3] == 'a' &&
7417 if (name[1] == 'a' &&
7432 case 7: /* 28 tokens of length 7 */
7436 if (name[1] == 'E' &&
7449 if (name[1] == '_' &&
7462 if (name[1] == 'i' &&
7469 return -KEY_binmode;
7475 if (name[1] == 'o' &&
7482 return -KEY_connect;
7491 if (name[2] == 'm' &&
7497 return -KEY_dbmopen;
7503 if (name[2] == 'f' &&
7519 if (name[1] == 'o' &&
7532 if (name[1] == 'e' &&
7539 if (name[5] == 'r' &&
7542 return -KEY_getpgrp;
7548 if (name[5] == 'i' &&
7551 return -KEY_getppid;
7564 if (name[1] == 'c' &&
7571 return -KEY_lcfirst;
7577 if (name[1] == 'p' &&
7584 return -KEY_opendir;
7590 if (name[1] == 'a' &&
7608 if (name[3] == 'd' &&
7613 return -KEY_readdir;
7619 if (name[3] == 'u' &&
7630 if (name[3] == 'e' &&
7635 return -KEY_reverse;
7654 if (name[3] == 'k' &&
7659 return -KEY_seekdir;
7665 if (name[3] == 'p' &&
7670 return -KEY_setpgrp;
7680 if (name[2] == 'm' &&
7686 return -KEY_shmread;
7692 if (name[2] == 'r' &&
7698 return -KEY_sprintf;
7707 if (name[3] == 'l' &&
7712 return -KEY_symlink;
7721 if (name[4] == 'a' &&
7725 return -KEY_syscall;
7731 if (name[4] == 'p' &&
7735 return -KEY_sysopen;
7741 if (name[4] == 'e' &&
7745 return -KEY_sysread;
7751 if (name[4] == 'e' &&
7755 return -KEY_sysseek;
7773 if (name[1] == 'e' &&
7780 return -KEY_telldir;
7789 if (name[2] == 'f' &&
7795 return -KEY_ucfirst;
7801 if (name[2] == 's' &&
7807 return -KEY_unshift;
7817 if (name[1] == 'a' &&
7824 return -KEY_waitpid;
7833 case 8: /* 26 tokens of length 8 */
7837 if (name[1] == 'U' &&
7845 return KEY_AUTOLOAD;
7856 if (name[3] == 'A' &&
7862 return KEY___DATA__;
7868 if (name[3] == 'I' &&
7874 return -KEY___FILE__;
7880 if (name[3] == 'I' &&
7886 return -KEY___LINE__;
7902 if (name[2] == 'o' &&
7909 return -KEY_closedir;
7915 if (name[2] == 'n' &&
7922 return -KEY_continue;
7932 if (name[1] == 'b' &&
7940 return -KEY_dbmclose;
7946 if (name[1] == 'n' &&
7952 if (name[4] == 'r' &&
7957 return -KEY_endgrent;
7963 if (name[4] == 'w' &&
7968 return -KEY_endpwent;
7981 if (name[1] == 'o' &&
7989 return -KEY_formline;
7995 if (name[1] == 'e' &&
8006 if (name[6] == 'n' &&
8009 return -KEY_getgrent;
8015 if (name[6] == 'i' &&
8018 return -KEY_getgrgid;
8024 if (name[6] == 'a' &&
8027 return -KEY_getgrnam;
8040 if (name[4] == 'o' &&
8045 return -KEY_getlogin;
8056 if (name[6] == 'n' &&
8059 return -KEY_getpwent;
8065 if (name[6] == 'a' &&
8068 return -KEY_getpwnam;
8074 if (name[6] == 'i' &&
8077 return -KEY_getpwuid;
8097 if (name[1] == 'e' &&
8104 if (name[5] == 'i' &&
8111 return -KEY_readline;
8116 return -KEY_readlink;
8127 if (name[5] == 'i' &&
8131 return -KEY_readpipe;
8152 if (name[4] == 'r' &&
8157 return -KEY_setgrent;
8163 if (name[4] == 'w' &&
8168 return -KEY_setpwent;
8184 if (name[3] == 'w' &&
8190 return -KEY_shmwrite;
8196 if (name[3] == 't' &&
8202 return -KEY_shutdown;
8212 if (name[2] == 's' &&
8219 return -KEY_syswrite;
8229 if (name[1] == 'r' &&
8237 return -KEY_truncate;
8246 case 9: /* 8 tokens of length 9 */
8250 if (name[1] == 'n' &&
8259 return -KEY_endnetent;
8265 if (name[1] == 'e' &&
8274 return -KEY_getnetent;
8280 if (name[1] == 'o' &&
8289 return -KEY_localtime;
8295 if (name[1] == 'r' &&
8304 return KEY_prototype;
8310 if (name[1] == 'u' &&
8319 return -KEY_quotemeta;
8325 if (name[1] == 'e' &&
8334 return -KEY_rewinddir;
8340 if (name[1] == 'e' &&
8349 return -KEY_setnetent;
8355 if (name[1] == 'a' &&
8364 return -KEY_wantarray;
8373 case 10: /* 9 tokens of length 10 */
8377 if (name[1] == 'n' &&
8383 if (name[4] == 'o' &&
8390 return -KEY_endhostent;
8396 if (name[4] == 'e' &&
8403 return -KEY_endservent;
8416 if (name[1] == 'e' &&
8422 if (name[4] == 'o' &&
8429 return -KEY_gethostent;
8438 if (name[5] == 'r' &&
8444 return -KEY_getservent;
8450 if (name[5] == 'c' &&
8456 return -KEY_getsockopt;
8481 if (name[4] == 'o' &&
8488 return -KEY_sethostent;
8497 if (name[5] == 'r' &&
8503 return -KEY_setservent;
8509 if (name[5] == 'c' &&
8515 return -KEY_setsockopt;
8532 if (name[2] == 'c' &&
8541 return -KEY_socketpair;
8554 case 11: /* 8 tokens of length 11 */
8558 if (name[1] == '_' &&
8569 return -KEY___PACKAGE__;
8575 if (name[1] == 'n' &&
8586 return -KEY_endprotoent;
8592 if (name[1] == 'e' &&
8601 if (name[5] == 'e' &&
8608 return -KEY_getpeername;
8617 if (name[6] == 'o' &&
8623 return -KEY_getpriority;
8629 if (name[6] == 't' &&
8635 return -KEY_getprotoent;
8649 if (name[4] == 'o' &&
8657 return -KEY_getsockname;
8670 if (name[1] == 'e' &&
8678 if (name[6] == 'o' &&
8684 return -KEY_setpriority;
8690 if (name[6] == 't' &&
8696 return -KEY_setprotoent;
8712 case 12: /* 2 tokens of length 12 */
8713 if (name[0] == 'g' &&
8725 if (name[9] == 'd' &&
8728 { /* getnetbyaddr */
8729 return -KEY_getnetbyaddr;
8735 if (name[9] == 'a' &&
8738 { /* getnetbyname */
8739 return -KEY_getnetbyname;
8751 case 13: /* 4 tokens of length 13 */
8752 if (name[0] == 'g' &&
8759 if (name[4] == 'o' &&
8768 if (name[10] == 'd' &&
8771 { /* gethostbyaddr */
8772 return -KEY_gethostbyaddr;
8778 if (name[10] == 'a' &&
8781 { /* gethostbyname */
8782 return -KEY_gethostbyname;
8795 if (name[4] == 'e' &&
8804 if (name[10] == 'a' &&
8807 { /* getservbyname */
8808 return -KEY_getservbyname;
8814 if (name[10] == 'o' &&
8817 { /* getservbyport */
8818 return -KEY_getservbyport;
8837 case 14: /* 1 tokens of length 14 */
8838 if (name[0] == 'g' &&
8852 { /* getprotobyname */
8853 return -KEY_getprotobyname;
8858 case 16: /* 1 tokens of length 16 */
8859 if (name[0] == 'g' &&
8875 { /* getprotobynumber */
8876 return -KEY_getprotobynumber;
8890 S_checkcomma(pTHX_ register char *s, char *name, const char *what)
8894 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
8895 if (ckWARN(WARN_SYNTAX)) {
8897 for (w = s+2; *w && level; w++) {
8904 for (; *w && isSPACE(*w); w++) ;
8905 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
8906 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8907 "%s (...) interpreted as function",name);
8910 while (s < PL_bufend && isSPACE(*s))
8914 while (s < PL_bufend && isSPACE(*s))
8916 if (isIDFIRST_lazy_if(s,UTF)) {
8918 while (isALNUM_lazy_if(s,UTF))
8920 while (s < PL_bufend && isSPACE(*s))
8925 kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
8929 Perl_croak(aTHX_ "No comma allowed after %s", what);
8934 /* Either returns sv, or mortalizes sv and returns a new SV*.
8935 Best used as sv=new_constant(..., sv, ...).
8936 If s, pv are NULL, calls subroutine with one argument,
8937 and type is used with error messages only. */
8940 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
8944 HV *table = GvHV(PL_hintgv); /* ^H */
8948 const char *why1, *why2, *why3;
8950 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
8953 why2 = strEQ(key,"charnames")
8954 ? "(possibly a missing \"use charnames ...\")"
8956 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
8957 (type ? type: "undef"), why2);
8959 /* This is convoluted and evil ("goto considered harmful")
8960 * but I do not understand the intricacies of all the different
8961 * failure modes of %^H in here. The goal here is to make
8962 * the most probable error message user-friendly. --jhi */
8967 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
8968 (type ? type: "undef"), why1, why2, why3);
8970 yyerror(SvPVX(msg));
8974 cvp = hv_fetch(table, key, strlen(key), FALSE);
8975 if (!cvp || !SvOK(*cvp)) {
8978 why3 = "} is not defined";
8981 sv_2mortal(sv); /* Parent created it permanently */
8984 pv = sv_2mortal(newSVpvn(s, len));
8986 typesv = sv_2mortal(newSVpv(type, 0));
8988 typesv = &PL_sv_undef;
8990 PUSHSTACKi(PERLSI_OVERLOAD);
9002 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9006 /* Check the eval first */
9007 if (!PL_in_eval && SvTRUE(ERRSV)) {
9009 sv_catpv(ERRSV, "Propagated");
9010 yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
9012 res = SvREFCNT_inc(sv);
9016 (void)SvREFCNT_inc(res);
9025 why1 = "Call to &{$^H{";
9027 why3 = "}} did not return a defined value";
9035 /* Returns a NUL terminated string, with the length of the string written to
9039 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9041 register char *d = dest;
9042 register char *e = d + destlen - 3; /* two-character token, ending NUL */
9045 Perl_croak(aTHX_ ident_too_long);
9046 if (isALNUM(*s)) /* UTF handled below */
9048 else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9053 else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9057 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9058 char *t = s + UTF8SKIP(s);
9059 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9061 if (d + (t - s) > e)
9062 Perl_croak(aTHX_ ident_too_long);
9063 Copy(s, d, t - s, char);
9076 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
9086 e = d + destlen - 3; /* two-character token, ending NUL */
9088 while (isDIGIT(*s)) {
9090 Perl_croak(aTHX_ ident_too_long);
9097 Perl_croak(aTHX_ ident_too_long);
9098 if (isALNUM(*s)) /* UTF handled below */
9100 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9105 else if (*s == ':' && s[1] == ':') {
9109 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9110 char *t = s + UTF8SKIP(s);
9111 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9113 if (d + (t - s) > e)
9114 Perl_croak(aTHX_ ident_too_long);
9115 Copy(s, d, t - s, char);
9126 if (PL_lex_state != LEX_NORMAL)
9127 PL_lex_state = LEX_INTERPENDMAYBE;
9130 if (*s == '$' && s[1] &&
9131 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9144 if (*d == '^' && *s && isCONTROLVAR(*s)) {
9149 if (isSPACE(s[-1])) {
9152 if (!SPACE_OR_TAB(ch)) {
9158 if (isIDFIRST_lazy_if(d,UTF)) {
9162 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9164 while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9167 Copy(s, d, e - s, char);
9172 while ((isALNUM(*s) || *s == ':') && d < e)
9175 Perl_croak(aTHX_ ident_too_long);
9178 while (s < send && SPACE_OR_TAB(*s)) s++;
9179 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9180 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9181 const char *brack = *s == '[' ? "[...]" : "{...}";
9182 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9183 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9184 funny, dest, brack, funny, dest, brack);
9187 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9191 /* Handle extended ${^Foo} variables
9192 * 1999-02-27 mjd-perl-patch@plover.com */
9193 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9197 while (isALNUM(*s) && d < e) {
9201 Perl_croak(aTHX_ ident_too_long);
9206 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9207 PL_lex_state = LEX_INTERPEND;
9212 if (PL_lex_state == LEX_NORMAL) {
9213 if (ckWARN(WARN_AMBIGUOUS) &&
9214 (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9216 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9217 "Ambiguous use of %c{%s} resolved to %c%s",
9218 funny, dest, funny, dest);
9223 s = bracket; /* let the parser handle it */
9227 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9228 PL_lex_state = LEX_INTERPEND;
9233 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9238 *pmfl |= PMf_GLOBAL;
9240 *pmfl |= PMf_CONTINUE;
9244 *pmfl |= PMf_MULTILINE;
9246 *pmfl |= PMf_SINGLELINE;
9248 *pmfl |= PMf_EXTENDED;
9252 S_scan_pat(pTHX_ char *start, I32 type)
9257 s = scan_str(start,FALSE,FALSE);
9259 Perl_croak(aTHX_ "Search pattern not terminated");
9261 pm = (PMOP*)newPMOP(type, 0);
9262 if (PL_multi_open == '?')
9263 pm->op_pmflags |= PMf_ONCE;
9265 while (*s && strchr("iomsx", *s))
9266 pmflag(&pm->op_pmflags,*s++);
9269 while (*s && strchr("iogcmsx", *s))
9270 pmflag(&pm->op_pmflags,*s++);
9272 /* issue a warning if /c is specified,but /g is not */
9273 if (ckWARN(WARN_REGEXP) &&
9274 (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9276 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
9279 pm->op_pmpermflags = pm->op_pmflags;
9281 PL_lex_op = (OP*)pm;
9282 yylval.ival = OP_MATCH;
9287 S_scan_subst(pTHX_ char *start)
9294 yylval.ival = OP_NULL;
9296 s = scan_str(start,FALSE,FALSE);
9299 Perl_croak(aTHX_ "Substitution pattern not terminated");
9301 if (s[-1] == PL_multi_open)
9304 first_start = PL_multi_start;
9305 s = scan_str(s,FALSE,FALSE);
9308 SvREFCNT_dec(PL_lex_stuff);
9309 PL_lex_stuff = Nullsv;
9311 Perl_croak(aTHX_ "Substitution replacement not terminated");
9313 PL_multi_start = first_start; /* so whole substitution is taken together */
9315 pm = (PMOP*)newPMOP(OP_SUBST, 0);
9321 else if (strchr("iogcmsx", *s))
9322 pmflag(&pm->op_pmflags,*s++);
9327 /* /c is not meaningful with s/// */
9328 if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
9330 Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
9335 PL_sublex_info.super_bufptr = s;
9336 PL_sublex_info.super_bufend = PL_bufend;
9338 pm->op_pmflags |= PMf_EVAL;
9339 repl = newSVpvn("",0);
9341 sv_catpv(repl, es ? "eval " : "do ");
9342 sv_catpvn(repl, "{ ", 2);
9343 sv_catsv(repl, PL_lex_repl);
9344 sv_catpvn(repl, " };", 2);
9346 SvREFCNT_dec(PL_lex_repl);
9350 pm->op_pmpermflags = pm->op_pmflags;
9351 PL_lex_op = (OP*)pm;
9352 yylval.ival = OP_SUBST;
9357 S_scan_trans(pTHX_ char *start)
9366 yylval.ival = OP_NULL;
9368 s = scan_str(start,FALSE,FALSE);
9370 Perl_croak(aTHX_ "Transliteration pattern not terminated");
9371 if (s[-1] == PL_multi_open)
9374 s = scan_str(s,FALSE,FALSE);
9377 SvREFCNT_dec(PL_lex_stuff);
9378 PL_lex_stuff = Nullsv;
9380 Perl_croak(aTHX_ "Transliteration replacement not terminated");
9383 complement = del = squash = 0;
9387 complement = OPpTRANS_COMPLEMENT;
9390 del = OPpTRANS_DELETE;
9393 squash = OPpTRANS_SQUASH;
9402 New(803, tbl, complement&&!del?258:256, short);
9403 o = newPVOP(OP_TRANS, 0, (char*)tbl);
9404 o->op_private &= ~OPpTRANS_ALL;
9405 o->op_private |= del|squash|complement|
9406 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9407 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
9410 yylval.ival = OP_TRANS;
9415 S_scan_heredoc(pTHX_ register char *s)
9418 I32 op_type = OP_SCALAR;
9422 const char newline[] = "\n";
9423 const char *found_newline;
9427 int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9431 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9434 for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9435 if (*peek == '`' || *peek == '\'' || *peek =='"') {
9438 s = delimcpy(d, e, s, PL_bufend, term, &len);
9448 if (!isALNUM_lazy_if(s,UTF))
9449 deprecate_old("bare << to mean <<\"\"");
9450 for (; isALNUM_lazy_if(s,UTF); s++) {
9455 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9456 Perl_croak(aTHX_ "Delimiter for here document is too long");
9459 len = d - PL_tokenbuf;
9460 #ifndef PERL_STRICT_CR
9461 d = strchr(s, '\r');
9465 while (s < PL_bufend) {
9471 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
9480 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
9484 if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9485 herewas = newSVpvn(s,PL_bufend-s);
9489 herewas = newSVpvn(s,found_newline-s);
9491 s += SvCUR(herewas);
9493 tmpstr = NEWSV(87,79);
9494 sv_upgrade(tmpstr, SVt_PVIV);
9499 else if (term == '`') {
9500 op_type = OP_BACKTICK;
9501 SvIVX(tmpstr) = '\\';
9505 PL_multi_start = CopLINE(PL_curcop);
9506 PL_multi_open = PL_multi_close = '<';
9507 term = *PL_tokenbuf;
9508 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9509 char *bufptr = PL_sublex_info.super_bufptr;
9510 char *bufend = PL_sublex_info.super_bufend;
9511 char *olds = s - SvCUR(herewas);
9512 s = strchr(bufptr, '\n');
9516 while (s < bufend &&
9517 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9519 CopLINE_inc(PL_curcop);
9522 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9523 missingterm(PL_tokenbuf);
9525 sv_setpvn(herewas,bufptr,d-bufptr+1);
9526 sv_setpvn(tmpstr,d+1,s-d);
9528 sv_catpvn(herewas,s,bufend-s);
9529 Copy(SvPVX(herewas),bufptr,SvCUR(herewas) + 1,char);
9536 while (s < PL_bufend &&
9537 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9539 CopLINE_inc(PL_curcop);
9541 if (s >= PL_bufend) {
9542 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9543 missingterm(PL_tokenbuf);
9545 sv_setpvn(tmpstr,d+1,s-d);
9547 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9549 sv_catpvn(herewas,s,PL_bufend-s);
9550 sv_setsv(PL_linestr,herewas);
9551 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9552 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9553 PL_last_lop = PL_last_uni = Nullch;
9556 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
9557 while (s >= PL_bufend) { /* multiple line string? */
9559 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9560 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9561 missingterm(PL_tokenbuf);
9563 CopLINE_inc(PL_curcop);
9564 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9565 PL_last_lop = PL_last_uni = Nullch;
9566 #ifndef PERL_STRICT_CR
9567 if (PL_bufend - PL_linestart >= 2) {
9568 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9569 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9571 PL_bufend[-2] = '\n';
9573 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
9575 else if (PL_bufend[-1] == '\r')
9576 PL_bufend[-1] = '\n';
9578 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9579 PL_bufend[-1] = '\n';
9581 if (PERLDB_LINE && PL_curstash != PL_debstash) {
9582 SV *sv = NEWSV(88,0);
9584 sv_upgrade(sv, SVt_PVMG);
9585 sv_setsv(sv,PL_linestr);
9588 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9590 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9591 STRLEN off = PL_bufend - 1 - SvPVX(PL_linestr);
9592 *(SvPVX(PL_linestr) + off ) = ' ';
9593 sv_catsv(PL_linestr,herewas);
9594 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9595 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9599 sv_catsv(tmpstr,PL_linestr);
9604 PL_multi_end = CopLINE(PL_curcop);
9605 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9606 SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
9607 Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
9609 SvREFCNT_dec(herewas);
9611 if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
9613 else if (PL_encoding)
9614 sv_recode_to_utf8(tmpstr, PL_encoding);
9616 PL_lex_stuff = tmpstr;
9617 yylval.ival = op_type;
9622 takes: current position in input buffer
9623 returns: new position in input buffer
9624 side-effects: yylval and lex_op are set.
9629 <FH> read from filehandle
9630 <pkg::FH> read from package qualified filehandle
9631 <pkg'FH> read from package qualified filehandle
9632 <$fh> read from filehandle in $fh
9638 S_scan_inputsymbol(pTHX_ char *start)
9640 register char *s = start; /* current position in buffer */
9646 d = PL_tokenbuf; /* start of temp holding space */
9647 e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
9648 end = strchr(s, '\n');
9651 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
9653 /* die if we didn't have space for the contents of the <>,
9654 or if it didn't end, or if we see a newline
9657 if (len >= sizeof PL_tokenbuf)
9658 Perl_croak(aTHX_ "Excessively long <> operator");
9660 Perl_croak(aTHX_ "Unterminated <> operator");
9665 Remember, only scalar variables are interpreted as filehandles by
9666 this code. Anything more complex (e.g., <$fh{$num}>) will be
9667 treated as a glob() call.
9668 This code makes use of the fact that except for the $ at the front,
9669 a scalar variable and a filehandle look the same.
9671 if (*d == '$' && d[1]) d++;
9673 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9674 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9677 /* If we've tried to read what we allow filehandles to look like, and
9678 there's still text left, then it must be a glob() and not a getline.
9679 Use scan_str to pull out the stuff between the <> and treat it
9680 as nothing more than a string.
9683 if (d - PL_tokenbuf != len) {
9684 yylval.ival = OP_GLOB;
9686 s = scan_str(start,FALSE,FALSE);
9688 Perl_croak(aTHX_ "Glob not terminated");
9692 bool readline_overriden = FALSE;
9693 GV *gv_readline = Nullgv;
9695 /* we're in a filehandle read situation */
9698 /* turn <> into <ARGV> */
9700 Copy("ARGV",d,5,char);
9702 /* Check whether readline() is overriden */
9703 if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9704 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9706 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9707 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9708 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9709 readline_overriden = TRUE;
9711 /* if <$fh>, create the ops to turn the variable into a
9717 /* try to find it in the pad for this block, otherwise find
9718 add symbol table ops
9720 if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9721 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9722 SV *sym = sv_2mortal(
9723 newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
9724 sv_catpvn(sym, "::", 2);
9730 OP *o = newOP(OP_PADSV, 0);
9732 PL_lex_op = readline_overriden
9733 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9734 append_elem(OP_LIST, o,
9735 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9736 : (OP*)newUNOP(OP_READLINE, 0, o);
9745 ? (GV_ADDMULTI | GV_ADDINEVAL)
9748 PL_lex_op = readline_overriden
9749 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9750 append_elem(OP_LIST,
9751 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9752 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9753 : (OP*)newUNOP(OP_READLINE, 0,
9754 newUNOP(OP_RV2SV, 0,
9755 newGVOP(OP_GV, 0, gv)));
9757 if (!readline_overriden)
9758 PL_lex_op->op_flags |= OPf_SPECIAL;
9759 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9760 yylval.ival = OP_NULL;
9763 /* If it's none of the above, it must be a literal filehandle
9764 (<Foo::BAR> or <FOO>) so build a simple readline OP */
9766 GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9767 PL_lex_op = readline_overriden
9768 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9769 append_elem(OP_LIST,
9770 newGVOP(OP_GV, 0, gv),
9771 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9772 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9773 yylval.ival = OP_NULL;
9782 takes: start position in buffer
9783 keep_quoted preserve \ on the embedded delimiter(s)
9784 keep_delims preserve the delimiters around the string
9785 returns: position to continue reading from buffer
9786 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9787 updates the read buffer.
9789 This subroutine pulls a string out of the input. It is called for:
9790 q single quotes q(literal text)
9791 ' single quotes 'literal text'
9792 qq double quotes qq(interpolate $here please)
9793 " double quotes "interpolate $here please"
9794 qx backticks qx(/bin/ls -l)
9795 ` backticks `/bin/ls -l`
9796 qw quote words @EXPORT_OK = qw( func() $spam )
9797 m// regexp match m/this/
9798 s/// regexp substitute s/this/that/
9799 tr/// string transliterate tr/this/that/
9800 y/// string transliterate y/this/that/
9801 ($*@) sub prototypes sub foo ($)
9802 (stuff) sub attr parameters sub foo : attr(stuff)
9803 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
9805 In most of these cases (all but <>, patterns and transliterate)
9806 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
9807 calls scan_str(). s/// makes yylex() call scan_subst() which calls
9808 scan_str(). tr/// and y/// make yylex() call scan_trans() which
9811 It skips whitespace before the string starts, and treats the first
9812 character as the delimiter. If the delimiter is one of ([{< then
9813 the corresponding "close" character )]}> is used as the closing
9814 delimiter. It allows quoting of delimiters, and if the string has
9815 balanced delimiters ([{<>}]) it allows nesting.
9817 On success, the SV with the resulting string is put into lex_stuff or,
9818 if that is already non-NULL, into lex_repl. The second case occurs only
9819 when parsing the RHS of the special constructs s/// and tr/// (y///).
9820 For convenience, the terminating delimiter character is stuffed into
9825 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9827 SV *sv; /* scalar value: string */
9828 char *tmps; /* temp string, used for delimiter matching */
9829 register char *s = start; /* current position in the buffer */
9830 register char term; /* terminating character */
9831 register char *to; /* current position in the sv's data */
9832 I32 brackets = 1; /* bracket nesting level */
9833 bool has_utf8 = FALSE; /* is there any utf8 content? */
9834 I32 termcode; /* terminating char. code */
9835 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
9836 STRLEN termlen; /* length of terminating string */
9837 char *last = NULL; /* last position for nesting bracket */
9839 /* skip space before the delimiter */
9843 /* mark where we are, in case we need to report errors */
9846 /* after skipping whitespace, the next character is the terminator */
9849 termcode = termstr[0] = term;
9853 termcode = utf8_to_uvchr((U8*)s, &termlen);
9854 Copy(s, termstr, termlen, U8);
9855 if (!UTF8_IS_INVARIANT(term))
9859 /* mark where we are */
9860 PL_multi_start = CopLINE(PL_curcop);
9861 PL_multi_open = term;
9863 /* find corresponding closing delimiter */
9864 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9865 termcode = termstr[0] = term = tmps[5];
9867 PL_multi_close = term;
9869 /* create a new SV to hold the contents. 87 is leak category, I'm
9870 assuming. 79 is the SV's initial length. What a random number. */
9872 sv_upgrade(sv, SVt_PVIV);
9873 SvIVX(sv) = termcode;
9874 (void)SvPOK_only(sv); /* validate pointer */
9876 /* move past delimiter and try to read a complete string */
9878 sv_catpvn(sv, s, termlen);
9881 if (PL_encoding && !UTF) {
9885 int offset = s - SvPVX(PL_linestr);
9886 bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9887 &offset, (char*)termstr, termlen);
9888 char *ns = SvPVX(PL_linestr) + offset;
9889 char *svlast = SvEND(sv) - 1;
9891 for (; s < ns; s++) {
9892 if (*s == '\n' && !PL_rsfp)
9893 CopLINE_inc(PL_curcop);
9896 goto read_more_line;
9898 /* handle quoted delimiters */
9899 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9901 for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
9903 if ((svlast-1 - t) % 2) {
9907 SvCUR_set(sv, SvCUR(sv) - 1);
9912 if (PL_multi_open == PL_multi_close) {
9919 for (w = t = last; t < svlast; w++, t++) {
9920 /* At here, all closes are "was quoted" one,
9921 so we don't check PL_multi_close. */
9923 if (!keep_quoted && *(t+1) == PL_multi_open)
9928 else if (*t == PL_multi_open)
9936 SvCUR_set(sv, w - SvPVX(sv));
9939 if (--brackets <= 0)
9945 SvCUR_set(sv, SvCUR(sv) - 1);
9951 /* extend sv if need be */
9952 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
9953 /* set 'to' to the next character in the sv's string */
9954 to = SvPVX(sv)+SvCUR(sv);
9956 /* if open delimiter is the close delimiter read unbridle */
9957 if (PL_multi_open == PL_multi_close) {
9958 for (; s < PL_bufend; s++,to++) {
9959 /* embedded newlines increment the current line number */
9960 if (*s == '\n' && !PL_rsfp)
9961 CopLINE_inc(PL_curcop);
9962 /* handle quoted delimiters */
9963 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
9964 if (!keep_quoted && s[1] == term)
9966 /* any other quotes are simply copied straight through */
9970 /* terminate when run out of buffer (the for() condition), or
9971 have found the terminator */
9972 else if (*s == term) {
9975 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
9978 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
9984 /* if the terminator isn't the same as the start character (e.g.,
9985 matched brackets), we have to allow more in the quoting, and
9986 be prepared for nested brackets.
9989 /* read until we run out of string, or we find the terminator */
9990 for (; s < PL_bufend; s++,to++) {
9991 /* embedded newlines increment the line count */
9992 if (*s == '\n' && !PL_rsfp)
9993 CopLINE_inc(PL_curcop);
9994 /* backslashes can escape the open or closing characters */
9995 if (*s == '\\' && s+1 < PL_bufend) {
9997 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10002 /* allow nested opens and closes */
10003 else if (*s == PL_multi_close && --brackets <= 0)
10005 else if (*s == PL_multi_open)
10007 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10012 /* terminate the copied string and update the sv's end-of-string */
10014 SvCUR_set(sv, to - SvPVX(sv));
10017 * this next chunk reads more into the buffer if we're not done yet
10021 break; /* handle case where we are done yet :-) */
10023 #ifndef PERL_STRICT_CR
10024 if (to - SvPVX(sv) >= 2) {
10025 if ((to[-2] == '\r' && to[-1] == '\n') ||
10026 (to[-2] == '\n' && to[-1] == '\r'))
10030 SvCUR_set(sv, to - SvPVX(sv));
10032 else if (to[-1] == '\r')
10035 else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
10040 /* if we're out of file, or a read fails, bail and reset the current
10041 line marker so we can report where the unterminated string began
10044 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10046 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10049 /* we read a line, so increment our line counter */
10050 CopLINE_inc(PL_curcop);
10052 /* update debugger info */
10053 if (PERLDB_LINE && PL_curstash != PL_debstash) {
10054 SV *sv = NEWSV(88,0);
10056 sv_upgrade(sv, SVt_PVMG);
10057 sv_setsv(sv,PL_linestr);
10058 (void)SvIOK_on(sv);
10060 av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10063 /* having changed the buffer, we must update PL_bufend */
10064 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10065 PL_last_lop = PL_last_uni = Nullch;
10068 /* at this point, we have successfully read the delimited string */
10070 if (!PL_encoding || UTF) {
10072 sv_catpvn(sv, s, termlen);
10075 if (has_utf8 || PL_encoding)
10078 PL_multi_end = CopLINE(PL_curcop);
10080 /* if we allocated too much space, give some back */
10081 if (SvCUR(sv) + 5 < SvLEN(sv)) {
10082 SvLEN_set(sv, SvCUR(sv) + 1);
10083 Renew(SvPVX(sv), SvLEN(sv), char);
10086 /* decide whether this is the first or second quoted string we've read
10099 takes: pointer to position in buffer
10100 returns: pointer to new position in buffer
10101 side-effects: builds ops for the constant in yylval.op
10103 Read a number in any of the formats that Perl accepts:
10105 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10106 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10109 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10111 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10114 If it reads a number without a decimal point or an exponent, it will
10115 try converting the number to an integer and see if it can do so
10116 without loss of precision.
10120 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10122 register const char *s = start; /* current position in buffer */
10123 register char *d; /* destination in temp buffer */
10124 register char *e; /* end of temp buffer */
10125 NV nv; /* number read, as a double */
10126 SV *sv = Nullsv; /* place to put the converted number */
10127 bool floatit; /* boolean: int or float? */
10128 const char *lastub = 0; /* position of last underbar */
10129 static char const number_too_long[] = "Number too long";
10131 /* We use the first character to decide what type of number this is */
10135 Perl_croak(aTHX_ "panic: scan_num");
10137 /* if it starts with a 0, it could be an octal number, a decimal in
10138 0.13 disguise, or a hexadecimal number, or a binary number. */
10142 u holds the "number so far"
10143 shift the power of 2 of the base
10144 (hex == 4, octal == 3, binary == 1)
10145 overflowed was the number more than we can hold?
10147 Shift is used when we add a digit. It also serves as an "are
10148 we in octal/hex/binary?" indicator to disallow hex characters
10149 when in octal mode.
10154 bool overflowed = FALSE;
10155 bool just_zero = TRUE; /* just plain 0 or binary number? */
10156 static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10157 static char const* bases[5] = { "", "binary", "", "octal",
10159 static char const* Bases[5] = { "", "Binary", "", "Octal",
10161 static char const *maxima[5] = { "",
10162 "0b11111111111111111111111111111111",
10166 const char *base, *Base, *max;
10168 /* check for hex */
10173 } else if (s[1] == 'b') {
10178 /* check for a decimal in disguise */
10179 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10181 /* so it must be octal */
10188 if (ckWARN(WARN_SYNTAX))
10189 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10190 "Misplaced _ in number");
10194 base = bases[shift];
10195 Base = Bases[shift];
10196 max = maxima[shift];
10198 /* read the rest of the number */
10200 /* x is used in the overflow test,
10201 b is the digit we're adding on. */
10206 /* if we don't mention it, we're done */
10210 /* _ are ignored -- but warned about if consecutive */
10212 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
10213 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10214 "Misplaced _ in number");
10218 /* 8 and 9 are not octal */
10219 case '8': case '9':
10221 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10225 case '2': case '3': case '4':
10226 case '5': case '6': case '7':
10228 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10231 case '0': case '1':
10232 b = *s++ & 15; /* ASCII digit -> value of digit */
10236 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10237 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10238 /* make sure they said 0x */
10241 b = (*s++ & 7) + 9;
10243 /* Prepare to put the digit we have onto the end
10244 of the number so far. We check for overflows.
10250 x = u << shift; /* make room for the digit */
10252 if ((x >> shift) != u
10253 && !(PL_hints & HINT_NEW_BINARY)) {
10256 if (ckWARN_d(WARN_OVERFLOW))
10257 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10258 "Integer overflow in %s number",
10261 u = x | b; /* add the digit to the end */
10264 n *= nvshift[shift];
10265 /* If an NV has not enough bits in its
10266 * mantissa to represent an UV this summing of
10267 * small low-order numbers is a waste of time
10268 * (because the NV cannot preserve the
10269 * low-order bits anyway): we could just
10270 * remember when did we overflow and in the
10271 * end just multiply n by the right
10279 /* if we get here, we had success: make a scalar value from
10284 /* final misplaced underbar check */
10285 if (s[-1] == '_') {
10286 if (ckWARN(WARN_SYNTAX))
10287 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10292 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
10293 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10294 "%s number > %s non-portable",
10300 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
10301 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10302 "%s number > %s non-portable",
10307 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10308 sv = new_constant(start, s - start, "integer",
10310 else if (PL_hints & HINT_NEW_BINARY)
10311 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10316 handle decimal numbers.
10317 we're also sent here when we read a 0 as the first digit
10319 case '1': case '2': case '3': case '4': case '5':
10320 case '6': case '7': case '8': case '9': case '.':
10323 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10326 /* read next group of digits and _ and copy into d */
10327 while (isDIGIT(*s) || *s == '_') {
10328 /* skip underscores, checking for misplaced ones
10332 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
10333 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10334 "Misplaced _ in number");
10338 /* check for end of fixed-length buffer */
10340 Perl_croak(aTHX_ number_too_long);
10341 /* if we're ok, copy the character */
10346 /* final misplaced underbar check */
10347 if (lastub && s == lastub + 1) {
10348 if (ckWARN(WARN_SYNTAX))
10349 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10352 /* read a decimal portion if there is one. avoid
10353 3..5 being interpreted as the number 3. followed
10356 if (*s == '.' && s[1] != '.') {
10361 if (ckWARN(WARN_SYNTAX))
10362 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10363 "Misplaced _ in number");
10367 /* copy, ignoring underbars, until we run out of digits.
10369 for (; isDIGIT(*s) || *s == '_'; s++) {
10370 /* fixed length buffer check */
10372 Perl_croak(aTHX_ number_too_long);
10374 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
10375 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10376 "Misplaced _ in number");
10382 /* fractional part ending in underbar? */
10383 if (s[-1] == '_') {
10384 if (ckWARN(WARN_SYNTAX))
10385 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10386 "Misplaced _ in number");
10388 if (*s == '.' && isDIGIT(s[1])) {
10389 /* oops, it's really a v-string, but without the "v" */
10395 /* read exponent part, if present */
10396 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10400 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10401 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
10403 /* stray preinitial _ */
10405 if (ckWARN(WARN_SYNTAX))
10406 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10407 "Misplaced _ in number");
10411 /* allow positive or negative exponent */
10412 if (*s == '+' || *s == '-')
10415 /* stray initial _ */
10417 if (ckWARN(WARN_SYNTAX))
10418 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10419 "Misplaced _ in number");
10423 /* read digits of exponent */
10424 while (isDIGIT(*s) || *s == '_') {
10427 Perl_croak(aTHX_ number_too_long);
10431 if (ckWARN(WARN_SYNTAX) &&
10432 ((lastub && s == lastub + 1) ||
10433 (!isDIGIT(s[1]) && s[1] != '_')))
10434 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10435 "Misplaced _ in number");
10442 /* make an sv from the string */
10446 We try to do an integer conversion first if no characters
10447 indicating "float" have been found.
10452 int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10454 if (flags == IS_NUMBER_IN_UV) {
10456 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10459 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10460 if (uv <= (UV) IV_MIN)
10461 sv_setiv(sv, -(IV)uv);
10468 /* terminate the string */
10470 nv = Atof(PL_tokenbuf);
10474 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10475 (PL_hints & HINT_NEW_INTEGER) )
10476 sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10477 (floatit ? "float" : "integer"),
10481 /* if it starts with a v, it could be a v-string */
10484 sv = NEWSV(92,5); /* preallocate storage space */
10485 s = scan_vstring(s,sv);
10489 /* make the op for the constant and return */
10492 lvalp->opval = newSVOP(OP_CONST, 0, sv);
10494 lvalp->opval = Nullop;
10500 S_scan_formline(pTHX_ register char *s)
10502 register char *eol;
10504 SV *stuff = newSVpvn("",0);
10505 bool needargs = FALSE;
10506 bool eofmt = FALSE;
10508 while (!needargs) {
10511 #ifdef PERL_STRICT_CR
10512 for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10514 for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10516 if (*t == '\n' || t == PL_bufend) {
10521 if (PL_in_eval && !PL_rsfp) {
10522 eol = memchr(s,'\n',PL_bufend-s);
10527 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10529 for (t = s; t < eol; t++) {
10530 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10532 goto enough; /* ~~ must be first line in formline */
10534 if (*t == '@' || *t == '^')
10538 sv_catpvn(stuff, s, eol-s);
10539 #ifndef PERL_STRICT_CR
10540 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10541 char *end = SvPVX(stuff) + SvCUR(stuff);
10553 s = filter_gets(PL_linestr, PL_rsfp, 0);
10554 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10555 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10556 PL_last_lop = PL_last_uni = Nullch;
10565 if (SvCUR(stuff)) {
10568 PL_lex_state = LEX_NORMAL;
10569 PL_nextval[PL_nexttoke].ival = 0;
10573 PL_lex_state = LEX_FORMLINE;
10575 if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
10577 else if (PL_encoding)
10578 sv_recode_to_utf8(stuff, PL_encoding);
10580 PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10582 PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10586 SvREFCNT_dec(stuff);
10588 PL_lex_formbrack = 0;
10599 PL_cshlen = strlen(PL_cshname);
10604 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10606 I32 oldsavestack_ix = PL_savestack_ix;
10607 CV* outsidecv = PL_compcv;
10610 assert(SvTYPE(PL_compcv) == SVt_PVCV);
10612 SAVEI32(PL_subline);
10613 save_item(PL_subname);
10614 SAVESPTR(PL_compcv);
10616 PL_compcv = (CV*)NEWSV(1104,0);
10617 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10618 CvFLAGS(PL_compcv) |= flags;
10620 PL_subline = CopLINE(PL_curcop);
10621 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10622 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10623 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10625 return oldsavestack_ix;
10629 #pragma segment Perl_yylex
10632 Perl_yywarn(pTHX_ const char *s)
10634 PL_in_eval |= EVAL_WARNONLY;
10636 PL_in_eval &= ~EVAL_WARNONLY;
10641 Perl_yyerror(pTHX_ const char *s)
10643 const char *where = NULL;
10644 const char *context = NULL;
10648 if (!yychar || (yychar == ';' && !PL_rsfp))
10650 else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
10651 PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
10654 The code below is removed for NetWare because it abends/crashes on NetWare
10655 when the script has error such as not having the closing quotes like:
10656 if ($var eq "value)
10657 Checking of white spaces is anyway done in NetWare code.
10660 while (isSPACE(*PL_oldoldbufptr))
10663 context = PL_oldoldbufptr;
10664 contlen = PL_bufptr - PL_oldoldbufptr;
10666 else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
10667 PL_oldbufptr != PL_bufptr) {
10670 The code below is removed for NetWare because it abends/crashes on NetWare
10671 when the script has error such as not having the closing quotes like:
10672 if ($var eq "value)
10673 Checking of white spaces is anyway done in NetWare code.
10676 while (isSPACE(*PL_oldbufptr))
10679 context = PL_oldbufptr;
10680 contlen = PL_bufptr - PL_oldbufptr;
10682 else if (yychar > 255)
10683 where = "next token ???";
10684 else if (yychar == -2) { /* YYEMPTY */
10685 if (PL_lex_state == LEX_NORMAL ||
10686 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10687 where = "at end of line";
10688 else if (PL_lex_inpat)
10689 where = "within pattern";
10691 where = "within string";
10694 SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10696 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10697 else if (isPRINT_LC(yychar))
10698 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10700 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10701 where = SvPVX(where_sv);
10703 msg = sv_2mortal(newSVpv(s, 0));
10704 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10705 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10707 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10709 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10710 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10711 Perl_sv_catpvf(aTHX_ msg,
10712 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10713 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10716 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10717 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10720 if (PL_error_count >= 10) {
10721 if (PL_in_eval && SvCUR(ERRSV))
10722 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10723 ERRSV, OutCopFILE(PL_curcop));
10725 Perl_croak(aTHX_ "%s has too many errors.\n",
10726 OutCopFILE(PL_curcop));
10729 PL_in_my_stash = Nullhv;
10733 #pragma segment Main
10737 S_swallow_bom(pTHX_ U8 *s)
10740 slen = SvCUR(PL_linestr);
10743 if (s[1] == 0xFE) {
10744 /* UTF-16 little-endian? (or UTF32-LE?) */
10745 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
10746 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10747 #ifndef PERL_NO_UTF16_FILTER
10748 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10751 if (PL_bufend > (char*)s) {
10755 filter_add(utf16rev_textfilter, NULL);
10756 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10757 utf16_to_utf8_reversed(s, news,
10758 PL_bufend - (char*)s - 1,
10760 sv_setpvn(PL_linestr, (const char*)news, newlen);
10762 SvUTF8_on(PL_linestr);
10763 s = (U8*)SvPVX(PL_linestr);
10764 PL_bufend = SvPVX(PL_linestr) + newlen;
10767 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10772 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
10773 #ifndef PERL_NO_UTF16_FILTER
10774 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10777 if (PL_bufend > (char *)s) {
10781 filter_add(utf16_textfilter, NULL);
10782 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10783 utf16_to_utf8(s, news,
10784 PL_bufend - (char*)s,
10786 sv_setpvn(PL_linestr, (const char*)news, newlen);
10788 SvUTF8_on(PL_linestr);
10789 s = (U8*)SvPVX(PL_linestr);
10790 PL_bufend = SvPVX(PL_linestr) + newlen;
10793 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10798 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10799 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10800 s += 3; /* UTF-8 */
10806 if (s[2] == 0xFE && s[3] == 0xFF) {
10807 /* UTF-32 big-endian */
10808 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10811 else if (s[2] == 0 && s[3] != 0) {
10814 * are a good indicator of UTF-16BE. */
10815 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10820 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10823 * are a good indicator of UTF-16LE. */
10824 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10833 * Restore a source filter.
10837 restore_rsfp(pTHX_ void *f)
10839 PerlIO *fp = (PerlIO*)f;
10841 if (PL_rsfp == PerlIO_stdin())
10842 PerlIO_clearerr(PL_rsfp);
10843 else if (PL_rsfp && (PL_rsfp != fp))
10844 PerlIO_close(PL_rsfp);
10848 #ifndef PERL_NO_UTF16_FILTER
10850 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10852 STRLEN old = SvCUR(sv);
10853 I32 count = FILTER_READ(idx+1, sv, maxlen);
10854 DEBUG_P(PerlIO_printf(Perl_debug_log,
10855 "utf16_textfilter(%p): %d %d (%d)\n",
10856 utf16_textfilter, idx, maxlen, (int) count));
10860 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10861 Copy(SvPVX(sv), tmps, old, char);
10862 utf16_to_utf8((U8*)SvPVX(sv) + old, tmps + old,
10863 SvCUR(sv) - old, &newlen);
10864 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10866 DEBUG_P({sv_dump(sv);});
10871 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10873 STRLEN old = SvCUR(sv);
10874 I32 count = FILTER_READ(idx+1, sv, maxlen);
10875 DEBUG_P(PerlIO_printf(Perl_debug_log,
10876 "utf16rev_textfilter(%p): %d %d (%d)\n",
10877 utf16rev_textfilter, idx, maxlen, (int) count));
10881 New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10882 Copy(SvPVX(sv), tmps, old, char);
10883 utf16_to_utf8((U8*)SvPVX(sv) + old, tmps + old,
10884 SvCUR(sv) - old, &newlen);
10885 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10887 DEBUG_P({ sv_dump(sv); });
10893 Returns a pointer to the next character after the parsed
10894 vstring, as well as updating the passed in sv.
10896 Function must be called like
10899 s = scan_vstring(s,sv);
10901 The sv should already be large enough to store the vstring
10902 passed in, for performance reasons.
10907 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
10909 const char *pos = s;
10910 const char *start = s;
10911 if (*pos == 'v') pos++; /* get past 'v' */
10912 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
10914 if ( *pos != '.') {
10915 /* this may not be a v-string if followed by => */
10916 const char *next = pos;
10917 while (next < PL_bufend && isSPACE(*next))
10919 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
10920 /* return string not v-string */
10921 sv_setpvn(sv,(char *)s,pos-s);
10922 return (char *)pos;
10926 if (!isALPHA(*pos)) {
10928 U8 tmpbuf[UTF8_MAXBYTES+1];
10931 if (*s == 'v') s++; /* get past 'v' */
10933 sv_setpvn(sv, "", 0);
10938 /* this is atoi() that tolerates underscores */
10939 const char *end = pos;
10941 while (--end >= s) {
10946 rev += (*end - '0') * mult;
10948 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
10949 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10950 "Integer overflow in decimal number");
10954 if (rev > 0x7FFFFFFF)
10955 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
10957 /* Append native character for the rev point */
10958 tmpend = uvchr_to_utf8(tmpbuf, rev);
10959 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
10960 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
10962 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
10968 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
10972 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);