3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4 * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 yylval (PL_parser->yylval)
28 /* YYINITDEPTH -- initial size of the parser's stacks. */
29 #define YYINITDEPTH 200
31 /* XXX temporary backwards compatibility */
32 #define PL_lex_brackets (PL_parser->lex_brackets)
33 #define PL_lex_brackstack (PL_parser->lex_brackstack)
34 #define PL_lex_casemods (PL_parser->lex_casemods)
35 #define PL_lex_casestack (PL_parser->lex_casestack)
36 #define PL_lex_defer (PL_parser->lex_defer)
37 #define PL_lex_dojoin (PL_parser->lex_dojoin)
38 #define PL_lex_expect (PL_parser->lex_expect)
39 #define PL_lex_formbrack (PL_parser->lex_formbrack)
40 #define PL_lex_inpat (PL_parser->lex_inpat)
41 #define PL_lex_inwhat (PL_parser->lex_inwhat)
42 #define PL_lex_op (PL_parser->lex_op)
43 #define PL_lex_repl (PL_parser->lex_repl)
44 #define PL_lex_starts (PL_parser->lex_starts)
45 #define PL_lex_stuff (PL_parser->lex_stuff)
46 #define PL_multi_start (PL_parser->multi_start)
47 #define PL_multi_open (PL_parser->multi_open)
48 #define PL_multi_close (PL_parser->multi_close)
49 #define PL_pending_ident (PL_parser->pending_ident)
50 #define PL_preambled (PL_parser->preambled)
51 #define PL_sublex_info (PL_parser->sublex_info)
54 # define PL_endwhite (PL_parser->endwhite)
55 # define PL_faketokens (PL_parser->faketokens)
56 # define PL_lasttoke (PL_parser->lasttoke)
57 # define PL_nextwhite (PL_parser->nextwhite)
58 # define PL_realtokenstart (PL_parser->realtokenstart)
59 # define PL_skipwhite (PL_parser->skipwhite)
60 # define PL_thisclose (PL_parser->thisclose)
61 # define PL_thismad (PL_parser->thismad)
62 # define PL_thisopen (PL_parser->thisopen)
63 # define PL_thisstuff (PL_parser->thisstuff)
64 # define PL_thistoken (PL_parser->thistoken)
65 # define PL_thiswhite (PL_parser->thiswhite)
69 S_pending_ident(pTHX);
71 static const char ident_too_long[] = "Identifier too long";
72 static const char commaless_variable_list[] = "comma-less variable list";
74 static void restore_rsfp(pTHX_ void *f);
75 #ifndef PERL_NO_UTF16_FILTER
76 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
77 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
81 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
82 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
84 # define CURMAD(slot,sv)
85 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
88 #define XFAKEBRACK 128
91 #ifdef USE_UTF8_SCRIPTS
92 # define UTF (!IN_BYTES)
94 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
97 /* In variables named $^X, these are the legal values for X.
98 * 1999-02-27 mjd-perl-patch@plover.com */
99 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
101 /* On MacOS, respect nonbreaking spaces */
102 #ifdef MACOS_TRADITIONAL
103 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
105 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
108 /* LEX_* are values for PL_lex_state, the state of the lexer.
109 * They are arranged oddly so that the guard on the switch statement
110 * can get by with a single comparison (if the compiler is smart enough).
113 /* #define LEX_NOTPARSING 11 is done in perl.h. */
115 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
116 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
117 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
118 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
119 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
121 /* at end of code, eg "$x" followed by: */
122 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
123 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
125 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
126 string or after \E, $foo, etc */
127 #define LEX_INTERPCONST 2 /* NOT USED */
128 #define LEX_FORMLINE 1 /* expecting a format line */
129 #define LEX_KNOWNEXT 0 /* next token known; just return it */
133 static const char* const lex_state_names[] = {
152 #include "keywords.h"
154 /* CLINE is a macro that ensures PL_copline has a sane value */
159 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
162 # define SKIPSPACE0(s) skipspace0(s)
163 # define SKIPSPACE1(s) skipspace1(s)
164 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
165 # define PEEKSPACE(s) skipspace2(s,0)
167 # define SKIPSPACE0(s) skipspace(s)
168 # define SKIPSPACE1(s) skipspace(s)
169 # define SKIPSPACE2(s,tsv) skipspace(s)
170 # define PEEKSPACE(s) skipspace(s)
174 * Convenience functions to return different tokens and prime the
175 * lexer for the next token. They all take an argument.
177 * TOKEN : generic token (used for '(', DOLSHARP, etc)
178 * OPERATOR : generic operator
179 * AOPERATOR : assignment operator
180 * PREBLOCK : beginning the block after an if, while, foreach, ...
181 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
182 * PREREF : *EXPR where EXPR is not a simple identifier
183 * TERM : expression term
184 * LOOPX : loop exiting command (goto, last, dump, etc)
185 * FTST : file test operator
186 * FUN0 : zero-argument function
187 * FUN1 : not used, except for not, which isn't a UNIOP
188 * BOop : bitwise or or xor
190 * SHop : shift operator
191 * PWop : power operator
192 * PMop : pattern-matching operator
193 * Aop : addition-level operator
194 * Mop : multiplication-level operator
195 * Eop : equality-testing operator
196 * Rop : relational operator <= != gt
198 * Also see LOP and lop() below.
201 #ifdef DEBUGGING /* Serve -DT. */
202 # define REPORT(retval) tokereport((I32)retval)
204 # define REPORT(retval) (retval)
207 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
208 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
209 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
210 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
211 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
212 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
213 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
214 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
215 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
216 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
217 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
218 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
219 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
220 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
221 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
222 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
223 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
224 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
225 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
226 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
228 /* This bit of chicanery makes a unary function followed by
229 * a parenthesis into a function with one argument, highest precedence.
230 * The UNIDOR macro is for unary functions that can be followed by the //
231 * operator (such as C<shift // 0>).
233 #define UNI2(f,x) { \
237 PL_last_uni = PL_oldbufptr; \
238 PL_last_lop_op = f; \
240 return REPORT( (int)FUNC1 ); \
242 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
244 #define UNI(f) UNI2(f,XTERM)
245 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
247 #define UNIBRACK(f) { \
250 PL_last_uni = PL_oldbufptr; \
252 return REPORT( (int)FUNC1 ); \
254 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
257 /* grandfather return to old style */
258 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
262 /* how to interpret the yylval associated with the token */
266 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
272 static struct debug_tokens {
274 enum token_type type;
276 } const debug_tokens[] =
278 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
279 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
280 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
281 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
282 { ARROW, TOKENTYPE_NONE, "ARROW" },
283 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
284 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
285 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
286 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
287 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
288 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
289 { DO, TOKENTYPE_NONE, "DO" },
290 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
291 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
292 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
293 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
294 { ELSE, TOKENTYPE_NONE, "ELSE" },
295 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
296 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
297 { FOR, TOKENTYPE_IVAL, "FOR" },
298 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
299 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
300 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
301 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
302 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
303 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
304 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
305 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
306 { IF, TOKENTYPE_IVAL, "IF" },
307 { LABEL, TOKENTYPE_PVAL, "LABEL" },
308 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
309 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
310 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
311 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
312 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
313 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
314 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
315 { MY, TOKENTYPE_IVAL, "MY" },
316 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
317 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
318 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
319 { OROP, TOKENTYPE_IVAL, "OROP" },
320 { OROR, TOKENTYPE_NONE, "OROR" },
321 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
322 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
323 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
324 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
325 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
326 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
327 { PREINC, TOKENTYPE_NONE, "PREINC" },
328 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
329 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
330 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
331 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
332 { SUB, TOKENTYPE_NONE, "SUB" },
333 { THING, TOKENTYPE_OPVAL, "THING" },
334 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
335 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
336 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
337 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
338 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
339 { USE, TOKENTYPE_IVAL, "USE" },
340 { WHEN, TOKENTYPE_IVAL, "WHEN" },
341 { WHILE, TOKENTYPE_IVAL, "WHILE" },
342 { WORD, TOKENTYPE_OPVAL, "WORD" },
343 { 0, TOKENTYPE_NONE, NULL }
346 /* dump the returned token in rv, plus any optional arg in yylval */
349 S_tokereport(pTHX_ I32 rv)
353 const char *name = NULL;
354 enum token_type type = TOKENTYPE_NONE;
355 const struct debug_tokens *p;
356 SV* const report = newSVpvs("<== ");
358 for (p = debug_tokens; p->token; p++) {
359 if (p->token == (int)rv) {
366 Perl_sv_catpv(aTHX_ report, name);
367 else if ((char)rv > ' ' && (char)rv < '~')
368 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
370 sv_catpvs(report, "EOF");
372 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
375 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
378 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
380 case TOKENTYPE_OPNUM:
381 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
382 PL_op_name[yylval.ival]);
385 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
387 case TOKENTYPE_OPVAL:
389 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
390 PL_op_name[yylval.opval->op_type]);
391 if (yylval.opval->op_type == OP_CONST) {
392 Perl_sv_catpvf(aTHX_ report, " %s",
393 SvPEEK(cSVOPx_sv(yylval.opval)));
398 sv_catpvs(report, "(opval=null)");
401 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
407 /* print the buffer with suitable escapes */
410 S_printbuf(pTHX_ const char* fmt, const char* s)
412 SV* const tmp = newSVpvs("");
413 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
422 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
423 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
427 S_ao(pTHX_ int toketype)
430 if (*PL_bufptr == '=') {
432 if (toketype == ANDAND)
433 yylval.ival = OP_ANDASSIGN;
434 else if (toketype == OROR)
435 yylval.ival = OP_ORASSIGN;
436 else if (toketype == DORDOR)
437 yylval.ival = OP_DORASSIGN;
445 * When Perl expects an operator and finds something else, no_op
446 * prints the warning. It always prints "<something> found where
447 * operator expected. It prints "Missing semicolon on previous line?"
448 * if the surprise occurs at the start of the line. "do you need to
449 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
450 * where the compiler doesn't know if foo is a method call or a function.
451 * It prints "Missing operator before end of line" if there's nothing
452 * after the missing operator, or "... before <...>" if there is something
453 * after the missing operator.
457 S_no_op(pTHX_ const char *what, char *s)
460 char * const oldbp = PL_bufptr;
461 const bool is_first = (PL_oldbufptr == PL_linestart);
467 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
468 if (ckWARN_d(WARN_SYNTAX)) {
470 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
471 "\t(Missing semicolon on previous line?)\n");
472 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
474 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
476 if (t < PL_bufptr && isSPACE(*t))
477 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
478 "\t(Do you need to predeclare %.*s?)\n",
479 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
483 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
484 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
492 * Complain about missing quote/regexp/heredoc terminator.
493 * If it's called with NULL then it cauterizes the line buffer.
494 * If we're in a delimited string and the delimiter is a control
495 * character, it's reformatted into a two-char sequence like ^C.
500 S_missingterm(pTHX_ char *s)
506 char * const nl = strrchr(s,'\n');
512 iscntrl(PL_multi_close)
514 PL_multi_close < 32 || PL_multi_close == 127
518 tmpbuf[1] = (char)toCTRL(PL_multi_close);
523 *tmpbuf = (char)PL_multi_close;
527 q = strchr(s,'"') ? '\'' : '"';
528 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
531 #define FEATURE_IS_ENABLED(name) \
532 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
533 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
535 * S_feature_is_enabled
536 * Check whether the named feature is enabled.
539 S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
542 HV * const hinthv = GvHV(PL_hintgv);
543 char he_name[32] = "feature_";
544 (void) my_strlcpy(&he_name[8], name, 24);
546 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
554 Perl_deprecate(pTHX_ const char *s)
556 if (ckWARN(WARN_DEPRECATED))
557 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
561 Perl_deprecate_old(pTHX_ const char *s)
563 /* This function should NOT be called for any new deprecated warnings */
564 /* Use Perl_deprecate instead */
566 /* It is here to maintain backward compatibility with the pre-5.8 */
567 /* warnings category hierarchy. The "deprecated" category used to */
568 /* live under the "syntax" category. It is now a top-level category */
569 /* in its own right. */
571 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
572 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
573 "Use of %s is deprecated", s);
577 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
578 * utf16-to-utf8-reversed.
581 #ifdef PERL_CR_FILTER
585 register const char *s = SvPVX_const(sv);
586 register const char * const e = s + SvCUR(sv);
587 /* outer loop optimized to do nothing if there are no CR-LFs */
589 if (*s++ == '\r' && *s == '\n') {
590 /* hit a CR-LF, need to copy the rest */
591 register char *d = s - 1;
594 if (*s == '\r' && s[1] == '\n')
605 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
607 const I32 count = FILTER_READ(idx+1, sv, maxlen);
608 if (count > 0 && !maxlen)
618 * Initialize variables. Uses the Perl save_stack to save its state (for
619 * recursive calls to the parser).
623 Perl_lex_start(pTHX_ SV *line)
626 const char *s = NULL;
630 /* create and initialise a parser */
632 Newxz(parser, 1, yy_parser);
633 parser->old_parser = PL_parser;
636 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
637 parser->ps = parser->stack;
638 parser->stack_size = YYINITDEPTH;
640 parser->stack->state = 0;
641 parser->yyerrstatus = 0;
642 parser->yychar = YYEMPTY; /* Cause a token to be read. */
644 /* initialise lexer state */
646 SAVEI32(PL_lex_state);
648 if (PL_lex_state == LEX_KNOWNEXT) {
649 I32 toke = parser->old_parser->lasttoke;
650 while (--toke >= 0) {
651 SAVEI32(PL_nexttoke[toke].next_type);
652 SAVEVPTR(PL_nexttoke[toke].next_val);
654 SAVEVPTR(PL_nexttoke[toke].next_mad);
657 SAVEI32(PL_curforce);
659 if (PL_lex_state == LEX_KNOWNEXT) {
660 I32 toke = PL_nexttoke;
661 while (--toke >= 0) {
662 SAVEI32(PL_nexttype[toke]);
663 SAVEVPTR(PL_nextval[toke]);
665 SAVEI32(PL_nexttoke);
668 SAVECOPLINE(PL_curcop);
671 SAVEPPTR(PL_oldbufptr);
672 SAVEPPTR(PL_oldoldbufptr);
673 SAVEPPTR(PL_last_lop);
674 SAVEPPTR(PL_last_uni);
675 SAVEPPTR(PL_linestart);
676 SAVESPTR(PL_linestr);
677 SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
680 PL_lex_state = LEX_NORMAL;
682 Newx(parser->lex_brackstack, 120, char);
683 Newx(parser->lex_casestack, 12, char);
684 *parser->lex_casestack = '\0';
690 s = SvPV_const(line, len);
695 PL_linestr = newSVpvs("\n;");
696 } else if (SvREADONLY(line) || s[len-1] != ';') {
697 PL_linestr = newSVsv(line);
699 sv_catpvs(PL_linestr, "\n;");
702 SvREFCNT_inc_simple_void_NN(line);
705 /* PL_linestr needs to survive until end of scope, not just the next
706 FREETMPS. See changes 17505 and 17546 which fixed the symptoms only. */
707 SAVEFREESV(PL_linestr);
708 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
709 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
710 PL_last_lop = PL_last_uni = NULL;
716 * Finalizer for lexing operations. Must be called when the parser is
717 * done with the lexer.
724 PL_doextract = FALSE;
729 * This subroutine has nothing to do with tilting, whether at windmills
730 * or pinball tables. Its name is short for "increment line". It
731 * increments the current line number in CopLINE(PL_curcop) and checks
732 * to see whether the line starts with a comment of the form
733 * # line 500 "foo.pm"
734 * If so, it sets the current line number and file to the values in the comment.
738 S_incline(pTHX_ char *s)
746 CopLINE_inc(PL_curcop);
749 while (SPACE_OR_TAB(*s))
751 if (strnEQ(s, "line", 4))
755 if (SPACE_OR_TAB(*s))
759 while (SPACE_OR_TAB(*s))
767 while (SPACE_OR_TAB(*s))
769 if (*s == '"' && (t = strchr(s+1, '"'))) {
779 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
781 if (*e != '\n' && *e != '\0')
782 return; /* false alarm */
788 const char * const cf = CopFILE(PL_curcop);
789 STRLEN tmplen = cf ? strlen(cf) : 0;
790 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
791 /* must copy *{"::_<(eval N)[oldfilename:L]"}
792 * to *{"::_<newfilename"} */
793 char smallbuf[256], smallbuf2[256];
794 char *tmpbuf, *tmpbuf2;
796 STRLEN tmplen2 = strlen(s);
797 if (tmplen + 3 < sizeof smallbuf)
800 Newx(tmpbuf, tmplen + 3, char);
801 if (tmplen2 + 3 < sizeof smallbuf2)
804 Newx(tmpbuf2, tmplen2 + 3, char);
805 tmpbuf[0] = tmpbuf2[0] = '_';
806 tmpbuf[1] = tmpbuf2[1] = '<';
807 memcpy(tmpbuf + 2, cf, ++tmplen);
808 memcpy(tmpbuf2 + 2, s, ++tmplen2);
810 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
812 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
814 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
815 /* adjust ${"::_<newfilename"} to store the new file name */
816 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
817 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
818 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
821 if (tmpbuf != smallbuf) Safefree(tmpbuf);
822 if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
825 CopFILE_free(PL_curcop);
826 CopFILE_set(PL_curcop, s);
829 CopLINE_set(PL_curcop, atoi(n)-1);
833 /* skip space before PL_thistoken */
836 S_skipspace0(pTHX_ register char *s)
843 PL_thiswhite = newSVpvs("");
844 sv_catsv(PL_thiswhite, PL_skipwhite);
845 sv_free(PL_skipwhite);
848 PL_realtokenstart = s - SvPVX(PL_linestr);
852 /* skip space after PL_thistoken */
855 S_skipspace1(pTHX_ register char *s)
857 const char *start = s;
858 I32 startoff = start - SvPVX(PL_linestr);
863 start = SvPVX(PL_linestr) + startoff;
864 if (!PL_thistoken && PL_realtokenstart >= 0) {
865 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
866 PL_thistoken = newSVpvn(tstart, start - tstart);
868 PL_realtokenstart = -1;
871 PL_nextwhite = newSVpvs("");
872 sv_catsv(PL_nextwhite, PL_skipwhite);
873 sv_free(PL_skipwhite);
880 S_skipspace2(pTHX_ register char *s, SV **svp)
883 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
884 const I32 startoff = s - SvPVX(PL_linestr);
887 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
888 if (!PL_madskills || !svp)
890 start = SvPVX(PL_linestr) + startoff;
891 if (!PL_thistoken && PL_realtokenstart >= 0) {
892 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
893 PL_thistoken = newSVpvn(tstart, start - tstart);
894 PL_realtokenstart = -1;
899 sv_setsv(*svp, PL_skipwhite);
900 sv_free(PL_skipwhite);
909 S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len)
911 AV *av = CopFILEAVx(PL_curcop);
913 SV * const sv = newSV(0);
914 sv_upgrade(sv, SVt_PVMG);
916 sv_setsv(sv, orig_sv);
918 sv_setpvn(sv, buf, len);
921 av_store(av, (I32)CopLINE(PL_curcop), sv);
927 * Called to gobble the appropriate amount and type of whitespace.
928 * Skips comments as well.
932 S_skipspace(pTHX_ register char *s)
937 int startoff = s - SvPVX(PL_linestr);
940 sv_free(PL_skipwhite);
945 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
946 while (s < PL_bufend && SPACE_OR_TAB(*s))
956 SSize_t oldprevlen, oldoldprevlen;
957 SSize_t oldloplen = 0, oldunilen = 0;
958 while (s < PL_bufend && isSPACE(*s)) {
959 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
964 if (s < PL_bufend && *s == '#') {
965 while (s < PL_bufend && *s != '\n')
969 if (PL_in_eval && !PL_rsfp) {
976 /* only continue to recharge the buffer if we're at the end
977 * of the buffer, we're not reading from a source filter, and
978 * we're in normal lexing mode
980 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
981 PL_lex_state == LEX_FORMLINE)
988 /* try to recharge the buffer */
990 curoff = s - SvPVX(PL_linestr);
993 if ((s = filter_gets(PL_linestr, PL_rsfp,
994 (prevlen = SvCUR(PL_linestr)))) == NULL)
997 if (PL_madskills && curoff != startoff) {
999 PL_skipwhite = newSVpvs("");
1000 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1004 /* mustn't throw out old stuff yet if madpropping */
1005 SvCUR(PL_linestr) = curoff;
1006 s = SvPVX(PL_linestr) + curoff;
1008 if (curoff && s[-1] == '\n')
1012 /* end of file. Add on the -p or -n magic */
1013 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1016 sv_catpv(PL_linestr,
1017 ";}continue{print or die qq(-p destination: $!\\n);}");
1019 sv_setpv(PL_linestr,
1020 ";}continue{print or die qq(-p destination: $!\\n);}");
1022 PL_minus_n = PL_minus_p = 0;
1024 else if (PL_minus_n) {
1026 sv_catpvn(PL_linestr, ";}", 2);
1028 sv_setpvn(PL_linestr, ";}", 2);
1034 sv_catpvn(PL_linestr,";", 1);
1036 sv_setpvn(PL_linestr,";", 1);
1039 /* reset variables for next time we lex */
1040 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1046 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1047 PL_last_lop = PL_last_uni = NULL;
1049 /* Close the filehandle. Could be from -P preprocessor,
1050 * STDIN, or a regular file. If we were reading code from
1051 * STDIN (because the commandline held no -e or filename)
1052 * then we don't close it, we reset it so the code can
1053 * read from STDIN too.
1056 if (PL_preprocess && !PL_in_eval)
1057 (void)PerlProc_pclose(PL_rsfp);
1058 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1059 PerlIO_clearerr(PL_rsfp);
1061 (void)PerlIO_close(PL_rsfp);
1066 /* not at end of file, so we only read another line */
1067 /* make corresponding updates to old pointers, for yyerror() */
1068 oldprevlen = PL_oldbufptr - PL_bufend;
1069 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1071 oldunilen = PL_last_uni - PL_bufend;
1073 oldloplen = PL_last_lop - PL_bufend;
1074 PL_linestart = PL_bufptr = s + prevlen;
1075 PL_bufend = s + SvCUR(PL_linestr);
1077 PL_oldbufptr = s + oldprevlen;
1078 PL_oldoldbufptr = s + oldoldprevlen;
1080 PL_last_uni = s + oldunilen;
1082 PL_last_lop = s + oldloplen;
1085 /* debugger active and we're not compiling the debugger code,
1086 * so store the line into the debugger's array of lines
1088 if (PERLDB_LINE && PL_curstash != PL_debstash)
1089 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1096 PL_skipwhite = newSVpvs("");
1097 curoff = s - SvPVX(PL_linestr);
1098 if (curoff - startoff)
1099 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1108 * Check the unary operators to ensure there's no ambiguity in how they're
1109 * used. An ambiguous piece of code would be:
1111 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1112 * the +5 is its argument.
1122 if (PL_oldoldbufptr != PL_last_uni)
1124 while (isSPACE(*PL_last_uni))
1127 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1129 if ((t = strchr(s, '(')) && t < PL_bufptr)
1132 if (ckWARN_d(WARN_AMBIGUOUS)){
1133 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1134 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1135 (int)(s - PL_last_uni), PL_last_uni);
1140 * LOP : macro to build a list operator. Its behaviour has been replaced
1141 * with a subroutine, S_lop() for which LOP is just another name.
1144 #define LOP(f,x) return lop(f,x,s)
1148 * Build a list operator (or something that might be one). The rules:
1149 * - if we have a next token, then it's a list operator [why?]
1150 * - if the next thing is an opening paren, then it's a function
1151 * - else it's a list operator
1155 S_lop(pTHX_ I32 f, int x, char *s)
1162 PL_last_lop = PL_oldbufptr;
1163 PL_last_lop_op = (OPCODE)f;
1166 return REPORT(LSTOP);
1169 return REPORT(LSTOP);
1172 return REPORT(FUNC);
1175 return REPORT(FUNC);
1177 return REPORT(LSTOP);
1183 * Sets up for an eventual force_next(). start_force(0) basically does
1184 * an unshift, while start_force(-1) does a push. yylex removes items
1189 S_start_force(pTHX_ int where)
1193 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1194 where = PL_lasttoke;
1195 assert(PL_curforce < 0 || PL_curforce == where);
1196 if (PL_curforce != where) {
1197 for (i = PL_lasttoke; i > where; --i) {
1198 PL_nexttoke[i] = PL_nexttoke[i-1];
1202 if (PL_curforce < 0) /* in case of duplicate start_force() */
1203 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1204 PL_curforce = where;
1207 curmad('^', newSVpvs(""));
1208 CURMAD('_', PL_nextwhite);
1213 S_curmad(pTHX_ char slot, SV *sv)
1219 if (PL_curforce < 0)
1220 where = &PL_thismad;
1222 where = &PL_nexttoke[PL_curforce].next_mad;
1225 sv_setpvn(sv, "", 0);
1228 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1230 else if (PL_encoding) {
1231 sv_recode_to_utf8(sv, PL_encoding);
1236 /* keep a slot open for the head of the list? */
1237 if (slot != '_' && *where && (*where)->mad_key == '^') {
1238 (*where)->mad_key = slot;
1239 sv_free((*where)->mad_val);
1240 (*where)->mad_val = (void*)sv;
1243 addmad(newMADsv(slot, sv), where, 0);
1246 # define start_force(where) NOOP
1247 # define curmad(slot, sv) NOOP
1252 * When the lexer realizes it knows the next token (for instance,
1253 * it is reordering tokens for the parser) then it can call S_force_next
1254 * to know what token to return the next time the lexer is called. Caller
1255 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1256 * and possibly PL_expect to ensure the lexer handles the token correctly.
1260 S_force_next(pTHX_ I32 type)
1264 if (PL_curforce < 0)
1265 start_force(PL_lasttoke);
1266 PL_nexttoke[PL_curforce].next_type = type;
1267 if (PL_lex_state != LEX_KNOWNEXT)
1268 PL_lex_defer = PL_lex_state;
1269 PL_lex_state = LEX_KNOWNEXT;
1270 PL_lex_expect = PL_expect;
1273 PL_nexttype[PL_nexttoke] = type;
1275 if (PL_lex_state != LEX_KNOWNEXT) {
1276 PL_lex_defer = PL_lex_state;
1277 PL_lex_expect = PL_expect;
1278 PL_lex_state = LEX_KNOWNEXT;
1284 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
1287 SV * const sv = newSVpvn(start,len);
1288 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
1295 * When the lexer knows the next thing is a word (for instance, it has
1296 * just seen -> and it knows that the next char is a word char, then
1297 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1301 * char *start : buffer position (must be within PL_linestr)
1302 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1303 * int check_keyword : if true, Perl checks to make sure the word isn't
1304 * a keyword (do this if the word is a label, e.g. goto FOO)
1305 * int allow_pack : if true, : characters will also be allowed (require,
1306 * use, etc. do this)
1307 * int allow_initial_tick : used by the "sub" lexer only.
1311 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1317 start = SKIPSPACE1(start);
1319 if (isIDFIRST_lazy_if(s,UTF) ||
1320 (allow_pack && *s == ':') ||
1321 (allow_initial_tick && *s == '\'') )
1323 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1324 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1326 start_force(PL_curforce);
1328 curmad('X', newSVpvn(start,s-start));
1329 if (token == METHOD) {
1334 PL_expect = XOPERATOR;
1337 NEXTVAL_NEXTTOKE.opval
1338 = (OP*)newSVOP(OP_CONST,0,
1339 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1340 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1348 * Called when the lexer wants $foo *foo &foo etc, but the program
1349 * text only contains the "foo" portion. The first argument is a pointer
1350 * to the "foo", and the second argument is the type symbol to prefix.
1351 * Forces the next token to be a "WORD".
1352 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1356 S_force_ident(pTHX_ register const char *s, int kind)
1360 const STRLEN len = strlen(s);
1361 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1362 start_force(PL_curforce);
1363 NEXTVAL_NEXTTOKE.opval = o;
1366 o->op_private = OPpCONST_ENTERED;
1367 /* XXX see note in pp_entereval() for why we forgo typo
1368 warnings if the symbol must be introduced in an eval.
1370 gv_fetchpvn_flags(s, len,
1371 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1373 kind == '$' ? SVt_PV :
1374 kind == '@' ? SVt_PVAV :
1375 kind == '%' ? SVt_PVHV :
1383 Perl_str_to_version(pTHX_ SV *sv)
1388 const char *start = SvPV_const(sv,len);
1389 const char * const end = start + len;
1390 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1391 while (start < end) {
1395 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1400 retval += ((NV)n)/nshift;
1409 * Forces the next token to be a version number.
1410 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1411 * and if "guessing" is TRUE, then no new token is created (and the caller
1412 * must use an alternative parsing method).
1416 S_force_version(pTHX_ char *s, int guessing)
1422 I32 startoff = s - SvPVX(PL_linestr);
1431 while (isDIGIT(*d) || *d == '_' || *d == '.')
1435 start_force(PL_curforce);
1436 curmad('X', newSVpvn(s,d-s));
1439 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1441 s = scan_num(s, &yylval);
1442 version = yylval.opval;
1443 ver = cSVOPx(version)->op_sv;
1444 if (SvPOK(ver) && !SvNIOK(ver)) {
1445 SvUPGRADE(ver, SVt_PVNV);
1446 SvNV_set(ver, str_to_version(ver));
1447 SvNOK_on(ver); /* hint that it is a version */
1450 else if (guessing) {
1453 sv_free(PL_nextwhite); /* let next token collect whitespace */
1455 s = SvPVX(PL_linestr) + startoff;
1463 if (PL_madskills && !version) {
1464 sv_free(PL_nextwhite); /* let next token collect whitespace */
1466 s = SvPVX(PL_linestr) + startoff;
1469 /* NOTE: The parser sees the package name and the VERSION swapped */
1470 start_force(PL_curforce);
1471 NEXTVAL_NEXTTOKE.opval = version;
1479 * Tokenize a quoted string passed in as an SV. It finds the next
1480 * chunk, up to end of string or a backslash. It may make a new
1481 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1486 S_tokeq(pTHX_ SV *sv)
1490 register char *send;
1498 s = SvPV_force(sv, len);
1499 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1502 while (s < send && *s != '\\')
1507 if ( PL_hints & HINT_NEW_STRING ) {
1508 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1514 if (s + 1 < send && (s[1] == '\\'))
1515 s++; /* all that, just for this */
1520 SvCUR_set(sv, d - SvPVX_const(sv));
1522 if ( PL_hints & HINT_NEW_STRING )
1523 return new_constant(NULL, 0, "q", sv, pv, "q");
1528 * Now come three functions related to double-quote context,
1529 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1530 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1531 * interact with PL_lex_state, and create fake ( ... ) argument lists
1532 * to handle functions and concatenation.
1533 * They assume that whoever calls them will be setting up a fake
1534 * join call, because each subthing puts a ',' after it. This lets
1537 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1539 * (I'm not sure whether the spurious commas at the end of lcfirst's
1540 * arguments and join's arguments are created or not).
1545 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1547 * Pattern matching will set PL_lex_op to the pattern-matching op to
1548 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1550 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1552 * Everything else becomes a FUNC.
1554 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1555 * had an OP_CONST or OP_READLINE). This just sets us up for a
1556 * call to S_sublex_push().
1560 S_sublex_start(pTHX)
1563 register const I32 op_type = yylval.ival;
1565 if (op_type == OP_NULL) {
1566 yylval.opval = PL_lex_op;
1570 if (op_type == OP_CONST || op_type == OP_READLINE) {
1571 SV *sv = tokeq(PL_lex_stuff);
1573 if (SvTYPE(sv) == SVt_PVIV) {
1574 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1576 const char * const p = SvPV_const(sv, len);
1577 SV * const nsv = newSVpvn(p, len);
1583 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1584 PL_lex_stuff = NULL;
1585 /* Allow <FH> // "foo" */
1586 if (op_type == OP_READLINE)
1587 PL_expect = XTERMORDORDOR;
1590 else if (op_type == OP_BACKTICK && PL_lex_op) {
1591 /* readpipe() vas overriden */
1592 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1593 yylval.opval = PL_lex_op;
1595 PL_lex_stuff = NULL;
1599 PL_sublex_info.super_state = PL_lex_state;
1600 PL_sublex_info.sub_inwhat = op_type;
1601 PL_sublex_info.sub_op = PL_lex_op;
1602 PL_lex_state = LEX_INTERPPUSH;
1606 yylval.opval = PL_lex_op;
1616 * Create a new scope to save the lexing state. The scope will be
1617 * ended in S_sublex_done. Returns a '(', starting the function arguments
1618 * to the uc, lc, etc. found before.
1619 * Sets PL_lex_state to LEX_INTERPCONCAT.
1628 PL_lex_state = PL_sublex_info.super_state;
1629 SAVEI32(PL_lex_dojoin);
1630 SAVEI32(PL_lex_brackets);
1631 SAVEI32(PL_lex_casemods);
1632 SAVEI32(PL_lex_starts);
1633 SAVEI32(PL_lex_state);
1634 SAVEVPTR(PL_lex_inpat);
1635 SAVEI32(PL_lex_inwhat);
1636 SAVECOPLINE(PL_curcop);
1637 SAVEPPTR(PL_bufptr);
1638 SAVEPPTR(PL_bufend);
1639 SAVEPPTR(PL_oldbufptr);
1640 SAVEPPTR(PL_oldoldbufptr);
1641 SAVEPPTR(PL_last_lop);
1642 SAVEPPTR(PL_last_uni);
1643 SAVEPPTR(PL_linestart);
1644 SAVESPTR(PL_linestr);
1645 SAVEGENERICPV(PL_lex_brackstack);
1646 SAVEGENERICPV(PL_lex_casestack);
1648 PL_linestr = PL_lex_stuff;
1649 PL_lex_stuff = NULL;
1651 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1652 = SvPVX(PL_linestr);
1653 PL_bufend += SvCUR(PL_linestr);
1654 PL_last_lop = PL_last_uni = NULL;
1655 SAVEFREESV(PL_linestr);
1657 PL_lex_dojoin = FALSE;
1658 PL_lex_brackets = 0;
1659 Newx(PL_lex_brackstack, 120, char);
1660 Newx(PL_lex_casestack, 12, char);
1661 PL_lex_casemods = 0;
1662 *PL_lex_casestack = '\0';
1664 PL_lex_state = LEX_INTERPCONCAT;
1665 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1667 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1668 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1669 PL_lex_inpat = PL_sublex_info.sub_op;
1671 PL_lex_inpat = NULL;
1678 * Restores lexer state after a S_sublex_push.
1685 if (!PL_lex_starts++) {
1686 SV * const sv = newSVpvs("");
1687 if (SvUTF8(PL_linestr))
1689 PL_expect = XOPERATOR;
1690 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1694 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1695 PL_lex_state = LEX_INTERPCASEMOD;
1699 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1700 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1701 PL_linestr = PL_lex_repl;
1703 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1704 PL_bufend += SvCUR(PL_linestr);
1705 PL_last_lop = PL_last_uni = NULL;
1706 SAVEFREESV(PL_linestr);
1707 PL_lex_dojoin = FALSE;
1708 PL_lex_brackets = 0;
1709 PL_lex_casemods = 0;
1710 *PL_lex_casestack = '\0';
1712 if (SvEVALED(PL_lex_repl)) {
1713 PL_lex_state = LEX_INTERPNORMAL;
1715 /* we don't clear PL_lex_repl here, so that we can check later
1716 whether this is an evalled subst; that means we rely on the
1717 logic to ensure sublex_done() is called again only via the
1718 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1721 PL_lex_state = LEX_INTERPCONCAT;
1731 PL_endwhite = newSVpvs("");
1732 sv_catsv(PL_endwhite, PL_thiswhite);
1736 sv_setpvn(PL_thistoken,"",0);
1738 PL_realtokenstart = -1;
1742 PL_bufend = SvPVX(PL_linestr);
1743 PL_bufend += SvCUR(PL_linestr);
1744 PL_expect = XOPERATOR;
1745 PL_sublex_info.sub_inwhat = 0;
1753 Extracts a pattern, double-quoted string, or transliteration. This
1756 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1757 processing a pattern (PL_lex_inpat is true), a transliteration
1758 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1760 Returns a pointer to the character scanned up to. If this is
1761 advanced from the start pointer supplied (i.e. if anything was
1762 successfully parsed), will leave an OP for the substring scanned
1763 in yylval. Caller must intuit reason for not parsing further
1764 by looking at the next characters herself.
1768 double-quoted style: \r and \n
1769 regexp special ones: \D \s
1772 case and quoting: \U \Q \E
1773 stops on @ and $, but not for $ as tail anchor
1775 In transliterations:
1776 characters are VERY literal, except for - not at the start or end
1777 of the string, which indicates a range. If the range is in bytes,
1778 scan_const expands the range to the full set of intermediate
1779 characters. If the range is in utf8, the hyphen is replaced with
1780 a certain range mark which will be handled by pmtrans() in op.c.
1782 In double-quoted strings:
1784 double-quoted style: \r and \n
1786 deprecated backrefs: \1 (in substitution replacements)
1787 case and quoting: \U \Q \E
1790 scan_const does *not* construct ops to handle interpolated strings.
1791 It stops processing as soon as it finds an embedded $ or @ variable
1792 and leaves it to the caller to work out what's going on.
1794 embedded arrays (whether in pattern or not) could be:
1795 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1797 $ in double-quoted strings must be the symbol of an embedded scalar.
1799 $ in pattern could be $foo or could be tail anchor. Assumption:
1800 it's a tail anchor if $ is the last thing in the string, or if it's
1801 followed by one of "()| \r\n\t"
1803 \1 (backreferences) are turned into $1
1805 The structure of the code is
1806 while (there's a character to process) {
1807 handle transliteration ranges
1808 skip regexp comments /(?#comment)/ and codes /(?{code})/
1809 skip #-initiated comments in //x patterns
1810 check for embedded arrays
1811 check for embedded scalars
1813 leave intact backslashes from leaveit (below)
1814 deprecate \1 in substitution replacements
1815 handle string-changing backslashes \l \U \Q \E, etc.
1816 switch (what was escaped) {
1817 handle \- in a transliteration (becomes a literal -)
1818 handle \132 (octal characters)
1819 handle \x15 and \x{1234} (hex characters)
1820 handle \N{name} (named characters)
1821 handle \cV (control characters)
1822 handle printf-style backslashes (\f, \r, \n, etc)
1824 } (end if backslash)
1825 } (end while character to read)
1830 S_scan_const(pTHX_ char *start)
1833 register char *send = PL_bufend; /* end of the constant */
1834 SV *sv = newSV(send - start); /* sv for the constant */
1835 register char *s = start; /* start of the constant */
1836 register char *d = SvPVX(sv); /* destination for copies */
1837 bool dorange = FALSE; /* are we in a translit range? */
1838 bool didrange = FALSE; /* did we just finish a range? */
1839 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1840 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1843 UV literal_endpoint = 0;
1844 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1847 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1848 /* If we are doing a trans and we know we want UTF8 set expectation */
1849 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1850 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1854 while (s < send || dorange) {
1855 /* get transliterations out of the way (they're most literal) */
1856 if (PL_lex_inwhat == OP_TRANS) {
1857 /* expand a range A-Z to the full set of characters. AIE! */
1859 I32 i; /* current expanded character */
1860 I32 min; /* first character in range */
1861 I32 max; /* last character in range */
1872 char * const c = (char*)utf8_hop((U8*)d, -1);
1876 *c = (char)UTF_TO_NATIVE(0xff);
1877 /* mark the range as done, and continue */
1883 i = d - SvPVX_const(sv); /* remember current offset */
1886 SvLEN(sv) + (has_utf8 ?
1887 (512 - UTF_CONTINUATION_MARK +
1890 /* How many two-byte within 0..255: 128 in UTF-8,
1891 * 96 in UTF-8-mod. */
1893 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1895 d = SvPVX(sv) + i; /* refresh d after realloc */
1899 for (j = 0; j <= 1; j++) {
1900 char * const c = (char*)utf8_hop((U8*)d, -1);
1901 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
1907 max = (U8)0xff; /* only to \xff */
1908 uvmax = uv; /* \x{100} to uvmax */
1910 d = c; /* eat endpoint chars */
1915 d -= 2; /* eat the first char and the - */
1916 min = (U8)*d; /* first char in range */
1917 max = (U8)d[1]; /* last char in range */
1924 "Invalid range \"%c-%c\" in transliteration operator",
1925 (char)min, (char)max);
1929 if (literal_endpoint == 2 &&
1930 ((isLOWER(min) && isLOWER(max)) ||
1931 (isUPPER(min) && isUPPER(max)))) {
1933 for (i = min; i <= max; i++)
1935 *d++ = NATIVE_TO_NEED(has_utf8,i);
1937 for (i = min; i <= max; i++)
1939 *d++ = NATIVE_TO_NEED(has_utf8,i);
1944 for (i = min; i <= max; i++)
1947 const U8 ch = (U8)NATIVE_TO_UTF(i);
1948 if (UNI_IS_INVARIANT(ch))
1951 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
1952 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
1961 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
1963 *d++ = (char)UTF_TO_NATIVE(0xff);
1965 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
1969 /* mark the range as done, and continue */
1973 literal_endpoint = 0;
1978 /* range begins (ignore - as first or last char) */
1979 else if (*s == '-' && s+1 < send && s != start) {
1981 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1988 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
1998 literal_endpoint = 0;
1999 native_range = TRUE;
2004 /* if we get here, we're not doing a transliteration */
2006 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2007 except for the last char, which will be done separately. */
2008 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2010 while (s+1 < send && *s != ')')
2011 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2013 else if (s[2] == '{' /* This should match regcomp.c */
2014 || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
2017 char *regparse = s + (s[2] == '{' ? 3 : 4);
2020 while (count && (c = *regparse)) {
2021 if (c == '\\' && regparse[1])
2029 if (*regparse != ')')
2030 regparse--; /* Leave one char for continuation. */
2031 while (s < regparse)
2032 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2036 /* likewise skip #-initiated comments in //x patterns */
2037 else if (*s == '#' && PL_lex_inpat &&
2038 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2039 while (s+1 < send && *s != '\n')
2040 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2043 /* check for embedded arrays
2044 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2046 else if (*s == '@' && s[1]) {
2047 if (isALNUM_lazy_if(s+1,UTF))
2049 if (strchr(":'{$", s[1]))
2051 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2052 break; /* in regexp, neither @+ nor @- are interpolated */
2055 /* check for embedded scalars. only stop if we're sure it's a
2058 else if (*s == '$') {
2059 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2061 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
2062 break; /* in regexp, $ might be tail anchor */
2065 /* End of else if chain - OP_TRANS rejoin rest */
2068 if (*s == '\\' && s+1 < send) {
2071 /* deprecate \1 in strings and substitution replacements */
2072 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2073 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2075 if (ckWARN(WARN_SYNTAX))
2076 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2081 /* string-change backslash escapes */
2082 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2086 /* skip any other backslash escapes in a pattern */
2087 else if (PL_lex_inpat) {
2088 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2089 goto default_action;
2092 /* if we get here, it's either a quoted -, or a digit */
2095 /* quoted - in transliterations */
2097 if (PL_lex_inwhat == OP_TRANS) {
2104 if ((isALPHA(*s) || isDIGIT(*s)) &&
2106 Perl_warner(aTHX_ packWARN(WARN_MISC),
2107 "Unrecognized escape \\%c passed through",
2109 /* default action is to copy the quoted character */
2110 goto default_action;
2113 /* \132 indicates an octal constant */
2114 case '0': case '1': case '2': case '3':
2115 case '4': case '5': case '6': case '7':
2119 uv = grok_oct(s, &len, &flags, NULL);
2122 goto NUM_ESCAPE_INSERT;
2124 /* \x24 indicates a hex constant */
2128 char* const e = strchr(s, '}');
2129 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2130 PERL_SCAN_DISALLOW_PREFIX;
2135 yyerror("Missing right brace on \\x{}");
2139 uv = grok_hex(s, &len, &flags, NULL);
2145 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2146 uv = grok_hex(s, &len, &flags, NULL);
2152 /* Insert oct or hex escaped character.
2153 * There will always enough room in sv since such
2154 * escapes will be longer than any UTF-8 sequence
2155 * they can end up as. */
2157 /* We need to map to chars to ASCII before doing the tests
2160 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2161 if (!has_utf8 && uv > 255) {
2162 /* Might need to recode whatever we have
2163 * accumulated so far if it contains any
2166 * (Can't we keep track of that and avoid
2167 * this rescan? --jhi)
2171 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2172 if (!NATIVE_IS_INVARIANT(*c)) {
2177 const STRLEN offset = d - SvPVX_const(sv);
2179 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2183 while (src >= (const U8 *)SvPVX_const(sv)) {
2184 if (!NATIVE_IS_INVARIANT(*src)) {
2185 const U8 ch = NATIVE_TO_ASCII(*src);
2186 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2187 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2197 if (has_utf8 || uv > 255) {
2198 d = (char*)uvchr_to_utf8((U8*)d, uv);
2200 if (PL_lex_inwhat == OP_TRANS &&
2201 PL_sublex_info.sub_op) {
2202 PL_sublex_info.sub_op->op_private |=
2203 (PL_lex_repl ? OPpTRANS_FROM_UTF
2207 if (uv > 255 && !dorange)
2208 native_range = FALSE;
2220 /* \N{LATIN SMALL LETTER A} is a named character */
2224 char* e = strchr(s, '}');
2231 yyerror("Missing right brace on \\N{}");
2235 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2237 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2238 PERL_SCAN_DISALLOW_PREFIX;
2241 uv = grok_hex(s, &len, &flags, NULL);
2242 if ( e > s && len != (STRLEN)(e - s) ) {
2246 goto NUM_ESCAPE_INSERT;
2248 res = newSVpvn(s + 1, e - s - 1);
2249 type = newSVpvn(s - 2,e - s + 3);
2250 res = new_constant( NULL, 0, "charnames",
2251 res, NULL, SvPVX(type) );
2254 sv_utf8_upgrade(res);
2255 str = SvPV_const(res,len);
2256 #ifdef EBCDIC_NEVER_MIND
2257 /* charnames uses pack U and that has been
2258 * recently changed to do the below uni->native
2259 * mapping, so this would be redundant (and wrong,
2260 * the code point would be doubly converted).
2261 * But leave this in just in case the pack U change
2262 * gets revoked, but the semantics is still
2263 * desireable for charnames. --jhi */
2265 UV uv = utf8_to_uvchr((const U8*)str, 0);
2268 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2270 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2271 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2272 str = SvPV_const(res, len);
2276 if (!has_utf8 && SvUTF8(res)) {
2277 const char * const ostart = SvPVX_const(sv);
2278 SvCUR_set(sv, d - ostart);
2281 sv_utf8_upgrade(sv);
2282 /* this just broke our allocation above... */
2283 SvGROW(sv, (STRLEN)(send - start));
2284 d = SvPVX(sv) + SvCUR(sv);
2287 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2288 const char * const odest = SvPVX_const(sv);
2290 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2291 d = SvPVX(sv) + (d - odest);
2295 native_range = FALSE; /* \N{} is guessed to be Unicode */
2297 Copy(str, d, len, char);
2304 yyerror("Missing braces on \\N{}");
2307 /* \c is a control character */
2316 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2319 yyerror("Missing control char name in \\c");
2323 /* printf-style backslashes, formfeeds, newlines, etc */
2325 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2328 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2331 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2334 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2337 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2340 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2343 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2349 } /* end if (backslash) */
2356 /* If we started with encoded form, or already know we want it
2357 and then encode the next character */
2358 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2360 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2361 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2364 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2365 const STRLEN off = d - SvPVX_const(sv);
2366 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2368 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2371 if (uv > 255 && !dorange)
2372 native_range = FALSE;
2376 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2378 } /* while loop to process each character */
2380 /* terminate the string and set up the sv */
2382 SvCUR_set(sv, d - SvPVX_const(sv));
2383 if (SvCUR(sv) >= SvLEN(sv))
2384 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2387 if (PL_encoding && !has_utf8) {
2388 sv_recode_to_utf8(sv, PL_encoding);
2394 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2395 PL_sublex_info.sub_op->op_private |=
2396 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2400 /* shrink the sv if we allocated more than we used */
2401 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2402 SvPV_shrink_to_cur(sv);
2405 /* return the substring (via yylval) only if we parsed anything */
2406 if (s > PL_bufptr) {
2407 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2408 sv = new_constant(start, s - start,
2409 (const char *)(PL_lex_inpat ? "qr" : "q"),
2412 (( PL_lex_inwhat == OP_TRANS
2414 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2417 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2424 * Returns TRUE if there's more to the expression (e.g., a subscript),
2427 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2429 * ->[ and ->{ return TRUE
2430 * { and [ outside a pattern are always subscripts, so return TRUE
2431 * if we're outside a pattern and it's not { or [, then return FALSE
2432 * if we're in a pattern and the first char is a {
2433 * {4,5} (any digits around the comma) returns FALSE
2434 * if we're in a pattern and the first char is a [
2436 * [SOMETHING] has a funky algorithm to decide whether it's a
2437 * character class or not. It has to deal with things like
2438 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2439 * anything else returns TRUE
2442 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2445 S_intuit_more(pTHX_ register char *s)
2448 if (PL_lex_brackets)
2450 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2452 if (*s != '{' && *s != '[')
2457 /* In a pattern, so maybe we have {n,m}. */
2474 /* On the other hand, maybe we have a character class */
2477 if (*s == ']' || *s == '^')
2480 /* this is terrifying, and it works */
2481 int weight = 2; /* let's weigh the evidence */
2483 unsigned char un_char = 255, last_un_char;
2484 const char * const send = strchr(s,']');
2485 char tmpbuf[sizeof PL_tokenbuf * 4];
2487 if (!send) /* has to be an expression */
2490 Zero(seen,256,char);
2493 else if (isDIGIT(*s)) {
2495 if (isDIGIT(s[1]) && s[2] == ']')
2501 for (; s < send; s++) {
2502 last_un_char = un_char;
2503 un_char = (unsigned char)*s;
2508 weight -= seen[un_char] * 10;
2509 if (isALNUM_lazy_if(s+1,UTF)) {
2511 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2512 len = (int)strlen(tmpbuf);
2513 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2518 else if (*s == '$' && s[1] &&
2519 strchr("[#!%*<>()-=",s[1])) {
2520 if (/*{*/ strchr("])} =",s[2]))
2529 if (strchr("wds]",s[1]))
2531 else if (seen[(U8)'\''] || seen[(U8)'"'])
2533 else if (strchr("rnftbxcav",s[1]))
2535 else if (isDIGIT(s[1])) {
2537 while (s[1] && isDIGIT(s[1]))
2547 if (strchr("aA01! ",last_un_char))
2549 if (strchr("zZ79~",s[1]))
2551 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2552 weight -= 5; /* cope with negative subscript */
2555 if (!isALNUM(last_un_char)
2556 && !(last_un_char == '$' || last_un_char == '@'
2557 || last_un_char == '&')
2558 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2563 if (keyword(tmpbuf, d - tmpbuf, 0))
2566 if (un_char == last_un_char + 1)
2568 weight -= seen[un_char];
2573 if (weight >= 0) /* probably a character class */
2583 * Does all the checking to disambiguate
2585 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2586 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2588 * First argument is the stuff after the first token, e.g. "bar".
2590 * Not a method if bar is a filehandle.
2591 * Not a method if foo is a subroutine prototyped to take a filehandle.
2592 * Not a method if it's really "Foo $bar"
2593 * Method if it's "foo $bar"
2594 * Not a method if it's really "print foo $bar"
2595 * Method if it's really "foo package::" (interpreted as package->foo)
2596 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2597 * Not a method if bar is a filehandle or package, but is quoted with
2602 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2605 char *s = start + (*start == '$');
2606 char tmpbuf[sizeof PL_tokenbuf];
2614 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2618 const char *proto = SvPVX_const(cv);
2629 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2630 /* start is the beginning of the possible filehandle/object,
2631 * and s is the end of it
2632 * tmpbuf is a copy of it
2635 if (*start == '$') {
2636 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2639 len = start - SvPVX(PL_linestr);
2643 start = SvPVX(PL_linestr) + len;
2647 return *s == '(' ? FUNCMETH : METHOD;
2649 if (!keyword(tmpbuf, len, 0)) {
2650 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2654 soff = s - SvPVX(PL_linestr);
2658 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2659 if (indirgv && GvCVu(indirgv))
2661 /* filehandle or package name makes it a method */
2662 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2664 soff = s - SvPVX(PL_linestr);
2667 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2668 return 0; /* no assumptions -- "=>" quotes bearword */
2670 start_force(PL_curforce);
2671 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2672 newSVpvn(tmpbuf,len));
2673 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2675 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2680 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2682 return *s == '(' ? FUNCMETH : METHOD;
2690 * Return a string of Perl code to load the debugger. If PERL5DB
2691 * is set, it will return the contents of that, otherwise a
2692 * compile-time require of perl5db.pl.
2700 const char * const pdb = PerlEnv_getenv("PERL5DB");
2704 SETERRNO(0,SS_NORMAL);
2705 return "BEGIN { require 'perl5db.pl' }";
2711 /* Encoded script support. filter_add() effectively inserts a
2712 * 'pre-processing' function into the current source input stream.
2713 * Note that the filter function only applies to the current source file
2714 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2716 * The datasv parameter (which may be NULL) can be used to pass
2717 * private data to this instance of the filter. The filter function
2718 * can recover the SV using the FILTER_DATA macro and use it to
2719 * store private buffers and state information.
2721 * The supplied datasv parameter is upgraded to a PVIO type
2722 * and the IoDIRP/IoANY field is used to store the function pointer,
2723 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2724 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2725 * private use must be set using malloc'd pointers.
2729 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2735 if (!PL_rsfp_filters)
2736 PL_rsfp_filters = newAV();
2739 SvUPGRADE(datasv, SVt_PVIO);
2740 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2741 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2742 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2743 FPTR2DPTR(void *, IoANY(datasv)),
2744 SvPV_nolen(datasv)));
2745 av_unshift(PL_rsfp_filters, 1);
2746 av_store(PL_rsfp_filters, 0, datasv) ;
2751 /* Delete most recently added instance of this filter function. */
2753 Perl_filter_del(pTHX_ filter_t funcp)
2759 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2760 FPTR2DPTR(void*, funcp)));
2762 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2764 /* if filter is on top of stack (usual case) just pop it off */
2765 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2766 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2767 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2768 IoANY(datasv) = (void *)NULL;
2769 sv_free(av_pop(PL_rsfp_filters));
2773 /* we need to search for the correct entry and clear it */
2774 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2778 /* Invoke the idxth filter function for the current rsfp. */
2779 /* maxlen 0 = read one text line */
2781 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2786 /* This API is bad. It should have been using unsigned int for maxlen.
2787 Not sure if we want to change the API, but if not we should sanity
2788 check the value here. */
2789 const unsigned int correct_length
2798 if (!PL_rsfp_filters)
2800 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2801 /* Provide a default input filter to make life easy. */
2802 /* Note that we append to the line. This is handy. */
2803 DEBUG_P(PerlIO_printf(Perl_debug_log,
2804 "filter_read %d: from rsfp\n", idx));
2805 if (correct_length) {
2808 const int old_len = SvCUR(buf_sv);
2810 /* ensure buf_sv is large enough */
2811 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2812 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2813 correct_length)) <= 0) {
2814 if (PerlIO_error(PL_rsfp))
2815 return -1; /* error */
2817 return 0 ; /* end of file */
2819 SvCUR_set(buf_sv, old_len + len) ;
2822 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2823 if (PerlIO_error(PL_rsfp))
2824 return -1; /* error */
2826 return 0 ; /* end of file */
2829 return SvCUR(buf_sv);
2831 /* Skip this filter slot if filter has been deleted */
2832 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2833 DEBUG_P(PerlIO_printf(Perl_debug_log,
2834 "filter_read %d: skipped (filter deleted)\n",
2836 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2838 /* Get function pointer hidden within datasv */
2839 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2840 DEBUG_P(PerlIO_printf(Perl_debug_log,
2841 "filter_read %d: via function %p (%s)\n",
2842 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2843 /* Call function. The function is expected to */
2844 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2845 /* Return: <0:error, =0:eof, >0:not eof */
2846 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2850 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2853 #ifdef PERL_CR_FILTER
2854 if (!PL_rsfp_filters) {
2855 filter_add(S_cr_textfilter,NULL);
2858 if (PL_rsfp_filters) {
2860 SvCUR_set(sv, 0); /* start with empty line */
2861 if (FILTER_READ(0, sv, 0) > 0)
2862 return ( SvPVX(sv) ) ;
2867 return (sv_gets(sv, fp, append));
2871 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2876 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2880 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2881 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2883 return GvHV(gv); /* Foo:: */
2886 /* use constant CLASS => 'MyClass' */
2887 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
2888 if (gv && GvCV(gv)) {
2889 SV * const sv = cv_const_sv(GvCV(gv));
2891 pkgname = SvPV_nolen_const(sv);
2894 return gv_stashpv(pkgname, FALSE);
2898 * S_readpipe_override
2899 * Check whether readpipe() is overriden, and generates the appropriate
2900 * optree, provided sublex_start() is called afterwards.
2903 S_readpipe_override(pTHX)
2906 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
2907 yylval.ival = OP_BACKTICK;
2909 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
2911 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
2912 && (gv_readpipe = *gvp) != (GV*)&PL_sv_undef
2913 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
2915 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
2916 append_elem(OP_LIST,
2917 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
2918 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
2928 * The intent of this yylex wrapper is to minimize the changes to the
2929 * tokener when we aren't interested in collecting madprops. It remains
2930 * to be seen how successful this strategy will be...
2937 char *s = PL_bufptr;
2939 /* make sure PL_thiswhite is initialized */
2943 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2944 if (PL_pending_ident)
2945 return S_pending_ident(aTHX);
2947 /* previous token ate up our whitespace? */
2948 if (!PL_lasttoke && PL_nextwhite) {
2949 PL_thiswhite = PL_nextwhite;
2953 /* isolate the token, and figure out where it is without whitespace */
2954 PL_realtokenstart = -1;
2958 assert(PL_curforce < 0);
2960 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
2961 if (!PL_thistoken) {
2962 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
2963 PL_thistoken = newSVpvs("");
2965 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
2966 PL_thistoken = newSVpvn(tstart, s - tstart);
2969 if (PL_thismad) /* install head */
2970 CURMAD('X', PL_thistoken);
2973 /* last whitespace of a sublex? */
2974 if (optype == ')' && PL_endwhite) {
2975 CURMAD('X', PL_endwhite);
2980 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
2981 if (!PL_thiswhite && !PL_endwhite && !optype) {
2982 sv_free(PL_thistoken);
2987 /* put off final whitespace till peg */
2988 if (optype == ';' && !PL_rsfp) {
2989 PL_nextwhite = PL_thiswhite;
2992 else if (PL_thisopen) {
2993 CURMAD('q', PL_thisopen);
2995 sv_free(PL_thistoken);
2999 /* Store actual token text as madprop X */
3000 CURMAD('X', PL_thistoken);
3004 /* add preceding whitespace as madprop _ */
3005 CURMAD('_', PL_thiswhite);
3009 /* add quoted material as madprop = */
3010 CURMAD('=', PL_thisstuff);
3014 /* add terminating quote as madprop Q */
3015 CURMAD('Q', PL_thisclose);
3019 /* special processing based on optype */
3023 /* opval doesn't need a TOKEN since it can already store mp */
3034 append_madprops(PL_thismad, yylval.opval, 0);
3042 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3051 /* remember any fake bracket that lexer is about to discard */
3052 if (PL_lex_brackets == 1 &&
3053 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3056 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3059 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3060 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3063 break; /* don't bother looking for trailing comment */
3072 /* attach a trailing comment to its statement instead of next token */
3076 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3078 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3080 if (*s == '\n' || *s == '#') {
3081 while (s < PL_bufend && *s != '\n')
3085 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3086 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3103 /* Create new token struct. Note: opvals return early above. */
3104 yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
3111 S_tokenize_use(pTHX_ int is_use, char *s) {
3113 if (PL_expect != XSTATE)
3114 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3115 is_use ? "use" : "no"));
3117 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3118 s = force_version(s, TRUE);
3119 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3120 start_force(PL_curforce);
3121 NEXTVAL_NEXTTOKE.opval = NULL;
3124 else if (*s == 'v') {
3125 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3126 s = force_version(s, FALSE);
3130 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3131 s = force_version(s, FALSE);
3133 yylval.ival = is_use;
3137 static const char* const exp_name[] =
3138 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3139 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3146 Works out what to call the token just pulled out of the input
3147 stream. The yacc parser takes care of taking the ops we return and
3148 stitching them into a tree.
3154 if read an identifier
3155 if we're in a my declaration
3156 croak if they tried to say my($foo::bar)
3157 build the ops for a my() declaration
3158 if it's an access to a my() variable
3159 are we in a sort block?
3160 croak if my($a); $a <=> $b
3161 build ops for access to a my() variable
3162 if in a dq string, and they've said @foo and we can't find @foo
3164 build ops for a bareword
3165 if we already built the token before, use it.
3170 #pragma segment Perl_yylex
3176 register char *s = PL_bufptr;
3181 /* orig_keyword, gvp, and gv are initialized here because
3182 * jump to the label just_a_word_zero can bypass their
3183 * initialization later. */
3184 I32 orig_keyword = 0;
3189 SV* tmp = newSVpvs("");
3190 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3191 (IV)CopLINE(PL_curcop),
3192 lex_state_names[PL_lex_state],
3193 exp_name[PL_expect],
3194 pv_display(tmp, s, strlen(s), 0, 60));
3197 /* check if there's an identifier for us to look at */
3198 if (PL_pending_ident)
3199 return REPORT(S_pending_ident(aTHX));
3201 /* no identifier pending identification */
3203 switch (PL_lex_state) {
3205 case LEX_NORMAL: /* Some compilers will produce faster */
3206 case LEX_INTERPNORMAL: /* code if we comment these out. */
3210 /* when we've already built the next token, just pull it out of the queue */
3214 yylval = PL_nexttoke[PL_lasttoke].next_val;
3216 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3217 PL_nexttoke[PL_lasttoke].next_mad = 0;
3218 if (PL_thismad && PL_thismad->mad_key == '_') {
3219 PL_thiswhite = (SV*)PL_thismad->mad_val;
3220 PL_thismad->mad_val = 0;
3221 mad_free(PL_thismad);
3226 PL_lex_state = PL_lex_defer;
3227 PL_expect = PL_lex_expect;
3228 PL_lex_defer = LEX_NORMAL;
3229 if (!PL_nexttoke[PL_lasttoke].next_type)
3234 yylval = PL_nextval[PL_nexttoke];
3236 PL_lex_state = PL_lex_defer;
3237 PL_expect = PL_lex_expect;
3238 PL_lex_defer = LEX_NORMAL;
3242 /* FIXME - can these be merged? */
3243 return(PL_nexttoke[PL_lasttoke].next_type);
3245 return REPORT(PL_nexttype[PL_nexttoke]);
3248 /* interpolated case modifiers like \L \U, including \Q and \E.
3249 when we get here, PL_bufptr is at the \
3251 case LEX_INTERPCASEMOD:
3253 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3254 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3256 /* handle \E or end of string */
3257 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3259 if (PL_lex_casemods) {
3260 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3261 PL_lex_casestack[PL_lex_casemods] = '\0';
3263 if (PL_bufptr != PL_bufend
3264 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3266 PL_lex_state = LEX_INTERPCONCAT;
3269 PL_thistoken = newSVpvs("\\E");
3275 while (PL_bufptr != PL_bufend &&
3276 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3278 PL_thiswhite = newSVpvs("");
3279 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3283 if (PL_bufptr != PL_bufend)
3286 PL_lex_state = LEX_INTERPCONCAT;
3290 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3291 "### Saw case modifier\n"); });
3293 if (s[1] == '\\' && s[2] == 'E') {
3296 PL_thiswhite = newSVpvs("");
3297 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3300 PL_lex_state = LEX_INTERPCONCAT;
3305 if (!PL_madskills) /* when just compiling don't need correct */
3306 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3307 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3308 if ((*s == 'L' || *s == 'U') &&
3309 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3310 PL_lex_casestack[--PL_lex_casemods] = '\0';
3313 if (PL_lex_casemods > 10)
3314 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3315 PL_lex_casestack[PL_lex_casemods++] = *s;
3316 PL_lex_casestack[PL_lex_casemods] = '\0';
3317 PL_lex_state = LEX_INTERPCONCAT;
3318 start_force(PL_curforce);
3319 NEXTVAL_NEXTTOKE.ival = 0;
3321 start_force(PL_curforce);
3323 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3325 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3327 NEXTVAL_NEXTTOKE.ival = OP_LC;
3329 NEXTVAL_NEXTTOKE.ival = OP_UC;
3331 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3333 Perl_croak(aTHX_ "panic: yylex");
3335 SV* const tmpsv = newSVpvs("");
3336 Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3342 if (PL_lex_starts) {
3348 sv_free(PL_thistoken);
3349 PL_thistoken = newSVpvs("");
3352 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3353 if (PL_lex_casemods == 1 && PL_lex_inpat)
3362 case LEX_INTERPPUSH:
3363 return REPORT(sublex_push());
3365 case LEX_INTERPSTART:
3366 if (PL_bufptr == PL_bufend)
3367 return REPORT(sublex_done());
3368 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3369 "### Interpolated variable\n"); });
3371 PL_lex_dojoin = (*PL_bufptr == '@');
3372 PL_lex_state = LEX_INTERPNORMAL;
3373 if (PL_lex_dojoin) {
3374 start_force(PL_curforce);
3375 NEXTVAL_NEXTTOKE.ival = 0;
3377 start_force(PL_curforce);
3378 force_ident("\"", '$');
3379 start_force(PL_curforce);
3380 NEXTVAL_NEXTTOKE.ival = 0;
3382 start_force(PL_curforce);
3383 NEXTVAL_NEXTTOKE.ival = 0;
3385 start_force(PL_curforce);
3386 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3389 if (PL_lex_starts++) {
3394 sv_free(PL_thistoken);
3395 PL_thistoken = newSVpvs("");
3398 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3399 if (!PL_lex_casemods && PL_lex_inpat)
3406 case LEX_INTERPENDMAYBE:
3407 if (intuit_more(PL_bufptr)) {
3408 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3414 if (PL_lex_dojoin) {
3415 PL_lex_dojoin = FALSE;
3416 PL_lex_state = LEX_INTERPCONCAT;
3420 sv_free(PL_thistoken);
3421 PL_thistoken = newSVpvs("");
3426 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3427 && SvEVALED(PL_lex_repl))
3429 if (PL_bufptr != PL_bufend)
3430 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3434 case LEX_INTERPCONCAT:
3436 if (PL_lex_brackets)
3437 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3439 if (PL_bufptr == PL_bufend)
3440 return REPORT(sublex_done());
3442 if (SvIVX(PL_linestr) == '\'') {
3443 SV *sv = newSVsv(PL_linestr);
3446 else if ( PL_hints & HINT_NEW_RE )
3447 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3448 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3452 s = scan_const(PL_bufptr);
3454 PL_lex_state = LEX_INTERPCASEMOD;
3456 PL_lex_state = LEX_INTERPSTART;
3459 if (s != PL_bufptr) {
3460 start_force(PL_curforce);
3462 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3464 NEXTVAL_NEXTTOKE = yylval;
3467 if (PL_lex_starts++) {
3471 sv_free(PL_thistoken);
3472 PL_thistoken = newSVpvs("");
3475 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3476 if (!PL_lex_casemods && PL_lex_inpat)
3489 PL_lex_state = LEX_NORMAL;
3490 s = scan_formline(PL_bufptr);
3491 if (!PL_lex_formbrack)
3497 PL_oldoldbufptr = PL_oldbufptr;
3503 sv_free(PL_thistoken);
3506 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3510 if (isIDFIRST_lazy_if(s,UTF))
3512 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3515 goto fake_eof; /* emulate EOF on ^D or ^Z */
3524 if (PL_lex_brackets) {
3525 yyerror((const char *)
3527 ? "Format not terminated"
3528 : "Missing right curly or square bracket"));
3530 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3531 "### Tokener got EOF\n");
3535 if (s++ < PL_bufend)
3536 goto retry; /* ignore stray nulls */
3539 if (!PL_in_eval && !PL_preambled) {
3540 PL_preambled = TRUE;
3545 sv_setpv(PL_linestr,incl_perldb());
3546 if (SvCUR(PL_linestr))
3547 sv_catpvs(PL_linestr,";");
3549 while(AvFILLp(PL_preambleav) >= 0) {
3550 SV *tmpsv = av_shift(PL_preambleav);
3551 sv_catsv(PL_linestr, tmpsv);
3552 sv_catpvs(PL_linestr, ";");
3555 sv_free((SV*)PL_preambleav);
3556 PL_preambleav = NULL;
3558 if (PL_minus_n || PL_minus_p) {
3559 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3561 sv_catpvs(PL_linestr,"chomp;");
3564 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3565 || *PL_splitstr == '"')
3566 && strchr(PL_splitstr + 1, *PL_splitstr))
3567 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3569 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3570 bytes can be used as quoting characters. :-) */
3571 const char *splits = PL_splitstr;
3572 sv_catpvs(PL_linestr, "our @F=split(q\0");
3575 if (*splits == '\\')
3576 sv_catpvn(PL_linestr, splits, 1);
3577 sv_catpvn(PL_linestr, splits, 1);
3578 } while (*splits++);
3579 /* This loop will embed the trailing NUL of
3580 PL_linestr as the last thing it does before
3582 sv_catpvs(PL_linestr, ");");
3586 sv_catpvs(PL_linestr,"our @F=split(' ');");
3590 sv_catpvs(PL_linestr,"use feature ':5.10';");
3591 sv_catpvs(PL_linestr, "\n");
3592 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3593 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3594 PL_last_lop = PL_last_uni = NULL;
3595 if (PERLDB_LINE && PL_curstash != PL_debstash)
3596 update_debugger_info(PL_linestr, NULL, 0);
3600 bof = PL_rsfp ? TRUE : FALSE;
3601 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3604 PL_realtokenstart = -1;
3607 if (PL_preprocess && !PL_in_eval)
3608 (void)PerlProc_pclose(PL_rsfp);
3609 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3610 PerlIO_clearerr(PL_rsfp);
3612 (void)PerlIO_close(PL_rsfp);
3614 PL_doextract = FALSE;
3616 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3621 sv_setpv(PL_linestr,
3624 ? ";}continue{print;}" : ";}"));
3625 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3626 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3627 PL_last_lop = PL_last_uni = NULL;
3628 PL_minus_n = PL_minus_p = 0;
3631 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3632 PL_last_lop = PL_last_uni = NULL;
3633 sv_setpvn(PL_linestr,"",0);
3634 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3636 /* If it looks like the start of a BOM or raw UTF-16,
3637 * check if it in fact is. */
3643 #ifdef PERLIO_IS_STDIO
3644 # ifdef __GNU_LIBRARY__
3645 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3646 # define FTELL_FOR_PIPE_IS_BROKEN
3650 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3651 # define FTELL_FOR_PIPE_IS_BROKEN
3656 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3657 /* This loses the possibility to detect the bof
3658 * situation on perl -P when the libc5 is being used.
3659 * Workaround? Maybe attach some extra state to PL_rsfp?
3662 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3664 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3667 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3668 s = swallow_bom((U8*)s);
3672 /* Incest with pod. */
3675 sv_catsv(PL_thiswhite, PL_linestr);
3677 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3678 sv_setpvn(PL_linestr, "", 0);
3679 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3680 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3681 PL_last_lop = PL_last_uni = NULL;
3682 PL_doextract = FALSE;
3686 } while (PL_doextract);
3687 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3688 if (PERLDB_LINE && PL_curstash != PL_debstash)
3689 update_debugger_info(PL_linestr, NULL, 0);
3690 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3691 PL_last_lop = PL_last_uni = NULL;
3692 if (CopLINE(PL_curcop) == 1) {
3693 while (s < PL_bufend && isSPACE(*s))
3695 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3699 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3703 if (*s == '#' && *(s+1) == '!')
3705 #ifdef ALTERNATE_SHEBANG
3707 static char const as[] = ALTERNATE_SHEBANG;
3708 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3709 d = s + (sizeof(as) - 1);
3711 #endif /* ALTERNATE_SHEBANG */
3720 while (*d && !isSPACE(*d))
3724 #ifdef ARG_ZERO_IS_SCRIPT
3725 if (ipathend > ipath) {
3727 * HP-UX (at least) sets argv[0] to the script name,
3728 * which makes $^X incorrect. And Digital UNIX and Linux,
3729 * at least, set argv[0] to the basename of the Perl
3730 * interpreter. So, having found "#!", we'll set it right.
3732 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3734 assert(SvPOK(x) || SvGMAGICAL(x));
3735 if (sv_eq(x, CopFILESV(PL_curcop))) {
3736 sv_setpvn(x, ipath, ipathend - ipath);
3742 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3743 const char * const lstart = SvPV_const(x,llen);
3745 bstart += blen - llen;
3746 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3747 sv_setpvn(x, ipath, ipathend - ipath);
3752 TAINT_NOT; /* $^X is always tainted, but that's OK */
3754 #endif /* ARG_ZERO_IS_SCRIPT */
3759 d = instr(s,"perl -");
3761 d = instr(s,"perl");
3763 /* avoid getting into infinite loops when shebang
3764 * line contains "Perl" rather than "perl" */
3766 for (d = ipathend-4; d >= ipath; --d) {
3767 if ((*d == 'p' || *d == 'P')
3768 && !ibcmp(d, "perl", 4))
3778 #ifdef ALTERNATE_SHEBANG
3780 * If the ALTERNATE_SHEBANG on this system starts with a
3781 * character that can be part of a Perl expression, then if
3782 * we see it but not "perl", we're probably looking at the
3783 * start of Perl code, not a request to hand off to some
3784 * other interpreter. Similarly, if "perl" is there, but
3785 * not in the first 'word' of the line, we assume the line
3786 * contains the start of the Perl program.
3788 if (d && *s != '#') {
3789 const char *c = ipath;
3790 while (*c && !strchr("; \t\r\n\f\v#", *c))
3793 d = NULL; /* "perl" not in first word; ignore */
3795 *s = '#'; /* Don't try to parse shebang line */
3797 #endif /* ALTERNATE_SHEBANG */
3798 #ifndef MACOS_TRADITIONAL
3803 !instr(s,"indir") &&
3804 instr(PL_origargv[0],"perl"))
3811 while (s < PL_bufend && isSPACE(*s))
3813 if (s < PL_bufend) {
3814 Newxz(newargv,PL_origargc+3,char*);
3816 while (s < PL_bufend && !isSPACE(*s))
3819 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3822 newargv = PL_origargv;
3825 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3827 Perl_croak(aTHX_ "Can't exec %s", ipath);
3831 while (*d && !isSPACE(*d))
3833 while (SPACE_OR_TAB(*d))
3837 const bool switches_done = PL_doswitches;
3838 const U32 oldpdb = PL_perldb;
3839 const bool oldn = PL_minus_n;
3840 const bool oldp = PL_minus_p;
3843 if (*d == 'M' || *d == 'm' || *d == 'C') {
3844 const char * const m = d;
3845 while (*d && !isSPACE(*d))
3847 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3850 d = moreswitches(d);
3852 if (PL_doswitches && !switches_done) {
3853 int argc = PL_origargc;
3854 char **argv = PL_origargv;
3857 } while (argc && argv[0][0] == '-' && argv[0][1]);
3858 init_argv_symbols(argc,argv);
3860 if ((PERLDB_LINE && !oldpdb) ||
3861 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3862 /* if we have already added "LINE: while (<>) {",
3863 we must not do it again */
3865 sv_setpvn(PL_linestr, "", 0);
3866 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3867 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3868 PL_last_lop = PL_last_uni = NULL;
3869 PL_preambled = FALSE;
3871 (void)gv_fetchfile(PL_origfilename);
3878 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3880 PL_lex_state = LEX_FORMLINE;
3885 #ifdef PERL_STRICT_CR
3886 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3888 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3890 case ' ': case '\t': case '\f': case 013:
3891 #ifdef MACOS_TRADITIONAL
3895 PL_realtokenstart = -1;
3904 PL_realtokenstart = -1;
3908 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3909 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3910 /* handle eval qq[#line 1 "foo"\n ...] */
3911 CopLINE_dec(PL_curcop);
3914 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3916 if (!PL_in_eval || PL_rsfp)
3921 while (d < PL_bufend && *d != '\n')
3925 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3926 Perl_croak(aTHX_ "panic: input overflow");
3929 PL_thiswhite = newSVpvn(s, d - s);
3934 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3936 PL_lex_state = LEX_FORMLINE;
3942 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3943 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3946 TOKEN(PEG); /* make sure any #! line is accessible */
3951 /* if (PL_madskills && PL_lex_formbrack) { */
3953 while (d < PL_bufend && *d != '\n')
3957 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3958 Perl_croak(aTHX_ "panic: input overflow");
3959 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
3961 PL_thiswhite = newSVpvs("");
3962 if (CopLINE(PL_curcop) == 1) {
3963 sv_setpvn(PL_thiswhite, "", 0);
3966 sv_catpvn(PL_thiswhite, s, d - s);
3980 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3988 while (s < PL_bufend && SPACE_OR_TAB(*s))
3991 if (strnEQ(s,"=>",2)) {
3992 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3993 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
3994 OPERATOR('-'); /* unary minus */
3996 PL_last_uni = PL_oldbufptr;
3998 case 'r': ftst = OP_FTEREAD; break;
3999 case 'w': ftst = OP_FTEWRITE; break;
4000 case 'x': ftst = OP_FTEEXEC; break;
4001 case 'o': ftst = OP_FTEOWNED; break;
4002 case 'R': ftst = OP_FTRREAD; break;
4003 case 'W': ftst = OP_FTRWRITE; break;
4004 case 'X': ftst = OP_FTREXEC; break;
4005 case 'O': ftst = OP_FTROWNED; break;
4006 case 'e': ftst = OP_FTIS; break;
4007 case 'z': ftst = OP_FTZERO; break;
4008 case 's': ftst = OP_FTSIZE; break;
4009 case 'f': ftst = OP_FTFILE; break;
4010 case 'd': ftst = OP_FTDIR; break;
4011 case 'l': ftst = OP_FTLINK; break;
4012 case 'p': ftst = OP_FTPIPE; break;
4013 case 'S': ftst = OP_FTSOCK; break;
4014 case 'u': ftst = OP_FTSUID; break;
4015 case 'g': ftst = OP_FTSGID; break;
4016 case 'k': ftst = OP_FTSVTX; break;
4017 case 'b': ftst = OP_FTBLK; break;
4018 case 'c': ftst = OP_FTCHR; break;
4019 case 't': ftst = OP_FTTTY; break;
4020 case 'T': ftst = OP_FTTEXT; break;
4021 case 'B': ftst = OP_FTBINARY; break;
4022 case 'M': case 'A': case 'C':
4023 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4025 case 'M': ftst = OP_FTMTIME; break;
4026 case 'A': ftst = OP_FTATIME; break;
4027 case 'C': ftst = OP_FTCTIME; break;
4035 PL_last_lop_op = (OPCODE)ftst;
4036 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4037 "### Saw file test %c\n", (int)tmp);
4042 /* Assume it was a minus followed by a one-letter named
4043 * subroutine call (or a -bareword), then. */
4044 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4045 "### '-%c' looked like a file test but was not\n",
4052 const char tmp = *s++;
4055 if (PL_expect == XOPERATOR)
4060 else if (*s == '>') {
4063 if (isIDFIRST_lazy_if(s,UTF)) {
4064 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4072 if (PL_expect == XOPERATOR)
4075 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4077 OPERATOR('-'); /* unary minus */
4083 const char tmp = *s++;
4086 if (PL_expect == XOPERATOR)
4091 if (PL_expect == XOPERATOR)
4094 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4101 if (PL_expect != XOPERATOR) {
4102 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4103 PL_expect = XOPERATOR;
4104 force_ident(PL_tokenbuf, '*');
4117 if (PL_expect == XOPERATOR) {
4121 PL_tokenbuf[0] = '%';
4122 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
4123 if (!PL_tokenbuf[1]) {
4126 PL_pending_ident = '%';
4137 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
4138 && FEATURE_IS_ENABLED("~~"))
4145 const char tmp = *s++;
4151 goto just_a_word_zero_gv;
4154 switch (PL_expect) {
4160 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4162 PL_bufptr = s; /* update in case we back off */
4168 PL_expect = XTERMBLOCK;
4171 stuffstart = s - SvPVX(PL_linestr) - 1;
4175 while (isIDFIRST_lazy_if(s,UTF)) {
4178 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4179 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4180 if (tmp < 0) tmp = -tmp;
4195 sv = newSVpvn(s, len);
4197 d = scan_str(d,TRUE,TRUE);
4199 /* MUST advance bufptr here to avoid bogus
4200 "at end of line" context messages from yyerror().
4202 PL_bufptr = s + len;
4203 yyerror("Unterminated attribute parameter in attribute list");
4207 return REPORT(0); /* EOF indicator */
4211 sv_catsv(sv, PL_lex_stuff);
4212 attrs = append_elem(OP_LIST, attrs,
4213 newSVOP(OP_CONST, 0, sv));
4214 SvREFCNT_dec(PL_lex_stuff);
4215 PL_lex_stuff = NULL;
4218 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4220 if (PL_in_my == KEY_our) {
4222 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4224 /* skip to avoid loading attributes.pm */
4226 deprecate(":unique");
4229 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4232 /* NOTE: any CV attrs applied here need to be part of
4233 the CVf_BUILTIN_ATTRS define in cv.h! */
4234 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4236 CvLVALUE_on(PL_compcv);
4238 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4240 CvLOCKED_on(PL_compcv);
4242 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4244 CvMETHOD_on(PL_compcv);
4246 else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4248 CvASSERTION_on(PL_compcv);
4250 /* After we've set the flags, it could be argued that
4251 we don't need to do the attributes.pm-based setting
4252 process, and shouldn't bother appending recognized
4253 flags. To experiment with that, uncomment the
4254 following "else". (Note that's already been
4255 uncommented. That keeps the above-applied built-in
4256 attributes from being intercepted (and possibly
4257 rejected) by a package's attribute routines, but is
4258 justified by the performance win for the common case
4259 of applying only built-in attributes.) */
4261 attrs = append_elem(OP_LIST, attrs,
4262 newSVOP(OP_CONST, 0,
4266 if (*s == ':' && s[1] != ':')
4269 break; /* require real whitespace or :'s */
4270 /* XXX losing whitespace on sequential attributes here */
4274 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4275 if (*s != ';' && *s != '}' && *s != tmp
4276 && (tmp != '=' || *s != ')')) {
4277 const char q = ((*s == '\'') ? '"' : '\'');
4278 /* If here for an expression, and parsed no attrs, back
4280 if (tmp == '=' && !attrs) {
4284 /* MUST advance bufptr here to avoid bogus "at end of line"
4285 context messages from yyerror().
4288 yyerror( (const char *)
4290 ? Perl_form(aTHX_ "Invalid separator character "
4291 "%c%c%c in attribute list", q, *s, q)
4292 : "Unterminated attribute list" ) );
4300 start_force(PL_curforce);
4301 NEXTVAL_NEXTTOKE.opval = attrs;
4302 CURMAD('_', PL_nextwhite);
4307 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4308 (s - SvPVX(PL_linestr)) - stuffstart);
4316 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4317 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4325 const char tmp = *s++;
4330 const char tmp = *s++;
4338 if (PL_lex_brackets <= 0)
4339 yyerror("Unmatched right square bracket");
4342 if (PL_lex_state == LEX_INTERPNORMAL) {
4343 if (PL_lex_brackets == 0) {
4344 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4345 PL_lex_state = LEX_INTERPEND;
4352 if (PL_lex_brackets > 100) {
4353 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4355 switch (PL_expect) {
4357 if (PL_lex_formbrack) {
4361 if (PL_oldoldbufptr == PL_last_lop)
4362 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4364 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4365 OPERATOR(HASHBRACK);
4367 while (s < PL_bufend && SPACE_OR_TAB(*s))
4370 PL_tokenbuf[0] = '\0';
4371 if (d < PL_bufend && *d == '-') {
4372 PL_tokenbuf[0] = '-';
4374 while (d < PL_bufend && SPACE_OR_TAB(*d))
4377 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4378 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4380 while (d < PL_bufend && SPACE_OR_TAB(*d))
4383 const char minus = (PL_tokenbuf[0] == '-');
4384 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4392 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4397 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4402 if (PL_oldoldbufptr == PL_last_lop)
4403 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4405 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4408 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4410 /* This hack is to get the ${} in the message. */
4412 yyerror("syntax error");
4415 OPERATOR(HASHBRACK);
4417 /* This hack serves to disambiguate a pair of curlies
4418 * as being a block or an anon hash. Normally, expectation
4419 * determines that, but in cases where we're not in a
4420 * position to expect anything in particular (like inside
4421 * eval"") we have to resolve the ambiguity. This code
4422 * covers the case where the first term in the curlies is a
4423 * quoted string. Most other cases need to be explicitly
4424 * disambiguated by prepending a "+" before the opening
4425 * curly in order to force resolution as an anon hash.
4427 * XXX should probably propagate the outer expectation
4428 * into eval"" to rely less on this hack, but that could
4429 * potentially break current behavior of eval"".
4433 if (*s == '\'' || *s == '"' || *s == '`') {
4434 /* common case: get past first string, handling escapes */
4435 for (t++; t < PL_bufend && *t != *s;)
4436 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4440 else if (*s == 'q') {
4443 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4446 /* skip q//-like construct */
4448 char open, close, term;
4451 while (t < PL_bufend && isSPACE(*t))
4453 /* check for q => */
4454 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4455 OPERATOR(HASHBRACK);
4459 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4463 for (t++; t < PL_bufend; t++) {
4464 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4466 else if (*t == open)
4470 for (t++; t < PL_bufend; t++) {
4471 if (*t == '\\' && t+1 < PL_bufend)
4473 else if (*t == close && --brackets <= 0)
4475 else if (*t == open)
4482 /* skip plain q word */
4483 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4486 else if (isALNUM_lazy_if(t,UTF)) {
4488 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4491 while (t < PL_bufend && isSPACE(*t))
4493 /* if comma follows first term, call it an anon hash */
4494 /* XXX it could be a comma expression with loop modifiers */
4495 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4496 || (*t == '=' && t[1] == '>')))
4497 OPERATOR(HASHBRACK);
4498 if (PL_expect == XREF)
4501 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4507 yylval.ival = CopLINE(PL_curcop);
4508 if (isSPACE(*s) || *s == '#')
4509 PL_copline = NOLINE; /* invalidate current command line number */
4514 if (PL_lex_brackets <= 0)
4515 yyerror("Unmatched right curly bracket");
4517 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4518 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4519 PL_lex_formbrack = 0;
4520 if (PL_lex_state == LEX_INTERPNORMAL) {
4521 if (PL_lex_brackets == 0) {
4522 if (PL_expect & XFAKEBRACK) {
4523 PL_expect &= XENUMMASK;
4524 PL_lex_state = LEX_INTERPEND;
4529 PL_thiswhite = newSVpvs("");
4530 sv_catpvn(PL_thiswhite,"}",1);
4533 return yylex(); /* ignore fake brackets */
4535 if (*s == '-' && s[1] == '>')
4536 PL_lex_state = LEX_INTERPENDMAYBE;
4537 else if (*s != '[' && *s != '{')
4538 PL_lex_state = LEX_INTERPEND;
4541 if (PL_expect & XFAKEBRACK) {
4542 PL_expect &= XENUMMASK;
4544 return yylex(); /* ignore fake brackets */
4546 start_force(PL_curforce);
4548 curmad('X', newSVpvn(s-1,1));
4549 CURMAD('_', PL_thiswhite);
4554 PL_thistoken = newSVpvs("");
4562 if (PL_expect == XOPERATOR) {
4563 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4564 && isIDFIRST_lazy_if(s,UTF))
4566 CopLINE_dec(PL_curcop);
4567 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4568 CopLINE_inc(PL_curcop);
4573 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4575 PL_expect = XOPERATOR;
4576 force_ident(PL_tokenbuf, '&');
4580 yylval.ival = (OPpENTERSUB_AMPER<<8);
4592 const char tmp = *s++;
4599 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4600 && strchr("+-*/%.^&|<",tmp))
4601 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4602 "Reversed %c= operator",(int)tmp);
4604 if (PL_expect == XSTATE && isALPHA(tmp) &&
4605 (s == PL_linestart+1 || s[-2] == '\n') )
4607 if (PL_in_eval && !PL_rsfp) {
4612 if (strnEQ(s,"=cut",4)) {
4628 PL_thiswhite = newSVpvs("");
4629 sv_catpvn(PL_thiswhite, PL_linestart,
4630 PL_bufend - PL_linestart);
4634 PL_doextract = TRUE;
4638 if (PL_lex_brackets < PL_lex_formbrack) {
4640 #ifdef PERL_STRICT_CR
4641 while (SPACE_OR_TAB(*t))
4643 while (SPACE_OR_TAB(*t) || *t == '\r')
4646 if (*t == '\n' || *t == '#') {
4657 const char tmp = *s++;
4659 /* was this !=~ where !~ was meant?
4660 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4662 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4663 const char *t = s+1;
4665 while (t < PL_bufend && isSPACE(*t))
4668 if (*t == '/' || *t == '?' ||
4669 ((*t == 'm' || *t == 's' || *t == 'y')
4670 && !isALNUM(t[1])) ||
4671 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4672 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4673 "!=~ should be !~");
4683 if (PL_expect != XOPERATOR) {
4684 if (s[1] != '<' && !strchr(s,'>'))
4687 s = scan_heredoc(s);
4689 s = scan_inputsymbol(s);
4690 TERM(sublex_start());
4696 SHop(OP_LEFT_SHIFT);
4710 const char tmp = *s++;
4712 SHop(OP_RIGHT_SHIFT);
4713 else if (tmp == '=')
4722 if (PL_expect == XOPERATOR) {
4723 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4725 deprecate_old(commaless_variable_list);
4726 return REPORT(','); /* grandfather non-comma-format format */
4730 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4731 PL_tokenbuf[0] = '@';
4732 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4733 sizeof PL_tokenbuf - 1, FALSE);
4734 if (PL_expect == XOPERATOR)
4735 no_op("Array length", s);
4736 if (!PL_tokenbuf[1])
4738 PL_expect = XOPERATOR;
4739 PL_pending_ident = '#';
4743 PL_tokenbuf[0] = '$';
4744 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4745 sizeof PL_tokenbuf - 1, FALSE);
4746 if (PL_expect == XOPERATOR)
4748 if (!PL_tokenbuf[1]) {
4750 yyerror("Final $ should be \\$ or $name");
4754 /* This kludge not intended to be bulletproof. */
4755 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4756 yylval.opval = newSVOP(OP_CONST, 0,
4757 newSViv(CopARYBASE_get(&PL_compiling)));
4758 yylval.opval->op_private = OPpCONST_ARYBASE;
4764 const char tmp = *s;
4765 if (PL_lex_state == LEX_NORMAL)
4768 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4769 && intuit_more(s)) {
4771 PL_tokenbuf[0] = '@';
4772 if (ckWARN(WARN_SYNTAX)) {
4775 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4778 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4779 while (t < PL_bufend && *t != ']')
4781 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4782 "Multidimensional syntax %.*s not supported",
4783 (int)((t - PL_bufptr) + 1), PL_bufptr);
4787 else if (*s == '{') {
4789 PL_tokenbuf[0] = '%';
4790 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4791 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4793 char tmpbuf[sizeof PL_tokenbuf];
4796 } while (isSPACE(*t));
4797 if (isIDFIRST_lazy_if(t,UTF)) {
4799 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4803 if (*t == ';' && get_cv(tmpbuf, FALSE))
4804 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4805 "You need to quote \"%s\"",
4812 PL_expect = XOPERATOR;
4813 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4814 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4815 if (!islop || PL_last_lop_op == OP_GREPSTART)
4816 PL_expect = XOPERATOR;
4817 else if (strchr("$@\"'`q", *s))
4818 PL_expect = XTERM; /* e.g. print $fh "foo" */
4819 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4820 PL_expect = XTERM; /* e.g. print $fh &sub */
4821 else if (isIDFIRST_lazy_if(s,UTF)) {
4822 char tmpbuf[sizeof PL_tokenbuf];
4824 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4825 if ((t2 = keyword(tmpbuf, len, 0))) {
4826 /* binary operators exclude handle interpretations */
4838 PL_expect = XTERM; /* e.g. print $fh length() */
4843 PL_expect = XTERM; /* e.g. print $fh subr() */
4846 else if (isDIGIT(*s))
4847 PL_expect = XTERM; /* e.g. print $fh 3 */
4848 else if (*s == '.' && isDIGIT(s[1]))
4849 PL_expect = XTERM; /* e.g. print $fh .3 */
4850 else if ((*s == '?' || *s == '-' || *s == '+')
4851 && !isSPACE(s[1]) && s[1] != '=')
4852 PL_expect = XTERM; /* e.g. print $fh -1 */
4853 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4855 PL_expect = XTERM; /* e.g. print $fh /.../
4856 XXX except DORDOR operator
4858 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4860 PL_expect = XTERM; /* print $fh <<"EOF" */
4863 PL_pending_ident = '$';
4867 if (PL_expect == XOPERATOR)
4869 PL_tokenbuf[0] = '@';
4870 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4871 if (!PL_tokenbuf[1]) {
4874 if (PL_lex_state == LEX_NORMAL)
4876 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4878 PL_tokenbuf[0] = '%';
4880 /* Warn about @ where they meant $. */
4881 if (*s == '[' || *s == '{') {
4882 if (ckWARN(WARN_SYNTAX)) {
4883 const char *t = s + 1;
4884 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4886 if (*t == '}' || *t == ']') {
4888 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4889 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4890 "Scalar value %.*s better written as $%.*s",
4891 (int)(t-PL_bufptr), PL_bufptr,
4892 (int)(t-PL_bufptr-1), PL_bufptr+1);
4897 PL_pending_ident = '@';
4900 case '/': /* may be division, defined-or, or pattern */
4901 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4905 case '?': /* may either be conditional or pattern */
4906 if(PL_expect == XOPERATOR) {
4914 /* A // operator. */
4924 /* Disable warning on "study /blah/" */
4925 if (PL_oldoldbufptr == PL_last_uni
4926 && (*PL_last_uni != 's' || s - PL_last_uni < 5
4927 || memNE(PL_last_uni, "study", 5)
4928 || isALNUM_lazy_if(PL_last_uni+5,UTF)
4931 s = scan_pat(s,OP_MATCH);
4932 TERM(sublex_start());
4936 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4937 #ifdef PERL_STRICT_CR
4940 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4942 && (s == PL_linestart || s[-1] == '\n') )
4944 PL_lex_formbrack = 0;
4948 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4954 yylval.ival = OPf_SPECIAL;
4960 if (PL_expect != XOPERATOR)
4965 case '0': case '1': case '2': case '3': case '4':
4966 case '5': case '6': case '7': case '8': case '9':
4967 s = scan_num(s, &yylval);
4968 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
4969 if (PL_expect == XOPERATOR)
4974 s = scan_str(s,!!PL_madskills,FALSE);
4975 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4976 if (PL_expect == XOPERATOR) {
4977 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4979 deprecate_old(commaless_variable_list);
4980 return REPORT(','); /* grandfather non-comma-format format */
4987 yylval.ival = OP_CONST;
4988 TERM(sublex_start());
4991 s = scan_str(s,!!PL_madskills,FALSE);
4992 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4993 if (PL_expect == XOPERATOR) {
4994 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4996 deprecate_old(commaless_variable_list);
4997 return REPORT(','); /* grandfather non-comma-format format */
5004 yylval.ival = OP_CONST;
5005 /* FIXME. I think that this can be const if char *d is replaced by
5006 more localised variables. */
5007 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5008 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5009 yylval.ival = OP_STRINGIFY;
5013 TERM(sublex_start());
5016 s = scan_str(s,!!PL_madskills,FALSE);
5017 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5018 if (PL_expect == XOPERATOR)
5019 no_op("Backticks",s);
5022 readpipe_override();
5023 TERM(sublex_start());
5027 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5028 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5030 if (PL_expect == XOPERATOR)
5031 no_op("Backslash",s);
5035 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5036 char *start = s + 2;
5037 while (isDIGIT(*start) || *start == '_')
5039 if (*start == '.' && isDIGIT(start[1])) {
5040 s = scan_num(s, &yylval);
5043 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5044 else if (!isALPHA(*start) && (PL_expect == XTERM
5045 || PL_expect == XREF || PL_expect == XSTATE
5046 || PL_expect == XTERMORDORDOR)) {
5047 /* XXX Use gv_fetchpvn rather than stomping on a const string */
5048 const char c = *start;
5051 gv = gv_fetchpv(s, 0, SVt_PVCV);
5054 s = scan_num(s, &yylval);
5061 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5103 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5105 /* Some keywords can be followed by any delimiter, including ':' */
5106 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5107 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5108 (PL_tokenbuf[0] == 'q' &&
5109 strchr("qwxr", PL_tokenbuf[1])))));
5111 /* x::* is just a word, unless x is "CORE" */
5112 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5116 while (d < PL_bufend && isSPACE(*d))
5117 d++; /* no comments skipped here, or s### is misparsed */
5119 /* Is this a label? */
5120 if (!tmp && PL_expect == XSTATE
5121 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5123 yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5128 /* Check for keywords */
5129 tmp = keyword(PL_tokenbuf, len, 0);
5131 /* Is this a word before a => operator? */
5132 if (*d == '=' && d[1] == '>') {
5135 = (OP*)newSVOP(OP_CONST, 0,
5136 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5137 yylval.opval->op_private = OPpCONST_BARE;
5141 if (tmp < 0) { /* second-class keyword? */
5142 GV *ogv = NULL; /* override (winner) */
5143 GV *hgv = NULL; /* hidden (loser) */
5144 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5146 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5149 if (GvIMPORTED_CV(gv))
5151 else if (! CvMETHOD(cv))
5155 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5156 (gv = *gvp) != (GV*)&PL_sv_undef &&
5157 GvCVu(gv) && GvIMPORTED_CV(gv))
5164 tmp = 0; /* overridden by import or by GLOBAL */
5167 && -tmp==KEY_lock /* XXX generalizable kludge */
5169 && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
5171 tmp = 0; /* any sub overrides "weak" keyword */
5173 else { /* no override */
5175 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5176 Perl_warner(aTHX_ packWARN(WARN_MISC),
5177 "dump() better written as CORE::dump()");
5181 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5182 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
5183 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5184 "Ambiguous call resolved as CORE::%s(), %s",
5185 GvENAME(hgv), "qualify as such or use &");
5192 default: /* not a keyword */
5193 /* Trade off - by using this evil construction we can pull the
5194 variable gv into the block labelled keylookup. If not, then
5195 we have to give it function scope so that the goto from the
5196 earlier ':' case doesn't bypass the initialisation. */
5198 just_a_word_zero_gv:
5206 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5209 SV *nextPL_nextwhite = 0;
5213 /* Get the rest if it looks like a package qualifier */
5215 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5217 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5220 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5221 *s == '\'' ? "'" : "::");
5226 if (PL_expect == XOPERATOR) {
5227 if (PL_bufptr == PL_linestart) {
5228 CopLINE_dec(PL_curcop);
5229 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5230 CopLINE_inc(PL_curcop);
5233 no_op("Bareword",s);
5236 /* Look for a subroutine with this name in current package,
5237 unless name is "Foo::", in which case Foo is a bearword
5238 (and a package name). */
5240 if (len > 2 && !PL_madskills &&
5241 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5243 if (ckWARN(WARN_BAREWORD)
5244 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5245 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5246 "Bareword \"%s\" refers to nonexistent package",
5249 PL_tokenbuf[len] = '\0';
5255 /* Mustn't actually add anything to a symbol table.
5256 But also don't want to "initialise" any placeholder
5257 constants that might already be there into full
5258 blown PVGVs with attached PVCV. */
5259 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5260 GV_NOADD_NOINIT, SVt_PVCV);
5265 /* if we saw a global override before, get the right name */
5268 sv = newSVpvs("CORE::GLOBAL::");
5269 sv_catpv(sv,PL_tokenbuf);
5272 /* If len is 0, newSVpv does strlen(), which is correct.
5273 If len is non-zero, then it will be the true length,
5274 and so the scalar will be created correctly. */
5275 sv = newSVpv(PL_tokenbuf,len);
5278 if (PL_madskills && !PL_thistoken) {
5279 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5280 PL_thistoken = newSVpv(start,s - start);
5281 PL_realtokenstart = s - SvPVX(PL_linestr);
5285 /* Presume this is going to be a bareword of some sort. */
5288 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5289 yylval.opval->op_private = OPpCONST_BARE;
5290 /* UTF-8 package name? */
5291 if (UTF && !IN_BYTES &&
5292 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5295 /* And if "Foo::", then that's what it certainly is. */
5300 /* Do the explicit type check so that we don't need to force
5301 the initialisation of the symbol table to have a real GV.
5302 Beware - gv may not really be a PVGV, cv may not really be
5303 a PVCV, (because of the space optimisations that gv_init
5304 understands) But they're true if for this symbol there is
5305 respectively a typeglob and a subroutine.
5307 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5308 /* Real typeglob, so get the real subroutine: */
5310 /* A proxy for a subroutine in this package? */
5311 : SvOK(gv) ? (CV *) gv : NULL)
5314 /* See if it's the indirect object for a list operator. */
5316 if (PL_oldoldbufptr &&
5317 PL_oldoldbufptr < PL_bufptr &&
5318 (PL_oldoldbufptr == PL_last_lop
5319 || PL_oldoldbufptr == PL_last_uni) &&
5320 /* NO SKIPSPACE BEFORE HERE! */
5321 (PL_expect == XREF ||
5322 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5324 bool immediate_paren = *s == '(';
5326 /* (Now we can afford to cross potential line boundary.) */
5327 s = SKIPSPACE2(s,nextPL_nextwhite);
5329 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5332 /* Two barewords in a row may indicate method call. */
5334 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5335 (tmp = intuit_method(s, gv, cv)))
5338 /* If not a declared subroutine, it's an indirect object. */
5339 /* (But it's an indir obj regardless for sort.) */
5340 /* Also, if "_" follows a filetest operator, it's a bareword */
5343 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5345 (PL_last_lop_op != OP_MAPSTART &&
5346 PL_last_lop_op != OP_GREPSTART))))
5347 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5348 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5351 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5356 PL_expect = XOPERATOR;
5359 s = SKIPSPACE2(s,nextPL_nextwhite);
5360 PL_nextwhite = nextPL_nextwhite;
5365 /* Is this a word before a => operator? */
5366 if (*s == '=' && s[1] == '>' && !pkgname) {
5368 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5369 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5370 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5374 /* If followed by a paren, it's certainly a subroutine. */
5379 while (SPACE_OR_TAB(*d))
5381 if (*d == ')' && (sv = gv_const_sv(gv))) {
5385 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5386 sv_catpvn(PL_thistoken, par, s - par);
5388 sv_free(PL_nextwhite);
5398 PL_nextwhite = PL_thiswhite;
5401 start_force(PL_curforce);
5403 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5404 PL_expect = XOPERATOR;
5407 PL_nextwhite = nextPL_nextwhite;
5408 curmad('X', PL_thistoken);
5409 PL_thistoken = newSVpvs("");
5417 /* If followed by var or block, call it a method (unless sub) */
5419 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5420 PL_last_lop = PL_oldbufptr;
5421 PL_last_lop_op = OP_METHOD;
5425 /* If followed by a bareword, see if it looks like indir obj. */
5428 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5429 && (tmp = intuit_method(s, gv, cv)))
5432 /* Not a method, so call it a subroutine (if defined) */
5435 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5436 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5437 "Ambiguous use of -%s resolved as -&%s()",
5438 PL_tokenbuf, PL_tokenbuf);
5439 /* Check for a constant sub */
5440 if ((sv = gv_const_sv(gv))) {
5442 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5443 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5444 yylval.opval->op_private = 0;
5448 /* Resolve to GV now. */
5449 if (SvTYPE(gv) != SVt_PVGV) {
5450 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5451 assert (SvTYPE(gv) == SVt_PVGV);
5452 /* cv must have been some sort of placeholder, so
5453 now needs replacing with a real code reference. */
5457 op_free(yylval.opval);
5458 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5459 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5460 PL_last_lop = PL_oldbufptr;
5461 PL_last_lop_op = OP_ENTERSUB;
5462 /* Is there a prototype? */
5470 const char *proto = SvPV_const((SV*)cv, protolen);
5473 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5475 while (*proto == ';')
5477 if (*proto == '&' && *s == '{') {
5478 sv_setpv(PL_subname,
5481 "__ANON__" : "__ANON__::__ANON__"));
5488 PL_nextwhite = PL_thiswhite;
5491 start_force(PL_curforce);
5492 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5495 PL_nextwhite = nextPL_nextwhite;
5496 curmad('X', PL_thistoken);
5497 PL_thistoken = newSVpvs("");
5504 /* Guess harder when madskills require "best effort". */
5505 if (PL_madskills && (!gv || !GvCVu(gv))) {
5506 int probable_sub = 0;
5507 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5509 else if (isALPHA(*s)) {
5513 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5514 if (!keyword(tmpbuf, tmplen, 0))
5517 while (d < PL_bufend && isSPACE(*d))
5519 if (*d == '=' && d[1] == '>')
5524 gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
5525 op_free(yylval.opval);
5526 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5527 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5528 PL_last_lop = PL_oldbufptr;
5529 PL_last_lop_op = OP_ENTERSUB;
5530 PL_nextwhite = PL_thiswhite;
5532 start_force(PL_curforce);
5533 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5535 PL_nextwhite = nextPL_nextwhite;
5536 curmad('X', PL_thistoken);
5537 PL_thistoken = newSVpvs("");
5542 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5549 /* Call it a bare word */
5551 if (PL_hints & HINT_STRICT_SUBS)
5552 yylval.opval->op_private |= OPpCONST_STRICT;
5555 if (lastchar != '-') {
5556 if (ckWARN(WARN_RESERVED)) {
5560 if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
5561 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5568 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5569 && ckWARN_d(WARN_AMBIGUOUS)) {
5570 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5571 "Operator or semicolon missing before %c%s",
5572 lastchar, PL_tokenbuf);
5573 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5574 "Ambiguous use of %c resolved as operator %c",
5575 lastchar, lastchar);
5581 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5582 newSVpv(CopFILE(PL_curcop),0));
5586 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5587 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5590 case KEY___PACKAGE__:
5591 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5593 ? newSVhek(HvNAME_HEK(PL_curstash))
5600 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5601 const char *pname = "main";
5602 if (PL_tokenbuf[2] == 'D')
5603 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5604 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5608 GvIOp(gv) = newIO();
5609 IoIFP(GvIOp(gv)) = PL_rsfp;
5610 #if defined(HAS_FCNTL) && defined(F_SETFD)
5612 const int fd = PerlIO_fileno(PL_rsfp);
5613 fcntl(fd,F_SETFD,fd >= 3);
5616 /* Mark this internal pseudo-handle as clean */
5617 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5619 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5620 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5621 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5623 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5624 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5625 /* if the script was opened in binmode, we need to revert
5626 * it to text mode for compatibility; but only iff it has CRs
5627 * XXX this is a questionable hack at best. */
5628 if (PL_bufend-PL_bufptr > 2
5629 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5632 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5633 loc = PerlIO_tell(PL_rsfp);
5634 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5637 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5639 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5640 #endif /* NETWARE */
5641 #ifdef PERLIO_IS_STDIO /* really? */
5642 # if defined(__BORLANDC__)
5643 /* XXX see note in do_binmode() */
5644 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5648 PerlIO_seek(PL_rsfp, loc, 0);
5652 #ifdef PERLIO_LAYERS
5655 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5656 else if (PL_encoding) {
5663 XPUSHs(PL_encoding);
5665 call_method("name", G_SCALAR);
5669 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5670 Perl_form(aTHX_ ":encoding(%"SVf")",
5679 if (PL_realtokenstart >= 0) {
5680 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5682 PL_endwhite = newSVpvs("");
5683 sv_catsv(PL_endwhite, PL_thiswhite);
5685 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5686 PL_realtokenstart = -1;
5688 while ((s = filter_gets(PL_endwhite, PL_rsfp,
5689 SvCUR(PL_endwhite))) != Nullch) ;
5704 if (PL_expect == XSTATE) {
5711 if (*s == ':' && s[1] == ':') {
5714 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5715 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5716 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5719 else if (tmp == KEY_require || tmp == KEY_do)
5720 /* that's a way to remember we saw "CORE::" */
5733 LOP(OP_ACCEPT,XTERM);
5739 LOP(OP_ATAN2,XTERM);
5745 LOP(OP_BINMODE,XTERM);
5748 LOP(OP_BLESS,XTERM);
5757 /* When 'use switch' is in effect, continue has a dual
5758 life as a control operator. */
5760 if (!FEATURE_IS_ENABLED("switch"))
5763 /* We have to disambiguate the two senses of
5764 "continue". If the next token is a '{' then
5765 treat it as the start of a continue block;
5766 otherwise treat it as a control operator.
5778 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5795 if (!PL_cryptseen) {
5796 PL_cryptseen = TRUE;
5800 LOP(OP_CRYPT,XTERM);
5803 LOP(OP_CHMOD,XTERM);
5806 LOP(OP_CHOWN,XTERM);
5809 LOP(OP_CONNECT,XTERM);
5828 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5829 if (orig_keyword == KEY_do) {
5838 PL_hints |= HINT_BLOCK_SCOPE;
5848 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5849 LOP(OP_DBMOPEN,XTERM);
5855 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5862 yylval.ival = CopLINE(PL_curcop);
5878 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5879 UNIBRACK(OP_ENTEREVAL);
5897 case KEY_endhostent:
5903 case KEY_endservent:
5906 case KEY_endprotoent:
5917 yylval.ival = CopLINE(PL_curcop);
5919 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5922 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5925 if ((PL_bufend - p) >= 3 &&
5926 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5928 else if ((PL_bufend - p) >= 4 &&
5929 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5932 if (isIDFIRST_lazy_if(p,UTF)) {
5933 p = scan_ident(p, PL_bufend,
5934 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5938 Perl_croak(aTHX_ "Missing $ on loop variable");
5940 s = SvPVX(PL_linestr) + soff;
5946 LOP(OP_FORMLINE,XTERM);
5952 LOP(OP_FCNTL,XTERM);
5958 LOP(OP_FLOCK,XTERM);
5967 LOP(OP_GREPSTART, XREF);
5970 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5985 case KEY_getpriority:
5986 LOP(OP_GETPRIORITY,XTERM);
5988 case KEY_getprotobyname:
5991 case KEY_getprotobynumber:
5992 LOP(OP_GPBYNUMBER,XTERM);
5994 case KEY_getprotoent:
6006 case KEY_getpeername:
6007 UNI(OP_GETPEERNAME);
6009 case KEY_gethostbyname:
6012 case KEY_gethostbyaddr:
6013 LOP(OP_GHBYADDR,XTERM);
6015 case KEY_gethostent:
6018 case KEY_getnetbyname:
6021 case KEY_getnetbyaddr:
6022 LOP(OP_GNBYADDR,XTERM);
6027 case KEY_getservbyname:
6028 LOP(OP_GSBYNAME,XTERM);
6030 case KEY_getservbyport:
6031 LOP(OP_GSBYPORT,XTERM);
6033 case KEY_getservent:
6036 case KEY_getsockname:
6037 UNI(OP_GETSOCKNAME);
6039 case KEY_getsockopt:
6040 LOP(OP_GSOCKOPT,XTERM);
6055 yylval.ival = CopLINE(PL_curcop);
6066 yylval.ival = CopLINE(PL_curcop);
6070 LOP(OP_INDEX,XTERM);
6076 LOP(OP_IOCTL,XTERM);
6088 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6120 LOP(OP_LISTEN,XTERM);
6129 s = scan_pat(s,OP_MATCH);
6130 TERM(sublex_start());
6133 LOP(OP_MAPSTART, XREF);
6136 LOP(OP_MKDIR,XTERM);
6139 LOP(OP_MSGCTL,XTERM);
6142 LOP(OP_MSGGET,XTERM);
6145 LOP(OP_MSGRCV,XTERM);
6148 LOP(OP_MSGSND,XTERM);
6155 if (isIDFIRST_lazy_if(s,UTF)) {
6159 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6160 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6162 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6163 if (!PL_in_my_stash) {
6166 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6170 if (PL_madskills) { /* just add type to declarator token */
6171 sv_catsv(PL_thistoken, PL_nextwhite);
6173 sv_catpvn(PL_thistoken, start, s - start);
6181 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6188 s = tokenize_use(0, s);
6192 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6199 if (isIDFIRST_lazy_if(s,UTF)) {
6201 for (d = s; isALNUM_lazy_if(d,UTF);)
6203 for (t=d; isSPACE(*t);)
6205 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6207 && !(t[0] == '=' && t[1] == '>')
6209 int parms_len = (int)(d-s);
6210 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6211 "Precedence problem: open %.*s should be open(%.*s)",
6212 parms_len, s, parms_len, s);
6218 yylval.ival = OP_OR;
6228 LOP(OP_OPEN_DIR,XTERM);
6231 checkcomma(s,PL_tokenbuf,"filehandle");
6235 checkcomma(s,PL_tokenbuf,"filehandle");
6254 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6258 LOP(OP_PIPE_OP,XTERM);
6261 s = scan_str(s,!!PL_madskills,FALSE);
6264 yylval.ival = OP_CONST;
6265 TERM(sublex_start());
6271 s = scan_str(s,!!PL_madskills,FALSE);
6274 PL_expect = XOPERATOR;
6276 if (SvCUR(PL_lex_stuff)) {
6279 d = SvPV_force(PL_lex_stuff, len);
6281 for (; isSPACE(*d) && len; --len, ++d)
6286 if (!warned && ckWARN(WARN_QW)) {
6287 for (; !isSPACE(*d) && len; --len, ++d) {
6289 Perl_warner(aTHX_ packWARN(WARN_QW),
6290 "Possible attempt to separate words with commas");
6293 else if (*d == '#') {
6294 Perl_warner(aTHX_ packWARN(WARN_QW),
6295 "Possible attempt to put comments in qw() list");
6301 for (; !isSPACE(*d) && len; --len, ++d)
6304 sv = newSVpvn(b, d-b);
6305 if (DO_UTF8(PL_lex_stuff))
6307 words = append_elem(OP_LIST, words,
6308 newSVOP(OP_CONST, 0, tokeq(sv)));
6312 start_force(PL_curforce);
6313 NEXTVAL_NEXTTOKE.opval = words;
6318 SvREFCNT_dec(PL_lex_stuff);
6319 PL_lex_stuff = NULL;
6325 s = scan_str(s,!!PL_madskills,FALSE);
6328 yylval.ival = OP_STRINGIFY;
6329 if (SvIVX(PL_lex_stuff) == '\'')
6330 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6331 TERM(sublex_start());
6334 s = scan_pat(s,OP_QR);
6335 TERM(sublex_start());
6338 s = scan_str(s,!!PL_madskills,FALSE);
6341 readpipe_override();
6342 TERM(sublex_start());
6350 s = force_version(s, FALSE);
6352 else if (*s != 'v' || !isDIGIT(s[1])
6353 || (s = force_version(s, TRUE), *s == 'v'))
6355 *PL_tokenbuf = '\0';
6356 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6357 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6358 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
6360 yyerror("<> should be quotes");
6362 if (orig_keyword == KEY_require) {
6370 PL_last_uni = PL_oldbufptr;
6371 PL_last_lop_op = OP_REQUIRE;
6373 return REPORT( (int)REQUIRE );
6379 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6383 LOP(OP_RENAME,XTERM);
6392 LOP(OP_RINDEX,XTERM);
6402 UNIDOR(OP_READLINE);
6415 LOP(OP_REVERSE,XTERM);
6418 UNIDOR(OP_READLINK);
6426 TERM(sublex_start());
6428 TOKEN(1); /* force error */
6431 checkcomma(s,PL_tokenbuf,"filehandle");
6441 LOP(OP_SELECT,XTERM);
6447 LOP(OP_SEMCTL,XTERM);
6450 LOP(OP_SEMGET,XTERM);
6453 LOP(OP_SEMOP,XTERM);
6459 LOP(OP_SETPGRP,XTERM);
6461 case KEY_setpriority:
6462 LOP(OP_SETPRIORITY,XTERM);
6464 case KEY_sethostent:
6470 case KEY_setservent:
6473 case KEY_setprotoent:
6483 LOP(OP_SEEKDIR,XTERM);
6485 case KEY_setsockopt:
6486 LOP(OP_SSOCKOPT,XTERM);
6492 LOP(OP_SHMCTL,XTERM);
6495 LOP(OP_SHMGET,XTERM);
6498 LOP(OP_SHMREAD,XTERM);
6501 LOP(OP_SHMWRITE,XTERM);
6504 LOP(OP_SHUTDOWN,XTERM);
6513 LOP(OP_SOCKET,XTERM);
6515 case KEY_socketpair:
6516 LOP(OP_SOCKPAIR,XTERM);
6519 checkcomma(s,PL_tokenbuf,"subroutine name");
6521 if (*s == ';' || *s == ')') /* probably a close */
6522 Perl_croak(aTHX_ "sort is now a reserved word");
6524 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6528 LOP(OP_SPLIT,XTERM);
6531 LOP(OP_SPRINTF,XTERM);
6534 LOP(OP_SPLICE,XTERM);
6549 LOP(OP_SUBSTR,XTERM);
6555 char tmpbuf[sizeof PL_tokenbuf];
6556 SSize_t tboffset = 0;
6557 expectation attrful;
6558 bool have_name, have_proto;
6559 const int key = tmp;
6564 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6565 SV *subtoken = newSVpvn(tstart, s - tstart);
6569 s = SKIPSPACE2(s,tmpwhite);
6574 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6575 (*s == ':' && s[1] == ':'))
6582 attrful = XATTRBLOCK;
6583 /* remember buffer pos'n for later force_word */
6584 tboffset = s - PL_oldbufptr;
6585 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6588 nametoke = newSVpvn(s, d - s);
6590 if (strchr(tmpbuf, ':'))
6591 sv_setpv(PL_subname, tmpbuf);
6593 sv_setsv(PL_subname,PL_curstname);
6594 sv_catpvs(PL_subname,"::");
6595 sv_catpvn(PL_subname,tmpbuf,len);
6602 CURMAD('X', nametoke);
6603 CURMAD('_', tmpwhite);
6604 (void) force_word(PL_oldbufptr + tboffset, WORD,
6607 s = SKIPSPACE2(d,tmpwhite);
6614 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6615 PL_expect = XTERMBLOCK;
6616 attrful = XATTRTERM;
6617 sv_setpvn(PL_subname,"?",1);
6621 if (key == KEY_format) {
6623 PL_lex_formbrack = PL_lex_brackets + 1;
6625 PL_thistoken = subtoken;
6629 (void) force_word(PL_oldbufptr + tboffset, WORD,
6635 /* Look for a prototype */
6638 bool bad_proto = FALSE;
6639 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6641 s = scan_str(s,!!PL_madskills,FALSE);
6643 Perl_croak(aTHX_ "Prototype not terminated");
6644 /* strip spaces and check for bad characters */
6645 d = SvPVX(PL_lex_stuff);
6647 for (p = d; *p; ++p) {
6650 if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
6656 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6657 "Illegal character in prototype for %"SVf" : %s",
6658 SVfARG(PL_subname), d);
6659 SvCUR_set(PL_lex_stuff, tmp);
6664 CURMAD('q', PL_thisopen);
6665 CURMAD('_', tmpwhite);
6666 CURMAD('=', PL_thisstuff);
6667 CURMAD('Q', PL_thisclose);
6668 NEXTVAL_NEXTTOKE.opval =
6669 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6670 PL_lex_stuff = Nullsv;
6673 s = SKIPSPACE2(s,tmpwhite);
6681 if (*s == ':' && s[1] != ':')
6682 PL_expect = attrful;
6683 else if (*s != '{' && key == KEY_sub) {
6685 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6687 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6694 curmad('^', newSVpvs(""));
6695 CURMAD('_', tmpwhite);
6699 PL_thistoken = subtoken;
6702 NEXTVAL_NEXTTOKE.opval =
6703 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6704 PL_lex_stuff = NULL;
6709 sv_setpv(PL_subname,
6711 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
6715 (void) force_word(PL_oldbufptr + tboffset, WORD,
6725 LOP(OP_SYSTEM,XREF);
6728 LOP(OP_SYMLINK,XTERM);
6731 LOP(OP_SYSCALL,XTERM);
6734 LOP(OP_SYSOPEN,XTERM);
6737 LOP(OP_SYSSEEK,XTERM);
6740 LOP(OP_SYSREAD,XTERM);
6743 LOP(OP_SYSWRITE,XTERM);
6747 TERM(sublex_start());
6768 LOP(OP_TRUNCATE,XTERM);
6780 yylval.ival = CopLINE(PL_curcop);
6784 yylval.ival = CopLINE(PL_curcop);
6788 LOP(OP_UNLINK,XTERM);
6794 LOP(OP_UNPACK,XTERM);
6797 LOP(OP_UTIME,XTERM);
6803 LOP(OP_UNSHIFT,XTERM);
6806 s = tokenize_use(1, s);
6816 yylval.ival = CopLINE(PL_curcop);
6820 yylval.ival = CopLINE(PL_curcop);
6824 PL_hints |= HINT_BLOCK_SCOPE;
6831 LOP(OP_WAITPID,XTERM);
6840 ctl_l[0] = toCTRL('L');
6842 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6845 /* Make sure $^L is defined */
6846 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6851 if (PL_expect == XOPERATOR)
6857 yylval.ival = OP_XOR;
6862 TERM(sublex_start());
6867 #pragma segment Main
6871 S_pending_ident(pTHX)
6876 /* pit holds the identifier we read and pending_ident is reset */
6877 char pit = PL_pending_ident;
6878 PL_pending_ident = 0;
6880 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6881 DEBUG_T({ PerlIO_printf(Perl_debug_log,
6882 "### Pending identifier '%s'\n", PL_tokenbuf); });
6884 /* if we're in a my(), we can't allow dynamics here.
6885 $foo'bar has already been turned into $foo::bar, so
6886 just check for colons.
6888 if it's a legal name, the OP is a PADANY.
6891 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
6892 if (strchr(PL_tokenbuf,':'))
6893 yyerror(Perl_form(aTHX_ "No package name allowed for "
6894 "variable %s in \"our\"",
6896 tmp = allocmy(PL_tokenbuf);
6899 if (strchr(PL_tokenbuf,':'))
6900 yyerror(Perl_form(aTHX_ PL_no_myglob,
6901 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
6903 yylval.opval = newOP(OP_PADANY, 0);
6904 yylval.opval->op_targ = allocmy(PL_tokenbuf);
6910 build the ops for accesses to a my() variable.
6912 Deny my($a) or my($b) in a sort block, *if* $a or $b is
6913 then used in a comparison. This catches most, but not
6914 all cases. For instance, it catches
6915 sort { my($a); $a <=> $b }
6917 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6918 (although why you'd do that is anyone's guess).
6921 if (!strchr(PL_tokenbuf,':')) {
6923 tmp = pad_findmy(PL_tokenbuf);
6924 if (tmp != NOT_IN_PAD) {
6925 /* might be an "our" variable" */
6926 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6927 /* build ops for a bareword */
6928 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
6929 HEK * const stashname = HvNAME_HEK(stash);
6930 SV * const sym = newSVhek(stashname);
6931 sv_catpvs(sym, "::");
6932 sv_catpv(sym, PL_tokenbuf+1);
6933 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6934 yylval.opval->op_private = OPpCONST_ENTERED;
6937 ? (GV_ADDMULTI | GV_ADDINEVAL)
6940 ((PL_tokenbuf[0] == '$') ? SVt_PV
6941 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6946 /* if it's a sort block and they're naming $a or $b */
6947 if (PL_last_lop_op == OP_SORT &&
6948 PL_tokenbuf[0] == '$' &&
6949 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
6952 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
6953 d < PL_bufend && *d != '\n';
6956 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
6957 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
6963 yylval.opval = newOP(OP_PADANY, 0);
6964 yylval.opval->op_targ = tmp;
6970 Whine if they've said @foo in a doublequoted string,
6971 and @foo isn't a variable we can find in the symbol
6974 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
6975 GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
6976 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
6977 && ckWARN(WARN_AMBIGUOUS))
6979 /* Downgraded from fatal to warning 20000522 mjd */
6980 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6981 "Possible unintended interpolation of %s in string",
6986 /* build ops for a bareword */
6987 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
6988 yylval.opval->op_private = OPpCONST_ENTERED;
6991 /* If the identifier refers to a stash, don't autovivify it.
6992 * Change 24660 had the side effect of causing symbol table
6993 * hashes to always be defined, even if they were freshly
6994 * created and the only reference in the entire program was
6995 * the single statement with the defined %foo::bar:: test.
6996 * It appears that all code in the wild doing this actually
6997 * wants to know whether sub-packages have been loaded, so
6998 * by avoiding auto-vivifying symbol tables, we ensure that
6999 * defined %foo::bar:: continues to be false, and the existing
7000 * tests still give the expected answers, even though what
7001 * they're actually testing has now changed subtly.
7003 (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
7005 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7006 ((PL_tokenbuf[0] == '$') ? SVt_PV
7007 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7013 * The following code was generated by perl_keyword.pl.
7017 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7022 case 1: /* 5 tokens of length 1 */
7054 case 2: /* 18 tokens of length 2 */
7200 case 3: /* 29 tokens of length 3 */
7204 if (name[1] == 'N' &&
7267 if (name[1] == 'i' &&
7289 return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7307 if (name[1] == 'o' &&
7316 if (name[1] == 'e' &&
7325 if (name[1] == 'n' &&
7334 if (name[1] == 'o' &&
7343 if (name[1] == 'a' &&
7352 if (name[1] == 'o' &&
7414 if (name[1] == 'e' &&
7428 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7454 if (name[1] == 'i' &&
7463 if (name[1] == 's' &&
7472 if (name[1] == 'e' &&
7481 if (name[1] == 'o' &&
7493 case 4: /* 41 tokens of length 4 */
7497 if (name[1] == 'O' &&
7507 if (name[1] == 'N' &&
7517 if (name[1] == 'i' &&
7527 if (name[1] == 'h' &&
7537 if (name[1] == 'u' &&
7550 if (name[2] == 'c' &&
7559 if (name[2] == 's' &&
7568 if (name[2] == 'a' &&
7604 if (name[1] == 'o' &&
7617 if (name[2] == 't' &&
7626 if (name[2] == 'o' &&
7635 if (name[2] == 't' &&
7644 if (name[2] == 'e' &&
7657 if (name[1] == 'o' &&
7670 if (name[2] == 'y' &&
7679 if (name[2] == 'l' &&
7695 if (name[2] == 's' &&
7704 if (name[2] == 'n' &&
7713 if (name[2] == 'c' &&
7726 if (name[1] == 'e' &&
7736 if (name[1] == 'p' &&
7749 if (name[2] == 'c' &&
7758 if (name[2] == 'p' &&
7767 if (name[2] == 's' &&
7783 if (name[2] == 'n' &&
7853 if (name[2] == 'r' &&
7862 if (name[2] == 'r' &&
7871 if (name[2] == 'a' &&
7887 if (name[2] == 'l' &&
7949 if (name[2] == 'e' &&
7952 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
7965 case 5: /* 39 tokens of length 5 */
7969 if (name[1] == 'E' &&
7980 if (name[1] == 'H' &&
7994 if (name[2] == 'a' &&
8004 if (name[2] == 'a' &&
8021 if (name[2] == 'e' &&
8031 if (name[2] == 'e' &&
8035 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8051 if (name[3] == 'i' &&
8060 if (name[3] == 'o' &&
8096 if (name[2] == 'o' &&
8106 if (name[2] == 'y' &&
8120 if (name[1] == 'l' &&
8134 if (name[2] == 'n' &&
8144 if (name[2] == 'o' &&
8158 if (name[1] == 'i' &&
8163 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8172 if (name[2] == 'd' &&
8182 if (name[2] == 'c' &&
8199 if (name[2] == 'c' &&
8209 if (name[2] == 't' &&
8223 if (name[1] == 'k' &&
8234 if (name[1] == 'r' &&
8248 if (name[2] == 's' &&
8258 if (name[2] == 'd' &&
8275 if (name[2] == 'm' &&
8285 if (name[2] == 'i' &&
8295 if (name[2] == 'e' &&
8305 if (name[2] == 'l' &&
8315 if (name[2] == 'a' &&
8328 if (name[3] == 't' &&
8331 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8337 if (name[3] == 'd' &&
8354 if (name[1] == 'i' &&
8368 if (name[2] == 'a' &&
8381 if (name[3] == 'e' &&
8416 if (name[2] == 'i' &&
8433 if (name[2] == 'i' &&
8443 if (name[2] == 'i' &&
8460 case 6: /* 33 tokens of length 6 */
8464 if (name[1] == 'c' &&
8479 if (name[2] == 'l' &&
8490 if (name[2] == 'r' &&
8505 if (name[1] == 'e' &&
8520 if (name[2] == 's' &&
8525 if(ckWARN_d(WARN_SYNTAX))
8526 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8532 if (name[2] == 'i' &&
8550 if (name[2] == 'l' &&
8561 if (name[2] == 'r' &&
8576 if (name[1] == 'm' &&
8591 if (name[2] == 'n' &&
8602 if (name[2] == 's' &&
8617 if (name[1] == 's' &&
8623 if (name[4] == 't' &&
8632 if (name[4] == 'e' &&
8641 if (name[4] == 'c' &&
8650 if (name[4] == 'n' &&
8666 if (name[1] == 'r' &&
8684 if (name[3] == 'a' &&
8694 if (name[3] == 'u' &&
8708 if (name[2] == 'n' &&
8726 if (name[2] == 'a' &&
8740 if (name[3] == 'e' &&
8753 if (name[4] == 't' &&
8762 if (name[4] == 'e' &&
8784 if (name[4] == 't' &&
8793 if (name[4] == 'e' &&
8809 if (name[2] == 'c' &&
8820 if (name[2] == 'l' &&
8831 if (name[2] == 'b' &&
8842 if (name[2] == 's' &&
8865 if (name[4] == 's' &&
8874 if (name[4] == 'n' &&
8887 if (name[3] == 'a' &&
8904 if (name[1] == 'a' &&
8919 case 7: /* 29 tokens of length 7 */
8923 if (name[1] == 'E' &&
8936 if (name[1] == '_' &&
8949 if (name[1] == 'i' &&
8956 return -KEY_binmode;
8962 if (name[1] == 'o' &&
8969 return -KEY_connect;
8978 if (name[2] == 'm' &&
8984 return -KEY_dbmopen;
8995 if (name[4] == 'u' &&
8999 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9005 if (name[4] == 'n' &&
9026 if (name[1] == 'o' &&
9039 if (name[1] == 'e' &&
9046 if (name[5] == 'r' &&
9049 return -KEY_getpgrp;
9055 if (name[5] == 'i' &&
9058 return -KEY_getppid;
9071 if (name[1] == 'c' &&
9078 return -KEY_lcfirst;
9084 if (name[1] == 'p' &&
9091 return -KEY_opendir;
9097 if (name[1] == 'a' &&
9115 if (name[3] == 'd' &&
9120 return -KEY_readdir;
9126 if (name[3] == 'u' &&
9137 if (name[3] == 'e' &&
9142 return -KEY_reverse;
9161 if (name[3] == 'k' &&
9166 return -KEY_seekdir;
9172 if (name[3] == 'p' &&
9177 return -KEY_setpgrp;
9187 if (name[2] == 'm' &&
9193 return -KEY_shmread;
9199 if (name[2] == 'r' &&
9205 return -KEY_sprintf;
9214 if (name[3] == 'l' &&
9219 return -KEY_symlink;
9228 if (name[4] == 'a' &&
9232 return -KEY_syscall;
9238 if (name[4] == 'p' &&
9242 return -KEY_sysopen;
9248 if (name[4] == 'e' &&
9252 return -KEY_sysread;
9258 if (name[4] == 'e' &&
9262 return -KEY_sysseek;
9280 if (name[1] == 'e' &&
9287 return -KEY_telldir;
9296 if (name[2] == 'f' &&
9302 return -KEY_ucfirst;
9308 if (name[2] == 's' &&
9314 return -KEY_unshift;
9324 if (name[1] == 'a' &&
9331 return -KEY_waitpid;
9340 case 8: /* 26 tokens of length 8 */
9344 if (name[1] == 'U' &&
9352 return KEY_AUTOLOAD;
9363 if (name[3] == 'A' &&
9369 return KEY___DATA__;
9375 if (name[3] == 'I' &&
9381 return -KEY___FILE__;
9387 if (name[3] == 'I' &&
9393 return -KEY___LINE__;
9409 if (name[2] == 'o' &&
9416 return -KEY_closedir;
9422 if (name[2] == 'n' &&
9429 return -KEY_continue;
9439 if (name[1] == 'b' &&
9447 return -KEY_dbmclose;
9453 if (name[1] == 'n' &&
9459 if (name[4] == 'r' &&
9464 return -KEY_endgrent;
9470 if (name[4] == 'w' &&
9475 return -KEY_endpwent;
9488 if (name[1] == 'o' &&
9496 return -KEY_formline;
9502 if (name[1] == 'e' &&
9513 if (name[6] == 'n' &&
9516 return -KEY_getgrent;
9522 if (name[6] == 'i' &&
9525 return -KEY_getgrgid;
9531 if (name[6] == 'a' &&
9534 return -KEY_getgrnam;
9547 if (name[4] == 'o' &&
9552 return -KEY_getlogin;
9563 if (name[6] == 'n' &&
9566 return -KEY_getpwent;
9572 if (name[6] == 'a' &&
9575 return -KEY_getpwnam;
9581 if (name[6] == 'i' &&
9584 return -KEY_getpwuid;
9604 if (name[1] == 'e' &&
9611 if (name[5] == 'i' &&
9618 return -KEY_readline;
9623 return -KEY_readlink;
9634 if (name[5] == 'i' &&
9638 return -KEY_readpipe;
9659 if (name[4] == 'r' &&
9664 return -KEY_setgrent;
9670 if (name[4] == 'w' &&
9675 return -KEY_setpwent;
9691 if (name[3] == 'w' &&
9697 return -KEY_shmwrite;
9703 if (name[3] == 't' &&
9709 return -KEY_shutdown;
9719 if (name[2] == 's' &&
9726 return -KEY_syswrite;
9736 if (name[1] == 'r' &&
9744 return -KEY_truncate;
9753 case 9: /* 9 tokens of length 9 */
9757 if (name[1] == 'N' &&
9766 return KEY_UNITCHECK;
9772 if (name[1] == 'n' &&
9781 return -KEY_endnetent;
9787 if (name[1] == 'e' &&
9796 return -KEY_getnetent;
9802 if (name[1] == 'o' &&
9811 return -KEY_localtime;
9817 if (name[1] == 'r' &&
9826 return KEY_prototype;
9832 if (name[1] == 'u' &&
9841 return -KEY_quotemeta;
9847 if (name[1] == 'e' &&
9856 return -KEY_rewinddir;
9862 if (name[1] == 'e' &&
9871 return -KEY_setnetent;
9877 if (name[1] == 'a' &&
9886 return -KEY_wantarray;
9895 case 10: /* 9 tokens of length 10 */
9899 if (name[1] == 'n' &&
9905 if (name[4] == 'o' &&
9912 return -KEY_endhostent;
9918 if (name[4] == 'e' &&
9925 return -KEY_endservent;
9938 if (name[1] == 'e' &&
9944 if (name[4] == 'o' &&
9951 return -KEY_gethostent;
9960 if (name[5] == 'r' &&
9966 return -KEY_getservent;
9972 if (name[5] == 'c' &&
9978 return -KEY_getsockopt;
10003 if (name[4] == 'o' &&
10010 return -KEY_sethostent;
10019 if (name[5] == 'r' &&
10025 return -KEY_setservent;
10031 if (name[5] == 'c' &&
10037 return -KEY_setsockopt;
10054 if (name[2] == 'c' &&
10063 return -KEY_socketpair;
10076 case 11: /* 8 tokens of length 11 */
10080 if (name[1] == '_' &&
10090 { /* __PACKAGE__ */
10091 return -KEY___PACKAGE__;
10097 if (name[1] == 'n' &&
10107 { /* endprotoent */
10108 return -KEY_endprotoent;
10114 if (name[1] == 'e' &&
10123 if (name[5] == 'e' &&
10129 { /* getpeername */
10130 return -KEY_getpeername;
10139 if (name[6] == 'o' &&
10144 { /* getpriority */
10145 return -KEY_getpriority;
10151 if (name[6] == 't' &&
10156 { /* getprotoent */
10157 return -KEY_getprotoent;
10171 if (name[4] == 'o' &&
10178 { /* getsockname */
10179 return -KEY_getsockname;
10192 if (name[1] == 'e' &&
10200 if (name[6] == 'o' &&
10205 { /* setpriority */
10206 return -KEY_setpriority;
10212 if (name[6] == 't' &&
10217 { /* setprotoent */
10218 return -KEY_setprotoent;
10234 case 12: /* 2 tokens of length 12 */
10235 if (name[0] == 'g' &&
10247 if (name[9] == 'd' &&
10250 { /* getnetbyaddr */
10251 return -KEY_getnetbyaddr;
10257 if (name[9] == 'a' &&
10260 { /* getnetbyname */
10261 return -KEY_getnetbyname;
10273 case 13: /* 4 tokens of length 13 */
10274 if (name[0] == 'g' &&
10281 if (name[4] == 'o' &&
10290 if (name[10] == 'd' &&
10293 { /* gethostbyaddr */
10294 return -KEY_gethostbyaddr;
10300 if (name[10] == 'a' &&
10303 { /* gethostbyname */
10304 return -KEY_gethostbyname;
10317 if (name[4] == 'e' &&
10326 if (name[10] == 'a' &&
10329 { /* getservbyname */
10330 return -KEY_getservbyname;
10336 if (name[10] == 'o' &&
10339 { /* getservbyport */
10340 return -KEY_getservbyport;
10359 case 14: /* 1 tokens of length 14 */
10360 if (name[0] == 'g' &&
10374 { /* getprotobyname */
10375 return -KEY_getprotobyname;
10380 case 16: /* 1 tokens of length 16 */
10381 if (name[0] == 'g' &&
10397 { /* getprotobynumber */
10398 return -KEY_getprotobynumber;
10412 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10416 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10417 if (ckWARN(WARN_SYNTAX)) {
10420 for (w = s+2; *w && level; w++) {
10423 else if (*w == ')')
10426 while (isSPACE(*w))
10428 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
10429 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10430 "%s (...) interpreted as function",name);
10433 while (s < PL_bufend && isSPACE(*s))
10437 while (s < PL_bufend && isSPACE(*s))
10439 if (isIDFIRST_lazy_if(s,UTF)) {
10440 const char * const w = s++;
10441 while (isALNUM_lazy_if(s,UTF))
10443 while (s < PL_bufend && isSPACE(*s))
10447 if (keyword(w, s - w, 0))
10450 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10451 if (gv && GvCVu(gv))
10453 Perl_croak(aTHX_ "No comma allowed after %s", what);
10458 /* Either returns sv, or mortalizes sv and returns a new SV*.
10459 Best used as sv=new_constant(..., sv, ...).
10460 If s, pv are NULL, calls subroutine with one argument,
10461 and type is used with error messages only. */
10464 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10468 HV * const table = GvHV(PL_hintgv); /* ^H */
10472 const char *why1 = "", *why2 = "", *why3 = "";
10474 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10477 why2 = (const char *)
10478 (strEQ(key,"charnames")
10479 ? "(possibly a missing \"use charnames ...\")"
10481 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10482 (type ? type: "undef"), why2);
10484 /* This is convoluted and evil ("goto considered harmful")
10485 * but I do not understand the intricacies of all the different
10486 * failure modes of %^H in here. The goal here is to make
10487 * the most probable error message user-friendly. --jhi */
10492 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10493 (type ? type: "undef"), why1, why2, why3);
10495 yyerror(SvPVX_const(msg));
10499 cvp = hv_fetch(table, key, strlen(key), FALSE);
10500 if (!cvp || !SvOK(*cvp)) {
10503 why3 = "} is not defined";
10506 sv_2mortal(sv); /* Parent created it permanently */
10509 pv = sv_2mortal(newSVpvn(s, len));
10511 typesv = sv_2mortal(newSVpv(type, 0));
10513 typesv = &PL_sv_undef;
10515 PUSHSTACKi(PERLSI_OVERLOAD);
10527 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10531 /* Check the eval first */
10532 if (!PL_in_eval && SvTRUE(ERRSV)) {
10533 sv_catpvs(ERRSV, "Propagated");
10534 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10536 res = SvREFCNT_inc_simple(sv);
10540 SvREFCNT_inc_simple_void(res);
10549 why1 = "Call to &{$^H{";
10551 why3 = "}} did not return a defined value";
10559 /* Returns a NUL terminated string, with the length of the string written to
10563 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10566 register char *d = dest;
10567 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10570 Perl_croak(aTHX_ ident_too_long);
10571 if (isALNUM(*s)) /* UTF handled below */
10573 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10578 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10582 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10583 char *t = s + UTF8SKIP(s);
10585 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10589 Perl_croak(aTHX_ ident_too_long);
10590 Copy(s, d, len, char);
10603 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10606 char *bracket = NULL;
10608 register char *d = dest;
10609 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10614 while (isDIGIT(*s)) {
10616 Perl_croak(aTHX_ ident_too_long);
10623 Perl_croak(aTHX_ ident_too_long);
10624 if (isALNUM(*s)) /* UTF handled below */
10626 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10631 else if (*s == ':' && s[1] == ':') {
10635 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10636 char *t = s + UTF8SKIP(s);
10637 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10639 if (d + (t - s) > e)
10640 Perl_croak(aTHX_ ident_too_long);
10641 Copy(s, d, t - s, char);
10652 if (PL_lex_state != LEX_NORMAL)
10653 PL_lex_state = LEX_INTERPENDMAYBE;
10656 if (*s == '$' && s[1] &&
10657 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10670 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10675 if (isSPACE(s[-1])) {
10677 const char ch = *s++;
10678 if (!SPACE_OR_TAB(ch)) {
10684 if (isIDFIRST_lazy_if(d,UTF)) {
10688 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10689 end += UTF8SKIP(end);
10690 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10691 end += UTF8SKIP(end);
10693 Copy(s, d, end - s, char);
10698 while ((isALNUM(*s) || *s == ':') && d < e)
10701 Perl_croak(aTHX_ ident_too_long);
10704 while (s < send && SPACE_OR_TAB(*s))
10706 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10707 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10708 const char * const brack =
10710 ((*s == '[') ? "[...]" : "{...}");
10711 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10712 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10713 funny, dest, brack, funny, dest, brack);
10716 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10720 /* Handle extended ${^Foo} variables
10721 * 1999-02-27 mjd-perl-patch@plover.com */
10722 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10726 while (isALNUM(*s) && d < e) {
10730 Perl_croak(aTHX_ ident_too_long);
10735 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10736 PL_lex_state = LEX_INTERPEND;
10739 if (PL_lex_state == LEX_NORMAL) {
10740 if (ckWARN(WARN_AMBIGUOUS) &&
10741 (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
10745 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10746 "Ambiguous use of %c{%s} resolved to %c%s",
10747 funny, dest, funny, dest);
10752 s = bracket; /* let the parser handle it */
10756 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10757 PL_lex_state = LEX_INTERPEND;
10762 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10764 PERL_UNUSED_CONTEXT;
10767 else if (ch == 'g')
10768 *pmfl |= PMf_GLOBAL;
10769 else if (ch == 'c')
10770 *pmfl |= PMf_CONTINUE;
10771 else if (ch == 'o')
10773 else if (ch == 'm')
10774 *pmfl |= PMf_MULTILINE;
10775 else if (ch == 's')
10776 *pmfl |= PMf_SINGLELINE;
10777 else if (ch == 'x')
10778 *pmfl |= PMf_EXTENDED;
10782 S_scan_pat(pTHX_ char *start, I32 type)
10786 char *s = scan_str(start,!!PL_madskills,FALSE);
10787 const char * const valid_flags =
10788 (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
10795 const char * const delimiter = skipspace(start);
10799 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10800 : "Search pattern not terminated" ));
10803 pm = (PMOP*)newPMOP(type, 0);
10804 if (PL_multi_open == '?')
10805 pm->op_pmflags |= PMf_ONCE;
10809 while (*s && strchr(valid_flags, *s))
10810 pmflag(&pm->op_pmflags,*s++);
10812 if (PL_madskills && modstart != s) {
10813 SV* tmptoken = newSVpvn(modstart, s - modstart);
10814 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10817 /* issue a warning if /c is specified,but /g is not */
10818 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10819 && ckWARN(WARN_REGEXP))
10821 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
10824 pm->op_pmpermflags = pm->op_pmflags;
10826 PL_lex_op = (OP*)pm;
10827 yylval.ival = OP_MATCH;
10832 S_scan_subst(pTHX_ char *start)
10843 yylval.ival = OP_NULL;
10845 s = scan_str(start,!!PL_madskills,FALSE);
10848 Perl_croak(aTHX_ "Substitution pattern not terminated");
10850 if (s[-1] == PL_multi_open)
10853 if (PL_madskills) {
10854 CURMAD('q', PL_thisopen);
10855 CURMAD('_', PL_thiswhite);
10856 CURMAD('E', PL_thisstuff);
10857 CURMAD('Q', PL_thisclose);
10858 PL_realtokenstart = s - SvPVX(PL_linestr);
10862 first_start = PL_multi_start;
10863 s = scan_str(s,!!PL_madskills,FALSE);
10865 if (PL_lex_stuff) {
10866 SvREFCNT_dec(PL_lex_stuff);
10867 PL_lex_stuff = NULL;
10869 Perl_croak(aTHX_ "Substitution replacement not terminated");
10871 PL_multi_start = first_start; /* so whole substitution is taken together */
10873 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10876 if (PL_madskills) {
10877 CURMAD('z', PL_thisopen);
10878 CURMAD('R', PL_thisstuff);
10879 CURMAD('Z', PL_thisclose);
10889 else if (strchr("iogcmsx", *s))
10890 pmflag(&pm->op_pmflags,*s++);
10896 if (PL_madskills) {
10898 curmad('m', newSVpvn(modstart, s - modstart));
10899 append_madprops(PL_thismad, (OP*)pm, 0);
10903 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10904 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10908 SV * const repl = newSVpvs("");
10910 PL_sublex_info.super_bufptr = s;
10911 PL_sublex_info.super_bufend = PL_bufend;
10913 pm->op_pmflags |= PMf_EVAL;
10915 sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10916 sv_catpvs(repl, "{");
10917 sv_catsv(repl, PL_lex_repl);
10918 if (strchr(SvPVX(PL_lex_repl), '#'))
10919 sv_catpvs(repl, "\n");
10920 sv_catpvs(repl, "}");
10922 SvREFCNT_dec(PL_lex_repl);
10923 PL_lex_repl = repl;
10926 pm->op_pmpermflags = pm->op_pmflags;
10927 PL_lex_op = (OP*)pm;
10928 yylval.ival = OP_SUBST;
10933 S_scan_trans(pTHX_ char *start)
10946 yylval.ival = OP_NULL;
10948 s = scan_str(start,!!PL_madskills,FALSE);
10950 Perl_croak(aTHX_ "Transliteration pattern not terminated");
10952 if (s[-1] == PL_multi_open)
10955 if (PL_madskills) {
10956 CURMAD('q', PL_thisopen);
10957 CURMAD('_', PL_thiswhite);
10958 CURMAD('E', PL_thisstuff);
10959 CURMAD('Q', PL_thisclose);
10960 PL_realtokenstart = s - SvPVX(PL_linestr);
10964 s = scan_str(s,!!PL_madskills,FALSE);
10966 if (PL_lex_stuff) {
10967 SvREFCNT_dec(PL_lex_stuff);
10968 PL_lex_stuff = NULL;
10970 Perl_croak(aTHX_ "Transliteration replacement not terminated");
10972 if (PL_madskills) {
10973 CURMAD('z', PL_thisopen);
10974 CURMAD('R', PL_thisstuff);
10975 CURMAD('Z', PL_thisclose);
10978 complement = del = squash = 0;
10985 complement = OPpTRANS_COMPLEMENT;
10988 del = OPpTRANS_DELETE;
10991 squash = OPpTRANS_SQUASH;
11000 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11001 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11002 o->op_private &= ~OPpTRANS_ALL;
11003 o->op_private |= del|squash|complement|
11004 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11005 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11008 yylval.ival = OP_TRANS;
11011 if (PL_madskills) {
11013 curmad('m', newSVpvn(modstart, s - modstart));
11014 append_madprops(PL_thismad, o, 0);
11023 S_scan_heredoc(pTHX_ register char *s)
11027 I32 op_type = OP_SCALAR;
11031 const char *found_newline;
11035 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11037 I32 stuffstart = s - SvPVX(PL_linestr);
11040 PL_realtokenstart = -1;
11045 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11049 while (SPACE_OR_TAB(*peek))
11051 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11054 s = delimcpy(d, e, s, PL_bufend, term, &len);
11064 if (!isALNUM_lazy_if(s,UTF))
11065 deprecate_old("bare << to mean <<\"\"");
11066 for (; isALNUM_lazy_if(s,UTF); s++) {
11071 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11072 Perl_croak(aTHX_ "Delimiter for here document is too long");
11075 len = d - PL_tokenbuf;
11078 if (PL_madskills) {
11079 tstart = PL_tokenbuf + !outer;
11080 PL_thisclose = newSVpvn(tstart, len - !outer);
11081 tstart = SvPVX(PL_linestr) + stuffstart;
11082 PL_thisopen = newSVpvn(tstart, s - tstart);
11083 stuffstart = s - SvPVX(PL_linestr);
11086 #ifndef PERL_STRICT_CR
11087 d = strchr(s, '\r');
11089 char * const olds = s;
11091 while (s < PL_bufend) {
11097 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11106 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11113 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11114 herewas = newSVpvn(s,PL_bufend-s);
11118 herewas = newSVpvn(s-1,found_newline-s+1);
11121 herewas = newSVpvn(s,found_newline-s);
11125 if (PL_madskills) {
11126 tstart = SvPVX(PL_linestr) + stuffstart;
11128 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11130 PL_thisstuff = newSVpvn(tstart, s - tstart);
11133 s += SvCUR(herewas);
11136 stuffstart = s - SvPVX(PL_linestr);
11142 tmpstr = newSV(79);
11143 sv_upgrade(tmpstr, SVt_PVIV);
11144 if (term == '\'') {
11145 op_type = OP_CONST;
11146 SvIV_set(tmpstr, -1);
11148 else if (term == '`') {
11149 op_type = OP_BACKTICK;
11150 SvIV_set(tmpstr, '\\');
11154 PL_multi_start = CopLINE(PL_curcop);
11155 PL_multi_open = PL_multi_close = '<';
11156 term = *PL_tokenbuf;
11157 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11158 char * const bufptr = PL_sublex_info.super_bufptr;
11159 char * const bufend = PL_sublex_info.super_bufend;
11160 char * const olds = s - SvCUR(herewas);
11161 s = strchr(bufptr, '\n');
11165 while (s < bufend &&
11166 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11168 CopLINE_inc(PL_curcop);
11171 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11172 missingterm(PL_tokenbuf);
11174 sv_setpvn(herewas,bufptr,d-bufptr+1);
11175 sv_setpvn(tmpstr,d+1,s-d);
11177 sv_catpvn(herewas,s,bufend-s);
11178 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11185 while (s < PL_bufend &&
11186 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11188 CopLINE_inc(PL_curcop);
11190 if (s >= PL_bufend) {
11191 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11192 missingterm(PL_tokenbuf);
11194 sv_setpvn(tmpstr,d+1,s-d);
11196 if (PL_madskills) {
11198 sv_catpvn(PL_thisstuff, d + 1, s - d);
11200 PL_thisstuff = newSVpvn(d + 1, s - d);
11201 stuffstart = s - SvPVX(PL_linestr);
11205 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11207 sv_catpvn(herewas,s,PL_bufend-s);
11208 sv_setsv(PL_linestr,herewas);
11209 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11210 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11211 PL_last_lop = PL_last_uni = NULL;
11214 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
11215 while (s >= PL_bufend) { /* multiple line string? */
11217 if (PL_madskills) {
11218 tstart = SvPVX(PL_linestr) + stuffstart;
11220 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11222 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11226 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11227 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11228 missingterm(PL_tokenbuf);
11231 stuffstart = s - SvPVX(PL_linestr);
11233 CopLINE_inc(PL_curcop);
11234 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11235 PL_last_lop = PL_last_uni = NULL;
11236 #ifndef PERL_STRICT_CR
11237 if (PL_bufend - PL_linestart >= 2) {
11238 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11239 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11241 PL_bufend[-2] = '\n';
11243 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11245 else if (PL_bufend[-1] == '\r')
11246 PL_bufend[-1] = '\n';
11248 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11249 PL_bufend[-1] = '\n';
11251 if (PERLDB_LINE && PL_curstash != PL_debstash)
11252 update_debugger_info(PL_linestr, NULL, 0);
11253 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11254 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11255 *(SvPVX(PL_linestr) + off ) = ' ';
11256 sv_catsv(PL_linestr,herewas);
11257 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11258 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11262 sv_catsv(tmpstr,PL_linestr);
11267 PL_multi_end = CopLINE(PL_curcop);
11268 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11269 SvPV_shrink_to_cur(tmpstr);
11271 SvREFCNT_dec(herewas);
11273 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11275 else if (PL_encoding)
11276 sv_recode_to_utf8(tmpstr, PL_encoding);
11278 PL_lex_stuff = tmpstr;
11279 yylval.ival = op_type;
11283 /* scan_inputsymbol
11284 takes: current position in input buffer
11285 returns: new position in input buffer
11286 side-effects: yylval and lex_op are set.
11291 <FH> read from filehandle
11292 <pkg::FH> read from package qualified filehandle
11293 <pkg'FH> read from package qualified filehandle
11294 <$fh> read from filehandle in $fh
11295 <*.h> filename glob
11300 S_scan_inputsymbol(pTHX_ char *start)
11303 register char *s = start; /* current position in buffer */
11307 char *d = PL_tokenbuf; /* start of temp holding space */
11308 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11310 end = strchr(s, '\n');
11313 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11315 /* die if we didn't have space for the contents of the <>,
11316 or if it didn't end, or if we see a newline
11319 if (len >= (I32)sizeof PL_tokenbuf)
11320 Perl_croak(aTHX_ "Excessively long <> operator");
11322 Perl_croak(aTHX_ "Unterminated <> operator");
11327 Remember, only scalar variables are interpreted as filehandles by
11328 this code. Anything more complex (e.g., <$fh{$num}>) will be
11329 treated as a glob() call.
11330 This code makes use of the fact that except for the $ at the front,
11331 a scalar variable and a filehandle look the same.
11333 if (*d == '$' && d[1]) d++;
11335 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11336 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11339 /* If we've tried to read what we allow filehandles to look like, and
11340 there's still text left, then it must be a glob() and not a getline.
11341 Use scan_str to pull out the stuff between the <> and treat it
11342 as nothing more than a string.
11345 if (d - PL_tokenbuf != len) {
11346 yylval.ival = OP_GLOB;
11348 s = scan_str(start,!!PL_madskills,FALSE);
11350 Perl_croak(aTHX_ "Glob not terminated");
11354 bool readline_overriden = FALSE;
11357 /* we're in a filehandle read situation */
11360 /* turn <> into <ARGV> */
11362 Copy("ARGV",d,5,char);
11364 /* Check whether readline() is overriden */
11365 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11367 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11369 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11370 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
11371 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11372 readline_overriden = TRUE;
11374 /* if <$fh>, create the ops to turn the variable into a
11378 /* try to find it in the pad for this block, otherwise find
11379 add symbol table ops
11381 const PADOFFSET tmp = pad_findmy(d);
11382 if (tmp != NOT_IN_PAD) {
11383 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11384 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11385 HEK * const stashname = HvNAME_HEK(stash);
11386 SV * const sym = sv_2mortal(newSVhek(stashname));
11387 sv_catpvs(sym, "::");
11388 sv_catpv(sym, d+1);
11393 OP * const o = newOP(OP_PADSV, 0);
11395 PL_lex_op = readline_overriden
11396 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11397 append_elem(OP_LIST, o,
11398 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11399 : (OP*)newUNOP(OP_READLINE, 0, o);
11408 ? (GV_ADDMULTI | GV_ADDINEVAL)
11411 PL_lex_op = readline_overriden
11412 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11413 append_elem(OP_LIST,
11414 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11415 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11416 : (OP*)newUNOP(OP_READLINE, 0,
11417 newUNOP(OP_RV2SV, 0,
11418 newGVOP(OP_GV, 0, gv)));
11420 if (!readline_overriden)
11421 PL_lex_op->op_flags |= OPf_SPECIAL;
11422 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11423 yylval.ival = OP_NULL;
11426 /* If it's none of the above, it must be a literal filehandle
11427 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11429 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11430 PL_lex_op = readline_overriden
11431 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11432 append_elem(OP_LIST,
11433 newGVOP(OP_GV, 0, gv),
11434 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11435 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11436 yylval.ival = OP_NULL;
11445 takes: start position in buffer
11446 keep_quoted preserve \ on the embedded delimiter(s)
11447 keep_delims preserve the delimiters around the string
11448 returns: position to continue reading from buffer
11449 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11450 updates the read buffer.
11452 This subroutine pulls a string out of the input. It is called for:
11453 q single quotes q(literal text)
11454 ' single quotes 'literal text'
11455 qq double quotes qq(interpolate $here please)
11456 " double quotes "interpolate $here please"
11457 qx backticks qx(/bin/ls -l)
11458 ` backticks `/bin/ls -l`
11459 qw quote words @EXPORT_OK = qw( func() $spam )
11460 m// regexp match m/this/
11461 s/// regexp substitute s/this/that/
11462 tr/// string transliterate tr/this/that/
11463 y/// string transliterate y/this/that/
11464 ($*@) sub prototypes sub foo ($)
11465 (stuff) sub attr parameters sub foo : attr(stuff)
11466 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11468 In most of these cases (all but <>, patterns and transliterate)
11469 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11470 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11471 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11474 It skips whitespace before the string starts, and treats the first
11475 character as the delimiter. If the delimiter is one of ([{< then
11476 the corresponding "close" character )]}> is used as the closing
11477 delimiter. It allows quoting of delimiters, and if the string has
11478 balanced delimiters ([{<>}]) it allows nesting.
11480 On success, the SV with the resulting string is put into lex_stuff or,
11481 if that is already non-NULL, into lex_repl. The second case occurs only
11482 when parsing the RHS of the special constructs s/// and tr/// (y///).
11483 For convenience, the terminating delimiter character is stuffed into
11488 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11491 SV *sv; /* scalar value: string */
11492 const char *tmps; /* temp string, used for delimiter matching */
11493 register char *s = start; /* current position in the buffer */
11494 register char term; /* terminating character */
11495 register char *to; /* current position in the sv's data */
11496 I32 brackets = 1; /* bracket nesting level */
11497 bool has_utf8 = FALSE; /* is there any utf8 content? */
11498 I32 termcode; /* terminating char. code */
11499 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11500 STRLEN termlen; /* length of terminating string */
11501 int last_off = 0; /* last position for nesting bracket */
11507 /* skip space before the delimiter */
11513 if (PL_realtokenstart >= 0) {
11514 stuffstart = PL_realtokenstart;
11515 PL_realtokenstart = -1;
11518 stuffstart = start - SvPVX(PL_linestr);
11520 /* mark where we are, in case we need to report errors */
11523 /* after skipping whitespace, the next character is the terminator */
11526 termcode = termstr[0] = term;
11530 termcode = utf8_to_uvchr((U8*)s, &termlen);
11531 Copy(s, termstr, termlen, U8);
11532 if (!UTF8_IS_INVARIANT(term))
11536 /* mark where we are */
11537 PL_multi_start = CopLINE(PL_curcop);
11538 PL_multi_open = term;
11540 /* find corresponding closing delimiter */
11541 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11542 termcode = termstr[0] = term = tmps[5];
11544 PL_multi_close = term;
11546 /* create a new SV to hold the contents. 79 is the SV's initial length.
11547 What a random number. */
11549 sv_upgrade(sv, SVt_PVIV);
11550 SvIV_set(sv, termcode);
11551 (void)SvPOK_only(sv); /* validate pointer */
11553 /* move past delimiter and try to read a complete string */
11555 sv_catpvn(sv, s, termlen);
11558 tstart = SvPVX(PL_linestr) + stuffstart;
11559 if (!PL_thisopen && !keep_delims) {
11560 PL_thisopen = newSVpvn(tstart, s - tstart);
11561 stuffstart = s - SvPVX(PL_linestr);
11565 if (PL_encoding && !UTF) {
11569 int offset = s - SvPVX_const(PL_linestr);
11570 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11571 &offset, (char*)termstr, termlen);
11572 const char * const ns = SvPVX_const(PL_linestr) + offset;
11573 char * const svlast = SvEND(sv) - 1;
11575 for (; s < ns; s++) {
11576 if (*s == '\n' && !PL_rsfp)
11577 CopLINE_inc(PL_curcop);
11580 goto read_more_line;
11582 /* handle quoted delimiters */
11583 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11585 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11587 if ((svlast-1 - t) % 2) {
11588 if (!keep_quoted) {
11589 *(svlast-1) = term;
11591 SvCUR_set(sv, SvCUR(sv) - 1);
11596 if (PL_multi_open == PL_multi_close) {
11602 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11603 /* At here, all closes are "was quoted" one,
11604 so we don't check PL_multi_close. */
11606 if (!keep_quoted && *(t+1) == PL_multi_open)
11611 else if (*t == PL_multi_open)
11619 SvCUR_set(sv, w - SvPVX_const(sv));
11621 last_off = w - SvPVX(sv);
11622 if (--brackets <= 0)
11627 if (!keep_delims) {
11628 SvCUR_set(sv, SvCUR(sv) - 1);
11634 /* extend sv if need be */
11635 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11636 /* set 'to' to the next character in the sv's string */
11637 to = SvPVX(sv)+SvCUR(sv);
11639 /* if open delimiter is the close delimiter read unbridle */
11640 if (PL_multi_open == PL_multi_close) {
11641 for (; s < PL_bufend; s++,to++) {
11642 /* embedded newlines increment the current line number */
11643 if (*s == '\n' && !PL_rsfp)
11644 CopLINE_inc(PL_curcop);
11645 /* handle quoted delimiters */
11646 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11647 if (!keep_quoted && s[1] == term)
11649 /* any other quotes are simply copied straight through */
11653 /* terminate when run out of buffer (the for() condition), or
11654 have found the terminator */
11655 else if (*s == term) {
11658 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11661 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11667 /* if the terminator isn't the same as the start character (e.g.,
11668 matched brackets), we have to allow more in the quoting, and
11669 be prepared for nested brackets.
11672 /* read until we run out of string, or we find the terminator */
11673 for (; s < PL_bufend; s++,to++) {
11674 /* embedded newlines increment the line count */
11675 if (*s == '\n' && !PL_rsfp)
11676 CopLINE_inc(PL_curcop);
11677 /* backslashes can escape the open or closing characters */
11678 if (*s == '\\' && s+1 < PL_bufend) {
11679 if (!keep_quoted &&
11680 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11685 /* allow nested opens and closes */
11686 else if (*s == PL_multi_close && --brackets <= 0)
11688 else if (*s == PL_multi_open)
11690 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11695 /* terminate the copied string and update the sv's end-of-string */
11697 SvCUR_set(sv, to - SvPVX_const(sv));
11700 * this next chunk reads more into the buffer if we're not done yet
11704 break; /* handle case where we are done yet :-) */
11706 #ifndef PERL_STRICT_CR
11707 if (to - SvPVX_const(sv) >= 2) {
11708 if ((to[-2] == '\r' && to[-1] == '\n') ||
11709 (to[-2] == '\n' && to[-1] == '\r'))
11713 SvCUR_set(sv, to - SvPVX_const(sv));
11715 else if (to[-1] == '\r')
11718 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11723 /* if we're out of file, or a read fails, bail and reset the current
11724 line marker so we can report where the unterminated string began
11727 if (PL_madskills) {
11728 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11730 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11732 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11736 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11738 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11744 /* we read a line, so increment our line counter */
11745 CopLINE_inc(PL_curcop);
11747 /* update debugger info */
11748 if (PERLDB_LINE && PL_curstash != PL_debstash)
11749 update_debugger_info(PL_linestr, NULL, 0);
11751 /* having changed the buffer, we must update PL_bufend */
11752 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11753 PL_last_lop = PL_last_uni = NULL;
11756 /* at this point, we have successfully read the delimited string */
11758 if (!PL_encoding || UTF) {
11760 if (PL_madskills) {
11761 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11762 const int len = s - tstart;
11764 sv_catpvn(PL_thisstuff, tstart, len);
11766 PL_thisstuff = newSVpvn(tstart, len);
11767 if (!PL_thisclose && !keep_delims)
11768 PL_thisclose = newSVpvn(s,termlen);
11773 sv_catpvn(sv, s, termlen);
11778 if (PL_madskills) {
11779 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11780 const int len = s - tstart - termlen;
11782 sv_catpvn(PL_thisstuff, tstart, len);
11784 PL_thisstuff = newSVpvn(tstart, len);
11785 if (!PL_thisclose && !keep_delims)
11786 PL_thisclose = newSVpvn(s - termlen,termlen);
11790 if (has_utf8 || PL_encoding)
11793 PL_multi_end = CopLINE(PL_curcop);
11795 /* if we allocated too much space, give some back */
11796 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11797 SvLEN_set(sv, SvCUR(sv) + 1);
11798 SvPV_renew(sv, SvLEN(sv));
11801 /* decide whether this is the first or second quoted string we've read
11814 takes: pointer to position in buffer
11815 returns: pointer to new position in buffer
11816 side-effects: builds ops for the constant in yylval.op
11818 Read a number in any of the formats that Perl accepts:
11820 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11821 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11824 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11826 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11829 If it reads a number without a decimal point or an exponent, it will
11830 try converting the number to an integer and see if it can do so
11831 without loss of precision.
11835 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11838 register const char *s = start; /* current position in buffer */
11839 register char *d; /* destination in temp buffer */
11840 register char *e; /* end of temp buffer */
11841 NV nv; /* number read, as a double */
11842 SV *sv = NULL; /* place to put the converted number */
11843 bool floatit; /* boolean: int or float? */
11844 const char *lastub = NULL; /* position of last underbar */
11845 static char const number_too_long[] = "Number too long";
11847 /* We use the first character to decide what type of number this is */
11851 Perl_croak(aTHX_ "panic: scan_num");
11853 /* if it starts with a 0, it could be an octal number, a decimal in
11854 0.13 disguise, or a hexadecimal number, or a binary number. */
11858 u holds the "number so far"
11859 shift the power of 2 of the base
11860 (hex == 4, octal == 3, binary == 1)
11861 overflowed was the number more than we can hold?
11863 Shift is used when we add a digit. It also serves as an "are
11864 we in octal/hex/binary?" indicator to disallow hex characters
11865 when in octal mode.
11870 bool overflowed = FALSE;
11871 bool just_zero = TRUE; /* just plain 0 or binary number? */
11872 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11873 static const char* const bases[5] =
11874 { "", "binary", "", "octal", "hexadecimal" };
11875 static const char* const Bases[5] =
11876 { "", "Binary", "", "Octal", "Hexadecimal" };
11877 static const char* const maxima[5] =
11879 "0b11111111111111111111111111111111",
11883 const char *base, *Base, *max;
11885 /* check for hex */
11890 } else if (s[1] == 'b') {
11895 /* check for a decimal in disguise */
11896 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11898 /* so it must be octal */
11905 if (ckWARN(WARN_SYNTAX))
11906 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11907 "Misplaced _ in number");
11911 base = bases[shift];
11912 Base = Bases[shift];
11913 max = maxima[shift];
11915 /* read the rest of the number */
11917 /* x is used in the overflow test,
11918 b is the digit we're adding on. */
11923 /* if we don't mention it, we're done */
11927 /* _ are ignored -- but warned about if consecutive */
11929 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11930 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11931 "Misplaced _ in number");
11935 /* 8 and 9 are not octal */
11936 case '8': case '9':
11938 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11942 case '2': case '3': case '4':
11943 case '5': case '6': case '7':
11945 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11948 case '0': case '1':
11949 b = *s++ & 15; /* ASCII digit -> value of digit */
11953 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11954 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11955 /* make sure they said 0x */
11958 b = (*s++ & 7) + 9;
11960 /* Prepare to put the digit we have onto the end
11961 of the number so far. We check for overflows.
11967 x = u << shift; /* make room for the digit */
11969 if ((x >> shift) != u
11970 && !(PL_hints & HINT_NEW_BINARY)) {
11973 if (ckWARN_d(WARN_OVERFLOW))
11974 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11975 "Integer overflow in %s number",
11978 u = x | b; /* add the digit to the end */
11981 n *= nvshift[shift];
11982 /* If an NV has not enough bits in its
11983 * mantissa to represent an UV this summing of
11984 * small low-order numbers is a waste of time
11985 * (because the NV cannot preserve the
11986 * low-order bits anyway): we could just
11987 * remember when did we overflow and in the
11988 * end just multiply n by the right
11996 /* if we get here, we had success: make a scalar value from
12001 /* final misplaced underbar check */
12002 if (s[-1] == '_') {
12003 if (ckWARN(WARN_SYNTAX))
12004 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12009 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12010 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12011 "%s number > %s non-portable",
12017 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12018 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12019 "%s number > %s non-portable",
12024 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12025 sv = new_constant(start, s - start, "integer",
12027 else if (PL_hints & HINT_NEW_BINARY)
12028 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
12033 handle decimal numbers.
12034 we're also sent here when we read a 0 as the first digit
12036 case '1': case '2': case '3': case '4': case '5':
12037 case '6': case '7': case '8': case '9': case '.':
12040 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12043 /* read next group of digits and _ and copy into d */
12044 while (isDIGIT(*s) || *s == '_') {
12045 /* skip underscores, checking for misplaced ones
12049 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12050 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12051 "Misplaced _ in number");
12055 /* check for end of fixed-length buffer */
12057 Perl_croak(aTHX_ number_too_long);
12058 /* if we're ok, copy the character */
12063 /* final misplaced underbar check */
12064 if (lastub && s == lastub + 1) {
12065 if (ckWARN(WARN_SYNTAX))
12066 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12069 /* read a decimal portion if there is one. avoid
12070 3..5 being interpreted as the number 3. followed
12073 if (*s == '.' && s[1] != '.') {
12078 if (ckWARN(WARN_SYNTAX))
12079 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12080 "Misplaced _ in number");
12084 /* copy, ignoring underbars, until we run out of digits.
12086 for (; isDIGIT(*s) || *s == '_'; s++) {
12087 /* fixed length buffer check */
12089 Perl_croak(aTHX_ number_too_long);
12091 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12092 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12093 "Misplaced _ in number");
12099 /* fractional part ending in underbar? */
12100 if (s[-1] == '_') {
12101 if (ckWARN(WARN_SYNTAX))
12102 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12103 "Misplaced _ in number");
12105 if (*s == '.' && isDIGIT(s[1])) {
12106 /* oops, it's really a v-string, but without the "v" */
12112 /* read exponent part, if present */
12113 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12117 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12118 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12120 /* stray preinitial _ */
12122 if (ckWARN(WARN_SYNTAX))
12123 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12124 "Misplaced _ in number");
12128 /* allow positive or negative exponent */
12129 if (*s == '+' || *s == '-')
12132 /* stray initial _ */
12134 if (ckWARN(WARN_SYNTAX))
12135 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12136 "Misplaced _ in number");
12140 /* read digits of exponent */
12141 while (isDIGIT(*s) || *s == '_') {
12144 Perl_croak(aTHX_ number_too_long);
12148 if (((lastub && s == lastub + 1) ||
12149 (!isDIGIT(s[1]) && s[1] != '_'))
12150 && ckWARN(WARN_SYNTAX))
12151 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12152 "Misplaced _ in number");
12159 /* make an sv from the string */
12163 We try to do an integer conversion first if no characters
12164 indicating "float" have been found.
12169 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12171 if (flags == IS_NUMBER_IN_UV) {
12173 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12176 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12177 if (uv <= (UV) IV_MIN)
12178 sv_setiv(sv, -(IV)uv);
12185 /* terminate the string */
12187 nv = Atof(PL_tokenbuf);
12191 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12192 (PL_hints & HINT_NEW_INTEGER) )
12193 sv = new_constant(PL_tokenbuf,
12196 (floatit ? "float" : "integer"),
12200 /* if it starts with a v, it could be a v-string */
12203 sv = newSV(5); /* preallocate storage space */
12204 s = scan_vstring(s,sv);
12208 /* make the op for the constant and return */
12211 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12213 lvalp->opval = NULL;
12219 S_scan_formline(pTHX_ register char *s)
12222 register char *eol;
12224 SV * const stuff = newSVpvs("");
12225 bool needargs = FALSE;
12226 bool eofmt = FALSE;
12228 char *tokenstart = s;
12231 if (PL_madskills) {
12232 savewhite = PL_thiswhite;
12237 while (!needargs) {
12240 #ifdef PERL_STRICT_CR
12241 while (SPACE_OR_TAB(*t))
12244 while (SPACE_OR_TAB(*t) || *t == '\r')
12247 if (*t == '\n' || t == PL_bufend) {
12252 if (PL_in_eval && !PL_rsfp) {
12253 eol = (char *) memchr(s,'\n',PL_bufend-s);
12258 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12260 for (t = s; t < eol; t++) {
12261 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12263 goto enough; /* ~~ must be first line in formline */
12265 if (*t == '@' || *t == '^')
12269 sv_catpvn(stuff, s, eol-s);
12270 #ifndef PERL_STRICT_CR
12271 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12272 char *end = SvPVX(stuff) + SvCUR(stuff);
12275 SvCUR_set(stuff, SvCUR(stuff) - 1);
12285 if (PL_madskills) {
12287 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12289 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12292 s = filter_gets(PL_linestr, PL_rsfp, 0);
12294 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12296 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12298 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12299 PL_last_lop = PL_last_uni = NULL;
12308 if (SvCUR(stuff)) {
12311 PL_lex_state = LEX_NORMAL;
12312 start_force(PL_curforce);
12313 NEXTVAL_NEXTTOKE.ival = 0;
12317 PL_lex_state = LEX_FORMLINE;
12319 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12321 else if (PL_encoding)
12322 sv_recode_to_utf8(stuff, PL_encoding);
12324 start_force(PL_curforce);
12325 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12327 start_force(PL_curforce);
12328 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12332 SvREFCNT_dec(stuff);
12334 PL_lex_formbrack = 0;
12338 if (PL_madskills) {
12340 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12342 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12343 PL_thiswhite = savewhite;
12355 PL_cshlen = strlen(PL_cshname);
12357 #if defined(USE_ITHREADS)
12358 PERL_UNUSED_CONTEXT;
12364 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12367 const I32 oldsavestack_ix = PL_savestack_ix;
12368 CV* const outsidecv = PL_compcv;
12371 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12373 SAVEI32(PL_subline);
12374 save_item(PL_subname);
12375 SAVESPTR(PL_compcv);
12377 PL_compcv = (CV*)newSV(0);
12378 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
12379 CvFLAGS(PL_compcv) |= flags;
12381 PL_subline = CopLINE(PL_curcop);
12382 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12383 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12384 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12386 return oldsavestack_ix;
12390 #pragma segment Perl_yylex
12393 Perl_yywarn(pTHX_ const char *s)
12396 PL_in_eval |= EVAL_WARNONLY;
12398 PL_in_eval &= ~EVAL_WARNONLY;
12403 Perl_yyerror(pTHX_ const char *s)
12406 const char *where = NULL;
12407 const char *context = NULL;
12410 int yychar = PL_parser->yychar;
12412 if (!yychar || (yychar == ';' && !PL_rsfp))
12414 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12415 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12416 PL_oldbufptr != PL_bufptr) {
12419 The code below is removed for NetWare because it abends/crashes on NetWare
12420 when the script has error such as not having the closing quotes like:
12421 if ($var eq "value)
12422 Checking of white spaces is anyway done in NetWare code.
12425 while (isSPACE(*PL_oldoldbufptr))
12428 context = PL_oldoldbufptr;
12429 contlen = PL_bufptr - PL_oldoldbufptr;
12431 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12432 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12435 The code below is removed for NetWare because it abends/crashes on NetWare
12436 when the script has error such as not having the closing quotes like:
12437 if ($var eq "value)
12438 Checking of white spaces is anyway done in NetWare code.
12441 while (isSPACE(*PL_oldbufptr))
12444 context = PL_oldbufptr;
12445 contlen = PL_bufptr - PL_oldbufptr;
12447 else if (yychar > 255)
12448 where = "next token ???";
12449 else if (yychar == -2) { /* YYEMPTY */
12450 if (PL_lex_state == LEX_NORMAL ||
12451 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12452 where = "at end of line";
12453 else if (PL_lex_inpat)
12454 where = "within pattern";
12456 where = "within string";
12459 SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12461 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12462 else if (isPRINT_LC(yychar))
12463 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12465 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12466 where = SvPVX_const(where_sv);
12468 msg = sv_2mortal(newSVpv(s, 0));
12469 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12470 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12472 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12474 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12475 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12476 Perl_sv_catpvf(aTHX_ msg,
12477 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12478 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12481 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12482 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12485 if (PL_error_count >= 10) {
12486 if (PL_in_eval && SvCUR(ERRSV))
12487 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12488 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12490 Perl_croak(aTHX_ "%s has too many errors.\n",
12491 OutCopFILE(PL_curcop));
12494 PL_in_my_stash = NULL;
12498 #pragma segment Main
12502 S_swallow_bom(pTHX_ U8 *s)
12505 const STRLEN slen = SvCUR(PL_linestr);
12508 if (s[1] == 0xFE) {
12509 /* UTF-16 little-endian? (or UTF32-LE?) */
12510 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12511 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12512 #ifndef PERL_NO_UTF16_FILTER
12513 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12516 if (PL_bufend > (char*)s) {
12520 filter_add(utf16rev_textfilter, NULL);
12521 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12522 utf16_to_utf8_reversed(s, news,
12523 PL_bufend - (char*)s - 1,
12525 sv_setpvn(PL_linestr, (const char*)news, newlen);
12527 s = (U8*)SvPVX(PL_linestr);
12528 Copy(news, s, newlen, U8);
12532 SvUTF8_on(PL_linestr);
12533 s = (U8*)SvPVX(PL_linestr);
12535 /* FIXME - is this a general bug fix? */
12538 PL_bufend = SvPVX(PL_linestr) + newlen;
12541 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12546 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12547 #ifndef PERL_NO_UTF16_FILTER
12548 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12551 if (PL_bufend > (char *)s) {
12555 filter_add(utf16_textfilter, NULL);
12556 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12557 utf16_to_utf8(s, news,
12558 PL_bufend - (char*)s,
12560 sv_setpvn(PL_linestr, (const char*)news, newlen);
12562 SvUTF8_on(PL_linestr);
12563 s = (U8*)SvPVX(PL_linestr);
12564 PL_bufend = SvPVX(PL_linestr) + newlen;
12567 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12572 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12573 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12574 s += 3; /* UTF-8 */
12580 if (s[2] == 0xFE && s[3] == 0xFF) {
12581 /* UTF-32 big-endian */
12582 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12585 else if (s[2] == 0 && s[3] != 0) {
12588 * are a good indicator of UTF-16BE. */
12589 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12595 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12596 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12597 s += 4; /* UTF-8 */
12603 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12606 * are a good indicator of UTF-16LE. */
12607 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12616 * Restore a source filter.
12620 restore_rsfp(pTHX_ void *f)
12623 PerlIO * const fp = (PerlIO*)f;
12625 if (PL_rsfp == PerlIO_stdin())
12626 PerlIO_clearerr(PL_rsfp);
12627 else if (PL_rsfp && (PL_rsfp != fp))
12628 PerlIO_close(PL_rsfp);
12632 #ifndef PERL_NO_UTF16_FILTER
12634 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12637 const STRLEN old = SvCUR(sv);
12638 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12639 DEBUG_P(PerlIO_printf(Perl_debug_log,
12640 "utf16_textfilter(%p): %d %d (%d)\n",
12641 FPTR2DPTR(void *, utf16_textfilter),
12642 idx, maxlen, (int) count));
12646 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12647 Copy(SvPVX_const(sv), tmps, old, char);
12648 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12649 SvCUR(sv) - old, &newlen);
12650 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12652 DEBUG_P({sv_dump(sv);});
12657 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12660 const STRLEN old = SvCUR(sv);
12661 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12662 DEBUG_P(PerlIO_printf(Perl_debug_log,
12663 "utf16rev_textfilter(%p): %d %d (%d)\n",
12664 FPTR2DPTR(void *, utf16rev_textfilter),
12665 idx, maxlen, (int) count));
12669 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12670 Copy(SvPVX_const(sv), tmps, old, char);
12671 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12672 SvCUR(sv) - old, &newlen);
12673 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12675 DEBUG_P({ sv_dump(sv); });
12681 Returns a pointer to the next character after the parsed
12682 vstring, as well as updating the passed in sv.
12684 Function must be called like
12687 s = scan_vstring(s,sv);
12689 The sv should already be large enough to store the vstring
12690 passed in, for performance reasons.
12695 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
12698 const char *pos = s;
12699 const char *start = s;
12700 if (*pos == 'v') pos++; /* get past 'v' */
12701 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12703 if ( *pos != '.') {
12704 /* this may not be a v-string if followed by => */
12705 const char *next = pos;
12706 while (next < PL_bufend && isSPACE(*next))
12708 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
12709 /* return string not v-string */
12710 sv_setpvn(sv,(char *)s,pos-s);
12711 return (char *)pos;
12715 if (!isALPHA(*pos)) {
12716 U8 tmpbuf[UTF8_MAXBYTES+1];
12719 s++; /* get past 'v' */
12721 sv_setpvn(sv, "", 0);
12724 /* this is atoi() that tolerates underscores */
12727 const char *end = pos;
12729 while (--end >= s) {
12731 const UV orev = rev;
12732 rev += (*end - '0') * mult;
12734 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12735 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12736 "Integer overflow in decimal number");
12740 if (rev > 0x7FFFFFFF)
12741 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12743 /* Append native character for the rev point */
12744 tmpend = uvchr_to_utf8(tmpbuf, rev);
12745 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12746 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12748 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
12754 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12758 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12766 * c-indentation-style: bsd
12767 * c-basic-offset: 4
12768 * indent-tabs-mode: t
12771 * ex: set ts=8 sts=4 sw=4 noet: