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 = newSVpvn("",0);
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 = newSVpvn("",0);
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;
863 *svp = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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('^', newSVpvn("",0));
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 = newSVpvn("",0);
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+*?|()-Nnrtfeaxcz0123456789[{]} \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 = newSVpvn("",0);
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 = newSVpvn("\\E",2);
3201 while (PL_bufptr != PL_bufend &&
3202 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3204 PL_thiswhite = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
3262 Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3268 if (PL_lex_starts) {
3274 sv_free(PL_thistoken);
3275 PL_thistoken = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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 = newSVpvn("",0);
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, bad_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 */
6579 s = scan_str(s,!!PL_madskills,FALSE);
6581 Perl_croak(aTHX_ "Prototype not terminated");
6582 /* strip spaces and check for bad characters */
6583 d = SvPVX(PL_lex_stuff);
6586 for (p = d; *p; ++p) {
6589 if (!strchr("$@%*;[]&\\", *p))
6594 if (bad_proto && ckWARN(WARN_SYNTAX))
6595 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6596 "Illegal character in prototype for %"SVf" : %s",
6597 (void*)PL_subname, d);
6598 SvCUR_set(PL_lex_stuff, tmp);
6603 CURMAD('q', PL_thisopen);
6604 CURMAD('_', tmpwhite);
6605 CURMAD('=', PL_thisstuff);
6606 CURMAD('Q', PL_thisclose);
6607 NEXTVAL_NEXTTOKE.opval =
6608 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6609 PL_lex_stuff = Nullsv;
6612 s = SKIPSPACE2(s,tmpwhite);
6620 if (*s == ':' && s[1] != ':')
6621 PL_expect = attrful;
6622 else if (*s != '{' && key == KEY_sub) {
6624 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6626 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, (void*)PL_subname);
6633 curmad('^', newSVpvn("",0));
6634 CURMAD('_', tmpwhite);
6638 PL_thistoken = subtoken;
6641 NEXTVAL_NEXTTOKE.opval =
6642 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6643 PL_lex_stuff = NULL;
6648 sv_setpv(PL_subname,
6650 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
6654 (void) force_word(PL_oldbufptr + tboffset, WORD,
6664 LOP(OP_SYSTEM,XREF);
6667 LOP(OP_SYMLINK,XTERM);
6670 LOP(OP_SYSCALL,XTERM);
6673 LOP(OP_SYSOPEN,XTERM);
6676 LOP(OP_SYSSEEK,XTERM);
6679 LOP(OP_SYSREAD,XTERM);
6682 LOP(OP_SYSWRITE,XTERM);
6686 TERM(sublex_start());
6707 LOP(OP_TRUNCATE,XTERM);
6719 yylval.ival = CopLINE(PL_curcop);
6723 yylval.ival = CopLINE(PL_curcop);
6727 LOP(OP_UNLINK,XTERM);
6733 LOP(OP_UNPACK,XTERM);
6736 LOP(OP_UTIME,XTERM);
6742 LOP(OP_UNSHIFT,XTERM);
6745 s = tokenize_use(1, s);
6755 yylval.ival = CopLINE(PL_curcop);
6759 yylval.ival = CopLINE(PL_curcop);
6763 PL_hints |= HINT_BLOCK_SCOPE;
6770 LOP(OP_WAITPID,XTERM);
6779 ctl_l[0] = toCTRL('L');
6781 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6784 /* Make sure $^L is defined */
6785 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6790 if (PL_expect == XOPERATOR)
6796 yylval.ival = OP_XOR;
6801 TERM(sublex_start());
6806 #pragma segment Main
6810 S_pending_ident(pTHX)
6815 /* pit holds the identifier we read and pending_ident is reset */
6816 char pit = PL_pending_ident;
6817 PL_pending_ident = 0;
6819 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6820 DEBUG_T({ PerlIO_printf(Perl_debug_log,
6821 "### Pending identifier '%s'\n", PL_tokenbuf); });
6823 /* if we're in a my(), we can't allow dynamics here.
6824 $foo'bar has already been turned into $foo::bar, so
6825 just check for colons.
6827 if it's a legal name, the OP is a PADANY.
6830 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
6831 if (strchr(PL_tokenbuf,':'))
6832 yyerror(Perl_form(aTHX_ "No package name allowed for "
6833 "variable %s in \"our\"",
6835 tmp = allocmy(PL_tokenbuf);
6838 if (strchr(PL_tokenbuf,':'))
6839 yyerror(Perl_form(aTHX_ PL_no_myglob,
6840 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
6842 yylval.opval = newOP(OP_PADANY, 0);
6843 yylval.opval->op_targ = allocmy(PL_tokenbuf);
6849 build the ops for accesses to a my() variable.
6851 Deny my($a) or my($b) in a sort block, *if* $a or $b is
6852 then used in a comparison. This catches most, but not
6853 all cases. For instance, it catches
6854 sort { my($a); $a <=> $b }
6856 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6857 (although why you'd do that is anyone's guess).
6860 if (!strchr(PL_tokenbuf,':')) {
6862 tmp = pad_findmy(PL_tokenbuf);
6863 if (tmp != NOT_IN_PAD) {
6864 /* might be an "our" variable" */
6865 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6866 /* build ops for a bareword */
6867 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
6868 HEK * const stashname = HvNAME_HEK(stash);
6869 SV * const sym = newSVhek(stashname);
6870 sv_catpvs(sym, "::");
6871 sv_catpv(sym, PL_tokenbuf+1);
6872 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6873 yylval.opval->op_private = OPpCONST_ENTERED;
6876 ? (GV_ADDMULTI | GV_ADDINEVAL)
6879 ((PL_tokenbuf[0] == '$') ? SVt_PV
6880 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6885 /* if it's a sort block and they're naming $a or $b */
6886 if (PL_last_lop_op == OP_SORT &&
6887 PL_tokenbuf[0] == '$' &&
6888 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
6891 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
6892 d < PL_bufend && *d != '\n';
6895 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
6896 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
6902 yylval.opval = newOP(OP_PADANY, 0);
6903 yylval.opval->op_targ = tmp;
6909 Whine if they've said @foo in a doublequoted string,
6910 and @foo isn't a variable we can find in the symbol
6913 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
6914 GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
6915 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
6916 && ckWARN(WARN_AMBIGUOUS))
6918 /* Downgraded from fatal to warning 20000522 mjd */
6919 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6920 "Possible unintended interpolation of %s in string",
6925 /* build ops for a bareword */
6926 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
6927 yylval.opval->op_private = OPpCONST_ENTERED;
6930 /* If the identifier refers to a stash, don't autovivify it.
6931 * Change 24660 had the side effect of causing symbol table
6932 * hashes to always be defined, even if they were freshly
6933 * created and the only reference in the entire program was
6934 * the single statement with the defined %foo::bar:: test.
6935 * It appears that all code in the wild doing this actually
6936 * wants to know whether sub-packages have been loaded, so
6937 * by avoiding auto-vivifying symbol tables, we ensure that
6938 * defined %foo::bar:: continues to be false, and the existing
6939 * tests still give the expected answers, even though what
6940 * they're actually testing has now changed subtly.
6942 (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
6944 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
6945 ((PL_tokenbuf[0] == '$') ? SVt_PV
6946 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6952 * The following code was generated by perl_keyword.pl.
6956 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
6961 case 1: /* 5 tokens of length 1 */
6993 case 2: /* 18 tokens of length 2 */
7139 case 3: /* 29 tokens of length 3 */
7143 if (name[1] == 'N' &&
7206 if (name[1] == 'i' &&
7228 return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7246 if (name[1] == 'o' &&
7255 if (name[1] == 'e' &&
7264 if (name[1] == 'n' &&
7273 if (name[1] == 'o' &&
7282 if (name[1] == 'a' &&
7291 if (name[1] == 'o' &&
7353 if (name[1] == 'e' &&
7367 return (all_keywords || FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
7393 if (name[1] == 'i' &&
7402 if (name[1] == 's' &&
7411 if (name[1] == 'e' &&
7420 if (name[1] == 'o' &&
7432 case 4: /* 41 tokens of length 4 */
7436 if (name[1] == 'O' &&
7446 if (name[1] == 'N' &&
7456 if (name[1] == 'i' &&
7466 if (name[1] == 'h' &&
7476 if (name[1] == 'u' &&
7489 if (name[2] == 'c' &&
7498 if (name[2] == 's' &&
7507 if (name[2] == 'a' &&
7543 if (name[1] == 'o' &&
7556 if (name[2] == 't' &&
7565 if (name[2] == 'o' &&
7574 if (name[2] == 't' &&
7583 if (name[2] == 'e' &&
7596 if (name[1] == 'o' &&
7609 if (name[2] == 'y' &&
7618 if (name[2] == 'l' &&
7634 if (name[2] == 's' &&
7643 if (name[2] == 'n' &&
7652 if (name[2] == 'c' &&
7665 if (name[1] == 'e' &&
7675 if (name[1] == 'p' &&
7688 if (name[2] == 'c' &&
7697 if (name[2] == 'p' &&
7706 if (name[2] == 's' &&
7722 if (name[2] == 'n' &&
7792 if (name[2] == 'r' &&
7801 if (name[2] == 'r' &&
7810 if (name[2] == 'a' &&
7826 if (name[2] == 'l' &&
7888 if (name[2] == 'e' &&
7891 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
7904 case 5: /* 39 tokens of length 5 */
7908 if (name[1] == 'E' &&
7919 if (name[1] == 'H' &&
7933 if (name[2] == 'a' &&
7943 if (name[2] == 'a' &&
7960 if (name[2] == 'e' &&
7970 if (name[2] == 'e' &&
7974 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
7990 if (name[3] == 'i' &&
7999 if (name[3] == 'o' &&
8035 if (name[2] == 'o' &&
8045 if (name[2] == 'y' &&
8059 if (name[1] == 'l' &&
8073 if (name[2] == 'n' &&
8083 if (name[2] == 'o' &&
8097 if (name[1] == 'i' &&
8102 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8111 if (name[2] == 'd' &&
8121 if (name[2] == 'c' &&
8138 if (name[2] == 'c' &&
8148 if (name[2] == 't' &&
8162 if (name[1] == 'k' &&
8173 if (name[1] == 'r' &&
8187 if (name[2] == 's' &&
8197 if (name[2] == 'd' &&
8214 if (name[2] == 'm' &&
8224 if (name[2] == 'i' &&
8234 if (name[2] == 'e' &&
8244 if (name[2] == 'l' &&
8254 if (name[2] == 'a' &&
8267 if (name[3] == 't' &&
8270 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8276 if (name[3] == 'd' &&
8293 if (name[1] == 'i' &&
8307 if (name[2] == 'a' &&
8320 if (name[3] == 'e' &&
8355 if (name[2] == 'i' &&
8372 if (name[2] == 'i' &&
8382 if (name[2] == 'i' &&
8399 case 6: /* 33 tokens of length 6 */
8403 if (name[1] == 'c' &&
8418 if (name[2] == 'l' &&
8429 if (name[2] == 'r' &&
8444 if (name[1] == 'e' &&
8459 if (name[2] == 's' &&
8464 if(ckWARN_d(WARN_SYNTAX))
8465 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8471 if (name[2] == 'i' &&
8489 if (name[2] == 'l' &&
8500 if (name[2] == 'r' &&
8515 if (name[1] == 'm' &&
8530 if (name[2] == 'n' &&
8541 if (name[2] == 's' &&
8556 if (name[1] == 's' &&
8562 if (name[4] == 't' &&
8571 if (name[4] == 'e' &&
8580 if (name[4] == 'c' &&
8589 if (name[4] == 'n' &&
8605 if (name[1] == 'r' &&
8623 if (name[3] == 'a' &&
8633 if (name[3] == 'u' &&
8647 if (name[2] == 'n' &&
8665 if (name[2] == 'a' &&
8679 if (name[3] == 'e' &&
8692 if (name[4] == 't' &&
8701 if (name[4] == 'e' &&
8723 if (name[4] == 't' &&
8732 if (name[4] == 'e' &&
8748 if (name[2] == 'c' &&
8759 if (name[2] == 'l' &&
8770 if (name[2] == 'b' &&
8781 if (name[2] == 's' &&
8804 if (name[4] == 's' &&
8813 if (name[4] == 'n' &&
8826 if (name[3] == 'a' &&
8843 if (name[1] == 'a' &&
8858 case 7: /* 29 tokens of length 7 */
8862 if (name[1] == 'E' &&
8875 if (name[1] == '_' &&
8888 if (name[1] == 'i' &&
8895 return -KEY_binmode;
8901 if (name[1] == 'o' &&
8908 return -KEY_connect;
8917 if (name[2] == 'm' &&
8923 return -KEY_dbmopen;
8934 if (name[4] == 'u' &&
8938 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
8944 if (name[4] == 'n' &&
8965 if (name[1] == 'o' &&
8978 if (name[1] == 'e' &&
8985 if (name[5] == 'r' &&
8988 return -KEY_getpgrp;
8994 if (name[5] == 'i' &&
8997 return -KEY_getppid;
9010 if (name[1] == 'c' &&
9017 return -KEY_lcfirst;
9023 if (name[1] == 'p' &&
9030 return -KEY_opendir;
9036 if (name[1] == 'a' &&
9054 if (name[3] == 'd' &&
9059 return -KEY_readdir;
9065 if (name[3] == 'u' &&
9076 if (name[3] == 'e' &&
9081 return -KEY_reverse;
9100 if (name[3] == 'k' &&
9105 return -KEY_seekdir;
9111 if (name[3] == 'p' &&
9116 return -KEY_setpgrp;
9126 if (name[2] == 'm' &&
9132 return -KEY_shmread;
9138 if (name[2] == 'r' &&
9144 return -KEY_sprintf;
9153 if (name[3] == 'l' &&
9158 return -KEY_symlink;
9167 if (name[4] == 'a' &&
9171 return -KEY_syscall;
9177 if (name[4] == 'p' &&
9181 return -KEY_sysopen;
9187 if (name[4] == 'e' &&
9191 return -KEY_sysread;
9197 if (name[4] == 'e' &&
9201 return -KEY_sysseek;
9219 if (name[1] == 'e' &&
9226 return -KEY_telldir;
9235 if (name[2] == 'f' &&
9241 return -KEY_ucfirst;
9247 if (name[2] == 's' &&
9253 return -KEY_unshift;
9263 if (name[1] == 'a' &&
9270 return -KEY_waitpid;
9279 case 8: /* 26 tokens of length 8 */
9283 if (name[1] == 'U' &&
9291 return KEY_AUTOLOAD;
9302 if (name[3] == 'A' &&
9308 return KEY___DATA__;
9314 if (name[3] == 'I' &&
9320 return -KEY___FILE__;
9326 if (name[3] == 'I' &&
9332 return -KEY___LINE__;
9348 if (name[2] == 'o' &&
9355 return -KEY_closedir;
9361 if (name[2] == 'n' &&
9368 return -KEY_continue;
9378 if (name[1] == 'b' &&
9386 return -KEY_dbmclose;
9392 if (name[1] == 'n' &&
9398 if (name[4] == 'r' &&
9403 return -KEY_endgrent;
9409 if (name[4] == 'w' &&
9414 return -KEY_endpwent;
9427 if (name[1] == 'o' &&
9435 return -KEY_formline;
9441 if (name[1] == 'e' &&
9452 if (name[6] == 'n' &&
9455 return -KEY_getgrent;
9461 if (name[6] == 'i' &&
9464 return -KEY_getgrgid;
9470 if (name[6] == 'a' &&
9473 return -KEY_getgrnam;
9486 if (name[4] == 'o' &&
9491 return -KEY_getlogin;
9502 if (name[6] == 'n' &&
9505 return -KEY_getpwent;
9511 if (name[6] == 'a' &&
9514 return -KEY_getpwnam;
9520 if (name[6] == 'i' &&
9523 return -KEY_getpwuid;
9543 if (name[1] == 'e' &&
9550 if (name[5] == 'i' &&
9557 return -KEY_readline;
9562 return -KEY_readlink;
9573 if (name[5] == 'i' &&
9577 return -KEY_readpipe;
9598 if (name[4] == 'r' &&
9603 return -KEY_setgrent;
9609 if (name[4] == 'w' &&
9614 return -KEY_setpwent;
9630 if (name[3] == 'w' &&
9636 return -KEY_shmwrite;
9642 if (name[3] == 't' &&
9648 return -KEY_shutdown;
9658 if (name[2] == 's' &&
9665 return -KEY_syswrite;
9675 if (name[1] == 'r' &&
9683 return -KEY_truncate;
9692 case 9: /* 8 tokens of length 9 */
9696 if (name[1] == 'n' &&
9705 return -KEY_endnetent;
9711 if (name[1] == 'e' &&
9720 return -KEY_getnetent;
9726 if (name[1] == 'o' &&
9735 return -KEY_localtime;
9741 if (name[1] == 'r' &&
9750 return KEY_prototype;
9756 if (name[1] == 'u' &&
9765 return -KEY_quotemeta;
9771 if (name[1] == 'e' &&
9780 return -KEY_rewinddir;
9786 if (name[1] == 'e' &&
9795 return -KEY_setnetent;
9801 if (name[1] == 'a' &&
9810 return -KEY_wantarray;
9819 case 10: /* 9 tokens of length 10 */
9823 if (name[1] == 'n' &&
9829 if (name[4] == 'o' &&
9836 return -KEY_endhostent;
9842 if (name[4] == 'e' &&
9849 return -KEY_endservent;
9862 if (name[1] == 'e' &&
9868 if (name[4] == 'o' &&
9875 return -KEY_gethostent;
9884 if (name[5] == 'r' &&
9890 return -KEY_getservent;
9896 if (name[5] == 'c' &&
9902 return -KEY_getsockopt;
9927 if (name[4] == 'o' &&
9934 return -KEY_sethostent;
9943 if (name[5] == 'r' &&
9949 return -KEY_setservent;
9955 if (name[5] == 'c' &&
9961 return -KEY_setsockopt;
9978 if (name[2] == 'c' &&
9987 return -KEY_socketpair;
10000 case 11: /* 8 tokens of length 11 */
10004 if (name[1] == '_' &&
10014 { /* __PACKAGE__ */
10015 return -KEY___PACKAGE__;
10021 if (name[1] == 'n' &&
10031 { /* endprotoent */
10032 return -KEY_endprotoent;
10038 if (name[1] == 'e' &&
10047 if (name[5] == 'e' &&
10053 { /* getpeername */
10054 return -KEY_getpeername;
10063 if (name[6] == 'o' &&
10068 { /* getpriority */
10069 return -KEY_getpriority;
10075 if (name[6] == 't' &&
10080 { /* getprotoent */
10081 return -KEY_getprotoent;
10095 if (name[4] == 'o' &&
10102 { /* getsockname */
10103 return -KEY_getsockname;
10116 if (name[1] == 'e' &&
10124 if (name[6] == 'o' &&
10129 { /* setpriority */
10130 return -KEY_setpriority;
10136 if (name[6] == 't' &&
10141 { /* setprotoent */
10142 return -KEY_setprotoent;
10158 case 12: /* 2 tokens of length 12 */
10159 if (name[0] == 'g' &&
10171 if (name[9] == 'd' &&
10174 { /* getnetbyaddr */
10175 return -KEY_getnetbyaddr;
10181 if (name[9] == 'a' &&
10184 { /* getnetbyname */
10185 return -KEY_getnetbyname;
10197 case 13: /* 4 tokens of length 13 */
10198 if (name[0] == 'g' &&
10205 if (name[4] == 'o' &&
10214 if (name[10] == 'd' &&
10217 { /* gethostbyaddr */
10218 return -KEY_gethostbyaddr;
10224 if (name[10] == 'a' &&
10227 { /* gethostbyname */
10228 return -KEY_gethostbyname;
10241 if (name[4] == 'e' &&
10250 if (name[10] == 'a' &&
10253 { /* getservbyname */
10254 return -KEY_getservbyname;
10260 if (name[10] == 'o' &&
10263 { /* getservbyport */
10264 return -KEY_getservbyport;
10283 case 14: /* 1 tokens of length 14 */
10284 if (name[0] == 'g' &&
10298 { /* getprotobyname */
10299 return -KEY_getprotobyname;
10304 case 16: /* 1 tokens of length 16 */
10305 if (name[0] == 'g' &&
10321 { /* getprotobynumber */
10322 return -KEY_getprotobynumber;
10336 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10340 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10341 if (ckWARN(WARN_SYNTAX)) {
10344 for (w = s+2; *w && level; w++) {
10347 else if (*w == ')')
10350 while (isSPACE(*w))
10352 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
10353 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10354 "%s (...) interpreted as function",name);
10357 while (s < PL_bufend && isSPACE(*s))
10361 while (s < PL_bufend && isSPACE(*s))
10363 if (isIDFIRST_lazy_if(s,UTF)) {
10364 const char * const w = s++;
10365 while (isALNUM_lazy_if(s,UTF))
10367 while (s < PL_bufend && isSPACE(*s))
10371 if (keyword(w, s - w, 0))
10374 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10375 if (gv && GvCVu(gv))
10377 Perl_croak(aTHX_ "No comma allowed after %s", what);
10382 /* Either returns sv, or mortalizes sv and returns a new SV*.
10383 Best used as sv=new_constant(..., sv, ...).
10384 If s, pv are NULL, calls subroutine with one argument,
10385 and type is used with error messages only. */
10388 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10392 HV * const table = GvHV(PL_hintgv); /* ^H */
10396 const char *why1 = "", *why2 = "", *why3 = "";
10398 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10401 why2 = (const char *)
10402 (strEQ(key,"charnames")
10403 ? "(possibly a missing \"use charnames ...\")"
10405 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10406 (type ? type: "undef"), why2);
10408 /* This is convoluted and evil ("goto considered harmful")
10409 * but I do not understand the intricacies of all the different
10410 * failure modes of %^H in here. The goal here is to make
10411 * the most probable error message user-friendly. --jhi */
10416 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10417 (type ? type: "undef"), why1, why2, why3);
10419 yyerror(SvPVX_const(msg));
10423 cvp = hv_fetch(table, key, strlen(key), FALSE);
10424 if (!cvp || !SvOK(*cvp)) {
10427 why3 = "} is not defined";
10430 sv_2mortal(sv); /* Parent created it permanently */
10433 pv = sv_2mortal(newSVpvn(s, len));
10435 typesv = sv_2mortal(newSVpv(type, 0));
10437 typesv = &PL_sv_undef;
10439 PUSHSTACKi(PERLSI_OVERLOAD);
10451 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10455 /* Check the eval first */
10456 if (!PL_in_eval && SvTRUE(ERRSV)) {
10457 sv_catpvs(ERRSV, "Propagated");
10458 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10460 res = SvREFCNT_inc_simple(sv);
10464 SvREFCNT_inc_simple_void(res);
10473 why1 = "Call to &{$^H{";
10475 why3 = "}} did not return a defined value";
10483 /* Returns a NUL terminated string, with the length of the string written to
10487 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10490 register char *d = dest;
10491 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10494 Perl_croak(aTHX_ ident_too_long);
10495 if (isALNUM(*s)) /* UTF handled below */
10497 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10502 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10506 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10507 char *t = s + UTF8SKIP(s);
10509 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10513 Perl_croak(aTHX_ ident_too_long);
10514 Copy(s, d, len, char);
10527 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10530 char *bracket = NULL;
10532 register char *d = dest;
10533 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10538 while (isDIGIT(*s)) {
10540 Perl_croak(aTHX_ ident_too_long);
10547 Perl_croak(aTHX_ ident_too_long);
10548 if (isALNUM(*s)) /* UTF handled below */
10550 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10555 else if (*s == ':' && s[1] == ':') {
10559 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10560 char *t = s + UTF8SKIP(s);
10561 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10563 if (d + (t - s) > e)
10564 Perl_croak(aTHX_ ident_too_long);
10565 Copy(s, d, t - s, char);
10576 if (PL_lex_state != LEX_NORMAL)
10577 PL_lex_state = LEX_INTERPENDMAYBE;
10580 if (*s == '$' && s[1] &&
10581 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10594 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10599 if (isSPACE(s[-1])) {
10601 const char ch = *s++;
10602 if (!SPACE_OR_TAB(ch)) {
10608 if (isIDFIRST_lazy_if(d,UTF)) {
10612 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10613 end += UTF8SKIP(end);
10614 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10615 end += UTF8SKIP(end);
10617 Copy(s, d, end - s, char);
10622 while ((isALNUM(*s) || *s == ':') && d < e)
10625 Perl_croak(aTHX_ ident_too_long);
10628 while (s < send && SPACE_OR_TAB(*s))
10630 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10631 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10632 const char * const brack =
10634 ((*s == '[') ? "[...]" : "{...}");
10635 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10636 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10637 funny, dest, brack, funny, dest, brack);
10640 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10644 /* Handle extended ${^Foo} variables
10645 * 1999-02-27 mjd-perl-patch@plover.com */
10646 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10650 while (isALNUM(*s) && d < e) {
10654 Perl_croak(aTHX_ ident_too_long);
10659 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10660 PL_lex_state = LEX_INTERPEND;
10663 if (PL_lex_state == LEX_NORMAL) {
10664 if (ckWARN(WARN_AMBIGUOUS) &&
10665 (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
10669 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10670 "Ambiguous use of %c{%s} resolved to %c%s",
10671 funny, dest, funny, dest);
10676 s = bracket; /* let the parser handle it */
10680 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10681 PL_lex_state = LEX_INTERPEND;
10686 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10688 PERL_UNUSED_CONTEXT;
10691 else if (ch == 'g')
10692 *pmfl |= PMf_GLOBAL;
10693 else if (ch == 'c')
10694 *pmfl |= PMf_CONTINUE;
10695 else if (ch == 'o')
10697 else if (ch == 'm')
10698 *pmfl |= PMf_MULTILINE;
10699 else if (ch == 's')
10700 *pmfl |= PMf_SINGLELINE;
10701 else if (ch == 'x')
10702 *pmfl |= PMf_EXTENDED;
10706 S_scan_pat(pTHX_ char *start, I32 type)
10710 char *s = scan_str(start,!!PL_madskills,FALSE);
10711 const char * const valid_flags =
10712 (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
10719 const char * const delimiter = skipspace(start);
10723 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10724 : "Search pattern not terminated" ));
10727 pm = (PMOP*)newPMOP(type, 0);
10728 if (PL_multi_open == '?')
10729 pm->op_pmflags |= PMf_ONCE;
10733 while (*s && strchr(valid_flags, *s))
10734 pmflag(&pm->op_pmflags,*s++);
10736 if (PL_madskills && modstart != s) {
10737 SV* tmptoken = newSVpvn(modstart, s - modstart);
10738 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10741 /* issue a warning if /c is specified,but /g is not */
10742 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10743 && ckWARN(WARN_REGEXP))
10745 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
10748 pm->op_pmpermflags = pm->op_pmflags;
10750 PL_lex_op = (OP*)pm;
10751 yylval.ival = OP_MATCH;
10756 S_scan_subst(pTHX_ char *start)
10767 yylval.ival = OP_NULL;
10769 s = scan_str(start,!!PL_madskills,FALSE);
10772 Perl_croak(aTHX_ "Substitution pattern not terminated");
10774 if (s[-1] == PL_multi_open)
10777 if (PL_madskills) {
10778 CURMAD('q', PL_thisopen);
10779 CURMAD('_', PL_thiswhite);
10780 CURMAD('E', PL_thisstuff);
10781 CURMAD('Q', PL_thisclose);
10782 PL_realtokenstart = s - SvPVX(PL_linestr);
10786 first_start = PL_multi_start;
10787 s = scan_str(s,!!PL_madskills,FALSE);
10789 if (PL_lex_stuff) {
10790 SvREFCNT_dec(PL_lex_stuff);
10791 PL_lex_stuff = NULL;
10793 Perl_croak(aTHX_ "Substitution replacement not terminated");
10795 PL_multi_start = first_start; /* so whole substitution is taken together */
10797 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10800 if (PL_madskills) {
10801 CURMAD('z', PL_thisopen);
10802 CURMAD('R', PL_thisstuff);
10803 CURMAD('Z', PL_thisclose);
10813 else if (strchr("iogcmsx", *s))
10814 pmflag(&pm->op_pmflags,*s++);
10820 if (PL_madskills) {
10822 curmad('m', newSVpvn(modstart, s - modstart));
10823 append_madprops(PL_thismad, (OP*)pm, 0);
10827 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10828 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10832 SV * const repl = newSVpvs("");
10834 PL_sublex_info.super_bufptr = s;
10835 PL_sublex_info.super_bufend = PL_bufend;
10837 pm->op_pmflags |= PMf_EVAL;
10839 sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10840 sv_catpvs(repl, "{");
10841 sv_catsv(repl, PL_lex_repl);
10842 if (strchr(SvPVX(PL_lex_repl), '#'))
10843 sv_catpvs(repl, "\n");
10844 sv_catpvs(repl, "}");
10846 SvREFCNT_dec(PL_lex_repl);
10847 PL_lex_repl = repl;
10850 pm->op_pmpermflags = pm->op_pmflags;
10851 PL_lex_op = (OP*)pm;
10852 yylval.ival = OP_SUBST;
10857 S_scan_trans(pTHX_ char *start)
10870 yylval.ival = OP_NULL;
10872 s = scan_str(start,!!PL_madskills,FALSE);
10874 Perl_croak(aTHX_ "Transliteration pattern not terminated");
10876 if (s[-1] == PL_multi_open)
10879 if (PL_madskills) {
10880 CURMAD('q', PL_thisopen);
10881 CURMAD('_', PL_thiswhite);
10882 CURMAD('E', PL_thisstuff);
10883 CURMAD('Q', PL_thisclose);
10884 PL_realtokenstart = s - SvPVX(PL_linestr);
10888 s = scan_str(s,!!PL_madskills,FALSE);
10890 if (PL_lex_stuff) {
10891 SvREFCNT_dec(PL_lex_stuff);
10892 PL_lex_stuff = NULL;
10894 Perl_croak(aTHX_ "Transliteration replacement not terminated");
10896 if (PL_madskills) {
10897 CURMAD('z', PL_thisopen);
10898 CURMAD('R', PL_thisstuff);
10899 CURMAD('Z', PL_thisclose);
10902 complement = del = squash = 0;
10909 complement = OPpTRANS_COMPLEMENT;
10912 del = OPpTRANS_DELETE;
10915 squash = OPpTRANS_SQUASH;
10924 Newx(tbl, complement&&!del?258:256, short);
10925 o = newPVOP(OP_TRANS, 0, (char*)tbl);
10926 o->op_private &= ~OPpTRANS_ALL;
10927 o->op_private |= del|squash|complement|
10928 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
10929 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
10932 yylval.ival = OP_TRANS;
10935 if (PL_madskills) {
10937 curmad('m', newSVpvn(modstart, s - modstart));
10938 append_madprops(PL_thismad, o, 0);
10947 S_scan_heredoc(pTHX_ register char *s)
10951 I32 op_type = OP_SCALAR;
10955 const char *found_newline;
10959 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
10961 I32 stuffstart = s - SvPVX(PL_linestr);
10964 PL_realtokenstart = -1;
10969 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
10973 while (SPACE_OR_TAB(*peek))
10975 if (*peek == '`' || *peek == '\'' || *peek =='"') {
10978 s = delimcpy(d, e, s, PL_bufend, term, &len);
10988 if (!isALNUM_lazy_if(s,UTF))
10989 deprecate_old("bare << to mean <<\"\"");
10990 for (; isALNUM_lazy_if(s,UTF); s++) {
10995 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
10996 Perl_croak(aTHX_ "Delimiter for here document is too long");
10999 len = d - PL_tokenbuf;
11002 if (PL_madskills) {
11003 tstart = PL_tokenbuf + !outer;
11004 PL_thisclose = newSVpvn(tstart, len - !outer);
11005 tstart = SvPVX(PL_linestr) + stuffstart;
11006 PL_thisopen = newSVpvn(tstart, s - tstart);
11007 stuffstart = s - SvPVX(PL_linestr);
11010 #ifndef PERL_STRICT_CR
11011 d = strchr(s, '\r');
11013 char * const olds = s;
11015 while (s < PL_bufend) {
11021 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11030 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11037 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11038 herewas = newSVpvn(s,PL_bufend-s);
11042 herewas = newSVpvn(s-1,found_newline-s+1);
11045 herewas = newSVpvn(s,found_newline-s);
11049 if (PL_madskills) {
11050 tstart = SvPVX(PL_linestr) + stuffstart;
11052 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11054 PL_thisstuff = newSVpvn(tstart, s - tstart);
11057 s += SvCUR(herewas);
11060 stuffstart = s - SvPVX(PL_linestr);
11066 tmpstr = newSV(79);
11067 sv_upgrade(tmpstr, SVt_PVIV);
11068 if (term == '\'') {
11069 op_type = OP_CONST;
11070 SvIV_set(tmpstr, -1);
11072 else if (term == '`') {
11073 op_type = OP_BACKTICK;
11074 SvIV_set(tmpstr, '\\');
11078 PL_multi_start = CopLINE(PL_curcop);
11079 PL_multi_open = PL_multi_close = '<';
11080 term = *PL_tokenbuf;
11081 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11082 char * const bufptr = PL_sublex_info.super_bufptr;
11083 char * const bufend = PL_sublex_info.super_bufend;
11084 char * const olds = s - SvCUR(herewas);
11085 s = strchr(bufptr, '\n');
11089 while (s < bufend &&
11090 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11092 CopLINE_inc(PL_curcop);
11095 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11096 missingterm(PL_tokenbuf);
11098 sv_setpvn(herewas,bufptr,d-bufptr+1);
11099 sv_setpvn(tmpstr,d+1,s-d);
11101 sv_catpvn(herewas,s,bufend-s);
11102 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11109 while (s < PL_bufend &&
11110 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11112 CopLINE_inc(PL_curcop);
11114 if (s >= PL_bufend) {
11115 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11116 missingterm(PL_tokenbuf);
11118 sv_setpvn(tmpstr,d+1,s-d);
11120 if (PL_madskills) {
11122 sv_catpvn(PL_thisstuff, d + 1, s - d);
11124 PL_thisstuff = newSVpvn(d + 1, s - d);
11125 stuffstart = s - SvPVX(PL_linestr);
11129 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11131 sv_catpvn(herewas,s,PL_bufend-s);
11132 sv_setsv(PL_linestr,herewas);
11133 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11134 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11135 PL_last_lop = PL_last_uni = NULL;
11138 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
11139 while (s >= PL_bufend) { /* multiple line string? */
11141 if (PL_madskills) {
11142 tstart = SvPVX(PL_linestr) + stuffstart;
11144 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11146 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11150 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11151 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11152 missingterm(PL_tokenbuf);
11155 stuffstart = s - SvPVX(PL_linestr);
11157 CopLINE_inc(PL_curcop);
11158 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11159 PL_last_lop = PL_last_uni = NULL;
11160 #ifndef PERL_STRICT_CR
11161 if (PL_bufend - PL_linestart >= 2) {
11162 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11163 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11165 PL_bufend[-2] = '\n';
11167 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11169 else if (PL_bufend[-1] == '\r')
11170 PL_bufend[-1] = '\n';
11172 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11173 PL_bufend[-1] = '\n';
11175 if (PERLDB_LINE && PL_curstash != PL_debstash) {
11176 SV * const sv = newSV(0);
11178 sv_upgrade(sv, SVt_PVMG);
11179 sv_setsv(sv,PL_linestr);
11180 (void)SvIOK_on(sv);
11182 av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv);
11184 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11185 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11186 *(SvPVX(PL_linestr) + off ) = ' ';
11187 sv_catsv(PL_linestr,herewas);
11188 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11189 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11193 sv_catsv(tmpstr,PL_linestr);
11198 PL_multi_end = CopLINE(PL_curcop);
11199 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11200 SvPV_shrink_to_cur(tmpstr);
11202 SvREFCNT_dec(herewas);
11204 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11206 else if (PL_encoding)
11207 sv_recode_to_utf8(tmpstr, PL_encoding);
11209 PL_lex_stuff = tmpstr;
11210 yylval.ival = op_type;
11214 /* scan_inputsymbol
11215 takes: current position in input buffer
11216 returns: new position in input buffer
11217 side-effects: yylval and lex_op are set.
11222 <FH> read from filehandle
11223 <pkg::FH> read from package qualified filehandle
11224 <pkg'FH> read from package qualified filehandle
11225 <$fh> read from filehandle in $fh
11226 <*.h> filename glob
11231 S_scan_inputsymbol(pTHX_ char *start)
11234 register char *s = start; /* current position in buffer */
11238 char *d = PL_tokenbuf; /* start of temp holding space */
11239 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11241 end = strchr(s, '\n');
11244 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11246 /* die if we didn't have space for the contents of the <>,
11247 or if it didn't end, or if we see a newline
11250 if (len >= (I32)sizeof PL_tokenbuf)
11251 Perl_croak(aTHX_ "Excessively long <> operator");
11253 Perl_croak(aTHX_ "Unterminated <> operator");
11258 Remember, only scalar variables are interpreted as filehandles by
11259 this code. Anything more complex (e.g., <$fh{$num}>) will be
11260 treated as a glob() call.
11261 This code makes use of the fact that except for the $ at the front,
11262 a scalar variable and a filehandle look the same.
11264 if (*d == '$' && d[1]) d++;
11266 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11267 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11270 /* If we've tried to read what we allow filehandles to look like, and
11271 there's still text left, then it must be a glob() and not a getline.
11272 Use scan_str to pull out the stuff between the <> and treat it
11273 as nothing more than a string.
11276 if (d - PL_tokenbuf != len) {
11277 yylval.ival = OP_GLOB;
11279 s = scan_str(start,!!PL_madskills,FALSE);
11281 Perl_croak(aTHX_ "Glob not terminated");
11285 bool readline_overriden = FALSE;
11288 /* we're in a filehandle read situation */
11291 /* turn <> into <ARGV> */
11293 Copy("ARGV",d,5,char);
11295 /* Check whether readline() is overriden */
11296 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11298 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11300 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11301 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
11302 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11303 readline_overriden = TRUE;
11305 /* if <$fh>, create the ops to turn the variable into a
11309 /* try to find it in the pad for this block, otherwise find
11310 add symbol table ops
11312 const PADOFFSET tmp = pad_findmy(d);
11313 if (tmp != NOT_IN_PAD) {
11314 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11315 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11316 HEK * const stashname = HvNAME_HEK(stash);
11317 SV * const sym = sv_2mortal(newSVhek(stashname));
11318 sv_catpvs(sym, "::");
11319 sv_catpv(sym, d+1);
11324 OP * const o = newOP(OP_PADSV, 0);
11326 PL_lex_op = readline_overriden
11327 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11328 append_elem(OP_LIST, o,
11329 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11330 : (OP*)newUNOP(OP_READLINE, 0, o);
11339 ? (GV_ADDMULTI | GV_ADDINEVAL)
11342 PL_lex_op = readline_overriden
11343 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11344 append_elem(OP_LIST,
11345 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11346 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11347 : (OP*)newUNOP(OP_READLINE, 0,
11348 newUNOP(OP_RV2SV, 0,
11349 newGVOP(OP_GV, 0, gv)));
11351 if (!readline_overriden)
11352 PL_lex_op->op_flags |= OPf_SPECIAL;
11353 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11354 yylval.ival = OP_NULL;
11357 /* If it's none of the above, it must be a literal filehandle
11358 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11360 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11361 PL_lex_op = readline_overriden
11362 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11363 append_elem(OP_LIST,
11364 newGVOP(OP_GV, 0, gv),
11365 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11366 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11367 yylval.ival = OP_NULL;
11376 takes: start position in buffer
11377 keep_quoted preserve \ on the embedded delimiter(s)
11378 keep_delims preserve the delimiters around the string
11379 returns: position to continue reading from buffer
11380 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11381 updates the read buffer.
11383 This subroutine pulls a string out of the input. It is called for:
11384 q single quotes q(literal text)
11385 ' single quotes 'literal text'
11386 qq double quotes qq(interpolate $here please)
11387 " double quotes "interpolate $here please"
11388 qx backticks qx(/bin/ls -l)
11389 ` backticks `/bin/ls -l`
11390 qw quote words @EXPORT_OK = qw( func() $spam )
11391 m// regexp match m/this/
11392 s/// regexp substitute s/this/that/
11393 tr/// string transliterate tr/this/that/
11394 y/// string transliterate y/this/that/
11395 ($*@) sub prototypes sub foo ($)
11396 (stuff) sub attr parameters sub foo : attr(stuff)
11397 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11399 In most of these cases (all but <>, patterns and transliterate)
11400 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11401 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11402 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11405 It skips whitespace before the string starts, and treats the first
11406 character as the delimiter. If the delimiter is one of ([{< then
11407 the corresponding "close" character )]}> is used as the closing
11408 delimiter. It allows quoting of delimiters, and if the string has
11409 balanced delimiters ([{<>}]) it allows nesting.
11411 On success, the SV with the resulting string is put into lex_stuff or,
11412 if that is already non-NULL, into lex_repl. The second case occurs only
11413 when parsing the RHS of the special constructs s/// and tr/// (y///).
11414 For convenience, the terminating delimiter character is stuffed into
11419 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11422 SV *sv; /* scalar value: string */
11423 const char *tmps; /* temp string, used for delimiter matching */
11424 register char *s = start; /* current position in the buffer */
11425 register char term; /* terminating character */
11426 register char *to; /* current position in the sv's data */
11427 I32 brackets = 1; /* bracket nesting level */
11428 bool has_utf8 = FALSE; /* is there any utf8 content? */
11429 I32 termcode; /* terminating char. code */
11430 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11431 STRLEN termlen; /* length of terminating string */
11432 char *last = NULL; /* last position for nesting bracket */
11438 /* skip space before the delimiter */
11444 if (PL_realtokenstart >= 0) {
11445 stuffstart = PL_realtokenstart;
11446 PL_realtokenstart = -1;
11449 stuffstart = start - SvPVX(PL_linestr);
11451 /* mark where we are, in case we need to report errors */
11454 /* after skipping whitespace, the next character is the terminator */
11457 termcode = termstr[0] = term;
11461 termcode = utf8_to_uvchr((U8*)s, &termlen);
11462 Copy(s, termstr, termlen, U8);
11463 if (!UTF8_IS_INVARIANT(term))
11467 /* mark where we are */
11468 PL_multi_start = CopLINE(PL_curcop);
11469 PL_multi_open = term;
11471 /* find corresponding closing delimiter */
11472 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11473 termcode = termstr[0] = term = tmps[5];
11475 PL_multi_close = term;
11477 /* create a new SV to hold the contents. 79 is the SV's initial length.
11478 What a random number. */
11480 sv_upgrade(sv, SVt_PVIV);
11481 SvIV_set(sv, termcode);
11482 (void)SvPOK_only(sv); /* validate pointer */
11484 /* move past delimiter and try to read a complete string */
11486 sv_catpvn(sv, s, termlen);
11489 tstart = SvPVX(PL_linestr) + stuffstart;
11490 if (!PL_thisopen && !keep_delims) {
11491 PL_thisopen = newSVpvn(tstart, s - tstart);
11492 stuffstart = s - SvPVX(PL_linestr);
11496 if (PL_encoding && !UTF) {
11500 int offset = s - SvPVX_const(PL_linestr);
11501 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11502 &offset, (char*)termstr, termlen);
11503 const char * const ns = SvPVX_const(PL_linestr) + offset;
11504 char * const svlast = SvEND(sv) - 1;
11506 for (; s < ns; s++) {
11507 if (*s == '\n' && !PL_rsfp)
11508 CopLINE_inc(PL_curcop);
11511 goto read_more_line;
11513 /* handle quoted delimiters */
11514 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11516 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11518 if ((svlast-1 - t) % 2) {
11519 if (!keep_quoted) {
11520 *(svlast-1) = term;
11522 SvCUR_set(sv, SvCUR(sv) - 1);
11527 if (PL_multi_open == PL_multi_close) {
11535 for (t = w = last; t < svlast; w++, t++) {
11536 /* At here, all closes are "was quoted" one,
11537 so we don't check PL_multi_close. */
11539 if (!keep_quoted && *(t+1) == PL_multi_open)
11544 else if (*t == PL_multi_open)
11552 SvCUR_set(sv, w - SvPVX_const(sv));
11555 if (--brackets <= 0)
11560 if (!keep_delims) {
11561 SvCUR_set(sv, SvCUR(sv) - 1);
11567 /* extend sv if need be */
11568 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11569 /* set 'to' to the next character in the sv's string */
11570 to = SvPVX(sv)+SvCUR(sv);
11572 /* if open delimiter is the close delimiter read unbridle */
11573 if (PL_multi_open == PL_multi_close) {
11574 for (; s < PL_bufend; s++,to++) {
11575 /* embedded newlines increment the current line number */
11576 if (*s == '\n' && !PL_rsfp)
11577 CopLINE_inc(PL_curcop);
11578 /* handle quoted delimiters */
11579 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11580 if (!keep_quoted && s[1] == term)
11582 /* any other quotes are simply copied straight through */
11586 /* terminate when run out of buffer (the for() condition), or
11587 have found the terminator */
11588 else if (*s == term) {
11591 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11594 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11600 /* if the terminator isn't the same as the start character (e.g.,
11601 matched brackets), we have to allow more in the quoting, and
11602 be prepared for nested brackets.
11605 /* read until we run out of string, or we find the terminator */
11606 for (; s < PL_bufend; s++,to++) {
11607 /* embedded newlines increment the line count */
11608 if (*s == '\n' && !PL_rsfp)
11609 CopLINE_inc(PL_curcop);
11610 /* backslashes can escape the open or closing characters */
11611 if (*s == '\\' && s+1 < PL_bufend) {
11612 if (!keep_quoted &&
11613 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11618 /* allow nested opens and closes */
11619 else if (*s == PL_multi_close && --brackets <= 0)
11621 else if (*s == PL_multi_open)
11623 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11628 /* terminate the copied string and update the sv's end-of-string */
11630 SvCUR_set(sv, to - SvPVX_const(sv));
11633 * this next chunk reads more into the buffer if we're not done yet
11637 break; /* handle case where we are done yet :-) */
11639 #ifndef PERL_STRICT_CR
11640 if (to - SvPVX_const(sv) >= 2) {
11641 if ((to[-2] == '\r' && to[-1] == '\n') ||
11642 (to[-2] == '\n' && to[-1] == '\r'))
11646 SvCUR_set(sv, to - SvPVX_const(sv));
11648 else if (to[-1] == '\r')
11651 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11656 /* if we're out of file, or a read fails, bail and reset the current
11657 line marker so we can report where the unterminated string began
11660 if (PL_madskills) {
11661 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11663 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11665 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11669 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11671 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11677 /* we read a line, so increment our line counter */
11678 CopLINE_inc(PL_curcop);
11680 /* update debugger info */
11681 if (PERLDB_LINE && PL_curstash != PL_debstash) {
11682 SV * const line_sv = newSV(0);
11684 sv_upgrade(line_sv, SVt_PVMG);
11685 sv_setsv(line_sv,PL_linestr);
11686 (void)SvIOK_on(line_sv);
11687 SvIV_set(line_sv, 0);
11688 av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv);
11691 /* having changed the buffer, we must update PL_bufend */
11692 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11693 PL_last_lop = PL_last_uni = NULL;
11696 /* at this point, we have successfully read the delimited string */
11698 if (!PL_encoding || UTF) {
11700 if (PL_madskills) {
11701 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11702 const int len = s - start;
11704 sv_catpvn(PL_thisstuff, tstart, len);
11706 PL_thisstuff = newSVpvn(tstart, len);
11707 if (!PL_thisclose && !keep_delims)
11708 PL_thisclose = newSVpvn(s,termlen);
11713 sv_catpvn(sv, s, termlen);
11718 if (PL_madskills) {
11719 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11720 const int len = s - tstart - termlen;
11722 sv_catpvn(PL_thisstuff, tstart, len);
11724 PL_thisstuff = newSVpvn(tstart, len);
11725 if (!PL_thisclose && !keep_delims)
11726 PL_thisclose = newSVpvn(s - termlen,termlen);
11730 if (has_utf8 || PL_encoding)
11733 PL_multi_end = CopLINE(PL_curcop);
11735 /* if we allocated too much space, give some back */
11736 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11737 SvLEN_set(sv, SvCUR(sv) + 1);
11738 SvPV_renew(sv, SvLEN(sv));
11741 /* decide whether this is the first or second quoted string we've read
11754 takes: pointer to position in buffer
11755 returns: pointer to new position in buffer
11756 side-effects: builds ops for the constant in yylval.op
11758 Read a number in any of the formats that Perl accepts:
11760 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11761 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11764 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11766 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11769 If it reads a number without a decimal point or an exponent, it will
11770 try converting the number to an integer and see if it can do so
11771 without loss of precision.
11775 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11778 register const char *s = start; /* current position in buffer */
11779 register char *d; /* destination in temp buffer */
11780 register char *e; /* end of temp buffer */
11781 NV nv; /* number read, as a double */
11782 SV *sv = NULL; /* place to put the converted number */
11783 bool floatit; /* boolean: int or float? */
11784 const char *lastub = NULL; /* position of last underbar */
11785 static char const number_too_long[] = "Number too long";
11787 /* We use the first character to decide what type of number this is */
11791 Perl_croak(aTHX_ "panic: scan_num");
11793 /* if it starts with a 0, it could be an octal number, a decimal in
11794 0.13 disguise, or a hexadecimal number, or a binary number. */
11798 u holds the "number so far"
11799 shift the power of 2 of the base
11800 (hex == 4, octal == 3, binary == 1)
11801 overflowed was the number more than we can hold?
11803 Shift is used when we add a digit. It also serves as an "are
11804 we in octal/hex/binary?" indicator to disallow hex characters
11805 when in octal mode.
11810 bool overflowed = FALSE;
11811 bool just_zero = TRUE; /* just plain 0 or binary number? */
11812 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11813 static const char* const bases[5] =
11814 { "", "binary", "", "octal", "hexadecimal" };
11815 static const char* const Bases[5] =
11816 { "", "Binary", "", "Octal", "Hexadecimal" };
11817 static const char* const maxima[5] =
11819 "0b11111111111111111111111111111111",
11823 const char *base, *Base, *max;
11825 /* check for hex */
11830 } else if (s[1] == 'b') {
11835 /* check for a decimal in disguise */
11836 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11838 /* so it must be octal */
11845 if (ckWARN(WARN_SYNTAX))
11846 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11847 "Misplaced _ in number");
11851 base = bases[shift];
11852 Base = Bases[shift];
11853 max = maxima[shift];
11855 /* read the rest of the number */
11857 /* x is used in the overflow test,
11858 b is the digit we're adding on. */
11863 /* if we don't mention it, we're done */
11867 /* _ are ignored -- but warned about if consecutive */
11869 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11870 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11871 "Misplaced _ in number");
11875 /* 8 and 9 are not octal */
11876 case '8': case '9':
11878 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11882 case '2': case '3': case '4':
11883 case '5': case '6': case '7':
11885 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11888 case '0': case '1':
11889 b = *s++ & 15; /* ASCII digit -> value of digit */
11893 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11894 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11895 /* make sure they said 0x */
11898 b = (*s++ & 7) + 9;
11900 /* Prepare to put the digit we have onto the end
11901 of the number so far. We check for overflows.
11907 x = u << shift; /* make room for the digit */
11909 if ((x >> shift) != u
11910 && !(PL_hints & HINT_NEW_BINARY)) {
11913 if (ckWARN_d(WARN_OVERFLOW))
11914 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11915 "Integer overflow in %s number",
11918 u = x | b; /* add the digit to the end */
11921 n *= nvshift[shift];
11922 /* If an NV has not enough bits in its
11923 * mantissa to represent an UV this summing of
11924 * small low-order numbers is a waste of time
11925 * (because the NV cannot preserve the
11926 * low-order bits anyway): we could just
11927 * remember when did we overflow and in the
11928 * end just multiply n by the right
11936 /* if we get here, we had success: make a scalar value from
11941 /* final misplaced underbar check */
11942 if (s[-1] == '_') {
11943 if (ckWARN(WARN_SYNTAX))
11944 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11949 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
11950 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
11951 "%s number > %s non-portable",
11957 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
11958 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
11959 "%s number > %s non-portable",
11964 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
11965 sv = new_constant(start, s - start, "integer",
11967 else if (PL_hints & HINT_NEW_BINARY)
11968 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
11973 handle decimal numbers.
11974 we're also sent here when we read a 0 as the first digit
11976 case '1': case '2': case '3': case '4': case '5':
11977 case '6': case '7': case '8': case '9': case '.':
11980 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11983 /* read next group of digits and _ and copy into d */
11984 while (isDIGIT(*s) || *s == '_') {
11985 /* skip underscores, checking for misplaced ones
11989 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11990 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11991 "Misplaced _ in number");
11995 /* check for end of fixed-length buffer */
11997 Perl_croak(aTHX_ number_too_long);
11998 /* if we're ok, copy the character */
12003 /* final misplaced underbar check */
12004 if (lastub && s == lastub + 1) {
12005 if (ckWARN(WARN_SYNTAX))
12006 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12009 /* read a decimal portion if there is one. avoid
12010 3..5 being interpreted as the number 3. followed
12013 if (*s == '.' && s[1] != '.') {
12018 if (ckWARN(WARN_SYNTAX))
12019 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12020 "Misplaced _ in number");
12024 /* copy, ignoring underbars, until we run out of digits.
12026 for (; isDIGIT(*s) || *s == '_'; s++) {
12027 /* fixed length buffer check */
12029 Perl_croak(aTHX_ number_too_long);
12031 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12032 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12033 "Misplaced _ in number");
12039 /* fractional part ending in underbar? */
12040 if (s[-1] == '_') {
12041 if (ckWARN(WARN_SYNTAX))
12042 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12043 "Misplaced _ in number");
12045 if (*s == '.' && isDIGIT(s[1])) {
12046 /* oops, it's really a v-string, but without the "v" */
12052 /* read exponent part, if present */
12053 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12057 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12058 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12060 /* stray preinitial _ */
12062 if (ckWARN(WARN_SYNTAX))
12063 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12064 "Misplaced _ in number");
12068 /* allow positive or negative exponent */
12069 if (*s == '+' || *s == '-')
12072 /* stray initial _ */
12074 if (ckWARN(WARN_SYNTAX))
12075 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12076 "Misplaced _ in number");
12080 /* read digits of exponent */
12081 while (isDIGIT(*s) || *s == '_') {
12084 Perl_croak(aTHX_ number_too_long);
12088 if (((lastub && s == lastub + 1) ||
12089 (!isDIGIT(s[1]) && s[1] != '_'))
12090 && ckWARN(WARN_SYNTAX))
12091 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12092 "Misplaced _ in number");
12099 /* make an sv from the string */
12103 We try to do an integer conversion first if no characters
12104 indicating "float" have been found.
12109 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12111 if (flags == IS_NUMBER_IN_UV) {
12113 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12116 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12117 if (uv <= (UV) IV_MIN)
12118 sv_setiv(sv, -(IV)uv);
12125 /* terminate the string */
12127 nv = Atof(PL_tokenbuf);
12131 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12132 (PL_hints & HINT_NEW_INTEGER) )
12133 sv = new_constant(PL_tokenbuf,
12136 (floatit ? "float" : "integer"),
12140 /* if it starts with a v, it could be a v-string */
12143 sv = newSV(5); /* preallocate storage space */
12144 s = scan_vstring(s,sv);
12148 /* make the op for the constant and return */
12151 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12153 lvalp->opval = NULL;
12159 S_scan_formline(pTHX_ register char *s)
12162 register char *eol;
12164 SV * const stuff = newSVpvs("");
12165 bool needargs = FALSE;
12166 bool eofmt = FALSE;
12168 char *tokenstart = s;
12171 if (PL_madskills) {
12172 savewhite = PL_thiswhite;
12177 while (!needargs) {
12180 #ifdef PERL_STRICT_CR
12181 while (SPACE_OR_TAB(*t))
12184 while (SPACE_OR_TAB(*t) || *t == '\r')
12187 if (*t == '\n' || t == PL_bufend) {
12192 if (PL_in_eval && !PL_rsfp) {
12193 eol = (char *) memchr(s,'\n',PL_bufend-s);
12198 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12200 for (t = s; t < eol; t++) {
12201 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12203 goto enough; /* ~~ must be first line in formline */
12205 if (*t == '@' || *t == '^')
12209 sv_catpvn(stuff, s, eol-s);
12210 #ifndef PERL_STRICT_CR
12211 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12212 char *end = SvPVX(stuff) + SvCUR(stuff);
12215 SvCUR_set(stuff, SvCUR(stuff) - 1);
12225 if (PL_madskills) {
12227 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12229 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12232 s = filter_gets(PL_linestr, PL_rsfp, 0);
12234 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12236 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12238 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12239 PL_last_lop = PL_last_uni = NULL;
12248 if (SvCUR(stuff)) {
12251 PL_lex_state = LEX_NORMAL;
12252 start_force(PL_curforce);
12253 NEXTVAL_NEXTTOKE.ival = 0;
12257 PL_lex_state = LEX_FORMLINE;
12259 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12261 else if (PL_encoding)
12262 sv_recode_to_utf8(stuff, PL_encoding);
12264 start_force(PL_curforce);
12265 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12267 start_force(PL_curforce);
12268 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12272 SvREFCNT_dec(stuff);
12274 PL_lex_formbrack = 0;
12278 if (PL_madskills) {
12280 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12282 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12283 PL_thiswhite = savewhite;
12295 PL_cshlen = strlen(PL_cshname);
12297 #if defined(USE_ITHREADS)
12298 PERL_UNUSED_CONTEXT;
12304 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12307 const I32 oldsavestack_ix = PL_savestack_ix;
12308 CV* const outsidecv = PL_compcv;
12311 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12313 SAVEI32(PL_subline);
12314 save_item(PL_subname);
12315 SAVESPTR(PL_compcv);
12317 PL_compcv = (CV*)newSV(0);
12318 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
12319 CvFLAGS(PL_compcv) |= flags;
12321 PL_subline = CopLINE(PL_curcop);
12322 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12323 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12324 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12326 return oldsavestack_ix;
12330 #pragma segment Perl_yylex
12333 Perl_yywarn(pTHX_ const char *s)
12336 PL_in_eval |= EVAL_WARNONLY;
12338 PL_in_eval &= ~EVAL_WARNONLY;
12343 Perl_yyerror(pTHX_ const char *s)
12346 const char *where = NULL;
12347 const char *context = NULL;
12351 if (!yychar || (yychar == ';' && !PL_rsfp))
12353 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12354 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12355 PL_oldbufptr != PL_bufptr) {
12358 The code below is removed for NetWare because it abends/crashes on NetWare
12359 when the script has error such as not having the closing quotes like:
12360 if ($var eq "value)
12361 Checking of white spaces is anyway done in NetWare code.
12364 while (isSPACE(*PL_oldoldbufptr))
12367 context = PL_oldoldbufptr;
12368 contlen = PL_bufptr - PL_oldoldbufptr;
12370 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12371 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12374 The code below is removed for NetWare because it abends/crashes on NetWare
12375 when the script has error such as not having the closing quotes like:
12376 if ($var eq "value)
12377 Checking of white spaces is anyway done in NetWare code.
12380 while (isSPACE(*PL_oldbufptr))
12383 context = PL_oldbufptr;
12384 contlen = PL_bufptr - PL_oldbufptr;
12386 else if (yychar > 255)
12387 where = "next token ???";
12388 else if (yychar == -2) { /* YYEMPTY */
12389 if (PL_lex_state == LEX_NORMAL ||
12390 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12391 where = "at end of line";
12392 else if (PL_lex_inpat)
12393 where = "within pattern";
12395 where = "within string";
12398 SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12400 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12401 else if (isPRINT_LC(yychar))
12402 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12404 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12405 where = SvPVX_const(where_sv);
12407 msg = sv_2mortal(newSVpv(s, 0));
12408 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12409 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12411 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12413 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12414 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12415 Perl_sv_catpvf(aTHX_ msg,
12416 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12417 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12420 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12421 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, (void*)msg);
12424 if (PL_error_count >= 10) {
12425 if (PL_in_eval && SvCUR(ERRSV))
12426 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12427 (void*)ERRSV, OutCopFILE(PL_curcop));
12429 Perl_croak(aTHX_ "%s has too many errors.\n",
12430 OutCopFILE(PL_curcop));
12433 PL_in_my_stash = NULL;
12437 #pragma segment Main
12441 S_swallow_bom(pTHX_ U8 *s)
12444 const STRLEN slen = SvCUR(PL_linestr);
12447 if (s[1] == 0xFE) {
12448 /* UTF-16 little-endian? (or UTF32-LE?) */
12449 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12450 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12451 #ifndef PERL_NO_UTF16_FILTER
12452 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12455 if (PL_bufend > (char*)s) {
12459 filter_add(utf16rev_textfilter, NULL);
12460 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12461 utf16_to_utf8_reversed(s, news,
12462 PL_bufend - (char*)s - 1,
12464 sv_setpvn(PL_linestr, (const char*)news, newlen);
12466 s = (U8*)SvPVX(PL_linestr);
12467 Copy(news, s, newlen, U8);
12471 SvUTF8_on(PL_linestr);
12472 s = (U8*)SvPVX(PL_linestr);
12474 /* FIXME - is this a general bug fix? */
12477 PL_bufend = SvPVX(PL_linestr) + newlen;
12480 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12485 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12486 #ifndef PERL_NO_UTF16_FILTER
12487 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12490 if (PL_bufend > (char *)s) {
12494 filter_add(utf16_textfilter, NULL);
12495 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12496 utf16_to_utf8(s, news,
12497 PL_bufend - (char*)s,
12499 sv_setpvn(PL_linestr, (const char*)news, newlen);
12501 SvUTF8_on(PL_linestr);
12502 s = (U8*)SvPVX(PL_linestr);
12503 PL_bufend = SvPVX(PL_linestr) + newlen;
12506 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12511 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12512 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12513 s += 3; /* UTF-8 */
12519 if (s[2] == 0xFE && s[3] == 0xFF) {
12520 /* UTF-32 big-endian */
12521 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12524 else if (s[2] == 0 && s[3] != 0) {
12527 * are a good indicator of UTF-16BE. */
12528 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12534 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12535 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12536 s += 4; /* UTF-8 */
12542 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12545 * are a good indicator of UTF-16LE. */
12546 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12555 * Restore a source filter.
12559 restore_rsfp(pTHX_ void *f)
12562 PerlIO * const fp = (PerlIO*)f;
12564 if (PL_rsfp == PerlIO_stdin())
12565 PerlIO_clearerr(PL_rsfp);
12566 else if (PL_rsfp && (PL_rsfp != fp))
12567 PerlIO_close(PL_rsfp);
12571 #ifndef PERL_NO_UTF16_FILTER
12573 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12576 const STRLEN old = SvCUR(sv);
12577 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12578 DEBUG_P(PerlIO_printf(Perl_debug_log,
12579 "utf16_textfilter(%p): %d %d (%d)\n",
12580 FPTR2DPTR(void *, utf16_textfilter),
12581 idx, maxlen, (int) count));
12585 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12586 Copy(SvPVX_const(sv), tmps, old, char);
12587 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12588 SvCUR(sv) - old, &newlen);
12589 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12591 DEBUG_P({sv_dump(sv);});
12596 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12599 const STRLEN old = SvCUR(sv);
12600 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12601 DEBUG_P(PerlIO_printf(Perl_debug_log,
12602 "utf16rev_textfilter(%p): %d %d (%d)\n",
12603 FPTR2DPTR(void *, utf16rev_textfilter),
12604 idx, maxlen, (int) count));
12608 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12609 Copy(SvPVX_const(sv), tmps, old, char);
12610 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12611 SvCUR(sv) - old, &newlen);
12612 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12614 DEBUG_P({ sv_dump(sv); });
12620 Returns a pointer to the next character after the parsed
12621 vstring, as well as updating the passed in sv.
12623 Function must be called like
12626 s = scan_vstring(s,sv);
12628 The sv should already be large enough to store the vstring
12629 passed in, for performance reasons.
12634 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
12637 const char *pos = s;
12638 const char *start = s;
12639 if (*pos == 'v') pos++; /* get past 'v' */
12640 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12642 if ( *pos != '.') {
12643 /* this may not be a v-string if followed by => */
12644 const char *next = pos;
12645 while (next < PL_bufend && isSPACE(*next))
12647 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
12648 /* return string not v-string */
12649 sv_setpvn(sv,(char *)s,pos-s);
12650 return (char *)pos;
12654 if (!isALPHA(*pos)) {
12655 U8 tmpbuf[UTF8_MAXBYTES+1];
12658 s++; /* get past 'v' */
12660 sv_setpvn(sv, "", 0);
12663 /* this is atoi() that tolerates underscores */
12666 const char *end = pos;
12668 while (--end >= s) {
12670 const UV orev = rev;
12671 rev += (*end - '0') * mult;
12673 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12674 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12675 "Integer overflow in decimal number");
12679 if (rev > 0x7FFFFFFF)
12680 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12682 /* Append native character for the rev point */
12683 tmpend = uvchr_to_utf8(tmpbuf, rev);
12684 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12685 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12687 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
12693 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12697 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12705 * c-indentation-style: bsd
12706 * c-basic-offset: 4
12707 * indent-tabs-mode: t
12710 * ex: set ts=8 sts=4 sw=4 noet: