3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "It all comes from here, the stench and the peril." --Frodo
16 * This file is the lexer for Perl. It's closely linked to the
19 * The main routine is yylex(), which returns the next token.
23 #define PERL_IN_TOKE_C
26 #define yychar (*PL_yycharp)
27 #define yylval (*PL_yylvalp)
29 static const char ident_too_long[] = "Identifier too long";
30 static const char commaless_variable_list[] = "comma-less variable list";
32 static void restore_rsfp(pTHX_ void *f);
33 #ifndef PERL_NO_UTF16_FILTER
34 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
35 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
39 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
40 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
42 # define CURMAD(slot,sv)
43 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
46 #define XFAKEBRACK 128
49 #ifdef USE_UTF8_SCRIPTS
50 # define UTF (!IN_BYTES)
52 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
55 /* In variables named $^X, these are the legal values for X.
56 * 1999-02-27 mjd-perl-patch@plover.com */
57 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
59 /* On MacOS, respect nonbreaking spaces */
60 #ifdef MACOS_TRADITIONAL
61 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
63 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
66 /* LEX_* are values for PL_lex_state, the state of the lexer.
67 * They are arranged oddly so that the guard on the switch statement
68 * can get by with a single comparison (if the compiler is smart enough).
71 /* #define LEX_NOTPARSING 11 is done in perl.h. */
73 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
74 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
75 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
76 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
77 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
79 /* at end of code, eg "$x" followed by: */
80 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
81 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
83 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
84 string or after \E, $foo, etc */
85 #define LEX_INTERPCONST 2 /* NOT USED */
86 #define LEX_FORMLINE 1 /* expecting a format line */
87 #define LEX_KNOWNEXT 0 /* next token known; just return it */
91 static const char* const lex_state_names[] = {
110 #include "keywords.h"
112 /* CLINE is a macro that ensures PL_copline has a sane value */
117 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
120 # define SKIPSPACE0(s) skipspace0(s)
121 # define SKIPSPACE1(s) skipspace1(s)
122 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
123 # define PEEKSPACE(s) skipspace2(s,0)
125 # define SKIPSPACE0(s) skipspace(s)
126 # define SKIPSPACE1(s) skipspace(s)
127 # define SKIPSPACE2(s,tsv) skipspace(s)
128 # define PEEKSPACE(s) skipspace(s)
132 * Convenience functions to return different tokens and prime the
133 * lexer for the next token. They all take an argument.
135 * TOKEN : generic token (used for '(', DOLSHARP, etc)
136 * OPERATOR : generic operator
137 * AOPERATOR : assignment operator
138 * PREBLOCK : beginning the block after an if, while, foreach, ...
139 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
140 * PREREF : *EXPR where EXPR is not a simple identifier
141 * TERM : expression term
142 * LOOPX : loop exiting command (goto, last, dump, etc)
143 * FTST : file test operator
144 * FUN0 : zero-argument function
145 * FUN1 : not used, except for not, which isn't a UNIOP
146 * BOop : bitwise or or xor
148 * SHop : shift operator
149 * PWop : power operator
150 * PMop : pattern-matching operator
151 * Aop : addition-level operator
152 * Mop : multiplication-level operator
153 * Eop : equality-testing operator
154 * Rop : relational operator <= != gt
156 * Also see LOP and lop() below.
159 #ifdef DEBUGGING /* Serve -DT. */
160 # define REPORT(retval) tokereport((I32)retval)
162 # define REPORT(retval) (retval)
165 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
166 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
167 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
168 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
169 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
170 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
171 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
172 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
173 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
174 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
175 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
176 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
177 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
178 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
179 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
180 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
181 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
182 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
183 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
184 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
186 /* This bit of chicanery makes a unary function followed by
187 * a parenthesis into a function with one argument, highest precedence.
188 * The UNIDOR macro is for unary functions that can be followed by the //
189 * operator (such as C<shift // 0>).
191 #define UNI2(f,x) { \
195 PL_last_uni = PL_oldbufptr; \
196 PL_last_lop_op = f; \
198 return REPORT( (int)FUNC1 ); \
200 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
202 #define UNI(f) UNI2(f,XTERM)
203 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
205 #define UNIBRACK(f) { \
208 PL_last_uni = PL_oldbufptr; \
210 return REPORT( (int)FUNC1 ); \
212 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
215 /* grandfather return to old style */
216 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
220 /* how to interpret the yylval associated with the token */
224 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
230 static struct debug_tokens {
232 enum token_type type;
234 } const debug_tokens[] =
236 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
237 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
238 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
239 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
240 { ARROW, TOKENTYPE_NONE, "ARROW" },
241 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
242 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
243 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
244 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
245 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
246 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
247 { DO, TOKENTYPE_NONE, "DO" },
248 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
249 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
250 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
251 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
252 { ELSE, TOKENTYPE_NONE, "ELSE" },
253 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
254 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
255 { FOR, TOKENTYPE_IVAL, "FOR" },
256 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
257 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
258 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
259 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
260 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
261 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
262 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
263 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
264 { IF, TOKENTYPE_IVAL, "IF" },
265 { LABEL, TOKENTYPE_PVAL, "LABEL" },
266 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
267 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
268 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
269 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
270 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
271 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
272 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
273 { MY, TOKENTYPE_IVAL, "MY" },
274 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
275 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
276 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
277 { OROP, TOKENTYPE_IVAL, "OROP" },
278 { OROR, TOKENTYPE_NONE, "OROR" },
279 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
280 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
281 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
282 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
283 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
284 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
285 { PREINC, TOKENTYPE_NONE, "PREINC" },
286 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
287 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
288 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
289 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
290 { SUB, TOKENTYPE_NONE, "SUB" },
291 { THING, TOKENTYPE_OPVAL, "THING" },
292 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
293 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
294 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
295 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
296 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
297 { USE, TOKENTYPE_IVAL, "USE" },
298 { WHEN, TOKENTYPE_IVAL, "WHEN" },
299 { WHILE, TOKENTYPE_IVAL, "WHILE" },
300 { WORD, TOKENTYPE_OPVAL, "WORD" },
301 { 0, TOKENTYPE_NONE, NULL }
304 /* dump the returned token in rv, plus any optional arg in yylval */
307 S_tokereport(pTHX_ I32 rv)
311 const char *name = NULL;
312 enum token_type type = TOKENTYPE_NONE;
313 const struct debug_tokens *p;
314 SV* const report = newSVpvs("<== ");
316 for (p = debug_tokens; p->token; p++) {
317 if (p->token == (int)rv) {
324 Perl_sv_catpv(aTHX_ report, name);
325 else if ((char)rv > ' ' && (char)rv < '~')
326 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
328 sv_catpvs(report, "EOF");
330 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
333 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
336 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
338 case TOKENTYPE_OPNUM:
339 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
340 PL_op_name[yylval.ival]);
343 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
345 case TOKENTYPE_OPVAL:
347 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
348 PL_op_name[yylval.opval->op_type]);
349 if (yylval.opval->op_type == OP_CONST) {
350 Perl_sv_catpvf(aTHX_ report, " %s",
351 SvPEEK(cSVOPx_sv(yylval.opval)));
356 sv_catpvs(report, "(opval=null)");
359 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
365 /* print the buffer with suitable escapes */
368 S_printbuf(pTHX_ const char* fmt, const char* s)
370 SV* const tmp = newSVpvs("");
371 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
380 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
381 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
385 S_ao(pTHX_ int toketype)
388 if (*PL_bufptr == '=') {
390 if (toketype == ANDAND)
391 yylval.ival = OP_ANDASSIGN;
392 else if (toketype == OROR)
393 yylval.ival = OP_ORASSIGN;
394 else if (toketype == DORDOR)
395 yylval.ival = OP_DORASSIGN;
403 * When Perl expects an operator and finds something else, no_op
404 * prints the warning. It always prints "<something> found where
405 * operator expected. It prints "Missing semicolon on previous line?"
406 * if the surprise occurs at the start of the line. "do you need to
407 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
408 * where the compiler doesn't know if foo is a method call or a function.
409 * It prints "Missing operator before end of line" if there's nothing
410 * after the missing operator, or "... before <...>" if there is something
411 * after the missing operator.
415 S_no_op(pTHX_ const char *what, char *s)
418 char * const oldbp = PL_bufptr;
419 const bool is_first = (PL_oldbufptr == PL_linestart);
425 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
426 if (ckWARN_d(WARN_SYNTAX)) {
428 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
429 "\t(Missing semicolon on previous line?)\n");
430 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
432 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
434 if (t < PL_bufptr && isSPACE(*t))
435 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
436 "\t(Do you need to predeclare %.*s?)\n",
437 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
441 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
442 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
450 * Complain about missing quote/regexp/heredoc terminator.
451 * If it's called with NULL then it cauterizes the line buffer.
452 * If we're in a delimited string and the delimiter is a control
453 * character, it's reformatted into a two-char sequence like ^C.
458 S_missingterm(pTHX_ char *s)
464 char * const nl = strrchr(s,'\n');
470 iscntrl(PL_multi_close)
472 PL_multi_close < 32 || PL_multi_close == 127
476 tmpbuf[1] = (char)toCTRL(PL_multi_close);
481 *tmpbuf = (char)PL_multi_close;
485 q = strchr(s,'"') ? '\'' : '"';
486 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
489 #define FEATURE_IS_ENABLED(name) \
490 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
491 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
493 * S_feature_is_enabled
494 * Check whether the named feature is enabled.
497 S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
500 HV * const hinthv = GvHV(PL_hintgv);
501 char he_name[32] = "feature_";
502 (void) my_strlcpy(&he_name[8], name, 24);
504 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
512 Perl_deprecate(pTHX_ const char *s)
514 if (ckWARN(WARN_DEPRECATED))
515 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
519 Perl_deprecate_old(pTHX_ const char *s)
521 /* This function should NOT be called for any new deprecated warnings */
522 /* Use Perl_deprecate instead */
524 /* It is here to maintain backward compatibility with the pre-5.8 */
525 /* warnings category hierarchy. The "deprecated" category used to */
526 /* live under the "syntax" category. It is now a top-level category */
527 /* in its own right. */
529 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
530 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
531 "Use of %s is deprecated", s);
535 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
536 * utf16-to-utf8-reversed.
539 #ifdef PERL_CR_FILTER
543 register const char *s = SvPVX_const(sv);
544 register const char * const e = s + SvCUR(sv);
545 /* outer loop optimized to do nothing if there are no CR-LFs */
547 if (*s++ == '\r' && *s == '\n') {
548 /* hit a CR-LF, need to copy the rest */
549 register char *d = s - 1;
552 if (*s == '\r' && s[1] == '\n')
563 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
565 const I32 count = FILTER_READ(idx+1, sv, maxlen);
566 if (count > 0 && !maxlen)
574 * Initialize variables. Uses the Perl save_stack to save its state (for
575 * recursive calls to the parser).
579 Perl_lex_start(pTHX_ SV *line)
585 SAVEI32(PL_lex_dojoin);
586 SAVEI32(PL_lex_brackets);
587 SAVEI32(PL_lex_casemods);
588 SAVEI32(PL_lex_starts);
589 SAVEI32(PL_lex_state);
590 SAVEVPTR(PL_lex_inpat);
591 SAVEI32(PL_lex_inwhat);
593 if (PL_lex_state == LEX_KNOWNEXT) {
594 I32 toke = PL_lasttoke;
595 while (--toke >= 0) {
596 SAVEI32(PL_nexttoke[toke].next_type);
597 SAVEVPTR(PL_nexttoke[toke].next_val);
599 SAVEVPTR(PL_nexttoke[toke].next_mad);
601 SAVEI32(PL_lasttoke);
604 SAVESPTR(PL_thistoken);
605 SAVESPTR(PL_thiswhite);
606 SAVESPTR(PL_nextwhite);
607 SAVESPTR(PL_thisopen);
608 SAVESPTR(PL_thisclose);
609 SAVESPTR(PL_thisstuff);
610 SAVEVPTR(PL_thismad);
611 SAVEI32(PL_realtokenstart);
612 SAVEI32(PL_faketokens);
614 SAVEI32(PL_curforce);
616 if (PL_lex_state == LEX_KNOWNEXT) {
617 I32 toke = PL_nexttoke;
618 while (--toke >= 0) {
619 SAVEI32(PL_nexttype[toke]);
620 SAVEVPTR(PL_nextval[toke]);
622 SAVEI32(PL_nexttoke);
625 SAVECOPLINE(PL_curcop);
628 SAVEPPTR(PL_oldbufptr);
629 SAVEPPTR(PL_oldoldbufptr);
630 SAVEPPTR(PL_last_lop);
631 SAVEPPTR(PL_last_uni);
632 SAVEPPTR(PL_linestart);
633 SAVESPTR(PL_linestr);
634 SAVEGENERICPV(PL_lex_brackstack);
635 SAVEGENERICPV(PL_lex_casestack);
636 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
637 SAVESPTR(PL_lex_stuff);
638 SAVEI32(PL_lex_defer);
639 SAVEI32(PL_sublex_info.sub_inwhat);
640 SAVESPTR(PL_lex_repl);
642 SAVEINT(PL_lex_expect);
644 PL_lex_state = LEX_NORMAL;
648 Newx(PL_lex_brackstack, 120, char);
649 Newx(PL_lex_casestack, 12, char);
651 *PL_lex_casestack = '\0';
663 PL_sublex_info.sub_inwhat = 0;
665 if (SvREADONLY(PL_linestr))
666 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
667 s = SvPV_const(PL_linestr, len);
668 if (!len || s[len-1] != ';') {
669 if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
670 PL_linestr = sv_2mortal(newSVsv(PL_linestr));
671 sv_catpvs(PL_linestr, "\n;");
673 SvTEMP_off(PL_linestr);
674 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
675 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
676 PL_last_lop = PL_last_uni = NULL;
682 * Finalizer for lexing operations. Must be called when the parser is
683 * done with the lexer.
690 PL_doextract = FALSE;
695 * This subroutine has nothing to do with tilting, whether at windmills
696 * or pinball tables. Its name is short for "increment line". It
697 * increments the current line number in CopLINE(PL_curcop) and checks
698 * to see whether the line starts with a comment of the form
699 * # line 500 "foo.pm"
700 * If so, it sets the current line number and file to the values in the comment.
704 S_incline(pTHX_ char *s)
712 CopLINE_inc(PL_curcop);
715 while (SPACE_OR_TAB(*s))
717 if (strnEQ(s, "line", 4))
721 if (SPACE_OR_TAB(*s))
725 while (SPACE_OR_TAB(*s))
733 while (SPACE_OR_TAB(*s))
735 if (*s == '"' && (t = strchr(s+1, '"'))) {
745 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
747 if (*e != '\n' && *e != '\0')
748 return; /* false alarm */
754 const char * const cf = CopFILE(PL_curcop);
755 STRLEN tmplen = cf ? strlen(cf) : 0;
756 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
757 /* must copy *{"::_<(eval N)[oldfilename:L]"}
758 * to *{"::_<newfilename"} */
759 char smallbuf[256], smallbuf2[256];
760 char *tmpbuf, *tmpbuf2;
762 STRLEN tmplen2 = strlen(s);
763 if (tmplen + 3 < sizeof smallbuf)
766 Newx(tmpbuf, tmplen + 3, char);
767 if (tmplen2 + 3 < sizeof smallbuf2)
770 Newx(tmpbuf2, tmplen2 + 3, char);
771 tmpbuf[0] = tmpbuf2[0] = '_';
772 tmpbuf[1] = tmpbuf2[1] = '<';
773 memcpy(tmpbuf + 2, cf, ++tmplen);
774 memcpy(tmpbuf2 + 2, s, ++tmplen2);
776 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
778 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
780 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
781 /* adjust ${"::_<newfilename"} to store the new file name */
782 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
783 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
784 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
786 if (tmpbuf != smallbuf) Safefree(tmpbuf);
787 if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
790 CopFILE_free(PL_curcop);
791 CopFILE_set(PL_curcop, s);
794 CopLINE_set(PL_curcop, atoi(n)-1);
798 /* skip space before PL_thistoken */
801 S_skipspace0(pTHX_ register char *s)
808 PL_thiswhite = newSVpvs("");
809 sv_catsv(PL_thiswhite, PL_skipwhite);
810 sv_free(PL_skipwhite);
813 PL_realtokenstart = s - SvPVX(PL_linestr);
817 /* skip space after PL_thistoken */
820 S_skipspace1(pTHX_ register char *s)
822 const char *start = s;
823 I32 startoff = start - SvPVX(PL_linestr);
828 start = SvPVX(PL_linestr) + startoff;
829 if (!PL_thistoken && PL_realtokenstart >= 0) {
830 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
831 PL_thistoken = newSVpvn(tstart, start - tstart);
833 PL_realtokenstart = -1;
836 PL_nextwhite = newSVpvs("");
837 sv_catsv(PL_nextwhite, PL_skipwhite);
838 sv_free(PL_skipwhite);
845 S_skipspace2(pTHX_ register char *s, SV **svp)
848 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
849 const I32 startoff = s - SvPVX(PL_linestr);
852 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
853 if (!PL_madskills || !svp)
855 start = SvPVX(PL_linestr) + startoff;
856 if (!PL_thistoken && PL_realtokenstart >= 0) {
857 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
858 PL_thistoken = newSVpvn(tstart, start - tstart);
859 PL_realtokenstart = -1;
864 sv_setsv(*svp, PL_skipwhite);
865 sv_free(PL_skipwhite);
875 * Called to gobble the appropriate amount and type of whitespace.
876 * Skips comments as well.
880 S_skipspace(pTHX_ register char *s)
885 int startoff = s - SvPVX(PL_linestr);
888 sv_free(PL_skipwhite);
893 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
894 while (s < PL_bufend && SPACE_OR_TAB(*s))
904 SSize_t oldprevlen, oldoldprevlen;
905 SSize_t oldloplen = 0, oldunilen = 0;
906 while (s < PL_bufend && isSPACE(*s)) {
907 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
912 if (s < PL_bufend && *s == '#') {
913 while (s < PL_bufend && *s != '\n')
917 if (PL_in_eval && !PL_rsfp) {
924 /* only continue to recharge the buffer if we're at the end
925 * of the buffer, we're not reading from a source filter, and
926 * we're in normal lexing mode
928 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
929 PL_lex_state == LEX_FORMLINE)
936 /* try to recharge the buffer */
938 curoff = s - SvPVX(PL_linestr);
941 if ((s = filter_gets(PL_linestr, PL_rsfp,
942 (prevlen = SvCUR(PL_linestr)))) == NULL)
945 if (PL_madskills && curoff != startoff) {
947 PL_skipwhite = newSVpvs("");
948 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
952 /* mustn't throw out old stuff yet if madpropping */
953 SvCUR(PL_linestr) = curoff;
954 s = SvPVX(PL_linestr) + curoff;
956 if (curoff && s[-1] == '\n')
960 /* end of file. Add on the -p or -n magic */
961 /* XXX these shouldn't really be added here, can't set PL_faketokens */
965 ";}continue{print or die qq(-p destination: $!\\n);}");
968 ";}continue{print or die qq(-p destination: $!\\n);}");
970 PL_minus_n = PL_minus_p = 0;
972 else if (PL_minus_n) {
974 sv_catpvn(PL_linestr, ";}", 2);
976 sv_setpvn(PL_linestr, ";}", 2);
982 sv_catpvn(PL_linestr,";", 1);
984 sv_setpvn(PL_linestr,";", 1);
987 /* reset variables for next time we lex */
988 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
994 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
995 PL_last_lop = PL_last_uni = NULL;
997 /* Close the filehandle. Could be from -P preprocessor,
998 * STDIN, or a regular file. If we were reading code from
999 * STDIN (because the commandline held no -e or filename)
1000 * then we don't close it, we reset it so the code can
1001 * read from STDIN too.
1004 if (PL_preprocess && !PL_in_eval)
1005 (void)PerlProc_pclose(PL_rsfp);
1006 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1007 PerlIO_clearerr(PL_rsfp);
1009 (void)PerlIO_close(PL_rsfp);
1014 /* not at end of file, so we only read another line */
1015 /* make corresponding updates to old pointers, for yyerror() */
1016 oldprevlen = PL_oldbufptr - PL_bufend;
1017 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1019 oldunilen = PL_last_uni - PL_bufend;
1021 oldloplen = PL_last_lop - PL_bufend;
1022 PL_linestart = PL_bufptr = s + prevlen;
1023 PL_bufend = s + SvCUR(PL_linestr);
1025 PL_oldbufptr = s + oldprevlen;
1026 PL_oldoldbufptr = s + oldoldprevlen;
1028 PL_last_uni = s + oldunilen;
1030 PL_last_lop = s + oldloplen;
1033 /* debugger active and we're not compiling the debugger code,
1034 * so store the line into the debugger's array of lines
1036 if (PERLDB_LINE && PL_curstash != PL_debstash) {
1037 SV * const sv = newSV(0);
1039 sv_upgrade(sv, SVt_PVMG);
1040 sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
1043 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
1051 PL_skipwhite = newSVpvs("");
1052 curoff = s - SvPVX(PL_linestr);
1053 if (curoff - startoff)
1054 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1063 * Check the unary operators to ensure there's no ambiguity in how they're
1064 * used. An ambiguous piece of code would be:
1066 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1067 * the +5 is its argument.
1077 if (PL_oldoldbufptr != PL_last_uni)
1079 while (isSPACE(*PL_last_uni))
1082 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1084 if ((t = strchr(s, '(')) && t < PL_bufptr)
1087 if (ckWARN_d(WARN_AMBIGUOUS)){
1088 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1089 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1090 (int)(s - PL_last_uni), PL_last_uni);
1095 * LOP : macro to build a list operator. Its behaviour has been replaced
1096 * with a subroutine, S_lop() for which LOP is just another name.
1099 #define LOP(f,x) return lop(f,x,s)
1103 * Build a list operator (or something that might be one). The rules:
1104 * - if we have a next token, then it's a list operator [why?]
1105 * - if the next thing is an opening paren, then it's a function
1106 * - else it's a list operator
1110 S_lop(pTHX_ I32 f, int x, char *s)
1117 PL_last_lop = PL_oldbufptr;
1118 PL_last_lop_op = (OPCODE)f;
1121 return REPORT(LSTOP);
1124 return REPORT(LSTOP);
1127 return REPORT(FUNC);
1130 return REPORT(FUNC);
1132 return REPORT(LSTOP);
1138 * Sets up for an eventual force_next(). start_force(0) basically does
1139 * an unshift, while start_force(-1) does a push. yylex removes items
1144 S_start_force(pTHX_ int where)
1148 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1149 where = PL_lasttoke;
1150 assert(PL_curforce < 0 || PL_curforce == where);
1151 if (PL_curforce != where) {
1152 for (i = PL_lasttoke; i > where; --i) {
1153 PL_nexttoke[i] = PL_nexttoke[i-1];
1157 if (PL_curforce < 0) /* in case of duplicate start_force() */
1158 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1159 PL_curforce = where;
1162 curmad('^', newSVpvs(""));
1163 CURMAD('_', PL_nextwhite);
1168 S_curmad(pTHX_ char slot, SV *sv)
1174 if (PL_curforce < 0)
1175 where = &PL_thismad;
1177 where = &PL_nexttoke[PL_curforce].next_mad;
1180 sv_setpvn(sv, "", 0);
1183 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1185 else if (PL_encoding) {
1186 sv_recode_to_utf8(sv, PL_encoding);
1191 /* keep a slot open for the head of the list? */
1192 if (slot != '_' && *where && (*where)->mad_key == '^') {
1193 (*where)->mad_key = slot;
1194 sv_free((*where)->mad_val);
1195 (*where)->mad_val = (void*)sv;
1198 addmad(newMADsv(slot, sv), where, 0);
1201 # define start_force(where) NOOP
1202 # define curmad(slot, sv) NOOP
1207 * When the lexer realizes it knows the next token (for instance,
1208 * it is reordering tokens for the parser) then it can call S_force_next
1209 * to know what token to return the next time the lexer is called. Caller
1210 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1211 * and possibly PL_expect to ensure the lexer handles the token correctly.
1215 S_force_next(pTHX_ I32 type)
1219 if (PL_curforce < 0)
1220 start_force(PL_lasttoke);
1221 PL_nexttoke[PL_curforce].next_type = type;
1222 if (PL_lex_state != LEX_KNOWNEXT)
1223 PL_lex_defer = PL_lex_state;
1224 PL_lex_state = LEX_KNOWNEXT;
1225 PL_lex_expect = PL_expect;
1228 PL_nexttype[PL_nexttoke] = type;
1230 if (PL_lex_state != LEX_KNOWNEXT) {
1231 PL_lex_defer = PL_lex_state;
1232 PL_lex_expect = PL_expect;
1233 PL_lex_state = LEX_KNOWNEXT;
1239 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
1242 SV * const sv = newSVpvn(start,len);
1243 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
1250 * When the lexer knows the next thing is a word (for instance, it has
1251 * just seen -> and it knows that the next char is a word char, then
1252 * it calls S_force_word to stick the next word into the PL_next lookahead.
1255 * char *start : buffer position (must be within PL_linestr)
1256 * int token : PL_next will be this type of bare word (e.g., METHOD,WORD)
1257 * int check_keyword : if true, Perl checks to make sure the word isn't
1258 * a keyword (do this if the word is a label, e.g. goto FOO)
1259 * int allow_pack : if true, : characters will also be allowed (require,
1260 * use, etc. do this)
1261 * int allow_initial_tick : used by the "sub" lexer only.
1265 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1271 start = SKIPSPACE1(start);
1273 if (isIDFIRST_lazy_if(s,UTF) ||
1274 (allow_pack && *s == ':') ||
1275 (allow_initial_tick && *s == '\'') )
1277 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1278 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1280 start_force(PL_curforce);
1282 curmad('X', newSVpvn(start,s-start));
1283 if (token == METHOD) {
1288 PL_expect = XOPERATOR;
1291 NEXTVAL_NEXTTOKE.opval
1292 = (OP*)newSVOP(OP_CONST,0,
1293 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1294 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1302 * Called when the lexer wants $foo *foo &foo etc, but the program
1303 * text only contains the "foo" portion. The first argument is a pointer
1304 * to the "foo", and the second argument is the type symbol to prefix.
1305 * Forces the next token to be a "WORD".
1306 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1310 S_force_ident(pTHX_ register const char *s, int kind)
1314 const STRLEN len = strlen(s);
1315 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1316 start_force(PL_curforce);
1317 NEXTVAL_NEXTTOKE.opval = o;
1320 o->op_private = OPpCONST_ENTERED;
1321 /* XXX see note in pp_entereval() for why we forgo typo
1322 warnings if the symbol must be introduced in an eval.
1324 gv_fetchpvn_flags(s, len,
1325 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1327 kind == '$' ? SVt_PV :
1328 kind == '@' ? SVt_PVAV :
1329 kind == '%' ? SVt_PVHV :
1337 Perl_str_to_version(pTHX_ SV *sv)
1342 const char *start = SvPV_const(sv,len);
1343 const char * const end = start + len;
1344 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1345 while (start < end) {
1349 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1354 retval += ((NV)n)/nshift;
1363 * Forces the next token to be a version number.
1364 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1365 * and if "guessing" is TRUE, then no new token is created (and the caller
1366 * must use an alternative parsing method).
1370 S_force_version(pTHX_ char *s, int guessing)
1376 I32 startoff = s - SvPVX(PL_linestr);
1385 while (isDIGIT(*d) || *d == '_' || *d == '.')
1389 start_force(PL_curforce);
1390 curmad('X', newSVpvn(s,d-s));
1393 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1395 s = scan_num(s, &yylval);
1396 version = yylval.opval;
1397 ver = cSVOPx(version)->op_sv;
1398 if (SvPOK(ver) && !SvNIOK(ver)) {
1399 SvUPGRADE(ver, SVt_PVNV);
1400 SvNV_set(ver, str_to_version(ver));
1401 SvNOK_on(ver); /* hint that it is a version */
1404 else if (guessing) {
1407 sv_free(PL_nextwhite); /* let next token collect whitespace */
1409 s = SvPVX(PL_linestr) + startoff;
1417 if (PL_madskills && !version) {
1418 sv_free(PL_nextwhite); /* let next token collect whitespace */
1420 s = SvPVX(PL_linestr) + startoff;
1423 /* NOTE: The parser sees the package name and the VERSION swapped */
1424 start_force(PL_curforce);
1425 NEXTVAL_NEXTTOKE.opval = version;
1433 * Tokenize a quoted string passed in as an SV. It finds the next
1434 * chunk, up to end of string or a backslash. It may make a new
1435 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1440 S_tokeq(pTHX_ SV *sv)
1444 register char *send;
1452 s = SvPV_force(sv, len);
1453 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1456 while (s < send && *s != '\\')
1461 if ( PL_hints & HINT_NEW_STRING ) {
1462 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1468 if (s + 1 < send && (s[1] == '\\'))
1469 s++; /* all that, just for this */
1474 SvCUR_set(sv, d - SvPVX_const(sv));
1476 if ( PL_hints & HINT_NEW_STRING )
1477 return new_constant(NULL, 0, "q", sv, pv, "q");
1482 * Now come three functions related to double-quote context,
1483 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1484 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1485 * interact with PL_lex_state, and create fake ( ... ) argument lists
1486 * to handle functions and concatenation.
1487 * They assume that whoever calls them will be setting up a fake
1488 * join call, because each subthing puts a ',' after it. This lets
1491 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1493 * (I'm not sure whether the spurious commas at the end of lcfirst's
1494 * arguments and join's arguments are created or not).
1499 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1501 * Pattern matching will set PL_lex_op to the pattern-matching op to
1502 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1504 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1506 * Everything else becomes a FUNC.
1508 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1509 * had an OP_CONST or OP_READLINE). This just sets us up for a
1510 * call to S_sublex_push().
1514 S_sublex_start(pTHX)
1517 register const I32 op_type = yylval.ival;
1519 if (op_type == OP_NULL) {
1520 yylval.opval = PL_lex_op;
1524 if (op_type == OP_CONST || op_type == OP_READLINE) {
1525 SV *sv = tokeq(PL_lex_stuff);
1527 if (SvTYPE(sv) == SVt_PVIV) {
1528 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1530 const char * const p = SvPV_const(sv, len);
1531 SV * const nsv = newSVpvn(p, len);
1537 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1538 PL_lex_stuff = NULL;
1539 /* Allow <FH> // "foo" */
1540 if (op_type == OP_READLINE)
1541 PL_expect = XTERMORDORDOR;
1545 PL_sublex_info.super_state = PL_lex_state;
1546 PL_sublex_info.sub_inwhat = op_type;
1547 PL_sublex_info.sub_op = PL_lex_op;
1548 PL_lex_state = LEX_INTERPPUSH;
1552 yylval.opval = PL_lex_op;
1562 * Create a new scope to save the lexing state. The scope will be
1563 * ended in S_sublex_done. Returns a '(', starting the function arguments
1564 * to the uc, lc, etc. found before.
1565 * Sets PL_lex_state to LEX_INTERPCONCAT.
1574 PL_lex_state = PL_sublex_info.super_state;
1575 SAVEI32(PL_lex_dojoin);
1576 SAVEI32(PL_lex_brackets);
1577 SAVEI32(PL_lex_casemods);
1578 SAVEI32(PL_lex_starts);
1579 SAVEI32(PL_lex_state);
1580 SAVEVPTR(PL_lex_inpat);
1581 SAVEI32(PL_lex_inwhat);
1582 SAVECOPLINE(PL_curcop);
1583 SAVEPPTR(PL_bufptr);
1584 SAVEPPTR(PL_bufend);
1585 SAVEPPTR(PL_oldbufptr);
1586 SAVEPPTR(PL_oldoldbufptr);
1587 SAVEPPTR(PL_last_lop);
1588 SAVEPPTR(PL_last_uni);
1589 SAVEPPTR(PL_linestart);
1590 SAVESPTR(PL_linestr);
1591 SAVEGENERICPV(PL_lex_brackstack);
1592 SAVEGENERICPV(PL_lex_casestack);
1594 PL_linestr = PL_lex_stuff;
1595 PL_lex_stuff = NULL;
1597 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1598 = SvPVX(PL_linestr);
1599 PL_bufend += SvCUR(PL_linestr);
1600 PL_last_lop = PL_last_uni = NULL;
1601 SAVEFREESV(PL_linestr);
1603 PL_lex_dojoin = FALSE;
1604 PL_lex_brackets = 0;
1605 Newx(PL_lex_brackstack, 120, char);
1606 Newx(PL_lex_casestack, 12, char);
1607 PL_lex_casemods = 0;
1608 *PL_lex_casestack = '\0';
1610 PL_lex_state = LEX_INTERPCONCAT;
1611 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1613 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1614 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1615 PL_lex_inpat = PL_sublex_info.sub_op;
1617 PL_lex_inpat = NULL;
1624 * Restores lexer state after a S_sublex_push.
1631 if (!PL_lex_starts++) {
1632 SV * const sv = newSVpvs("");
1633 if (SvUTF8(PL_linestr))
1635 PL_expect = XOPERATOR;
1636 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1640 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1641 PL_lex_state = LEX_INTERPCASEMOD;
1645 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1646 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1647 PL_linestr = PL_lex_repl;
1649 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1650 PL_bufend += SvCUR(PL_linestr);
1651 PL_last_lop = PL_last_uni = NULL;
1652 SAVEFREESV(PL_linestr);
1653 PL_lex_dojoin = FALSE;
1654 PL_lex_brackets = 0;
1655 PL_lex_casemods = 0;
1656 *PL_lex_casestack = '\0';
1658 if (SvEVALED(PL_lex_repl)) {
1659 PL_lex_state = LEX_INTERPNORMAL;
1661 /* we don't clear PL_lex_repl here, so that we can check later
1662 whether this is an evalled subst; that means we rely on the
1663 logic to ensure sublex_done() is called again only via the
1664 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1667 PL_lex_state = LEX_INTERPCONCAT;
1677 PL_endwhite = newSVpvs("");
1678 sv_catsv(PL_endwhite, PL_thiswhite);
1682 sv_setpvn(PL_thistoken,"",0);
1684 PL_realtokenstart = -1;
1688 PL_bufend = SvPVX(PL_linestr);
1689 PL_bufend += SvCUR(PL_linestr);
1690 PL_expect = XOPERATOR;
1691 PL_sublex_info.sub_inwhat = 0;
1699 Extracts a pattern, double-quoted string, or transliteration. This
1702 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1703 processing a pattern (PL_lex_inpat is true), a transliteration
1704 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1706 Returns a pointer to the character scanned up to. If this is
1707 advanced from the start pointer supplied (i.e. if anything was
1708 successfully parsed), will leave an OP for the substring scanned
1709 in yylval. Caller must intuit reason for not parsing further
1710 by looking at the next characters herself.
1714 double-quoted style: \r and \n
1715 regexp special ones: \D \s
1718 case and quoting: \U \Q \E
1719 stops on @ and $, but not for $ as tail anchor
1721 In transliterations:
1722 characters are VERY literal, except for - not at the start or end
1723 of the string, which indicates a range. If the range is in bytes,
1724 scan_const expands the range to the full set of intermediate
1725 characters. If the range is in utf8, the hyphen is replaced with
1726 a certain range mark which will be handled by pmtrans() in op.c.
1728 In double-quoted strings:
1730 double-quoted style: \r and \n
1732 deprecated backrefs: \1 (in substitution replacements)
1733 case and quoting: \U \Q \E
1736 scan_const does *not* construct ops to handle interpolated strings.
1737 It stops processing as soon as it finds an embedded $ or @ variable
1738 and leaves it to the caller to work out what's going on.
1740 embedded arrays (whether in pattern or not) could be:
1741 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1743 $ in double-quoted strings must be the symbol of an embedded scalar.
1745 $ in pattern could be $foo or could be tail anchor. Assumption:
1746 it's a tail anchor if $ is the last thing in the string, or if it's
1747 followed by one of "()| \r\n\t"
1749 \1 (backreferences) are turned into $1
1751 The structure of the code is
1752 while (there's a character to process) {
1753 handle transliteration ranges
1754 skip regexp comments /(?#comment)/ and codes /(?{code})/
1755 skip #-initiated comments in //x patterns
1756 check for embedded arrays
1757 check for embedded scalars
1759 leave intact backslashes from leaveit (below)
1760 deprecate \1 in substitution replacements
1761 handle string-changing backslashes \l \U \Q \E, etc.
1762 switch (what was escaped) {
1763 handle \- in a transliteration (becomes a literal -)
1764 handle \132 (octal characters)
1765 handle \x15 and \x{1234} (hex characters)
1766 handle \N{name} (named characters)
1767 handle \cV (control characters)
1768 handle printf-style backslashes (\f, \r, \n, etc)
1770 } (end if backslash)
1771 } (end while character to read)
1776 S_scan_const(pTHX_ char *start)
1779 register char *send = PL_bufend; /* end of the constant */
1780 SV *sv = newSV(send - start); /* sv for the constant */
1781 register char *s = start; /* start of the constant */
1782 register char *d = SvPVX(sv); /* destination for copies */
1783 bool dorange = FALSE; /* are we in a translit range? */
1784 bool didrange = FALSE; /* did we just finish a range? */
1785 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1786 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1789 UV literal_endpoint = 0;
1790 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1793 const char * const leaveit = /* set of acceptably-backslashed characters */
1796 ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-Nnrktfeaxcz0123456789[{]} \t\n\r\f\v#"
1799 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1800 /* If we are doing a trans and we know we want UTF8 set expectation */
1801 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1802 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1806 while (s < send || dorange) {
1807 /* get transliterations out of the way (they're most literal) */
1808 if (PL_lex_inwhat == OP_TRANS) {
1809 /* expand a range A-Z to the full set of characters. AIE! */
1811 I32 i; /* current expanded character */
1812 I32 min; /* first character in range */
1813 I32 max; /* last character in range */
1824 char * const c = (char*)utf8_hop((U8*)d, -1);
1828 *c = (char)UTF_TO_NATIVE(0xff);
1829 /* mark the range as done, and continue */
1835 i = d - SvPVX_const(sv); /* remember current offset */
1838 SvLEN(sv) + (has_utf8 ?
1839 (512 - UTF_CONTINUATION_MARK +
1842 /* How many two-byte within 0..255: 128 in UTF-8,
1843 * 96 in UTF-8-mod. */
1845 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1847 d = SvPVX(sv) + i; /* refresh d after realloc */
1851 for (j = 0; j <= 1; j++) {
1852 char * const c = (char*)utf8_hop((U8*)d, -1);
1853 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
1859 max = (U8)0xff; /* only to \xff */
1860 uvmax = uv; /* \x{100} to uvmax */
1862 d = c; /* eat endpoint chars */
1867 d -= 2; /* eat the first char and the - */
1868 min = (U8)*d; /* first char in range */
1869 max = (U8)d[1]; /* last char in range */
1876 "Invalid range \"%c-%c\" in transliteration operator",
1877 (char)min, (char)max);
1881 if (literal_endpoint == 2 &&
1882 ((isLOWER(min) && isLOWER(max)) ||
1883 (isUPPER(min) && isUPPER(max)))) {
1885 for (i = min; i <= max; i++)
1887 *d++ = NATIVE_TO_NEED(has_utf8,i);
1889 for (i = min; i <= max; i++)
1891 *d++ = NATIVE_TO_NEED(has_utf8,i);
1896 for (i = min; i <= max; i++)
1899 const U8 ch = (U8)NATIVE_TO_UTF(i);
1900 if (UNI_IS_INVARIANT(ch))
1903 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
1904 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
1913 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
1915 *d++ = (char)UTF_TO_NATIVE(0xff);
1917 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
1921 /* mark the range as done, and continue */
1925 literal_endpoint = 0;
1930 /* range begins (ignore - as first or last char) */
1931 else if (*s == '-' && s+1 < send && s != start) {
1933 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1940 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1950 literal_endpoint = 0;
1951 native_range = TRUE;
1956 /* if we get here, we're not doing a transliteration */
1958 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1959 except for the last char, which will be done separately. */
1960 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1962 while (s+1 < send && *s != ')')
1963 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1965 else if (s[2] == '{' /* This should match regcomp.c */
1966 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1969 char *regparse = s + (s[2] == '{' ? 3 : 4);
1972 while (count && (c = *regparse)) {
1973 if (c == '\\' && regparse[1])
1981 if (*regparse != ')')
1982 regparse--; /* Leave one char for continuation. */
1983 while (s < regparse)
1984 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1988 /* likewise skip #-initiated comments in //x patterns */
1989 else if (*s == '#' && PL_lex_inpat &&
1990 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1991 while (s+1 < send && *s != '\n')
1992 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1995 /* check for embedded arrays
1996 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1998 else if (*s == '@' && s[1]) {
1999 if (isALNUM_lazy_if(s+1,UTF))
2001 if (strchr(":'{$", s[1]))
2003 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2004 break; /* in regexp, neither @+ nor @- are interpolated */
2007 /* check for embedded scalars. only stop if we're sure it's a
2010 else if (*s == '$') {
2011 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2013 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
2014 break; /* in regexp, $ might be tail anchor */
2017 /* End of else if chain - OP_TRANS rejoin rest */
2020 if (*s == '\\' && s+1 < send) {
2023 /* some backslashes we leave behind */
2024 if (*leaveit && *s && strchr(leaveit, *s)) {
2025 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2026 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2030 /* deprecate \1 in strings and substitution replacements */
2031 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2032 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2034 if (ckWARN(WARN_SYNTAX))
2035 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2040 /* string-change backslash escapes */
2041 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2046 /* if we get here, it's either a quoted -, or a digit */
2049 /* quoted - in transliterations */
2051 if (PL_lex_inwhat == OP_TRANS) {
2058 if ((isALPHA(*s) || isDIGIT(*s)) &&
2060 Perl_warner(aTHX_ packWARN(WARN_MISC),
2061 "Unrecognized escape \\%c passed through",
2063 /* default action is to copy the quoted character */
2064 goto default_action;
2067 /* \132 indicates an octal constant */
2068 case '0': case '1': case '2': case '3':
2069 case '4': case '5': case '6': case '7':
2073 uv = grok_oct(s, &len, &flags, NULL);
2076 goto NUM_ESCAPE_INSERT;
2078 /* \x24 indicates a hex constant */
2082 char* const e = strchr(s, '}');
2083 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2084 PERL_SCAN_DISALLOW_PREFIX;
2089 yyerror("Missing right brace on \\x{}");
2093 uv = grok_hex(s, &len, &flags, NULL);
2099 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2100 uv = grok_hex(s, &len, &flags, NULL);
2106 /* Insert oct or hex escaped character.
2107 * There will always enough room in sv since such
2108 * escapes will be longer than any UTF-8 sequence
2109 * they can end up as. */
2111 /* We need to map to chars to ASCII before doing the tests
2114 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2115 if (!has_utf8 && uv > 255) {
2116 /* Might need to recode whatever we have
2117 * accumulated so far if it contains any
2120 * (Can't we keep track of that and avoid
2121 * this rescan? --jhi)
2125 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2126 if (!NATIVE_IS_INVARIANT(*c)) {
2131 const STRLEN offset = d - SvPVX_const(sv);
2133 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2137 while (src >= (const U8 *)SvPVX_const(sv)) {
2138 if (!NATIVE_IS_INVARIANT(*src)) {
2139 const U8 ch = NATIVE_TO_ASCII(*src);
2140 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2141 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2151 if (has_utf8 || uv > 255) {
2152 d = (char*)uvchr_to_utf8((U8*)d, uv);
2154 if (PL_lex_inwhat == OP_TRANS &&
2155 PL_sublex_info.sub_op) {
2156 PL_sublex_info.sub_op->op_private |=
2157 (PL_lex_repl ? OPpTRANS_FROM_UTF
2161 if (uv > 255 && !dorange)
2162 native_range = FALSE;
2174 /* \N{LATIN SMALL LETTER A} is a named character */
2178 char* e = strchr(s, '}');
2185 yyerror("Missing right brace on \\N{}");
2189 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2191 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2192 PERL_SCAN_DISALLOW_PREFIX;
2195 uv = grok_hex(s, &len, &flags, NULL);
2196 if ( e > s && len != (STRLEN)(e - s) ) {
2200 goto NUM_ESCAPE_INSERT;
2202 res = newSVpvn(s + 1, e - s - 1);
2203 type = newSVpvn(s - 2,e - s + 3);
2204 res = new_constant( NULL, 0, "charnames",
2205 res, NULL, SvPVX(type) );
2208 sv_utf8_upgrade(res);
2209 str = SvPV_const(res,len);
2210 #ifdef EBCDIC_NEVER_MIND
2211 /* charnames uses pack U and that has been
2212 * recently changed to do the below uni->native
2213 * mapping, so this would be redundant (and wrong,
2214 * the code point would be doubly converted).
2215 * But leave this in just in case the pack U change
2216 * gets revoked, but the semantics is still
2217 * desireable for charnames. --jhi */
2219 UV uv = utf8_to_uvchr((const U8*)str, 0);
2222 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2224 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2225 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2226 str = SvPV_const(res, len);
2230 if (!has_utf8 && SvUTF8(res)) {
2231 const char * const ostart = SvPVX_const(sv);
2232 SvCUR_set(sv, d - ostart);
2235 sv_utf8_upgrade(sv);
2236 /* this just broke our allocation above... */
2237 SvGROW(sv, (STRLEN)(send - start));
2238 d = SvPVX(sv) + SvCUR(sv);
2241 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2242 const char * const odest = SvPVX_const(sv);
2244 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2245 d = SvPVX(sv) + (d - odest);
2249 native_range = FALSE; /* \N{} is guessed to be Unicode */
2251 Copy(str, d, len, char);
2258 yyerror("Missing braces on \\N{}");
2261 /* \c is a control character */
2270 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2273 yyerror("Missing control char name in \\c");
2277 /* printf-style backslashes, formfeeds, newlines, etc */
2279 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2282 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2285 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2288 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2291 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2294 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2297 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2303 } /* end if (backslash) */
2310 /* If we started with encoded form, or already know we want it
2311 and then encode the next character */
2312 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2314 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2315 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2318 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2319 const STRLEN off = d - SvPVX_const(sv);
2320 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2322 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2325 if (uv > 255 && !dorange)
2326 native_range = FALSE;
2330 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2332 } /* while loop to process each character */
2334 /* terminate the string and set up the sv */
2336 SvCUR_set(sv, d - SvPVX_const(sv));
2337 if (SvCUR(sv) >= SvLEN(sv))
2338 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2341 if (PL_encoding && !has_utf8) {
2342 sv_recode_to_utf8(sv, PL_encoding);
2348 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2349 PL_sublex_info.sub_op->op_private |=
2350 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2354 /* shrink the sv if we allocated more than we used */
2355 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2356 SvPV_shrink_to_cur(sv);
2359 /* return the substring (via yylval) only if we parsed anything */
2360 if (s > PL_bufptr) {
2361 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2362 sv = new_constant(start, s - start,
2363 (const char *)(PL_lex_inpat ? "qr" : "q"),
2366 (( PL_lex_inwhat == OP_TRANS
2368 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2371 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2378 * Returns TRUE if there's more to the expression (e.g., a subscript),
2381 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2383 * ->[ and ->{ return TRUE
2384 * { and [ outside a pattern are always subscripts, so return TRUE
2385 * if we're outside a pattern and it's not { or [, then return FALSE
2386 * if we're in a pattern and the first char is a {
2387 * {4,5} (any digits around the comma) returns FALSE
2388 * if we're in a pattern and the first char is a [
2390 * [SOMETHING] has a funky algorithm to decide whether it's a
2391 * character class or not. It has to deal with things like
2392 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2393 * anything else returns TRUE
2396 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2399 S_intuit_more(pTHX_ register char *s)
2402 if (PL_lex_brackets)
2404 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2406 if (*s != '{' && *s != '[')
2411 /* In a pattern, so maybe we have {n,m}. */
2428 /* On the other hand, maybe we have a character class */
2431 if (*s == ']' || *s == '^')
2434 /* this is terrifying, and it works */
2435 int weight = 2; /* let's weigh the evidence */
2437 unsigned char un_char = 255, last_un_char;
2438 const char * const send = strchr(s,']');
2439 char tmpbuf[sizeof PL_tokenbuf * 4];
2441 if (!send) /* has to be an expression */
2444 Zero(seen,256,char);
2447 else if (isDIGIT(*s)) {
2449 if (isDIGIT(s[1]) && s[2] == ']')
2455 for (; s < send; s++) {
2456 last_un_char = un_char;
2457 un_char = (unsigned char)*s;
2462 weight -= seen[un_char] * 10;
2463 if (isALNUM_lazy_if(s+1,UTF)) {
2465 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2466 len = (int)strlen(tmpbuf);
2467 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2472 else if (*s == '$' && s[1] &&
2473 strchr("[#!%*<>()-=",s[1])) {
2474 if (/*{*/ strchr("])} =",s[2]))
2483 if (strchr("wds]",s[1]))
2485 else if (seen[(U8)'\''] || seen[(U8)'"'])
2487 else if (strchr("rnftbxcav",s[1]))
2489 else if (isDIGIT(s[1])) {
2491 while (s[1] && isDIGIT(s[1]))
2501 if (strchr("aA01! ",last_un_char))
2503 if (strchr("zZ79~",s[1]))
2505 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2506 weight -= 5; /* cope with negative subscript */
2509 if (!isALNUM(last_un_char)
2510 && !(last_un_char == '$' || last_un_char == '@'
2511 || last_un_char == '&')
2512 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2517 if (keyword(tmpbuf, d - tmpbuf, 0))
2520 if (un_char == last_un_char + 1)
2522 weight -= seen[un_char];
2527 if (weight >= 0) /* probably a character class */
2537 * Does all the checking to disambiguate
2539 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2540 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2542 * First argument is the stuff after the first token, e.g. "bar".
2544 * Not a method if bar is a filehandle.
2545 * Not a method if foo is a subroutine prototyped to take a filehandle.
2546 * Not a method if it's really "Foo $bar"
2547 * Method if it's "foo $bar"
2548 * Not a method if it's really "print foo $bar"
2549 * Method if it's really "foo package::" (interpreted as package->foo)
2550 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2551 * Not a method if bar is a filehandle or package, but is quoted with
2556 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2559 char *s = start + (*start == '$');
2560 char tmpbuf[sizeof PL_tokenbuf];
2568 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2572 const char *proto = SvPVX_const(cv);
2583 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2584 /* start is the beginning of the possible filehandle/object,
2585 * and s is the end of it
2586 * tmpbuf is a copy of it
2589 if (*start == '$') {
2590 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2593 len = start - SvPVX(PL_linestr);
2597 start = SvPVX(PL_linestr) + len;
2601 return *s == '(' ? FUNCMETH : METHOD;
2603 if (!keyword(tmpbuf, len, 0)) {
2604 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2608 soff = s - SvPVX(PL_linestr);
2612 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2613 if (indirgv && GvCVu(indirgv))
2615 /* filehandle or package name makes it a method */
2616 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2618 soff = s - SvPVX(PL_linestr);
2621 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2622 return 0; /* no assumptions -- "=>" quotes bearword */
2624 start_force(PL_curforce);
2625 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2626 newSVpvn(tmpbuf,len));
2627 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2629 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2634 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2636 return *s == '(' ? FUNCMETH : METHOD;
2644 * Return a string of Perl code to load the debugger. If PERL5DB
2645 * is set, it will return the contents of that, otherwise a
2646 * compile-time require of perl5db.pl.
2654 const char * const pdb = PerlEnv_getenv("PERL5DB");
2658 SETERRNO(0,SS_NORMAL);
2659 return "BEGIN { require 'perl5db.pl' }";
2665 /* Encoded script support. filter_add() effectively inserts a
2666 * 'pre-processing' function into the current source input stream.
2667 * Note that the filter function only applies to the current source file
2668 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2670 * The datasv parameter (which may be NULL) can be used to pass
2671 * private data to this instance of the filter. The filter function
2672 * can recover the SV using the FILTER_DATA macro and use it to
2673 * store private buffers and state information.
2675 * The supplied datasv parameter is upgraded to a PVIO type
2676 * and the IoDIRP/IoANY field is used to store the function pointer,
2677 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2678 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2679 * private use must be set using malloc'd pointers.
2683 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2689 if (!PL_rsfp_filters)
2690 PL_rsfp_filters = newAV();
2693 SvUPGRADE(datasv, SVt_PVIO);
2694 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2695 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2696 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2697 FPTR2DPTR(void *, IoANY(datasv)),
2698 SvPV_nolen(datasv)));
2699 av_unshift(PL_rsfp_filters, 1);
2700 av_store(PL_rsfp_filters, 0, datasv) ;
2705 /* Delete most recently added instance of this filter function. */
2707 Perl_filter_del(pTHX_ filter_t funcp)
2713 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2714 FPTR2DPTR(void*, funcp)));
2716 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2718 /* if filter is on top of stack (usual case) just pop it off */
2719 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2720 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2721 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2722 IoANY(datasv) = (void *)NULL;
2723 sv_free(av_pop(PL_rsfp_filters));
2727 /* we need to search for the correct entry and clear it */
2728 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2732 /* Invoke the idxth filter function for the current rsfp. */
2733 /* maxlen 0 = read one text line */
2735 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2740 /* This API is bad. It should have been using unsigned int for maxlen.
2741 Not sure if we want to change the API, but if not we should sanity
2742 check the value here. */
2743 const unsigned int correct_length
2752 if (!PL_rsfp_filters)
2754 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2755 /* Provide a default input filter to make life easy. */
2756 /* Note that we append to the line. This is handy. */
2757 DEBUG_P(PerlIO_printf(Perl_debug_log,
2758 "filter_read %d: from rsfp\n", idx));
2759 if (correct_length) {
2762 const int old_len = SvCUR(buf_sv);
2764 /* ensure buf_sv is large enough */
2765 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2766 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2767 correct_length)) <= 0) {
2768 if (PerlIO_error(PL_rsfp))
2769 return -1; /* error */
2771 return 0 ; /* end of file */
2773 SvCUR_set(buf_sv, old_len + len) ;
2776 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2777 if (PerlIO_error(PL_rsfp))
2778 return -1; /* error */
2780 return 0 ; /* end of file */
2783 return SvCUR(buf_sv);
2785 /* Skip this filter slot if filter has been deleted */
2786 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2787 DEBUG_P(PerlIO_printf(Perl_debug_log,
2788 "filter_read %d: skipped (filter deleted)\n",
2790 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2792 /* Get function pointer hidden within datasv */
2793 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2794 DEBUG_P(PerlIO_printf(Perl_debug_log,
2795 "filter_read %d: via function %p (%s)\n",
2796 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2797 /* Call function. The function is expected to */
2798 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2799 /* Return: <0:error, =0:eof, >0:not eof */
2800 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2804 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2807 #ifdef PERL_CR_FILTER
2808 if (!PL_rsfp_filters) {
2809 filter_add(S_cr_textfilter,NULL);
2812 if (PL_rsfp_filters) {
2814 SvCUR_set(sv, 0); /* start with empty line */
2815 if (FILTER_READ(0, sv, 0) > 0)
2816 return ( SvPVX(sv) ) ;
2821 return (sv_gets(sv, fp, append));
2825 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2830 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2834 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2835 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2837 return GvHV(gv); /* Foo:: */
2840 /* use constant CLASS => 'MyClass' */
2841 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
2842 if (gv && GvCV(gv)) {
2843 SV * const sv = cv_const_sv(GvCV(gv));
2845 pkgname = SvPV_nolen_const(sv);
2848 return gv_stashpv(pkgname, FALSE);
2854 * The intent of this yylex wrapper is to minimize the changes to the
2855 * tokener when we aren't interested in collecting madprops. It remains
2856 * to be seen how successful this strategy will be...
2863 char *s = PL_bufptr;
2865 /* make sure PL_thiswhite is initialized */
2869 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2870 if (PL_pending_ident)
2871 return S_pending_ident(aTHX);
2873 /* previous token ate up our whitespace? */
2874 if (!PL_lasttoke && PL_nextwhite) {
2875 PL_thiswhite = PL_nextwhite;
2879 /* isolate the token, and figure out where it is without whitespace */
2880 PL_realtokenstart = -1;
2884 assert(PL_curforce < 0);
2886 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
2887 if (!PL_thistoken) {
2888 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
2889 PL_thistoken = newSVpvs("");
2891 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
2892 PL_thistoken = newSVpvn(tstart, s - tstart);
2895 if (PL_thismad) /* install head */
2896 CURMAD('X', PL_thistoken);
2899 /* last whitespace of a sublex? */
2900 if (optype == ')' && PL_endwhite) {
2901 CURMAD('X', PL_endwhite);
2906 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
2907 if (!PL_thiswhite && !PL_endwhite && !optype) {
2908 sv_free(PL_thistoken);
2913 /* put off final whitespace till peg */
2914 if (optype == ';' && !PL_rsfp) {
2915 PL_nextwhite = PL_thiswhite;
2918 else if (PL_thisopen) {
2919 CURMAD('q', PL_thisopen);
2921 sv_free(PL_thistoken);
2925 /* Store actual token text as madprop X */
2926 CURMAD('X', PL_thistoken);
2930 /* add preceding whitespace as madprop _ */
2931 CURMAD('_', PL_thiswhite);
2935 /* add quoted material as madprop = */
2936 CURMAD('=', PL_thisstuff);
2940 /* add terminating quote as madprop Q */
2941 CURMAD('Q', PL_thisclose);
2945 /* special processing based on optype */
2949 /* opval doesn't need a TOKEN since it can already store mp */
2960 append_madprops(PL_thismad, yylval.opval, 0);
2968 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
2977 /* remember any fake bracket that lexer is about to discard */
2978 if (PL_lex_brackets == 1 &&
2979 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
2982 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2985 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
2986 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
2989 break; /* don't bother looking for trailing comment */
2998 /* attach a trailing comment to its statement instead of next token */
3002 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3004 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3006 if (*s == '\n' || *s == '#') {
3007 while (s < PL_bufend && *s != '\n')
3011 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3012 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3029 /* Create new token struct. Note: opvals return early above. */
3030 yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
3037 S_tokenize_use(pTHX_ int is_use, char *s) {
3039 if (PL_expect != XSTATE)
3040 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3041 is_use ? "use" : "no"));
3043 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3044 s = force_version(s, TRUE);
3045 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3046 start_force(PL_curforce);
3047 NEXTVAL_NEXTTOKE.opval = NULL;
3050 else if (*s == 'v') {
3051 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3052 s = force_version(s, FALSE);
3056 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3057 s = force_version(s, FALSE);
3059 yylval.ival = is_use;
3063 static const char* const exp_name[] =
3064 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3065 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3072 Works out what to call the token just pulled out of the input
3073 stream. The yacc parser takes care of taking the ops we return and
3074 stitching them into a tree.
3080 if read an identifier
3081 if we're in a my declaration
3082 croak if they tried to say my($foo::bar)
3083 build the ops for a my() declaration
3084 if it's an access to a my() variable
3085 are we in a sort block?
3086 croak if my($a); $a <=> $b
3087 build ops for access to a my() variable
3088 if in a dq string, and they've said @foo and we can't find @foo
3090 build ops for a bareword
3091 if we already built the token before, use it.
3096 #pragma segment Perl_yylex
3102 register char *s = PL_bufptr;
3107 /* orig_keyword, gvp, and gv are initialized here because
3108 * jump to the label just_a_word_zero can bypass their
3109 * initialization later. */
3110 I32 orig_keyword = 0;
3115 SV* tmp = newSVpvs("");
3116 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3117 (IV)CopLINE(PL_curcop),
3118 lex_state_names[PL_lex_state],
3119 exp_name[PL_expect],
3120 pv_display(tmp, s, strlen(s), 0, 60));
3123 /* check if there's an identifier for us to look at */
3124 if (PL_pending_ident)
3125 return REPORT(S_pending_ident(aTHX));
3127 /* no identifier pending identification */
3129 switch (PL_lex_state) {
3131 case LEX_NORMAL: /* Some compilers will produce faster */
3132 case LEX_INTERPNORMAL: /* code if we comment these out. */
3136 /* when we've already built the next token, just pull it out of the queue */
3140 yylval = PL_nexttoke[PL_lasttoke].next_val;
3142 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3143 PL_nexttoke[PL_lasttoke].next_mad = 0;
3144 if (PL_thismad && PL_thismad->mad_key == '_') {
3145 PL_thiswhite = (SV*)PL_thismad->mad_val;
3146 PL_thismad->mad_val = 0;
3147 mad_free(PL_thismad);
3152 PL_lex_state = PL_lex_defer;
3153 PL_expect = PL_lex_expect;
3154 PL_lex_defer = LEX_NORMAL;
3155 if (!PL_nexttoke[PL_lasttoke].next_type)
3160 yylval = PL_nextval[PL_nexttoke];
3162 PL_lex_state = PL_lex_defer;
3163 PL_expect = PL_lex_expect;
3164 PL_lex_defer = LEX_NORMAL;
3168 /* FIXME - can these be merged? */
3169 return(PL_nexttoke[PL_lasttoke].next_type);
3171 return REPORT(PL_nexttype[PL_nexttoke]);
3174 /* interpolated case modifiers like \L \U, including \Q and \E.
3175 when we get here, PL_bufptr is at the \
3177 case LEX_INTERPCASEMOD:
3179 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3180 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3182 /* handle \E or end of string */
3183 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3185 if (PL_lex_casemods) {
3186 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3187 PL_lex_casestack[PL_lex_casemods] = '\0';
3189 if (PL_bufptr != PL_bufend
3190 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3192 PL_lex_state = LEX_INTERPCONCAT;
3195 PL_thistoken = newSVpvs("\\E");
3201 while (PL_bufptr != PL_bufend &&
3202 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3204 PL_thiswhite = newSVpvs("");
3205 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3209 if (PL_bufptr != PL_bufend)
3212 PL_lex_state = LEX_INTERPCONCAT;
3216 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3217 "### Saw case modifier\n"); });
3219 if (s[1] == '\\' && s[2] == 'E') {
3222 PL_thiswhite = newSVpvs("");
3223 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3226 PL_lex_state = LEX_INTERPCONCAT;
3231 if (!PL_madskills) /* when just compiling don't need correct */
3232 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3233 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3234 if ((*s == 'L' || *s == 'U') &&
3235 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3236 PL_lex_casestack[--PL_lex_casemods] = '\0';
3239 if (PL_lex_casemods > 10)
3240 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3241 PL_lex_casestack[PL_lex_casemods++] = *s;
3242 PL_lex_casestack[PL_lex_casemods] = '\0';
3243 PL_lex_state = LEX_INTERPCONCAT;
3244 start_force(PL_curforce);
3245 NEXTVAL_NEXTTOKE.ival = 0;
3247 start_force(PL_curforce);
3249 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3251 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3253 NEXTVAL_NEXTTOKE.ival = OP_LC;
3255 NEXTVAL_NEXTTOKE.ival = OP_UC;
3257 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3259 Perl_croak(aTHX_ "panic: yylex");
3261 SV* const tmpsv = newSVpvs("");
3262 Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3268 if (PL_lex_starts) {
3274 sv_free(PL_thistoken);
3275 PL_thistoken = newSVpvs("");
3278 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3279 if (PL_lex_casemods == 1 && PL_lex_inpat)
3288 case LEX_INTERPPUSH:
3289 return REPORT(sublex_push());
3291 case LEX_INTERPSTART:
3292 if (PL_bufptr == PL_bufend)
3293 return REPORT(sublex_done());
3294 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3295 "### Interpolated variable\n"); });
3297 PL_lex_dojoin = (*PL_bufptr == '@');
3298 PL_lex_state = LEX_INTERPNORMAL;
3299 if (PL_lex_dojoin) {
3300 start_force(PL_curforce);
3301 NEXTVAL_NEXTTOKE.ival = 0;
3303 start_force(PL_curforce);
3304 force_ident("\"", '$');
3305 start_force(PL_curforce);
3306 NEXTVAL_NEXTTOKE.ival = 0;
3308 start_force(PL_curforce);
3309 NEXTVAL_NEXTTOKE.ival = 0;
3311 start_force(PL_curforce);
3312 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3315 if (PL_lex_starts++) {
3320 sv_free(PL_thistoken);
3321 PL_thistoken = newSVpvs("");
3324 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3325 if (!PL_lex_casemods && PL_lex_inpat)
3332 case LEX_INTERPENDMAYBE:
3333 if (intuit_more(PL_bufptr)) {
3334 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3340 if (PL_lex_dojoin) {
3341 PL_lex_dojoin = FALSE;
3342 PL_lex_state = LEX_INTERPCONCAT;
3346 sv_free(PL_thistoken);
3347 PL_thistoken = newSVpvs("");
3352 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3353 && SvEVALED(PL_lex_repl))
3355 if (PL_bufptr != PL_bufend)
3356 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3360 case LEX_INTERPCONCAT:
3362 if (PL_lex_brackets)
3363 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3365 if (PL_bufptr == PL_bufend)
3366 return REPORT(sublex_done());
3368 if (SvIVX(PL_linestr) == '\'') {
3369 SV *sv = newSVsv(PL_linestr);
3372 else if ( PL_hints & HINT_NEW_RE )
3373 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3374 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3378 s = scan_const(PL_bufptr);
3380 PL_lex_state = LEX_INTERPCASEMOD;
3382 PL_lex_state = LEX_INTERPSTART;
3385 if (s != PL_bufptr) {
3386 start_force(PL_curforce);
3388 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3390 NEXTVAL_NEXTTOKE = yylval;
3393 if (PL_lex_starts++) {
3397 sv_free(PL_thistoken);
3398 PL_thistoken = newSVpvs("");
3401 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3402 if (!PL_lex_casemods && PL_lex_inpat)
3415 PL_lex_state = LEX_NORMAL;
3416 s = scan_formline(PL_bufptr);
3417 if (!PL_lex_formbrack)
3423 PL_oldoldbufptr = PL_oldbufptr;
3429 sv_free(PL_thistoken);
3432 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3436 if (isIDFIRST_lazy_if(s,UTF))
3438 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3441 goto fake_eof; /* emulate EOF on ^D or ^Z */
3450 if (PL_lex_brackets) {
3451 yyerror((const char *)
3453 ? "Format not terminated"
3454 : "Missing right curly or square bracket"));
3456 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3457 "### Tokener got EOF\n");
3461 if (s++ < PL_bufend)
3462 goto retry; /* ignore stray nulls */
3465 if (!PL_in_eval && !PL_preambled) {
3466 PL_preambled = TRUE;
3471 sv_setpv(PL_linestr,incl_perldb());
3472 if (SvCUR(PL_linestr))
3473 sv_catpvs(PL_linestr,";");
3475 while(AvFILLp(PL_preambleav) >= 0) {
3476 SV *tmpsv = av_shift(PL_preambleav);
3477 sv_catsv(PL_linestr, tmpsv);
3478 sv_catpvs(PL_linestr, ";");
3481 sv_free((SV*)PL_preambleav);
3482 PL_preambleav = NULL;
3484 if (PL_minus_n || PL_minus_p) {
3485 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3487 sv_catpvs(PL_linestr,"chomp;");
3490 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3491 || *PL_splitstr == '"')
3492 && strchr(PL_splitstr + 1, *PL_splitstr))
3493 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3495 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3496 bytes can be used as quoting characters. :-) */
3497 const char *splits = PL_splitstr;
3498 sv_catpvs(PL_linestr, "our @F=split(q\0");
3501 if (*splits == '\\')
3502 sv_catpvn(PL_linestr, splits, 1);
3503 sv_catpvn(PL_linestr, splits, 1);
3504 } while (*splits++);
3505 /* This loop will embed the trailing NUL of
3506 PL_linestr as the last thing it does before
3508 sv_catpvs(PL_linestr, ");");
3512 sv_catpvs(PL_linestr,"our @F=split(' ');");
3516 sv_catpvs(PL_linestr,"use feature ':5.10';");
3517 sv_catpvs(PL_linestr, "\n");
3518 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3519 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3520 PL_last_lop = PL_last_uni = NULL;
3521 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3522 SV * const sv = newSV(0);
3524 sv_upgrade(sv, SVt_PVMG);
3525 sv_setsv(sv,PL_linestr);
3528 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3533 bof = PL_rsfp ? TRUE : FALSE;
3534 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3537 PL_realtokenstart = -1;
3540 if (PL_preprocess && !PL_in_eval)
3541 (void)PerlProc_pclose(PL_rsfp);
3542 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3543 PerlIO_clearerr(PL_rsfp);
3545 (void)PerlIO_close(PL_rsfp);
3547 PL_doextract = FALSE;
3549 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3554 sv_setpv(PL_linestr,
3557 ? ";}continue{print;}" : ";}"));
3558 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3559 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3560 PL_last_lop = PL_last_uni = NULL;
3561 PL_minus_n = PL_minus_p = 0;
3564 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3565 PL_last_lop = PL_last_uni = NULL;
3566 sv_setpvn(PL_linestr,"",0);
3567 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3569 /* If it looks like the start of a BOM or raw UTF-16,
3570 * check if it in fact is. */
3576 #ifdef PERLIO_IS_STDIO
3577 # ifdef __GNU_LIBRARY__
3578 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3579 # define FTELL_FOR_PIPE_IS_BROKEN
3583 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3584 # define FTELL_FOR_PIPE_IS_BROKEN
3589 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3590 /* This loses the possibility to detect the bof
3591 * situation on perl -P when the libc5 is being used.
3592 * Workaround? Maybe attach some extra state to PL_rsfp?
3595 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3597 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3600 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3601 s = swallow_bom((U8*)s);
3605 /* Incest with pod. */
3608 sv_catsv(PL_thiswhite, PL_linestr);
3610 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3611 sv_setpvn(PL_linestr, "", 0);
3612 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3613 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3614 PL_last_lop = PL_last_uni = NULL;
3615 PL_doextract = FALSE;
3619 } while (PL_doextract);
3620 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3621 if (PERLDB_LINE && PL_curstash != PL_debstash) {
3622 SV * const sv = newSV(0);
3624 sv_upgrade(sv, SVt_PVMG);
3625 sv_setsv(sv,PL_linestr);
3628 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3630 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3631 PL_last_lop = PL_last_uni = NULL;
3632 if (CopLINE(PL_curcop) == 1) {
3633 while (s < PL_bufend && isSPACE(*s))
3635 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3639 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3643 if (*s == '#' && *(s+1) == '!')
3645 #ifdef ALTERNATE_SHEBANG
3647 static char const as[] = ALTERNATE_SHEBANG;
3648 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3649 d = s + (sizeof(as) - 1);
3651 #endif /* ALTERNATE_SHEBANG */
3660 while (*d && !isSPACE(*d))
3664 #ifdef ARG_ZERO_IS_SCRIPT
3665 if (ipathend > ipath) {
3667 * HP-UX (at least) sets argv[0] to the script name,
3668 * which makes $^X incorrect. And Digital UNIX and Linux,
3669 * at least, set argv[0] to the basename of the Perl
3670 * interpreter. So, having found "#!", we'll set it right.
3672 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3674 assert(SvPOK(x) || SvGMAGICAL(x));
3675 if (sv_eq(x, CopFILESV(PL_curcop))) {
3676 sv_setpvn(x, ipath, ipathend - ipath);
3682 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3683 const char * const lstart = SvPV_const(x,llen);
3685 bstart += blen - llen;
3686 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3687 sv_setpvn(x, ipath, ipathend - ipath);
3692 TAINT_NOT; /* $^X is always tainted, but that's OK */
3694 #endif /* ARG_ZERO_IS_SCRIPT */
3699 d = instr(s,"perl -");
3701 d = instr(s,"perl");
3703 /* avoid getting into infinite loops when shebang
3704 * line contains "Perl" rather than "perl" */
3706 for (d = ipathend-4; d >= ipath; --d) {
3707 if ((*d == 'p' || *d == 'P')
3708 && !ibcmp(d, "perl", 4))
3718 #ifdef ALTERNATE_SHEBANG
3720 * If the ALTERNATE_SHEBANG on this system starts with a
3721 * character that can be part of a Perl expression, then if
3722 * we see it but not "perl", we're probably looking at the
3723 * start of Perl code, not a request to hand off to some
3724 * other interpreter. Similarly, if "perl" is there, but
3725 * not in the first 'word' of the line, we assume the line
3726 * contains the start of the Perl program.
3728 if (d && *s != '#') {
3729 const char *c = ipath;
3730 while (*c && !strchr("; \t\r\n\f\v#", *c))
3733 d = NULL; /* "perl" not in first word; ignore */
3735 *s = '#'; /* Don't try to parse shebang line */
3737 #endif /* ALTERNATE_SHEBANG */
3738 #ifndef MACOS_TRADITIONAL
3743 !instr(s,"indir") &&
3744 instr(PL_origargv[0],"perl"))
3751 while (s < PL_bufend && isSPACE(*s))
3753 if (s < PL_bufend) {
3754 Newxz(newargv,PL_origargc+3,char*);
3756 while (s < PL_bufend && !isSPACE(*s))
3759 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3762 newargv = PL_origargv;
3765 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3767 Perl_croak(aTHX_ "Can't exec %s", ipath);
3771 while (*d && !isSPACE(*d))
3773 while (SPACE_OR_TAB(*d))
3777 const bool switches_done = PL_doswitches;
3778 const U32 oldpdb = PL_perldb;
3779 const bool oldn = PL_minus_n;
3780 const bool oldp = PL_minus_p;
3783 if (*d == 'M' || *d == 'm' || *d == 'C') {
3784 const char * const m = d;
3785 while (*d && !isSPACE(*d))
3787 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3790 d = moreswitches(d);
3792 if (PL_doswitches && !switches_done) {
3793 int argc = PL_origargc;
3794 char **argv = PL_origargv;
3797 } while (argc && argv[0][0] == '-' && argv[0][1]);
3798 init_argv_symbols(argc,argv);
3800 if ((PERLDB_LINE && !oldpdb) ||
3801 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3802 /* if we have already added "LINE: while (<>) {",
3803 we must not do it again */
3805 sv_setpvn(PL_linestr, "", 0);
3806 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3807 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3808 PL_last_lop = PL_last_uni = NULL;
3809 PL_preambled = FALSE;
3811 (void)gv_fetchfile(PL_origfilename);
3818 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3820 PL_lex_state = LEX_FORMLINE;
3825 #ifdef PERL_STRICT_CR
3826 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3828 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3830 case ' ': case '\t': case '\f': case 013:
3831 #ifdef MACOS_TRADITIONAL
3835 PL_realtokenstart = -1;
3844 PL_realtokenstart = -1;
3848 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3849 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3850 /* handle eval qq[#line 1 "foo"\n ...] */
3851 CopLINE_dec(PL_curcop);
3854 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3856 if (!PL_in_eval || PL_rsfp)
3861 while (d < PL_bufend && *d != '\n')
3865 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3866 Perl_croak(aTHX_ "panic: input overflow");
3869 PL_thiswhite = newSVpvn(s, d - s);
3874 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3876 PL_lex_state = LEX_FORMLINE;
3882 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3883 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3886 TOKEN(PEG); /* make sure any #! line is accessible */
3891 /* if (PL_madskills && PL_lex_formbrack) { */
3893 while (d < PL_bufend && *d != '\n')
3897 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3898 Perl_croak(aTHX_ "panic: input overflow");
3899 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
3901 PL_thiswhite = newSVpvs("");
3902 if (CopLINE(PL_curcop) == 1) {
3903 sv_setpvn(PL_thiswhite, "", 0);
3906 sv_catpvn(PL_thiswhite, s, d - s);
3920 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3928 while (s < PL_bufend && SPACE_OR_TAB(*s))
3931 if (strnEQ(s,"=>",2)) {
3932 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3933 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
3934 OPERATOR('-'); /* unary minus */
3936 PL_last_uni = PL_oldbufptr;
3938 case 'r': ftst = OP_FTEREAD; break;
3939 case 'w': ftst = OP_FTEWRITE; break;
3940 case 'x': ftst = OP_FTEEXEC; break;
3941 case 'o': ftst = OP_FTEOWNED; break;
3942 case 'R': ftst = OP_FTRREAD; break;
3943 case 'W': ftst = OP_FTRWRITE; break;
3944 case 'X': ftst = OP_FTREXEC; break;
3945 case 'O': ftst = OP_FTROWNED; break;
3946 case 'e': ftst = OP_FTIS; break;
3947 case 'z': ftst = OP_FTZERO; break;
3948 case 's': ftst = OP_FTSIZE; break;
3949 case 'f': ftst = OP_FTFILE; break;
3950 case 'd': ftst = OP_FTDIR; break;
3951 case 'l': ftst = OP_FTLINK; break;
3952 case 'p': ftst = OP_FTPIPE; break;
3953 case 'S': ftst = OP_FTSOCK; break;
3954 case 'u': ftst = OP_FTSUID; break;
3955 case 'g': ftst = OP_FTSGID; break;
3956 case 'k': ftst = OP_FTSVTX; break;
3957 case 'b': ftst = OP_FTBLK; break;
3958 case 'c': ftst = OP_FTCHR; break;
3959 case 't': ftst = OP_FTTTY; break;
3960 case 'T': ftst = OP_FTTEXT; break;
3961 case 'B': ftst = OP_FTBINARY; break;
3962 case 'M': case 'A': case 'C':
3963 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
3965 case 'M': ftst = OP_FTMTIME; break;
3966 case 'A': ftst = OP_FTATIME; break;
3967 case 'C': ftst = OP_FTCTIME; break;
3975 PL_last_lop_op = (OPCODE)ftst;
3976 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3977 "### Saw file test %c\n", (int)tmp);
3982 /* Assume it was a minus followed by a one-letter named
3983 * subroutine call (or a -bareword), then. */
3984 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3985 "### '-%c' looked like a file test but was not\n",
3992 const char tmp = *s++;
3995 if (PL_expect == XOPERATOR)
4000 else if (*s == '>') {
4003 if (isIDFIRST_lazy_if(s,UTF)) {
4004 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4012 if (PL_expect == XOPERATOR)
4015 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4017 OPERATOR('-'); /* unary minus */
4023 const char tmp = *s++;
4026 if (PL_expect == XOPERATOR)
4031 if (PL_expect == XOPERATOR)
4034 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4041 if (PL_expect != XOPERATOR) {
4042 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4043 PL_expect = XOPERATOR;
4044 force_ident(PL_tokenbuf, '*');
4057 if (PL_expect == XOPERATOR) {
4061 PL_tokenbuf[0] = '%';
4062 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
4063 if (!PL_tokenbuf[1]) {
4066 PL_pending_ident = '%';
4077 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
4078 && FEATURE_IS_ENABLED("~~"))
4085 const char tmp = *s++;
4091 goto just_a_word_zero_gv;
4094 switch (PL_expect) {
4100 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4102 PL_bufptr = s; /* update in case we back off */
4108 PL_expect = XTERMBLOCK;
4111 stuffstart = s - SvPVX(PL_linestr) - 1;
4115 while (isIDFIRST_lazy_if(s,UTF)) {
4118 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4119 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4120 if (tmp < 0) tmp = -tmp;
4135 sv = newSVpvn(s, len);
4137 d = scan_str(d,TRUE,TRUE);
4139 /* MUST advance bufptr here to avoid bogus
4140 "at end of line" context messages from yyerror().
4142 PL_bufptr = s + len;
4143 yyerror("Unterminated attribute parameter in attribute list");
4147 return REPORT(0); /* EOF indicator */
4151 sv_catsv(sv, PL_lex_stuff);
4152 attrs = append_elem(OP_LIST, attrs,
4153 newSVOP(OP_CONST, 0, sv));
4154 SvREFCNT_dec(PL_lex_stuff);
4155 PL_lex_stuff = NULL;
4158 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4160 if (PL_in_my == KEY_our) {
4162 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4164 /* skip to avoid loading attributes.pm */
4166 deprecate(":unique");
4169 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4172 /* NOTE: any CV attrs applied here need to be part of
4173 the CVf_BUILTIN_ATTRS define in cv.h! */
4174 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4176 CvLVALUE_on(PL_compcv);
4178 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4180 CvLOCKED_on(PL_compcv);
4182 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4184 CvMETHOD_on(PL_compcv);
4186 else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4188 CvASSERTION_on(PL_compcv);
4190 /* After we've set the flags, it could be argued that
4191 we don't need to do the attributes.pm-based setting
4192 process, and shouldn't bother appending recognized
4193 flags. To experiment with that, uncomment the
4194 following "else". (Note that's already been
4195 uncommented. That keeps the above-applied built-in
4196 attributes from being intercepted (and possibly
4197 rejected) by a package's attribute routines, but is
4198 justified by the performance win for the common case
4199 of applying only built-in attributes.) */
4201 attrs = append_elem(OP_LIST, attrs,
4202 newSVOP(OP_CONST, 0,
4206 if (*s == ':' && s[1] != ':')
4209 break; /* require real whitespace or :'s */
4210 /* XXX losing whitespace on sequential attributes here */
4214 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4215 if (*s != ';' && *s != '}' && *s != tmp
4216 && (tmp != '=' || *s != ')')) {
4217 const char q = ((*s == '\'') ? '"' : '\'');
4218 /* If here for an expression, and parsed no attrs, back
4220 if (tmp == '=' && !attrs) {
4224 /* MUST advance bufptr here to avoid bogus "at end of line"
4225 context messages from yyerror().
4228 yyerror( (const char *)
4230 ? Perl_form(aTHX_ "Invalid separator character "
4231 "%c%c%c in attribute list", q, *s, q)
4232 : "Unterminated attribute list" ) );
4240 start_force(PL_curforce);
4241 NEXTVAL_NEXTTOKE.opval = attrs;
4242 CURMAD('_', PL_nextwhite);
4247 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4248 (s - SvPVX(PL_linestr)) - stuffstart);
4256 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4257 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4265 const char tmp = *s++;
4270 const char tmp = *s++;
4278 if (PL_lex_brackets <= 0)
4279 yyerror("Unmatched right square bracket");
4282 if (PL_lex_state == LEX_INTERPNORMAL) {
4283 if (PL_lex_brackets == 0) {
4284 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4285 PL_lex_state = LEX_INTERPEND;
4292 if (PL_lex_brackets > 100) {
4293 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4295 switch (PL_expect) {
4297 if (PL_lex_formbrack) {
4301 if (PL_oldoldbufptr == PL_last_lop)
4302 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4304 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4305 OPERATOR(HASHBRACK);
4307 while (s < PL_bufend && SPACE_OR_TAB(*s))
4310 PL_tokenbuf[0] = '\0';
4311 if (d < PL_bufend && *d == '-') {
4312 PL_tokenbuf[0] = '-';
4314 while (d < PL_bufend && SPACE_OR_TAB(*d))
4317 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4318 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4320 while (d < PL_bufend && SPACE_OR_TAB(*d))
4323 const char minus = (PL_tokenbuf[0] == '-');
4324 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4332 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4337 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4342 if (PL_oldoldbufptr == PL_last_lop)
4343 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4345 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4348 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4350 /* This hack is to get the ${} in the message. */
4352 yyerror("syntax error");
4355 OPERATOR(HASHBRACK);
4357 /* This hack serves to disambiguate a pair of curlies
4358 * as being a block or an anon hash. Normally, expectation
4359 * determines that, but in cases where we're not in a
4360 * position to expect anything in particular (like inside
4361 * eval"") we have to resolve the ambiguity. This code
4362 * covers the case where the first term in the curlies is a
4363 * quoted string. Most other cases need to be explicitly
4364 * disambiguated by prepending a "+" before the opening
4365 * curly in order to force resolution as an anon hash.
4367 * XXX should probably propagate the outer expectation
4368 * into eval"" to rely less on this hack, but that could
4369 * potentially break current behavior of eval"".
4373 if (*s == '\'' || *s == '"' || *s == '`') {
4374 /* common case: get past first string, handling escapes */
4375 for (t++; t < PL_bufend && *t != *s;)
4376 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4380 else if (*s == 'q') {
4383 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4386 /* skip q//-like construct */
4388 char open, close, term;
4391 while (t < PL_bufend && isSPACE(*t))
4393 /* check for q => */
4394 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4395 OPERATOR(HASHBRACK);
4399 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4403 for (t++; t < PL_bufend; t++) {
4404 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4406 else if (*t == open)
4410 for (t++; t < PL_bufend; t++) {
4411 if (*t == '\\' && t+1 < PL_bufend)
4413 else if (*t == close && --brackets <= 0)
4415 else if (*t == open)
4422 /* skip plain q word */
4423 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4426 else if (isALNUM_lazy_if(t,UTF)) {
4428 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4431 while (t < PL_bufend && isSPACE(*t))
4433 /* if comma follows first term, call it an anon hash */
4434 /* XXX it could be a comma expression with loop modifiers */
4435 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4436 || (*t == '=' && t[1] == '>')))
4437 OPERATOR(HASHBRACK);
4438 if (PL_expect == XREF)
4441 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4447 yylval.ival = CopLINE(PL_curcop);
4448 if (isSPACE(*s) || *s == '#')
4449 PL_copline = NOLINE; /* invalidate current command line number */
4454 if (PL_lex_brackets <= 0)
4455 yyerror("Unmatched right curly bracket");
4457 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4458 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4459 PL_lex_formbrack = 0;
4460 if (PL_lex_state == LEX_INTERPNORMAL) {
4461 if (PL_lex_brackets == 0) {
4462 if (PL_expect & XFAKEBRACK) {
4463 PL_expect &= XENUMMASK;
4464 PL_lex_state = LEX_INTERPEND;
4469 PL_thiswhite = newSVpvs("");
4470 sv_catpvn(PL_thiswhite,"}",1);
4473 return yylex(); /* ignore fake brackets */
4475 if (*s == '-' && s[1] == '>')
4476 PL_lex_state = LEX_INTERPENDMAYBE;
4477 else if (*s != '[' && *s != '{')
4478 PL_lex_state = LEX_INTERPEND;
4481 if (PL_expect & XFAKEBRACK) {
4482 PL_expect &= XENUMMASK;
4484 return yylex(); /* ignore fake brackets */
4486 start_force(PL_curforce);
4488 curmad('X', newSVpvn(s-1,1));
4489 CURMAD('_', PL_thiswhite);
4494 PL_thistoken = newSVpvs("");
4502 if (PL_expect == XOPERATOR) {
4503 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4504 && isIDFIRST_lazy_if(s,UTF))
4506 CopLINE_dec(PL_curcop);
4507 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4508 CopLINE_inc(PL_curcop);
4513 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4515 PL_expect = XOPERATOR;
4516 force_ident(PL_tokenbuf, '&');
4520 yylval.ival = (OPpENTERSUB_AMPER<<8);
4532 const char tmp = *s++;
4539 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4540 && strchr("+-*/%.^&|<",tmp))
4541 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4542 "Reversed %c= operator",(int)tmp);
4544 if (PL_expect == XSTATE && isALPHA(tmp) &&
4545 (s == PL_linestart+1 || s[-2] == '\n') )
4547 if (PL_in_eval && !PL_rsfp) {
4552 if (strnEQ(s,"=cut",4)) {
4568 PL_thiswhite = newSVpvs("");
4569 sv_catpvn(PL_thiswhite, PL_linestart,
4570 PL_bufend - PL_linestart);
4574 PL_doextract = TRUE;
4578 if (PL_lex_brackets < PL_lex_formbrack) {
4580 #ifdef PERL_STRICT_CR
4581 while (SPACE_OR_TAB(*t))
4583 while (SPACE_OR_TAB(*t) || *t == '\r')
4586 if (*t == '\n' || *t == '#') {
4597 const char tmp = *s++;
4599 /* was this !=~ where !~ was meant?
4600 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4602 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4603 const char *t = s+1;
4605 while (t < PL_bufend && isSPACE(*t))
4608 if (*t == '/' || *t == '?' ||
4609 ((*t == 'm' || *t == 's' || *t == 'y')
4610 && !isALNUM(t[1])) ||
4611 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4612 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4613 "!=~ should be !~");
4623 if (PL_expect != XOPERATOR) {
4624 if (s[1] != '<' && !strchr(s,'>'))
4627 s = scan_heredoc(s);
4629 s = scan_inputsymbol(s);
4630 TERM(sublex_start());
4636 SHop(OP_LEFT_SHIFT);
4650 const char tmp = *s++;
4652 SHop(OP_RIGHT_SHIFT);
4653 else if (tmp == '=')
4662 if (PL_expect == XOPERATOR) {
4663 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4665 deprecate_old(commaless_variable_list);
4666 return REPORT(','); /* grandfather non-comma-format format */
4670 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4671 PL_tokenbuf[0] = '@';
4672 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4673 sizeof PL_tokenbuf - 1, FALSE);
4674 if (PL_expect == XOPERATOR)
4675 no_op("Array length", s);
4676 if (!PL_tokenbuf[1])
4678 PL_expect = XOPERATOR;
4679 PL_pending_ident = '#';
4683 PL_tokenbuf[0] = '$';
4684 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4685 sizeof PL_tokenbuf - 1, FALSE);
4686 if (PL_expect == XOPERATOR)
4688 if (!PL_tokenbuf[1]) {
4690 yyerror("Final $ should be \\$ or $name");
4694 /* This kludge not intended to be bulletproof. */
4695 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4696 yylval.opval = newSVOP(OP_CONST, 0,
4697 newSViv(CopARYBASE_get(&PL_compiling)));
4698 yylval.opval->op_private = OPpCONST_ARYBASE;
4704 const char tmp = *s;
4705 if (PL_lex_state == LEX_NORMAL)
4708 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4709 && intuit_more(s)) {
4711 PL_tokenbuf[0] = '@';
4712 if (ckWARN(WARN_SYNTAX)) {
4715 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4718 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4719 while (t < PL_bufend && *t != ']')
4721 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4722 "Multidimensional syntax %.*s not supported",
4723 (int)((t - PL_bufptr) + 1), PL_bufptr);
4727 else if (*s == '{') {
4729 PL_tokenbuf[0] = '%';
4730 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4731 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4733 char tmpbuf[sizeof PL_tokenbuf];
4736 } while (isSPACE(*t));
4737 if (isIDFIRST_lazy_if(t,UTF)) {
4739 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4743 if (*t == ';' && get_cv(tmpbuf, FALSE))
4744 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4745 "You need to quote \"%s\"",
4752 PL_expect = XOPERATOR;
4753 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4754 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4755 if (!islop || PL_last_lop_op == OP_GREPSTART)
4756 PL_expect = XOPERATOR;
4757 else if (strchr("$@\"'`q", *s))
4758 PL_expect = XTERM; /* e.g. print $fh "foo" */
4759 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4760 PL_expect = XTERM; /* e.g. print $fh &sub */
4761 else if (isIDFIRST_lazy_if(s,UTF)) {
4762 char tmpbuf[sizeof PL_tokenbuf];
4764 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4765 if ((t2 = keyword(tmpbuf, len, 0))) {
4766 /* binary operators exclude handle interpretations */
4778 PL_expect = XTERM; /* e.g. print $fh length() */
4783 PL_expect = XTERM; /* e.g. print $fh subr() */
4786 else if (isDIGIT(*s))
4787 PL_expect = XTERM; /* e.g. print $fh 3 */
4788 else if (*s == '.' && isDIGIT(s[1]))
4789 PL_expect = XTERM; /* e.g. print $fh .3 */
4790 else if ((*s == '?' || *s == '-' || *s == '+')
4791 && !isSPACE(s[1]) && s[1] != '=')
4792 PL_expect = XTERM; /* e.g. print $fh -1 */
4793 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4795 PL_expect = XTERM; /* e.g. print $fh /.../
4796 XXX except DORDOR operator
4798 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4800 PL_expect = XTERM; /* print $fh <<"EOF" */
4803 PL_pending_ident = '$';
4807 if (PL_expect == XOPERATOR)
4809 PL_tokenbuf[0] = '@';
4810 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4811 if (!PL_tokenbuf[1]) {
4814 if (PL_lex_state == LEX_NORMAL)
4816 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4818 PL_tokenbuf[0] = '%';
4820 /* Warn about @ where they meant $. */
4821 if (*s == '[' || *s == '{') {
4822 if (ckWARN(WARN_SYNTAX)) {
4823 const char *t = s + 1;
4824 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4826 if (*t == '}' || *t == ']') {
4828 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4829 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4830 "Scalar value %.*s better written as $%.*s",
4831 (int)(t-PL_bufptr), PL_bufptr,
4832 (int)(t-PL_bufptr-1), PL_bufptr+1);
4837 PL_pending_ident = '@';
4840 case '/': /* may be division, defined-or, or pattern */
4841 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4845 case '?': /* may either be conditional or pattern */
4846 if(PL_expect == XOPERATOR) {
4854 /* A // operator. */
4864 /* Disable warning on "study /blah/" */
4865 if (PL_oldoldbufptr == PL_last_uni
4866 && (*PL_last_uni != 's' || s - PL_last_uni < 5
4867 || memNE(PL_last_uni, "study", 5)
4868 || isALNUM_lazy_if(PL_last_uni+5,UTF)
4871 s = scan_pat(s,OP_MATCH);
4872 TERM(sublex_start());
4876 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4877 #ifdef PERL_STRICT_CR
4880 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4882 && (s == PL_linestart || s[-1] == '\n') )
4884 PL_lex_formbrack = 0;
4888 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4894 yylval.ival = OPf_SPECIAL;
4900 if (PL_expect != XOPERATOR)
4905 case '0': case '1': case '2': case '3': case '4':
4906 case '5': case '6': case '7': case '8': case '9':
4907 s = scan_num(s, &yylval);
4908 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
4909 if (PL_expect == XOPERATOR)
4914 s = scan_str(s,!!PL_madskills,FALSE);
4915 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4916 if (PL_expect == XOPERATOR) {
4917 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4919 deprecate_old(commaless_variable_list);
4920 return REPORT(','); /* grandfather non-comma-format format */
4927 yylval.ival = OP_CONST;
4928 TERM(sublex_start());
4931 s = scan_str(s,!!PL_madskills,FALSE);
4932 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4933 if (PL_expect == XOPERATOR) {
4934 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4936 deprecate_old(commaless_variable_list);
4937 return REPORT(','); /* grandfather non-comma-format format */
4944 yylval.ival = OP_CONST;
4945 /* FIXME. I think that this can be const if char *d is replaced by
4946 more localised variables. */
4947 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
4948 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
4949 yylval.ival = OP_STRINGIFY;
4953 TERM(sublex_start());
4956 s = scan_str(s,!!PL_madskills,FALSE);
4957 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
4958 if (PL_expect == XOPERATOR)
4959 no_op("Backticks",s);
4962 yylval.ival = OP_BACKTICK;
4964 TERM(sublex_start());
4968 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
4969 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
4971 if (PL_expect == XOPERATOR)
4972 no_op("Backslash",s);
4976 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4977 char *start = s + 2;
4978 while (isDIGIT(*start) || *start == '_')
4980 if (*start == '.' && isDIGIT(start[1])) {
4981 s = scan_num(s, &yylval);
4984 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4985 else if (!isALPHA(*start) && (PL_expect == XTERM
4986 || PL_expect == XREF || PL_expect == XSTATE
4987 || PL_expect == XTERMORDORDOR)) {
4988 /* XXX Use gv_fetchpvn rather than stomping on a const string */
4989 const char c = *start;
4992 gv = gv_fetchpv(s, 0, SVt_PVCV);
4995 s = scan_num(s, &yylval);
5002 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5044 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5046 /* Some keywords can be followed by any delimiter, including ':' */
5047 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5048 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5049 (PL_tokenbuf[0] == 'q' &&
5050 strchr("qwxr", PL_tokenbuf[1])))));
5052 /* x::* is just a word, unless x is "CORE" */
5053 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5057 while (d < PL_bufend && isSPACE(*d))
5058 d++; /* no comments skipped here, or s### is misparsed */
5060 /* Is this a label? */
5061 if (!tmp && PL_expect == XSTATE
5062 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5064 yylval.pval = savepv(PL_tokenbuf);
5069 /* Check for keywords */
5070 tmp = keyword(PL_tokenbuf, len, 0);
5072 /* Is this a word before a => operator? */
5073 if (*d == '=' && d[1] == '>') {
5076 = (OP*)newSVOP(OP_CONST, 0,
5077 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5078 yylval.opval->op_private = OPpCONST_BARE;
5082 if (tmp < 0) { /* second-class keyword? */
5083 GV *ogv = NULL; /* override (winner) */
5084 GV *hgv = NULL; /* hidden (loser) */
5085 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5087 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5090 if (GvIMPORTED_CV(gv))
5092 else if (! CvMETHOD(cv))
5096 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5097 (gv = *gvp) != (GV*)&PL_sv_undef &&
5098 GvCVu(gv) && GvIMPORTED_CV(gv))
5105 tmp = 0; /* overridden by import or by GLOBAL */
5108 && -tmp==KEY_lock /* XXX generalizable kludge */
5110 && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
5112 tmp = 0; /* any sub overrides "weak" keyword */
5114 else { /* no override */
5116 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5117 Perl_warner(aTHX_ packWARN(WARN_MISC),
5118 "dump() better written as CORE::dump()");
5122 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5123 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
5124 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5125 "Ambiguous call resolved as CORE::%s(), %s",
5126 GvENAME(hgv), "qualify as such or use &");
5133 default: /* not a keyword */
5134 /* Trade off - by using this evil construction we can pull the
5135 variable gv into the block labelled keylookup. If not, then
5136 we have to give it function scope so that the goto from the
5137 earlier ':' case doesn't bypass the initialisation. */
5139 just_a_word_zero_gv:
5147 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5150 SV *nextPL_nextwhite = 0;
5154 /* Get the rest if it looks like a package qualifier */
5156 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5158 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5161 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5162 *s == '\'' ? "'" : "::");
5167 if (PL_expect == XOPERATOR) {
5168 if (PL_bufptr == PL_linestart) {
5169 CopLINE_dec(PL_curcop);
5170 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5171 CopLINE_inc(PL_curcop);
5174 no_op("Bareword",s);
5177 /* Look for a subroutine with this name in current package,
5178 unless name is "Foo::", in which case Foo is a bearword
5179 (and a package name). */
5181 if (len > 2 && !PL_madskills &&
5182 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5184 if (ckWARN(WARN_BAREWORD)
5185 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5186 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5187 "Bareword \"%s\" refers to nonexistent package",
5190 PL_tokenbuf[len] = '\0';
5196 /* Mustn't actually add anything to a symbol table.
5197 But also don't want to "initialise" any placeholder
5198 constants that might already be there into full
5199 blown PVGVs with attached PVCV. */
5200 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5201 GV_NOADD_NOINIT, SVt_PVCV);
5206 /* if we saw a global override before, get the right name */
5209 sv = newSVpvs("CORE::GLOBAL::");
5210 sv_catpv(sv,PL_tokenbuf);
5213 /* If len is 0, newSVpv does strlen(), which is correct.
5214 If len is non-zero, then it will be the true length,
5215 and so the scalar will be created correctly. */
5216 sv = newSVpv(PL_tokenbuf,len);
5219 if (PL_madskills && !PL_thistoken) {
5220 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5221 PL_thistoken = newSVpv(start,s - start);
5222 PL_realtokenstart = s - SvPVX(PL_linestr);
5226 /* Presume this is going to be a bareword of some sort. */
5229 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5230 yylval.opval->op_private = OPpCONST_BARE;
5231 /* UTF-8 package name? */
5232 if (UTF && !IN_BYTES &&
5233 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5236 /* And if "Foo::", then that's what it certainly is. */
5241 /* Do the explicit type check so that we don't need to force
5242 the initialisation of the symbol table to have a real GV.
5243 Beware - gv may not really be a PVGV, cv may not really be
5244 a PVCV, (because of the space optimisations that gv_init
5245 understands) But they're true if for this symbol there is
5246 respectively a typeglob and a subroutine.
5248 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5249 /* Real typeglob, so get the real subroutine: */
5251 /* A proxy for a subroutine in this package? */
5252 : SvOK(gv) ? (CV *) gv : NULL)
5255 /* See if it's the indirect object for a list operator. */
5257 if (PL_oldoldbufptr &&
5258 PL_oldoldbufptr < PL_bufptr &&
5259 (PL_oldoldbufptr == PL_last_lop
5260 || PL_oldoldbufptr == PL_last_uni) &&
5261 /* NO SKIPSPACE BEFORE HERE! */
5262 (PL_expect == XREF ||
5263 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5265 bool immediate_paren = *s == '(';
5267 /* (Now we can afford to cross potential line boundary.) */
5268 s = SKIPSPACE2(s,nextPL_nextwhite);
5270 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5273 /* Two barewords in a row may indicate method call. */
5275 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5276 (tmp = intuit_method(s, gv, cv)))
5279 /* If not a declared subroutine, it's an indirect object. */
5280 /* (But it's an indir obj regardless for sort.) */
5281 /* Also, if "_" follows a filetest operator, it's a bareword */
5284 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5286 (PL_last_lop_op != OP_MAPSTART &&
5287 PL_last_lop_op != OP_GREPSTART))))
5288 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5289 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5292 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5297 PL_expect = XOPERATOR;
5300 s = SKIPSPACE2(s,nextPL_nextwhite);
5301 PL_nextwhite = nextPL_nextwhite;
5306 /* Is this a word before a => operator? */
5307 if (*s == '=' && s[1] == '>' && !pkgname) {
5309 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5310 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5311 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5315 /* If followed by a paren, it's certainly a subroutine. */
5320 while (SPACE_OR_TAB(*d))
5322 if (*d == ')' && (sv = gv_const_sv(gv))) {
5326 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5327 sv_catpvn(PL_thistoken, par, s - par);
5329 sv_free(PL_nextwhite);
5339 PL_nextwhite = PL_thiswhite;
5342 start_force(PL_curforce);
5344 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5345 PL_expect = XOPERATOR;
5348 PL_nextwhite = nextPL_nextwhite;
5349 curmad('X', PL_thistoken);
5350 PL_thistoken = newSVpvs("");
5358 /* If followed by var or block, call it a method (unless sub) */
5360 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5361 PL_last_lop = PL_oldbufptr;
5362 PL_last_lop_op = OP_METHOD;
5366 /* If followed by a bareword, see if it looks like indir obj. */
5369 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5370 && (tmp = intuit_method(s, gv, cv)))
5373 /* Not a method, so call it a subroutine (if defined) */
5376 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5377 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5378 "Ambiguous use of -%s resolved as -&%s()",
5379 PL_tokenbuf, PL_tokenbuf);
5380 /* Check for a constant sub */
5381 if ((sv = gv_const_sv(gv))) {
5383 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5384 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5385 yylval.opval->op_private = 0;
5389 /* Resolve to GV now. */
5390 if (SvTYPE(gv) != SVt_PVGV) {
5391 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5392 assert (SvTYPE(gv) == SVt_PVGV);
5393 /* cv must have been some sort of placeholder, so
5394 now needs replacing with a real code reference. */
5398 op_free(yylval.opval);
5399 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5400 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5401 PL_last_lop = PL_oldbufptr;
5402 PL_last_lop_op = OP_ENTERSUB;
5403 /* Is there a prototype? */
5410 const char *proto = SvPV_const((SV*)cv, protolen);
5413 if (*proto == '$' && proto[1] == '\0')
5415 while (*proto == ';')
5417 if (*proto == '&' && *s == '{') {
5418 sv_setpv(PL_subname,
5421 "__ANON__" : "__ANON__::__ANON__"));
5428 PL_nextwhite = PL_thiswhite;
5431 start_force(PL_curforce);
5432 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5435 PL_nextwhite = nextPL_nextwhite;
5436 curmad('X', PL_thistoken);
5437 PL_thistoken = newSVpvs("");
5444 /* Guess harder when madskills require "best effort". */
5445 if (PL_madskills && (!gv || !GvCVu(gv))) {
5446 int probable_sub = 0;
5447 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5449 else if (isALPHA(*s)) {
5453 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5454 if (!keyword(tmpbuf, tmplen, 0))
5457 while (d < PL_bufend && isSPACE(*d))
5459 if (*d == '=' && d[1] == '>')
5464 gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
5465 op_free(yylval.opval);
5466 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5467 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5468 PL_last_lop = PL_oldbufptr;
5469 PL_last_lop_op = OP_ENTERSUB;
5470 PL_nextwhite = PL_thiswhite;
5472 start_force(PL_curforce);
5473 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5475 PL_nextwhite = nextPL_nextwhite;
5476 curmad('X', PL_thistoken);
5477 PL_thistoken = newSVpvs("");
5482 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5489 /* Call it a bare word */
5491 if (PL_hints & HINT_STRICT_SUBS)
5492 yylval.opval->op_private |= OPpCONST_STRICT;
5495 if (lastchar != '-') {
5496 if (ckWARN(WARN_RESERVED)) {
5500 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
5501 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5508 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5509 && ckWARN_d(WARN_AMBIGUOUS)) {
5510 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5511 "Operator or semicolon missing before %c%s",
5512 lastchar, PL_tokenbuf);
5513 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5514 "Ambiguous use of %c resolved as operator %c",
5515 lastchar, lastchar);
5521 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5522 newSVpv(CopFILE(PL_curcop),0));
5526 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5527 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5530 case KEY___PACKAGE__:
5531 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5533 ? newSVhek(HvNAME_HEK(PL_curstash))
5540 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5541 const char *pname = "main";
5542 if (PL_tokenbuf[2] == 'D')
5543 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5544 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5548 GvIOp(gv) = newIO();
5549 IoIFP(GvIOp(gv)) = PL_rsfp;
5550 #if defined(HAS_FCNTL) && defined(F_SETFD)
5552 const int fd = PerlIO_fileno(PL_rsfp);
5553 fcntl(fd,F_SETFD,fd >= 3);
5556 /* Mark this internal pseudo-handle as clean */
5557 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5559 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5560 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5561 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5563 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5564 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5565 /* if the script was opened in binmode, we need to revert
5566 * it to text mode for compatibility; but only iff it has CRs
5567 * XXX this is a questionable hack at best. */
5568 if (PL_bufend-PL_bufptr > 2
5569 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5572 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5573 loc = PerlIO_tell(PL_rsfp);
5574 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5577 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5579 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5580 #endif /* NETWARE */
5581 #ifdef PERLIO_IS_STDIO /* really? */
5582 # if defined(__BORLANDC__)
5583 /* XXX see note in do_binmode() */
5584 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5588 PerlIO_seek(PL_rsfp, loc, 0);
5592 #ifdef PERLIO_LAYERS
5595 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5596 else if (PL_encoding) {
5603 XPUSHs(PL_encoding);
5605 call_method("name", G_SCALAR);
5609 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5610 Perl_form(aTHX_ ":encoding(%"SVf")",
5619 if (PL_realtokenstart >= 0) {
5620 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5622 PL_endwhite = newSVpvs("");
5623 sv_catsv(PL_endwhite, PL_thiswhite);
5625 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5626 PL_realtokenstart = -1;
5628 while ((s = filter_gets(PL_endwhite, PL_rsfp,
5629 SvCUR(PL_endwhite))) != Nullch) ;
5643 if (PL_expect == XSTATE) {
5650 if (*s == ':' && s[1] == ':') {
5653 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5654 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5655 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5658 else if (tmp == KEY_require || tmp == KEY_do)
5659 /* that's a way to remember we saw "CORE::" */
5672 LOP(OP_ACCEPT,XTERM);
5678 LOP(OP_ATAN2,XTERM);
5684 LOP(OP_BINMODE,XTERM);
5687 LOP(OP_BLESS,XTERM);
5696 /* When 'use switch' is in effect, continue has a dual
5697 life as a control operator. */
5699 if (!FEATURE_IS_ENABLED("switch"))
5702 /* We have to disambiguate the two senses of
5703 "continue". If the next token is a '{' then
5704 treat it as the start of a continue block;
5705 otherwise treat it as a control operator.
5717 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5734 if (!PL_cryptseen) {
5735 PL_cryptseen = TRUE;
5739 LOP(OP_CRYPT,XTERM);
5742 LOP(OP_CHMOD,XTERM);
5745 LOP(OP_CHOWN,XTERM);
5748 LOP(OP_CONNECT,XTERM);
5767 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5768 if (orig_keyword == KEY_do) {
5777 PL_hints |= HINT_BLOCK_SCOPE;
5787 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5788 LOP(OP_DBMOPEN,XTERM);
5794 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5801 yylval.ival = CopLINE(PL_curcop);
5817 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5818 UNIBRACK(OP_ENTEREVAL);
5836 case KEY_endhostent:
5842 case KEY_endservent:
5845 case KEY_endprotoent:
5856 yylval.ival = CopLINE(PL_curcop);
5858 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5861 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5864 if ((PL_bufend - p) >= 3 &&
5865 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5867 else if ((PL_bufend - p) >= 4 &&
5868 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5871 if (isIDFIRST_lazy_if(p,UTF)) {
5872 p = scan_ident(p, PL_bufend,
5873 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5877 Perl_croak(aTHX_ "Missing $ on loop variable");
5879 s = SvPVX(PL_linestr) + soff;
5885 LOP(OP_FORMLINE,XTERM);
5891 LOP(OP_FCNTL,XTERM);
5897 LOP(OP_FLOCK,XTERM);
5906 LOP(OP_GREPSTART, XREF);
5909 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5924 case KEY_getpriority:
5925 LOP(OP_GETPRIORITY,XTERM);
5927 case KEY_getprotobyname:
5930 case KEY_getprotobynumber:
5931 LOP(OP_GPBYNUMBER,XTERM);
5933 case KEY_getprotoent:
5945 case KEY_getpeername:
5946 UNI(OP_GETPEERNAME);
5948 case KEY_gethostbyname:
5951 case KEY_gethostbyaddr:
5952 LOP(OP_GHBYADDR,XTERM);
5954 case KEY_gethostent:
5957 case KEY_getnetbyname:
5960 case KEY_getnetbyaddr:
5961 LOP(OP_GNBYADDR,XTERM);
5966 case KEY_getservbyname:
5967 LOP(OP_GSBYNAME,XTERM);
5969 case KEY_getservbyport:
5970 LOP(OP_GSBYPORT,XTERM);
5972 case KEY_getservent:
5975 case KEY_getsockname:
5976 UNI(OP_GETSOCKNAME);
5978 case KEY_getsockopt:
5979 LOP(OP_GSOCKOPT,XTERM);
5994 yylval.ival = CopLINE(PL_curcop);
6005 yylval.ival = CopLINE(PL_curcop);
6009 LOP(OP_INDEX,XTERM);
6015 LOP(OP_IOCTL,XTERM);
6027 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6059 LOP(OP_LISTEN,XTERM);
6068 s = scan_pat(s,OP_MATCH);
6069 TERM(sublex_start());
6072 LOP(OP_MAPSTART, XREF);
6075 LOP(OP_MKDIR,XTERM);
6078 LOP(OP_MSGCTL,XTERM);
6081 LOP(OP_MSGGET,XTERM);
6084 LOP(OP_MSGRCV,XTERM);
6087 LOP(OP_MSGSND,XTERM);
6094 if (isIDFIRST_lazy_if(s,UTF)) {
6098 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6099 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6101 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6102 if (!PL_in_my_stash) {
6105 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6109 if (PL_madskills) { /* just add type to declarator token */
6110 sv_catsv(PL_thistoken, PL_nextwhite);
6112 sv_catpvn(PL_thistoken, start, s - start);
6120 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6127 s = tokenize_use(0, s);
6131 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6138 if (isIDFIRST_lazy_if(s,UTF)) {
6140 for (d = s; isALNUM_lazy_if(d,UTF);)
6142 for (t=d; isSPACE(*t);)
6144 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6146 && !(t[0] == '=' && t[1] == '>')
6148 int parms_len = (int)(d-s);
6149 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6150 "Precedence problem: open %.*s should be open(%.*s)",
6151 parms_len, s, parms_len, s);
6157 yylval.ival = OP_OR;
6167 LOP(OP_OPEN_DIR,XTERM);
6170 checkcomma(s,PL_tokenbuf,"filehandle");
6174 checkcomma(s,PL_tokenbuf,"filehandle");
6193 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6197 LOP(OP_PIPE_OP,XTERM);
6200 s = scan_str(s,!!PL_madskills,FALSE);
6203 yylval.ival = OP_CONST;
6204 TERM(sublex_start());
6210 s = scan_str(s,!!PL_madskills,FALSE);
6213 PL_expect = XOPERATOR;
6215 if (SvCUR(PL_lex_stuff)) {
6218 d = SvPV_force(PL_lex_stuff, len);
6220 for (; isSPACE(*d) && len; --len, ++d)
6225 if (!warned && ckWARN(WARN_QW)) {
6226 for (; !isSPACE(*d) && len; --len, ++d) {
6228 Perl_warner(aTHX_ packWARN(WARN_QW),
6229 "Possible attempt to separate words with commas");
6232 else if (*d == '#') {
6233 Perl_warner(aTHX_ packWARN(WARN_QW),
6234 "Possible attempt to put comments in qw() list");
6240 for (; !isSPACE(*d) && len; --len, ++d)
6243 sv = newSVpvn(b, d-b);
6244 if (DO_UTF8(PL_lex_stuff))
6246 words = append_elem(OP_LIST, words,
6247 newSVOP(OP_CONST, 0, tokeq(sv)));
6251 start_force(PL_curforce);
6252 NEXTVAL_NEXTTOKE.opval = words;
6257 SvREFCNT_dec(PL_lex_stuff);
6258 PL_lex_stuff = NULL;
6264 s = scan_str(s,!!PL_madskills,FALSE);
6267 yylval.ival = OP_STRINGIFY;
6268 if (SvIVX(PL_lex_stuff) == '\'')
6269 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6270 TERM(sublex_start());
6273 s = scan_pat(s,OP_QR);
6274 TERM(sublex_start());
6277 s = scan_str(s,!!PL_madskills,FALSE);
6280 yylval.ival = OP_BACKTICK;
6282 TERM(sublex_start());
6290 s = force_version(s, FALSE);
6292 else if (*s != 'v' || !isDIGIT(s[1])
6293 || (s = force_version(s, TRUE), *s == 'v'))
6295 *PL_tokenbuf = '\0';
6296 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6297 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6298 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
6300 yyerror("<> should be quotes");
6302 if (orig_keyword == KEY_require) {
6310 PL_last_uni = PL_oldbufptr;
6311 PL_last_lop_op = OP_REQUIRE;
6313 return REPORT( (int)REQUIRE );
6319 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6323 LOP(OP_RENAME,XTERM);
6332 LOP(OP_RINDEX,XTERM);
6342 UNIDOR(OP_READLINE);
6355 LOP(OP_REVERSE,XTERM);
6358 UNIDOR(OP_READLINK);
6366 TERM(sublex_start());
6368 TOKEN(1); /* force error */
6371 checkcomma(s,PL_tokenbuf,"filehandle");
6381 LOP(OP_SELECT,XTERM);
6387 LOP(OP_SEMCTL,XTERM);
6390 LOP(OP_SEMGET,XTERM);
6393 LOP(OP_SEMOP,XTERM);
6399 LOP(OP_SETPGRP,XTERM);
6401 case KEY_setpriority:
6402 LOP(OP_SETPRIORITY,XTERM);
6404 case KEY_sethostent:
6410 case KEY_setservent:
6413 case KEY_setprotoent:
6423 LOP(OP_SEEKDIR,XTERM);
6425 case KEY_setsockopt:
6426 LOP(OP_SSOCKOPT,XTERM);
6432 LOP(OP_SHMCTL,XTERM);
6435 LOP(OP_SHMGET,XTERM);
6438 LOP(OP_SHMREAD,XTERM);
6441 LOP(OP_SHMWRITE,XTERM);
6444 LOP(OP_SHUTDOWN,XTERM);
6453 LOP(OP_SOCKET,XTERM);
6455 case KEY_socketpair:
6456 LOP(OP_SOCKPAIR,XTERM);
6459 checkcomma(s,PL_tokenbuf,"subroutine name");
6461 if (*s == ';' || *s == ')') /* probably a close */
6462 Perl_croak(aTHX_ "sort is now a reserved word");
6464 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6468 LOP(OP_SPLIT,XTERM);
6471 LOP(OP_SPRINTF,XTERM);
6474 LOP(OP_SPLICE,XTERM);
6489 LOP(OP_SUBSTR,XTERM);
6495 char tmpbuf[sizeof PL_tokenbuf];
6496 SSize_t tboffset = 0;
6497 expectation attrful;
6498 bool have_name, have_proto;
6499 const int key = tmp;
6504 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6505 SV *subtoken = newSVpvn(tstart, s - tstart);
6509 s = SKIPSPACE2(s,tmpwhite);
6514 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6515 (*s == ':' && s[1] == ':'))
6522 attrful = XATTRBLOCK;
6523 /* remember buffer pos'n for later force_word */
6524 tboffset = s - PL_oldbufptr;
6525 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6528 nametoke = newSVpvn(s, d - s);
6530 if (strchr(tmpbuf, ':'))
6531 sv_setpv(PL_subname, tmpbuf);
6533 sv_setsv(PL_subname,PL_curstname);
6534 sv_catpvs(PL_subname,"::");
6535 sv_catpvn(PL_subname,tmpbuf,len);
6542 CURMAD('X', nametoke);
6543 CURMAD('_', tmpwhite);
6544 (void) force_word(PL_oldbufptr + tboffset, WORD,
6547 s = SKIPSPACE2(d,tmpwhite);
6554 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6555 PL_expect = XTERMBLOCK;
6556 attrful = XATTRTERM;
6557 sv_setpvn(PL_subname,"?",1);
6561 if (key == KEY_format) {
6563 PL_lex_formbrack = PL_lex_brackets + 1;
6565 PL_thistoken = subtoken;
6569 (void) force_word(PL_oldbufptr + tboffset, WORD,
6575 /* Look for a prototype */
6578 s = scan_str(s,!!PL_madskills,FALSE);
6580 Perl_croak(aTHX_ "Prototype not terminated");
6581 /* strip spaces and check for bad characters */
6582 d = SvPVX(PL_lex_stuff);
6586 bool bad_proto = FALSE;
6587 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6588 for (p = d; *p; ++p) {
6591 if (warnsyntax && !strchr("$@%*;[]&\\", *p))
6597 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6598 "Illegal character in prototype for %"SVf" : %s",
6599 (void*)PL_subname, d);
6601 SvCUR_set(PL_lex_stuff, tmp);
6606 CURMAD('q', PL_thisopen);
6607 CURMAD('_', tmpwhite);
6608 CURMAD('=', PL_thisstuff);
6609 CURMAD('Q', PL_thisclose);
6610 NEXTVAL_NEXTTOKE.opval =
6611 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6612 PL_lex_stuff = Nullsv;
6615 s = SKIPSPACE2(s,tmpwhite);
6623 if (*s == ':' && s[1] != ':')
6624 PL_expect = attrful;
6625 else if (*s != '{' && key == KEY_sub) {
6627 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6629 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, (void*)PL_subname);
6636 curmad('^', newSVpvs(""));
6637 CURMAD('_', tmpwhite);
6641 PL_thistoken = subtoken;
6644 NEXTVAL_NEXTTOKE.opval =
6645 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6646 PL_lex_stuff = NULL;
6651 sv_setpv(PL_subname,
6653 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
6657 (void) force_word(PL_oldbufptr + tboffset, WORD,
6667 LOP(OP_SYSTEM,XREF);
6670 LOP(OP_SYMLINK,XTERM);
6673 LOP(OP_SYSCALL,XTERM);
6676 LOP(OP_SYSOPEN,XTERM);
6679 LOP(OP_SYSSEEK,XTERM);
6682 LOP(OP_SYSREAD,XTERM);
6685 LOP(OP_SYSWRITE,XTERM);
6689 TERM(sublex_start());
6710 LOP(OP_TRUNCATE,XTERM);
6722 yylval.ival = CopLINE(PL_curcop);
6726 yylval.ival = CopLINE(PL_curcop);
6730 LOP(OP_UNLINK,XTERM);
6736 LOP(OP_UNPACK,XTERM);
6739 LOP(OP_UTIME,XTERM);
6745 LOP(OP_UNSHIFT,XTERM);
6748 s = tokenize_use(1, s);
6758 yylval.ival = CopLINE(PL_curcop);
6762 yylval.ival = CopLINE(PL_curcop);
6766 PL_hints |= HINT_BLOCK_SCOPE;
6773 LOP(OP_WAITPID,XTERM);
6782 ctl_l[0] = toCTRL('L');
6784 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6787 /* Make sure $^L is defined */
6788 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6793 if (PL_expect == XOPERATOR)
6799 yylval.ival = OP_XOR;
6804 TERM(sublex_start());
6809 #pragma segment Main
6813 S_pending_ident(pTHX)
6818 /* pit holds the identifier we read and pending_ident is reset */
6819 char pit = PL_pending_ident;
6820 PL_pending_ident = 0;
6822 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6823 DEBUG_T({ PerlIO_printf(Perl_debug_log,
6824 "### Pending identifier '%s'\n", PL_tokenbuf); });
6826 /* if we're in a my(), we can't allow dynamics here.
6827 $foo'bar has already been turned into $foo::bar, so
6828 just check for colons.
6830 if it's a legal name, the OP is a PADANY.
6833 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
6834 if (strchr(PL_tokenbuf,':'))
6835 yyerror(Perl_form(aTHX_ "No package name allowed for "
6836 "variable %s in \"our\"",
6838 tmp = allocmy(PL_tokenbuf);
6841 if (strchr(PL_tokenbuf,':'))
6842 yyerror(Perl_form(aTHX_ PL_no_myglob,
6843 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
6845 yylval.opval = newOP(OP_PADANY, 0);
6846 yylval.opval->op_targ = allocmy(PL_tokenbuf);
6852 build the ops for accesses to a my() variable.
6854 Deny my($a) or my($b) in a sort block, *if* $a or $b is
6855 then used in a comparison. This catches most, but not
6856 all cases. For instance, it catches
6857 sort { my($a); $a <=> $b }
6859 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6860 (although why you'd do that is anyone's guess).
6863 if (!strchr(PL_tokenbuf,':')) {
6865 tmp = pad_findmy(PL_tokenbuf);
6866 if (tmp != NOT_IN_PAD) {
6867 /* might be an "our" variable" */
6868 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6869 /* build ops for a bareword */
6870 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
6871 HEK * const stashname = HvNAME_HEK(stash);
6872 SV * const sym = newSVhek(stashname);
6873 sv_catpvs(sym, "::");
6874 sv_catpv(sym, PL_tokenbuf+1);
6875 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6876 yylval.opval->op_private = OPpCONST_ENTERED;
6879 ? (GV_ADDMULTI | GV_ADDINEVAL)
6882 ((PL_tokenbuf[0] == '$') ? SVt_PV
6883 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6888 /* if it's a sort block and they're naming $a or $b */
6889 if (PL_last_lop_op == OP_SORT &&
6890 PL_tokenbuf[0] == '$' &&
6891 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
6894 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
6895 d < PL_bufend && *d != '\n';
6898 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
6899 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
6905 yylval.opval = newOP(OP_PADANY, 0);
6906 yylval.opval->op_targ = tmp;
6912 Whine if they've said @foo in a doublequoted string,
6913 and @foo isn't a variable we can find in the symbol
6916 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
6917 GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
6918 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
6919 && ckWARN(WARN_AMBIGUOUS))
6921 /* Downgraded from fatal to warning 20000522 mjd */
6922 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6923 "Possible unintended interpolation of %s in string",
6928 /* build ops for a bareword */
6929 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
6930 yylval.opval->op_private = OPpCONST_ENTERED;
6933 /* If the identifier refers to a stash, don't autovivify it.
6934 * Change 24660 had the side effect of causing symbol table
6935 * hashes to always be defined, even if they were freshly
6936 * created and the only reference in the entire program was
6937 * the single statement with the defined %foo::bar:: test.
6938 * It appears that all code in the wild doing this actually
6939 * wants to know whether sub-packages have been loaded, so
6940 * by avoiding auto-vivifying symbol tables, we ensure that
6941 * defined %foo::bar:: continues to be false, and the existing
6942 * tests still give the expected answers, even though what
6943 * they're actually testing has now changed subtly.
6945 (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
6947 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
6948 ((PL_tokenbuf[0] == '$') ? SVt_PV
6949 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6955 * The following code was generated by perl_keyword.pl.
6959 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
6964 case 1: /* 5 tokens of length 1 */
6996 case 2: /* 18 tokens of length 2 */
7142 case 3: /* 29 tokens of length 3 */
7146 if (name[1] == 'N' &&
7209 if (name[1] == 'i' &&
7231 return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7249 if (name[1] == 'o' &&
7258 if (name[1] == 'e' &&
7267 if (name[1] == 'n' &&
7276 if (name[1] == 'o' &&
7285 if (name[1] == 'a' &&
7294 if (name[1] == 'o' &&
7356 if (name[1] == 'e' &&
7370 return (all_keywords || FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
7396 if (name[1] == 'i' &&
7405 if (name[1] == 's' &&
7414 if (name[1] == 'e' &&
7423 if (name[1] == 'o' &&
7435 case 4: /* 41 tokens of length 4 */
7439 if (name[1] == 'O' &&
7449 if (name[1] == 'N' &&
7459 if (name[1] == 'i' &&
7469 if (name[1] == 'h' &&
7479 if (name[1] == 'u' &&
7492 if (name[2] == 'c' &&
7501 if (name[2] == 's' &&
7510 if (name[2] == 'a' &&
7546 if (name[1] == 'o' &&
7559 if (name[2] == 't' &&
7568 if (name[2] == 'o' &&
7577 if (name[2] == 't' &&
7586 if (name[2] == 'e' &&
7599 if (name[1] == 'o' &&
7612 if (name[2] == 'y' &&
7621 if (name[2] == 'l' &&
7637 if (name[2] == 's' &&
7646 if (name[2] == 'n' &&
7655 if (name[2] == 'c' &&
7668 if (name[1] == 'e' &&
7678 if (name[1] == 'p' &&
7691 if (name[2] == 'c' &&
7700 if (name[2] == 'p' &&
7709 if (name[2] == 's' &&
7725 if (name[2] == 'n' &&
7795 if (name[2] == 'r' &&
7804 if (name[2] == 'r' &&
7813 if (name[2] == 'a' &&
7829 if (name[2] == 'l' &&
7891 if (name[2] == 'e' &&
7894 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
7907 case 5: /* 39 tokens of length 5 */
7911 if (name[1] == 'E' &&
7922 if (name[1] == 'H' &&
7936 if (name[2] == 'a' &&
7946 if (name[2] == 'a' &&
7963 if (name[2] == 'e' &&
7973 if (name[2] == 'e' &&
7977 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
7993 if (name[3] == 'i' &&
8002 if (name[3] == 'o' &&
8038 if (name[2] == 'o' &&
8048 if (name[2] == 'y' &&
8062 if (name[1] == 'l' &&
8076 if (name[2] == 'n' &&
8086 if (name[2] == 'o' &&
8100 if (name[1] == 'i' &&
8105 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8114 if (name[2] == 'd' &&
8124 if (name[2] == 'c' &&
8141 if (name[2] == 'c' &&
8151 if (name[2] == 't' &&
8165 if (name[1] == 'k' &&
8176 if (name[1] == 'r' &&
8190 if (name[2] == 's' &&
8200 if (name[2] == 'd' &&
8217 if (name[2] == 'm' &&
8227 if (name[2] == 'i' &&
8237 if (name[2] == 'e' &&
8247 if (name[2] == 'l' &&
8257 if (name[2] == 'a' &&
8270 if (name[3] == 't' &&
8273 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8279 if (name[3] == 'd' &&
8296 if (name[1] == 'i' &&
8310 if (name[2] == 'a' &&
8323 if (name[3] == 'e' &&
8358 if (name[2] == 'i' &&
8375 if (name[2] == 'i' &&
8385 if (name[2] == 'i' &&
8402 case 6: /* 33 tokens of length 6 */
8406 if (name[1] == 'c' &&
8421 if (name[2] == 'l' &&
8432 if (name[2] == 'r' &&
8447 if (name[1] == 'e' &&
8462 if (name[2] == 's' &&
8467 if(ckWARN_d(WARN_SYNTAX))
8468 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8474 if (name[2] == 'i' &&
8492 if (name[2] == 'l' &&
8503 if (name[2] == 'r' &&
8518 if (name[1] == 'm' &&
8533 if (name[2] == 'n' &&
8544 if (name[2] == 's' &&
8559 if (name[1] == 's' &&
8565 if (name[4] == 't' &&
8574 if (name[4] == 'e' &&
8583 if (name[4] == 'c' &&
8592 if (name[4] == 'n' &&
8608 if (name[1] == 'r' &&
8626 if (name[3] == 'a' &&
8636 if (name[3] == 'u' &&
8650 if (name[2] == 'n' &&
8668 if (name[2] == 'a' &&
8682 if (name[3] == 'e' &&
8695 if (name[4] == 't' &&
8704 if (name[4] == 'e' &&
8726 if (name[4] == 't' &&
8735 if (name[4] == 'e' &&
8751 if (name[2] == 'c' &&
8762 if (name[2] == 'l' &&
8773 if (name[2] == 'b' &&
8784 if (name[2] == 's' &&
8807 if (name[4] == 's' &&
8816 if (name[4] == 'n' &&
8829 if (name[3] == 'a' &&
8846 if (name[1] == 'a' &&
8861 case 7: /* 29 tokens of length 7 */
8865 if (name[1] == 'E' &&
8878 if (name[1] == '_' &&
8891 if (name[1] == 'i' &&
8898 return -KEY_binmode;
8904 if (name[1] == 'o' &&
8911 return -KEY_connect;
8920 if (name[2] == 'm' &&
8926 return -KEY_dbmopen;
8937 if (name[4] == 'u' &&
8941 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
8947 if (name[4] == 'n' &&
8968 if (name[1] == 'o' &&
8981 if (name[1] == 'e' &&
8988 if (name[5] == 'r' &&
8991 return -KEY_getpgrp;
8997 if (name[5] == 'i' &&
9000 return -KEY_getppid;
9013 if (name[1] == 'c' &&
9020 return -KEY_lcfirst;
9026 if (name[1] == 'p' &&
9033 return -KEY_opendir;
9039 if (name[1] == 'a' &&
9057 if (name[3] == 'd' &&
9062 return -KEY_readdir;
9068 if (name[3] == 'u' &&
9079 if (name[3] == 'e' &&
9084 return -KEY_reverse;
9103 if (name[3] == 'k' &&
9108 return -KEY_seekdir;
9114 if (name[3] == 'p' &&
9119 return -KEY_setpgrp;
9129 if (name[2] == 'm' &&
9135 return -KEY_shmread;
9141 if (name[2] == 'r' &&
9147 return -KEY_sprintf;
9156 if (name[3] == 'l' &&
9161 return -KEY_symlink;
9170 if (name[4] == 'a' &&
9174 return -KEY_syscall;
9180 if (name[4] == 'p' &&
9184 return -KEY_sysopen;
9190 if (name[4] == 'e' &&
9194 return -KEY_sysread;
9200 if (name[4] == 'e' &&
9204 return -KEY_sysseek;
9222 if (name[1] == 'e' &&
9229 return -KEY_telldir;
9238 if (name[2] == 'f' &&
9244 return -KEY_ucfirst;
9250 if (name[2] == 's' &&
9256 return -KEY_unshift;
9266 if (name[1] == 'a' &&
9273 return -KEY_waitpid;
9282 case 8: /* 26 tokens of length 8 */
9286 if (name[1] == 'U' &&
9294 return KEY_AUTOLOAD;
9305 if (name[3] == 'A' &&
9311 return KEY___DATA__;
9317 if (name[3] == 'I' &&
9323 return -KEY___FILE__;
9329 if (name[3] == 'I' &&
9335 return -KEY___LINE__;
9351 if (name[2] == 'o' &&
9358 return -KEY_closedir;
9364 if (name[2] == 'n' &&
9371 return -KEY_continue;
9381 if (name[1] == 'b' &&
9389 return -KEY_dbmclose;
9395 if (name[1] == 'n' &&
9401 if (name[4] == 'r' &&
9406 return -KEY_endgrent;
9412 if (name[4] == 'w' &&
9417 return -KEY_endpwent;
9430 if (name[1] == 'o' &&
9438 return -KEY_formline;
9444 if (name[1] == 'e' &&
9455 if (name[6] == 'n' &&
9458 return -KEY_getgrent;
9464 if (name[6] == 'i' &&
9467 return -KEY_getgrgid;
9473 if (name[6] == 'a' &&
9476 return -KEY_getgrnam;
9489 if (name[4] == 'o' &&
9494 return -KEY_getlogin;
9505 if (name[6] == 'n' &&
9508 return -KEY_getpwent;
9514 if (name[6] == 'a' &&
9517 return -KEY_getpwnam;
9523 if (name[6] == 'i' &&
9526 return -KEY_getpwuid;
9546 if (name[1] == 'e' &&
9553 if (name[5] == 'i' &&
9560 return -KEY_readline;
9565 return -KEY_readlink;
9576 if (name[5] == 'i' &&
9580 return -KEY_readpipe;
9601 if (name[4] == 'r' &&
9606 return -KEY_setgrent;
9612 if (name[4] == 'w' &&
9617 return -KEY_setpwent;
9633 if (name[3] == 'w' &&
9639 return -KEY_shmwrite;
9645 if (name[3] == 't' &&
9651 return -KEY_shutdown;
9661 if (name[2] == 's' &&
9668 return -KEY_syswrite;
9678 if (name[1] == 'r' &&
9686 return -KEY_truncate;
9695 case 9: /* 8 tokens of length 9 */
9699 if (name[1] == 'n' &&
9708 return -KEY_endnetent;
9714 if (name[1] == 'e' &&
9723 return -KEY_getnetent;
9729 if (name[1] == 'o' &&
9738 return -KEY_localtime;
9744 if (name[1] == 'r' &&
9753 return KEY_prototype;
9759 if (name[1] == 'u' &&
9768 return -KEY_quotemeta;
9774 if (name[1] == 'e' &&
9783 return -KEY_rewinddir;
9789 if (name[1] == 'e' &&
9798 return -KEY_setnetent;
9804 if (name[1] == 'a' &&
9813 return -KEY_wantarray;
9822 case 10: /* 9 tokens of length 10 */
9826 if (name[1] == 'n' &&
9832 if (name[4] == 'o' &&
9839 return -KEY_endhostent;
9845 if (name[4] == 'e' &&
9852 return -KEY_endservent;
9865 if (name[1] == 'e' &&
9871 if (name[4] == 'o' &&
9878 return -KEY_gethostent;
9887 if (name[5] == 'r' &&
9893 return -KEY_getservent;
9899 if (name[5] == 'c' &&
9905 return -KEY_getsockopt;
9930 if (name[4] == 'o' &&
9937 return -KEY_sethostent;
9946 if (name[5] == 'r' &&
9952 return -KEY_setservent;
9958 if (name[5] == 'c' &&
9964 return -KEY_setsockopt;
9981 if (name[2] == 'c' &&
9990 return -KEY_socketpair;
10003 case 11: /* 8 tokens of length 11 */
10007 if (name[1] == '_' &&
10017 { /* __PACKAGE__ */
10018 return -KEY___PACKAGE__;
10024 if (name[1] == 'n' &&
10034 { /* endprotoent */
10035 return -KEY_endprotoent;
10041 if (name[1] == 'e' &&
10050 if (name[5] == 'e' &&
10056 { /* getpeername */
10057 return -KEY_getpeername;
10066 if (name[6] == 'o' &&
10071 { /* getpriority */
10072 return -KEY_getpriority;
10078 if (name[6] == 't' &&
10083 { /* getprotoent */
10084 return -KEY_getprotoent;
10098 if (name[4] == 'o' &&
10105 { /* getsockname */
10106 return -KEY_getsockname;
10119 if (name[1] == 'e' &&
10127 if (name[6] == 'o' &&
10132 { /* setpriority */
10133 return -KEY_setpriority;
10139 if (name[6] == 't' &&
10144 { /* setprotoent */
10145 return -KEY_setprotoent;
10161 case 12: /* 2 tokens of length 12 */
10162 if (name[0] == 'g' &&
10174 if (name[9] == 'd' &&
10177 { /* getnetbyaddr */
10178 return -KEY_getnetbyaddr;
10184 if (name[9] == 'a' &&
10187 { /* getnetbyname */
10188 return -KEY_getnetbyname;
10200 case 13: /* 4 tokens of length 13 */
10201 if (name[0] == 'g' &&
10208 if (name[4] == 'o' &&
10217 if (name[10] == 'd' &&
10220 { /* gethostbyaddr */
10221 return -KEY_gethostbyaddr;
10227 if (name[10] == 'a' &&
10230 { /* gethostbyname */
10231 return -KEY_gethostbyname;
10244 if (name[4] == 'e' &&
10253 if (name[10] == 'a' &&
10256 { /* getservbyname */
10257 return -KEY_getservbyname;
10263 if (name[10] == 'o' &&
10266 { /* getservbyport */
10267 return -KEY_getservbyport;
10286 case 14: /* 1 tokens of length 14 */
10287 if (name[0] == 'g' &&
10301 { /* getprotobyname */
10302 return -KEY_getprotobyname;
10307 case 16: /* 1 tokens of length 16 */
10308 if (name[0] == 'g' &&
10324 { /* getprotobynumber */
10325 return -KEY_getprotobynumber;
10339 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10343 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10344 if (ckWARN(WARN_SYNTAX)) {
10347 for (w = s+2; *w && level; w++) {
10350 else if (*w == ')')
10353 while (isSPACE(*w))
10355 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
10356 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10357 "%s (...) interpreted as function",name);
10360 while (s < PL_bufend && isSPACE(*s))
10364 while (s < PL_bufend && isSPACE(*s))
10366 if (isIDFIRST_lazy_if(s,UTF)) {
10367 const char * const w = s++;
10368 while (isALNUM_lazy_if(s,UTF))
10370 while (s < PL_bufend && isSPACE(*s))
10374 if (keyword(w, s - w, 0))
10377 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10378 if (gv && GvCVu(gv))
10380 Perl_croak(aTHX_ "No comma allowed after %s", what);
10385 /* Either returns sv, or mortalizes sv and returns a new SV*.
10386 Best used as sv=new_constant(..., sv, ...).
10387 If s, pv are NULL, calls subroutine with one argument,
10388 and type is used with error messages only. */
10391 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10395 HV * const table = GvHV(PL_hintgv); /* ^H */
10399 const char *why1 = "", *why2 = "", *why3 = "";
10401 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10404 why2 = (const char *)
10405 (strEQ(key,"charnames")
10406 ? "(possibly a missing \"use charnames ...\")"
10408 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10409 (type ? type: "undef"), why2);
10411 /* This is convoluted and evil ("goto considered harmful")
10412 * but I do not understand the intricacies of all the different
10413 * failure modes of %^H in here. The goal here is to make
10414 * the most probable error message user-friendly. --jhi */
10419 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10420 (type ? type: "undef"), why1, why2, why3);
10422 yyerror(SvPVX_const(msg));
10426 cvp = hv_fetch(table, key, strlen(key), FALSE);
10427 if (!cvp || !SvOK(*cvp)) {
10430 why3 = "} is not defined";
10433 sv_2mortal(sv); /* Parent created it permanently */
10436 pv = sv_2mortal(newSVpvn(s, len));
10438 typesv = sv_2mortal(newSVpv(type, 0));
10440 typesv = &PL_sv_undef;
10442 PUSHSTACKi(PERLSI_OVERLOAD);
10454 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10458 /* Check the eval first */
10459 if (!PL_in_eval && SvTRUE(ERRSV)) {
10460 sv_catpvs(ERRSV, "Propagated");
10461 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10463 res = SvREFCNT_inc_simple(sv);
10467 SvREFCNT_inc_simple_void(res);
10476 why1 = "Call to &{$^H{";
10478 why3 = "}} did not return a defined value";
10486 /* Returns a NUL terminated string, with the length of the string written to
10490 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10493 register char *d = dest;
10494 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10497 Perl_croak(aTHX_ ident_too_long);
10498 if (isALNUM(*s)) /* UTF handled below */
10500 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10505 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10509 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10510 char *t = s + UTF8SKIP(s);
10512 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10516 Perl_croak(aTHX_ ident_too_long);
10517 Copy(s, d, len, char);
10530 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10533 char *bracket = NULL;
10535 register char *d = dest;
10536 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10541 while (isDIGIT(*s)) {
10543 Perl_croak(aTHX_ ident_too_long);
10550 Perl_croak(aTHX_ ident_too_long);
10551 if (isALNUM(*s)) /* UTF handled below */
10553 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10558 else if (*s == ':' && s[1] == ':') {
10562 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10563 char *t = s + UTF8SKIP(s);
10564 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10566 if (d + (t - s) > e)
10567 Perl_croak(aTHX_ ident_too_long);
10568 Copy(s, d, t - s, char);
10579 if (PL_lex_state != LEX_NORMAL)
10580 PL_lex_state = LEX_INTERPENDMAYBE;
10583 if (*s == '$' && s[1] &&
10584 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10597 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10602 if (isSPACE(s[-1])) {
10604 const char ch = *s++;
10605 if (!SPACE_OR_TAB(ch)) {
10611 if (isIDFIRST_lazy_if(d,UTF)) {
10615 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10616 end += UTF8SKIP(end);
10617 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10618 end += UTF8SKIP(end);
10620 Copy(s, d, end - s, char);
10625 while ((isALNUM(*s) || *s == ':') && d < e)
10628 Perl_croak(aTHX_ ident_too_long);
10631 while (s < send && SPACE_OR_TAB(*s))
10633 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10634 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10635 const char * const brack =
10637 ((*s == '[') ? "[...]" : "{...}");
10638 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10639 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10640 funny, dest, brack, funny, dest, brack);
10643 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10647 /* Handle extended ${^Foo} variables
10648 * 1999-02-27 mjd-perl-patch@plover.com */
10649 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10653 while (isALNUM(*s) && d < e) {
10657 Perl_croak(aTHX_ ident_too_long);
10662 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10663 PL_lex_state = LEX_INTERPEND;
10666 if (PL_lex_state == LEX_NORMAL) {
10667 if (ckWARN(WARN_AMBIGUOUS) &&
10668 (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
10672 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10673 "Ambiguous use of %c{%s} resolved to %c%s",
10674 funny, dest, funny, dest);
10679 s = bracket; /* let the parser handle it */
10683 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10684 PL_lex_state = LEX_INTERPEND;
10689 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10691 PERL_UNUSED_CONTEXT;
10694 else if (ch == 'g')
10695 *pmfl |= PMf_GLOBAL;
10696 else if (ch == 'c')
10697 *pmfl |= PMf_CONTINUE;
10698 else if (ch == 'o')
10700 else if (ch == 'm')
10701 *pmfl |= PMf_MULTILINE;
10702 else if (ch == 's')
10703 *pmfl |= PMf_SINGLELINE;
10704 else if (ch == 'x')
10705 *pmfl |= PMf_EXTENDED;
10709 S_scan_pat(pTHX_ char *start, I32 type)
10713 char *s = scan_str(start,!!PL_madskills,FALSE);
10714 const char * const valid_flags =
10715 (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
10722 const char * const delimiter = skipspace(start);
10726 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10727 : "Search pattern not terminated" ));
10730 pm = (PMOP*)newPMOP(type, 0);
10731 if (PL_multi_open == '?')
10732 pm->op_pmflags |= PMf_ONCE;
10736 while (*s && strchr(valid_flags, *s))
10737 pmflag(&pm->op_pmflags,*s++);
10739 if (PL_madskills && modstart != s) {
10740 SV* tmptoken = newSVpvn(modstart, s - modstart);
10741 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10744 /* issue a warning if /c is specified,but /g is not */
10745 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10746 && ckWARN(WARN_REGEXP))
10748 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
10751 pm->op_pmpermflags = pm->op_pmflags;
10753 PL_lex_op = (OP*)pm;
10754 yylval.ival = OP_MATCH;
10759 S_scan_subst(pTHX_ char *start)
10770 yylval.ival = OP_NULL;
10772 s = scan_str(start,!!PL_madskills,FALSE);
10775 Perl_croak(aTHX_ "Substitution pattern not terminated");
10777 if (s[-1] == PL_multi_open)
10780 if (PL_madskills) {
10781 CURMAD('q', PL_thisopen);
10782 CURMAD('_', PL_thiswhite);
10783 CURMAD('E', PL_thisstuff);
10784 CURMAD('Q', PL_thisclose);
10785 PL_realtokenstart = s - SvPVX(PL_linestr);
10789 first_start = PL_multi_start;
10790 s = scan_str(s,!!PL_madskills,FALSE);
10792 if (PL_lex_stuff) {
10793 SvREFCNT_dec(PL_lex_stuff);
10794 PL_lex_stuff = NULL;
10796 Perl_croak(aTHX_ "Substitution replacement not terminated");
10798 PL_multi_start = first_start; /* so whole substitution is taken together */
10800 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10803 if (PL_madskills) {
10804 CURMAD('z', PL_thisopen);
10805 CURMAD('R', PL_thisstuff);
10806 CURMAD('Z', PL_thisclose);
10816 else if (strchr("iogcmsx", *s))
10817 pmflag(&pm->op_pmflags,*s++);
10823 if (PL_madskills) {
10825 curmad('m', newSVpvn(modstart, s - modstart));
10826 append_madprops(PL_thismad, (OP*)pm, 0);
10830 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10831 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10835 SV * const repl = newSVpvs("");
10837 PL_sublex_info.super_bufptr = s;
10838 PL_sublex_info.super_bufend = PL_bufend;
10840 pm->op_pmflags |= PMf_EVAL;
10842 sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10843 sv_catpvs(repl, "{");
10844 sv_catsv(repl, PL_lex_repl);
10845 if (strchr(SvPVX(PL_lex_repl), '#'))
10846 sv_catpvs(repl, "\n");
10847 sv_catpvs(repl, "}");
10849 SvREFCNT_dec(PL_lex_repl);
10850 PL_lex_repl = repl;
10853 pm->op_pmpermflags = pm->op_pmflags;
10854 PL_lex_op = (OP*)pm;
10855 yylval.ival = OP_SUBST;
10860 S_scan_trans(pTHX_ char *start)
10873 yylval.ival = OP_NULL;
10875 s = scan_str(start,!!PL_madskills,FALSE);
10877 Perl_croak(aTHX_ "Transliteration pattern not terminated");
10879 if (s[-1] == PL_multi_open)
10882 if (PL_madskills) {
10883 CURMAD('q', PL_thisopen);
10884 CURMAD('_', PL_thiswhite);
10885 CURMAD('E', PL_thisstuff);
10886 CURMAD('Q', PL_thisclose);
10887 PL_realtokenstart = s - SvPVX(PL_linestr);
10891 s = scan_str(s,!!PL_madskills,FALSE);
10893 if (PL_lex_stuff) {
10894 SvREFCNT_dec(PL_lex_stuff);
10895 PL_lex_stuff = NULL;
10897 Perl_croak(aTHX_ "Transliteration replacement not terminated");
10899 if (PL_madskills) {
10900 CURMAD('z', PL_thisopen);
10901 CURMAD('R', PL_thisstuff);
10902 CURMAD('Z', PL_thisclose);
10905 complement = del = squash = 0;
10912 complement = OPpTRANS_COMPLEMENT;
10915 del = OPpTRANS_DELETE;
10918 squash = OPpTRANS_SQUASH;
10927 Newx(tbl, complement&&!del?258:256, short);
10928 o = newPVOP(OP_TRANS, 0, (char*)tbl);
10929 o->op_private &= ~OPpTRANS_ALL;
10930 o->op_private |= del|squash|complement|
10931 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
10932 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
10935 yylval.ival = OP_TRANS;
10938 if (PL_madskills) {
10940 curmad('m', newSVpvn(modstart, s - modstart));
10941 append_madprops(PL_thismad, o, 0);
10950 S_scan_heredoc(pTHX_ register char *s)
10954 I32 op_type = OP_SCALAR;
10958 const char *found_newline;
10962 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
10964 I32 stuffstart = s - SvPVX(PL_linestr);
10967 PL_realtokenstart = -1;
10972 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
10976 while (SPACE_OR_TAB(*peek))
10978 if (*peek == '`' || *peek == '\'' || *peek =='"') {
10981 s = delimcpy(d, e, s, PL_bufend, term, &len);
10991 if (!isALNUM_lazy_if(s,UTF))
10992 deprecate_old("bare << to mean <<\"\"");
10993 for (; isALNUM_lazy_if(s,UTF); s++) {
10998 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10999 Perl_croak(aTHX_ "Delimiter for here document is too long");
11002 len = d - PL_tokenbuf;
11005 if (PL_madskills) {
11006 tstart = PL_tokenbuf + !outer;
11007 PL_thisclose = newSVpvn(tstart, len - !outer);
11008 tstart = SvPVX(PL_linestr) + stuffstart;
11009 PL_thisopen = newSVpvn(tstart, s - tstart);
11010 stuffstart = s - SvPVX(PL_linestr);
11013 #ifndef PERL_STRICT_CR
11014 d = strchr(s, '\r');
11016 char * const olds = s;
11018 while (s < PL_bufend) {
11024 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11033 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11040 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11041 herewas = newSVpvn(s,PL_bufend-s);
11045 herewas = newSVpvn(s-1,found_newline-s+1);
11048 herewas = newSVpvn(s,found_newline-s);
11052 if (PL_madskills) {
11053 tstart = SvPVX(PL_linestr) + stuffstart;
11055 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11057 PL_thisstuff = newSVpvn(tstart, s - tstart);
11060 s += SvCUR(herewas);
11063 stuffstart = s - SvPVX(PL_linestr);
11069 tmpstr = newSV(79);
11070 sv_upgrade(tmpstr, SVt_PVIV);
11071 if (term == '\'') {
11072 op_type = OP_CONST;
11073 SvIV_set(tmpstr, -1);
11075 else if (term == '`') {
11076 op_type = OP_BACKTICK;
11077 SvIV_set(tmpstr, '\\');
11081 PL_multi_start = CopLINE(PL_curcop);
11082 PL_multi_open = PL_multi_close = '<';
11083 term = *PL_tokenbuf;
11084 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11085 char * const bufptr = PL_sublex_info.super_bufptr;
11086 char * const bufend = PL_sublex_info.super_bufend;
11087 char * const olds = s - SvCUR(herewas);
11088 s = strchr(bufptr, '\n');
11092 while (s < bufend &&
11093 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11095 CopLINE_inc(PL_curcop);
11098 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11099 missingterm(PL_tokenbuf);
11101 sv_setpvn(herewas,bufptr,d-bufptr+1);
11102 sv_setpvn(tmpstr,d+1,s-d);
11104 sv_catpvn(herewas,s,bufend-s);
11105 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11112 while (s < PL_bufend &&
11113 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11115 CopLINE_inc(PL_curcop);
11117 if (s >= PL_bufend) {
11118 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11119 missingterm(PL_tokenbuf);
11121 sv_setpvn(tmpstr,d+1,s-d);
11123 if (PL_madskills) {
11125 sv_catpvn(PL_thisstuff, d + 1, s - d);
11127 PL_thisstuff = newSVpvn(d + 1, s - d);
11128 stuffstart = s - SvPVX(PL_linestr);
11132 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11134 sv_catpvn(herewas,s,PL_bufend-s);
11135 sv_setsv(PL_linestr,herewas);
11136 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11137 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11138 PL_last_lop = PL_last_uni = NULL;
11141 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
11142 while (s >= PL_bufend) { /* multiple line string? */
11144 if (PL_madskills) {
11145 tstart = SvPVX(PL_linestr) + stuffstart;
11147 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11149 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11153 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11154 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11155 missingterm(PL_tokenbuf);
11158 stuffstart = s - SvPVX(PL_linestr);
11160 CopLINE_inc(PL_curcop);
11161 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11162 PL_last_lop = PL_last_uni = NULL;
11163 #ifndef PERL_STRICT_CR
11164 if (PL_bufend - PL_linestart >= 2) {
11165 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11166 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11168 PL_bufend[-2] = '\n';
11170 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11172 else if (PL_bufend[-1] == '\r')
11173 PL_bufend[-1] = '\n';
11175 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11176 PL_bufend[-1] = '\n';
11178 if (PERLDB_LINE && PL_curstash != PL_debstash) {
11179 SV * const sv = newSV(0);
11181 sv_upgrade(sv, SVt_PVMG);
11182 sv_setsv(sv,PL_linestr);
11183 (void)SvIOK_on(sv);
11185 av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
11187 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11188 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11189 *(SvPVX(PL_linestr) + off ) = ' ';
11190 sv_catsv(PL_linestr,herewas);
11191 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11192 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11196 sv_catsv(tmpstr,PL_linestr);
11201 PL_multi_end = CopLINE(PL_curcop);
11202 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11203 SvPV_shrink_to_cur(tmpstr);
11205 SvREFCNT_dec(herewas);
11207 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11209 else if (PL_encoding)
11210 sv_recode_to_utf8(tmpstr, PL_encoding);
11212 PL_lex_stuff = tmpstr;
11213 yylval.ival = op_type;
11217 /* scan_inputsymbol
11218 takes: current position in input buffer
11219 returns: new position in input buffer
11220 side-effects: yylval and lex_op are set.
11225 <FH> read from filehandle
11226 <pkg::FH> read from package qualified filehandle
11227 <pkg'FH> read from package qualified filehandle
11228 <$fh> read from filehandle in $fh
11229 <*.h> filename glob
11234 S_scan_inputsymbol(pTHX_ char *start)
11237 register char *s = start; /* current position in buffer */
11241 char *d = PL_tokenbuf; /* start of temp holding space */
11242 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11244 end = strchr(s, '\n');
11247 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11249 /* die if we didn't have space for the contents of the <>,
11250 or if it didn't end, or if we see a newline
11253 if (len >= (I32)sizeof PL_tokenbuf)
11254 Perl_croak(aTHX_ "Excessively long <> operator");
11256 Perl_croak(aTHX_ "Unterminated <> operator");
11261 Remember, only scalar variables are interpreted as filehandles by
11262 this code. Anything more complex (e.g., <$fh{$num}>) will be
11263 treated as a glob() call.
11264 This code makes use of the fact that except for the $ at the front,
11265 a scalar variable and a filehandle look the same.
11267 if (*d == '$' && d[1]) d++;
11269 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11270 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11273 /* If we've tried to read what we allow filehandles to look like, and
11274 there's still text left, then it must be a glob() and not a getline.
11275 Use scan_str to pull out the stuff between the <> and treat it
11276 as nothing more than a string.
11279 if (d - PL_tokenbuf != len) {
11280 yylval.ival = OP_GLOB;
11282 s = scan_str(start,!!PL_madskills,FALSE);
11284 Perl_croak(aTHX_ "Glob not terminated");
11288 bool readline_overriden = FALSE;
11291 /* we're in a filehandle read situation */
11294 /* turn <> into <ARGV> */
11296 Copy("ARGV",d,5,char);
11298 /* Check whether readline() is overriden */
11299 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11301 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11303 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11304 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
11305 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11306 readline_overriden = TRUE;
11308 /* if <$fh>, create the ops to turn the variable into a
11312 /* try to find it in the pad for this block, otherwise find
11313 add symbol table ops
11315 const PADOFFSET tmp = pad_findmy(d);
11316 if (tmp != NOT_IN_PAD) {
11317 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11318 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11319 HEK * const stashname = HvNAME_HEK(stash);
11320 SV * const sym = sv_2mortal(newSVhek(stashname));
11321 sv_catpvs(sym, "::");
11322 sv_catpv(sym, d+1);
11327 OP * const o = newOP(OP_PADSV, 0);
11329 PL_lex_op = readline_overriden
11330 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11331 append_elem(OP_LIST, o,
11332 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11333 : (OP*)newUNOP(OP_READLINE, 0, o);
11342 ? (GV_ADDMULTI | GV_ADDINEVAL)
11345 PL_lex_op = readline_overriden
11346 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11347 append_elem(OP_LIST,
11348 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11349 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11350 : (OP*)newUNOP(OP_READLINE, 0,
11351 newUNOP(OP_RV2SV, 0,
11352 newGVOP(OP_GV, 0, gv)));
11354 if (!readline_overriden)
11355 PL_lex_op->op_flags |= OPf_SPECIAL;
11356 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11357 yylval.ival = OP_NULL;
11360 /* If it's none of the above, it must be a literal filehandle
11361 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11363 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11364 PL_lex_op = readline_overriden
11365 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11366 append_elem(OP_LIST,
11367 newGVOP(OP_GV, 0, gv),
11368 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11369 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11370 yylval.ival = OP_NULL;
11379 takes: start position in buffer
11380 keep_quoted preserve \ on the embedded delimiter(s)
11381 keep_delims preserve the delimiters around the string
11382 returns: position to continue reading from buffer
11383 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11384 updates the read buffer.
11386 This subroutine pulls a string out of the input. It is called for:
11387 q single quotes q(literal text)
11388 ' single quotes 'literal text'
11389 qq double quotes qq(interpolate $here please)
11390 " double quotes "interpolate $here please"
11391 qx backticks qx(/bin/ls -l)
11392 ` backticks `/bin/ls -l`
11393 qw quote words @EXPORT_OK = qw( func() $spam )
11394 m// regexp match m/this/
11395 s/// regexp substitute s/this/that/
11396 tr/// string transliterate tr/this/that/
11397 y/// string transliterate y/this/that/
11398 ($*@) sub prototypes sub foo ($)
11399 (stuff) sub attr parameters sub foo : attr(stuff)
11400 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11402 In most of these cases (all but <>, patterns and transliterate)
11403 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11404 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11405 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11408 It skips whitespace before the string starts, and treats the first
11409 character as the delimiter. If the delimiter is one of ([{< then
11410 the corresponding "close" character )]}> is used as the closing
11411 delimiter. It allows quoting of delimiters, and if the string has
11412 balanced delimiters ([{<>}]) it allows nesting.
11414 On success, the SV with the resulting string is put into lex_stuff or,
11415 if that is already non-NULL, into lex_repl. The second case occurs only
11416 when parsing the RHS of the special constructs s/// and tr/// (y///).
11417 For convenience, the terminating delimiter character is stuffed into
11422 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11425 SV *sv; /* scalar value: string */
11426 const char *tmps; /* temp string, used for delimiter matching */
11427 register char *s = start; /* current position in the buffer */
11428 register char term; /* terminating character */
11429 register char *to; /* current position in the sv's data */
11430 I32 brackets = 1; /* bracket nesting level */
11431 bool has_utf8 = FALSE; /* is there any utf8 content? */
11432 I32 termcode; /* terminating char. code */
11433 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11434 STRLEN termlen; /* length of terminating string */
11435 char *last = NULL; /* last position for nesting bracket */
11441 /* skip space before the delimiter */
11447 if (PL_realtokenstart >= 0) {
11448 stuffstart = PL_realtokenstart;
11449 PL_realtokenstart = -1;
11452 stuffstart = start - SvPVX(PL_linestr);
11454 /* mark where we are, in case we need to report errors */
11457 /* after skipping whitespace, the next character is the terminator */
11460 termcode = termstr[0] = term;
11464 termcode = utf8_to_uvchr((U8*)s, &termlen);
11465 Copy(s, termstr, termlen, U8);
11466 if (!UTF8_IS_INVARIANT(term))
11470 /* mark where we are */
11471 PL_multi_start = CopLINE(PL_curcop);
11472 PL_multi_open = term;
11474 /* find corresponding closing delimiter */
11475 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11476 termcode = termstr[0] = term = tmps[5];
11478 PL_multi_close = term;
11480 /* create a new SV to hold the contents. 79 is the SV's initial length.
11481 What a random number. */
11483 sv_upgrade(sv, SVt_PVIV);
11484 SvIV_set(sv, termcode);
11485 (void)SvPOK_only(sv); /* validate pointer */
11487 /* move past delimiter and try to read a complete string */
11489 sv_catpvn(sv, s, termlen);
11492 tstart = SvPVX(PL_linestr) + stuffstart;
11493 if (!PL_thisopen && !keep_delims) {
11494 PL_thisopen = newSVpvn(tstart, s - tstart);
11495 stuffstart = s - SvPVX(PL_linestr);
11499 if (PL_encoding && !UTF) {
11503 int offset = s - SvPVX_const(PL_linestr);
11504 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11505 &offset, (char*)termstr, termlen);
11506 const char * const ns = SvPVX_const(PL_linestr) + offset;
11507 char * const svlast = SvEND(sv) - 1;
11509 for (; s < ns; s++) {
11510 if (*s == '\n' && !PL_rsfp)
11511 CopLINE_inc(PL_curcop);
11514 goto read_more_line;
11516 /* handle quoted delimiters */
11517 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11519 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11521 if ((svlast-1 - t) % 2) {
11522 if (!keep_quoted) {
11523 *(svlast-1) = term;
11525 SvCUR_set(sv, SvCUR(sv) - 1);
11530 if (PL_multi_open == PL_multi_close) {
11538 for (t = w = last; t < svlast; w++, t++) {
11539 /* At here, all closes are "was quoted" one,
11540 so we don't check PL_multi_close. */
11542 if (!keep_quoted && *(t+1) == PL_multi_open)
11547 else if (*t == PL_multi_open)
11555 SvCUR_set(sv, w - SvPVX_const(sv));
11558 if (--brackets <= 0)
11563 if (!keep_delims) {
11564 SvCUR_set(sv, SvCUR(sv) - 1);
11570 /* extend sv if need be */
11571 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11572 /* set 'to' to the next character in the sv's string */
11573 to = SvPVX(sv)+SvCUR(sv);
11575 /* if open delimiter is the close delimiter read unbridle */
11576 if (PL_multi_open == PL_multi_close) {
11577 for (; s < PL_bufend; s++,to++) {
11578 /* embedded newlines increment the current line number */
11579 if (*s == '\n' && !PL_rsfp)
11580 CopLINE_inc(PL_curcop);
11581 /* handle quoted delimiters */
11582 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11583 if (!keep_quoted && s[1] == term)
11585 /* any other quotes are simply copied straight through */
11589 /* terminate when run out of buffer (the for() condition), or
11590 have found the terminator */
11591 else if (*s == term) {
11594 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11597 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11603 /* if the terminator isn't the same as the start character (e.g.,
11604 matched brackets), we have to allow more in the quoting, and
11605 be prepared for nested brackets.
11608 /* read until we run out of string, or we find the terminator */
11609 for (; s < PL_bufend; s++,to++) {
11610 /* embedded newlines increment the line count */
11611 if (*s == '\n' && !PL_rsfp)
11612 CopLINE_inc(PL_curcop);
11613 /* backslashes can escape the open or closing characters */
11614 if (*s == '\\' && s+1 < PL_bufend) {
11615 if (!keep_quoted &&
11616 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11621 /* allow nested opens and closes */
11622 else if (*s == PL_multi_close && --brackets <= 0)
11624 else if (*s == PL_multi_open)
11626 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11631 /* terminate the copied string and update the sv's end-of-string */
11633 SvCUR_set(sv, to - SvPVX_const(sv));
11636 * this next chunk reads more into the buffer if we're not done yet
11640 break; /* handle case where we are done yet :-) */
11642 #ifndef PERL_STRICT_CR
11643 if (to - SvPVX_const(sv) >= 2) {
11644 if ((to[-2] == '\r' && to[-1] == '\n') ||
11645 (to[-2] == '\n' && to[-1] == '\r'))
11649 SvCUR_set(sv, to - SvPVX_const(sv));
11651 else if (to[-1] == '\r')
11654 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11659 /* if we're out of file, or a read fails, bail and reset the current
11660 line marker so we can report where the unterminated string began
11663 if (PL_madskills) {
11664 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11666 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11668 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11672 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11674 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11680 /* we read a line, so increment our line counter */
11681 CopLINE_inc(PL_curcop);
11683 /* update debugger info */
11684 if (PERLDB_LINE && PL_curstash != PL_debstash) {
11685 SV * const line_sv = newSV(0);
11687 sv_upgrade(line_sv, SVt_PVMG);
11688 sv_setsv(line_sv,PL_linestr);
11689 (void)SvIOK_on(line_sv);
11690 SvIV_set(line_sv, 0);
11691 av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv);
11694 /* having changed the buffer, we must update PL_bufend */
11695 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11696 PL_last_lop = PL_last_uni = NULL;
11699 /* at this point, we have successfully read the delimited string */
11701 if (!PL_encoding || UTF) {
11703 if (PL_madskills) {
11704 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11705 const int len = s - start;
11707 sv_catpvn(PL_thisstuff, tstart, len);
11709 PL_thisstuff = newSVpvn(tstart, len);
11710 if (!PL_thisclose && !keep_delims)
11711 PL_thisclose = newSVpvn(s,termlen);
11716 sv_catpvn(sv, s, termlen);
11721 if (PL_madskills) {
11722 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11723 const int len = s - tstart - termlen;
11725 sv_catpvn(PL_thisstuff, tstart, len);
11727 PL_thisstuff = newSVpvn(tstart, len);
11728 if (!PL_thisclose && !keep_delims)
11729 PL_thisclose = newSVpvn(s - termlen,termlen);
11733 if (has_utf8 || PL_encoding)
11736 PL_multi_end = CopLINE(PL_curcop);
11738 /* if we allocated too much space, give some back */
11739 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11740 SvLEN_set(sv, SvCUR(sv) + 1);
11741 SvPV_renew(sv, SvLEN(sv));
11744 /* decide whether this is the first or second quoted string we've read
11757 takes: pointer to position in buffer
11758 returns: pointer to new position in buffer
11759 side-effects: builds ops for the constant in yylval.op
11761 Read a number in any of the formats that Perl accepts:
11763 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11764 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11767 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11769 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11772 If it reads a number without a decimal point or an exponent, it will
11773 try converting the number to an integer and see if it can do so
11774 without loss of precision.
11778 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11781 register const char *s = start; /* current position in buffer */
11782 register char *d; /* destination in temp buffer */
11783 register char *e; /* end of temp buffer */
11784 NV nv; /* number read, as a double */
11785 SV *sv = NULL; /* place to put the converted number */
11786 bool floatit; /* boolean: int or float? */
11787 const char *lastub = NULL; /* position of last underbar */
11788 static char const number_too_long[] = "Number too long";
11790 /* We use the first character to decide what type of number this is */
11794 Perl_croak(aTHX_ "panic: scan_num");
11796 /* if it starts with a 0, it could be an octal number, a decimal in
11797 0.13 disguise, or a hexadecimal number, or a binary number. */
11801 u holds the "number so far"
11802 shift the power of 2 of the base
11803 (hex == 4, octal == 3, binary == 1)
11804 overflowed was the number more than we can hold?
11806 Shift is used when we add a digit. It also serves as an "are
11807 we in octal/hex/binary?" indicator to disallow hex characters
11808 when in octal mode.
11813 bool overflowed = FALSE;
11814 bool just_zero = TRUE; /* just plain 0 or binary number? */
11815 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11816 static const char* const bases[5] =
11817 { "", "binary", "", "octal", "hexadecimal" };
11818 static const char* const Bases[5] =
11819 { "", "Binary", "", "Octal", "Hexadecimal" };
11820 static const char* const maxima[5] =
11822 "0b11111111111111111111111111111111",
11826 const char *base, *Base, *max;
11828 /* check for hex */
11833 } else if (s[1] == 'b') {
11838 /* check for a decimal in disguise */
11839 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11841 /* so it must be octal */
11848 if (ckWARN(WARN_SYNTAX))
11849 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11850 "Misplaced _ in number");
11854 base = bases[shift];
11855 Base = Bases[shift];
11856 max = maxima[shift];
11858 /* read the rest of the number */
11860 /* x is used in the overflow test,
11861 b is the digit we're adding on. */
11866 /* if we don't mention it, we're done */
11870 /* _ are ignored -- but warned about if consecutive */
11872 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11873 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11874 "Misplaced _ in number");
11878 /* 8 and 9 are not octal */
11879 case '8': case '9':
11881 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11885 case '2': case '3': case '4':
11886 case '5': case '6': case '7':
11888 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11891 case '0': case '1':
11892 b = *s++ & 15; /* ASCII digit -> value of digit */
11896 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11897 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11898 /* make sure they said 0x */
11901 b = (*s++ & 7) + 9;
11903 /* Prepare to put the digit we have onto the end
11904 of the number so far. We check for overflows.
11910 x = u << shift; /* make room for the digit */
11912 if ((x >> shift) != u
11913 && !(PL_hints & HINT_NEW_BINARY)) {
11916 if (ckWARN_d(WARN_OVERFLOW))
11917 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11918 "Integer overflow in %s number",
11921 u = x | b; /* add the digit to the end */
11924 n *= nvshift[shift];
11925 /* If an NV has not enough bits in its
11926 * mantissa to represent an UV this summing of
11927 * small low-order numbers is a waste of time
11928 * (because the NV cannot preserve the
11929 * low-order bits anyway): we could just
11930 * remember when did we overflow and in the
11931 * end just multiply n by the right
11939 /* if we get here, we had success: make a scalar value from
11944 /* final misplaced underbar check */
11945 if (s[-1] == '_') {
11946 if (ckWARN(WARN_SYNTAX))
11947 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11952 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
11953 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
11954 "%s number > %s non-portable",
11960 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
11961 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
11962 "%s number > %s non-portable",
11967 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11968 sv = new_constant(start, s - start, "integer",
11970 else if (PL_hints & HINT_NEW_BINARY)
11971 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
11976 handle decimal numbers.
11977 we're also sent here when we read a 0 as the first digit
11979 case '1': case '2': case '3': case '4': case '5':
11980 case '6': case '7': case '8': case '9': case '.':
11983 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11986 /* read next group of digits and _ and copy into d */
11987 while (isDIGIT(*s) || *s == '_') {
11988 /* skip underscores, checking for misplaced ones
11992 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11993 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11994 "Misplaced _ in number");
11998 /* check for end of fixed-length buffer */
12000 Perl_croak(aTHX_ number_too_long);
12001 /* if we're ok, copy the character */
12006 /* final misplaced underbar check */
12007 if (lastub && s == lastub + 1) {
12008 if (ckWARN(WARN_SYNTAX))
12009 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12012 /* read a decimal portion if there is one. avoid
12013 3..5 being interpreted as the number 3. followed
12016 if (*s == '.' && s[1] != '.') {
12021 if (ckWARN(WARN_SYNTAX))
12022 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12023 "Misplaced _ in number");
12027 /* copy, ignoring underbars, until we run out of digits.
12029 for (; isDIGIT(*s) || *s == '_'; s++) {
12030 /* fixed length buffer check */
12032 Perl_croak(aTHX_ number_too_long);
12034 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12035 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12036 "Misplaced _ in number");
12042 /* fractional part ending in underbar? */
12043 if (s[-1] == '_') {
12044 if (ckWARN(WARN_SYNTAX))
12045 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12046 "Misplaced _ in number");
12048 if (*s == '.' && isDIGIT(s[1])) {
12049 /* oops, it's really a v-string, but without the "v" */
12055 /* read exponent part, if present */
12056 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12060 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12061 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12063 /* stray preinitial _ */
12065 if (ckWARN(WARN_SYNTAX))
12066 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12067 "Misplaced _ in number");
12071 /* allow positive or negative exponent */
12072 if (*s == '+' || *s == '-')
12075 /* stray initial _ */
12077 if (ckWARN(WARN_SYNTAX))
12078 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12079 "Misplaced _ in number");
12083 /* read digits of exponent */
12084 while (isDIGIT(*s) || *s == '_') {
12087 Perl_croak(aTHX_ number_too_long);
12091 if (((lastub && s == lastub + 1) ||
12092 (!isDIGIT(s[1]) && s[1] != '_'))
12093 && ckWARN(WARN_SYNTAX))
12094 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12095 "Misplaced _ in number");
12102 /* make an sv from the string */
12106 We try to do an integer conversion first if no characters
12107 indicating "float" have been found.
12112 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12114 if (flags == IS_NUMBER_IN_UV) {
12116 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12119 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12120 if (uv <= (UV) IV_MIN)
12121 sv_setiv(sv, -(IV)uv);
12128 /* terminate the string */
12130 nv = Atof(PL_tokenbuf);
12134 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12135 (PL_hints & HINT_NEW_INTEGER) )
12136 sv = new_constant(PL_tokenbuf,
12139 (floatit ? "float" : "integer"),
12143 /* if it starts with a v, it could be a v-string */
12146 sv = newSV(5); /* preallocate storage space */
12147 s = scan_vstring(s,sv);
12151 /* make the op for the constant and return */
12154 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12156 lvalp->opval = NULL;
12162 S_scan_formline(pTHX_ register char *s)
12165 register char *eol;
12167 SV * const stuff = newSVpvs("");
12168 bool needargs = FALSE;
12169 bool eofmt = FALSE;
12171 char *tokenstart = s;
12174 if (PL_madskills) {
12175 savewhite = PL_thiswhite;
12180 while (!needargs) {
12183 #ifdef PERL_STRICT_CR
12184 while (SPACE_OR_TAB(*t))
12187 while (SPACE_OR_TAB(*t) || *t == '\r')
12190 if (*t == '\n' || t == PL_bufend) {
12195 if (PL_in_eval && !PL_rsfp) {
12196 eol = (char *) memchr(s,'\n',PL_bufend-s);
12201 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12203 for (t = s; t < eol; t++) {
12204 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12206 goto enough; /* ~~ must be first line in formline */
12208 if (*t == '@' || *t == '^')
12212 sv_catpvn(stuff, s, eol-s);
12213 #ifndef PERL_STRICT_CR
12214 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12215 char *end = SvPVX(stuff) + SvCUR(stuff);
12218 SvCUR_set(stuff, SvCUR(stuff) - 1);
12228 if (PL_madskills) {
12230 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12232 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12235 s = filter_gets(PL_linestr, PL_rsfp, 0);
12237 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12239 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12241 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12242 PL_last_lop = PL_last_uni = NULL;
12251 if (SvCUR(stuff)) {
12254 PL_lex_state = LEX_NORMAL;
12255 start_force(PL_curforce);
12256 NEXTVAL_NEXTTOKE.ival = 0;
12260 PL_lex_state = LEX_FORMLINE;
12262 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12264 else if (PL_encoding)
12265 sv_recode_to_utf8(stuff, PL_encoding);
12267 start_force(PL_curforce);
12268 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12270 start_force(PL_curforce);
12271 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12275 SvREFCNT_dec(stuff);
12277 PL_lex_formbrack = 0;
12281 if (PL_madskills) {
12283 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12285 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12286 PL_thiswhite = savewhite;
12298 PL_cshlen = strlen(PL_cshname);
12300 #if defined(USE_ITHREADS)
12301 PERL_UNUSED_CONTEXT;
12307 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12310 const I32 oldsavestack_ix = PL_savestack_ix;
12311 CV* const outsidecv = PL_compcv;
12314 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12316 SAVEI32(PL_subline);
12317 save_item(PL_subname);
12318 SAVESPTR(PL_compcv);
12320 PL_compcv = (CV*)newSV(0);
12321 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
12322 CvFLAGS(PL_compcv) |= flags;
12324 PL_subline = CopLINE(PL_curcop);
12325 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12326 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12327 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12329 return oldsavestack_ix;
12333 #pragma segment Perl_yylex
12336 Perl_yywarn(pTHX_ const char *s)
12339 PL_in_eval |= EVAL_WARNONLY;
12341 PL_in_eval &= ~EVAL_WARNONLY;
12346 Perl_yyerror(pTHX_ const char *s)
12349 const char *where = NULL;
12350 const char *context = NULL;
12354 if (!yychar || (yychar == ';' && !PL_rsfp))
12356 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12357 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12358 PL_oldbufptr != PL_bufptr) {
12361 The code below is removed for NetWare because it abends/crashes on NetWare
12362 when the script has error such as not having the closing quotes like:
12363 if ($var eq "value)
12364 Checking of white spaces is anyway done in NetWare code.
12367 while (isSPACE(*PL_oldoldbufptr))
12370 context = PL_oldoldbufptr;
12371 contlen = PL_bufptr - PL_oldoldbufptr;
12373 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12374 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12377 The code below is removed for NetWare because it abends/crashes on NetWare
12378 when the script has error such as not having the closing quotes like:
12379 if ($var eq "value)
12380 Checking of white spaces is anyway done in NetWare code.
12383 while (isSPACE(*PL_oldbufptr))
12386 context = PL_oldbufptr;
12387 contlen = PL_bufptr - PL_oldbufptr;
12389 else if (yychar > 255)
12390 where = "next token ???";
12391 else if (yychar == -2) { /* YYEMPTY */
12392 if (PL_lex_state == LEX_NORMAL ||
12393 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12394 where = "at end of line";
12395 else if (PL_lex_inpat)
12396 where = "within pattern";
12398 where = "within string";
12401 SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12403 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12404 else if (isPRINT_LC(yychar))
12405 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12407 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12408 where = SvPVX_const(where_sv);
12410 msg = sv_2mortal(newSVpv(s, 0));
12411 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12412 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12414 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12416 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12417 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12418 Perl_sv_catpvf(aTHX_ msg,
12419 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12420 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12423 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12424 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, (void*)msg);
12427 if (PL_error_count >= 10) {
12428 if (PL_in_eval && SvCUR(ERRSV))
12429 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12430 (void*)ERRSV, OutCopFILE(PL_curcop));
12432 Perl_croak(aTHX_ "%s has too many errors.\n",
12433 OutCopFILE(PL_curcop));
12436 PL_in_my_stash = NULL;
12440 #pragma segment Main
12444 S_swallow_bom(pTHX_ U8 *s)
12447 const STRLEN slen = SvCUR(PL_linestr);
12450 if (s[1] == 0xFE) {
12451 /* UTF-16 little-endian? (or UTF32-LE?) */
12452 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12453 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12454 #ifndef PERL_NO_UTF16_FILTER
12455 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12458 if (PL_bufend > (char*)s) {
12462 filter_add(utf16rev_textfilter, NULL);
12463 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12464 utf16_to_utf8_reversed(s, news,
12465 PL_bufend - (char*)s - 1,
12467 sv_setpvn(PL_linestr, (const char*)news, newlen);
12469 s = (U8*)SvPVX(PL_linestr);
12470 Copy(news, s, newlen, U8);
12474 SvUTF8_on(PL_linestr);
12475 s = (U8*)SvPVX(PL_linestr);
12477 /* FIXME - is this a general bug fix? */
12480 PL_bufend = SvPVX(PL_linestr) + newlen;
12483 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12488 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12489 #ifndef PERL_NO_UTF16_FILTER
12490 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12493 if (PL_bufend > (char *)s) {
12497 filter_add(utf16_textfilter, NULL);
12498 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12499 utf16_to_utf8(s, news,
12500 PL_bufend - (char*)s,
12502 sv_setpvn(PL_linestr, (const char*)news, newlen);
12504 SvUTF8_on(PL_linestr);
12505 s = (U8*)SvPVX(PL_linestr);
12506 PL_bufend = SvPVX(PL_linestr) + newlen;
12509 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12514 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12515 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12516 s += 3; /* UTF-8 */
12522 if (s[2] == 0xFE && s[3] == 0xFF) {
12523 /* UTF-32 big-endian */
12524 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12527 else if (s[2] == 0 && s[3] != 0) {
12530 * are a good indicator of UTF-16BE. */
12531 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12537 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12538 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12539 s += 4; /* UTF-8 */
12545 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12548 * are a good indicator of UTF-16LE. */
12549 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12558 * Restore a source filter.
12562 restore_rsfp(pTHX_ void *f)
12565 PerlIO * const fp = (PerlIO*)f;
12567 if (PL_rsfp == PerlIO_stdin())
12568 PerlIO_clearerr(PL_rsfp);
12569 else if (PL_rsfp && (PL_rsfp != fp))
12570 PerlIO_close(PL_rsfp);
12574 #ifndef PERL_NO_UTF16_FILTER
12576 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12579 const STRLEN old = SvCUR(sv);
12580 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12581 DEBUG_P(PerlIO_printf(Perl_debug_log,
12582 "utf16_textfilter(%p): %d %d (%d)\n",
12583 FPTR2DPTR(void *, utf16_textfilter),
12584 idx, maxlen, (int) count));
12588 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12589 Copy(SvPVX_const(sv), tmps, old, char);
12590 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12591 SvCUR(sv) - old, &newlen);
12592 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12594 DEBUG_P({sv_dump(sv);});
12599 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12602 const STRLEN old = SvCUR(sv);
12603 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12604 DEBUG_P(PerlIO_printf(Perl_debug_log,
12605 "utf16rev_textfilter(%p): %d %d (%d)\n",
12606 FPTR2DPTR(void *, utf16rev_textfilter),
12607 idx, maxlen, (int) count));
12611 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12612 Copy(SvPVX_const(sv), tmps, old, char);
12613 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12614 SvCUR(sv) - old, &newlen);
12615 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12617 DEBUG_P({ sv_dump(sv); });
12623 Returns a pointer to the next character after the parsed
12624 vstring, as well as updating the passed in sv.
12626 Function must be called like
12629 s = scan_vstring(s,sv);
12631 The sv should already be large enough to store the vstring
12632 passed in, for performance reasons.
12637 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
12640 const char *pos = s;
12641 const char *start = s;
12642 if (*pos == 'v') pos++; /* get past 'v' */
12643 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12645 if ( *pos != '.') {
12646 /* this may not be a v-string if followed by => */
12647 const char *next = pos;
12648 while (next < PL_bufend && isSPACE(*next))
12650 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
12651 /* return string not v-string */
12652 sv_setpvn(sv,(char *)s,pos-s);
12653 return (char *)pos;
12657 if (!isALPHA(*pos)) {
12658 U8 tmpbuf[UTF8_MAXBYTES+1];
12661 s++; /* get past 'v' */
12663 sv_setpvn(sv, "", 0);
12666 /* this is atoi() that tolerates underscores */
12669 const char *end = pos;
12671 while (--end >= s) {
12673 const UV orev = rev;
12674 rev += (*end - '0') * mult;
12676 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12677 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12678 "Integer overflow in decimal number");
12682 if (rev > 0x7FFFFFFF)
12683 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12685 /* Append native character for the rev point */
12686 tmpend = uvchr_to_utf8(tmpbuf, rev);
12687 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12688 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12690 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
12696 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12700 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12708 * c-indentation-style: bsd
12709 * c-basic-offset: 4
12710 * indent-tabs-mode: t
12713 * ex: set ts=8 sts=4 sw=4 noet: