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_cvn_flags(tmpbuf, len, 0))
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)
10742 || get_cvn_flags(dest, d - dest, 0)))
10746 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10747 "Ambiguous use of %c{%s} resolved to %c%s",
10748 funny, dest, funny, dest);
10753 s = bracket; /* let the parser handle it */
10757 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10758 PL_lex_state = LEX_INTERPEND;
10763 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10765 PERL_UNUSED_CONTEXT;
10768 else if (ch == 'g')
10769 *pmfl |= PMf_GLOBAL;
10770 else if (ch == 'c')
10771 *pmfl |= PMf_CONTINUE;
10772 else if (ch == 'o')
10774 else if (ch == 'm')
10775 *pmfl |= PMf_MULTILINE;
10776 else if (ch == 's')
10777 *pmfl |= PMf_SINGLELINE;
10778 else if (ch == 'x')
10779 *pmfl |= PMf_EXTENDED;
10783 S_scan_pat(pTHX_ char *start, I32 type)
10787 char *s = scan_str(start,!!PL_madskills,FALSE);
10788 const char * const valid_flags =
10789 (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
10796 const char * const delimiter = skipspace(start);
10800 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10801 : "Search pattern not terminated" ));
10804 pm = (PMOP*)newPMOP(type, 0);
10805 if (PL_multi_open == '?')
10806 pm->op_pmflags |= PMf_ONCE;
10810 while (*s && strchr(valid_flags, *s))
10811 pmflag(&pm->op_pmflags,*s++);
10813 if (PL_madskills && modstart != s) {
10814 SV* tmptoken = newSVpvn(modstart, s - modstart);
10815 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10818 /* issue a warning if /c is specified,but /g is not */
10819 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10820 && ckWARN(WARN_REGEXP))
10822 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
10825 pm->op_pmpermflags = pm->op_pmflags;
10827 PL_lex_op = (OP*)pm;
10828 yylval.ival = OP_MATCH;
10833 S_scan_subst(pTHX_ char *start)
10844 yylval.ival = OP_NULL;
10846 s = scan_str(start,!!PL_madskills,FALSE);
10849 Perl_croak(aTHX_ "Substitution pattern not terminated");
10851 if (s[-1] == PL_multi_open)
10854 if (PL_madskills) {
10855 CURMAD('q', PL_thisopen);
10856 CURMAD('_', PL_thiswhite);
10857 CURMAD('E', PL_thisstuff);
10858 CURMAD('Q', PL_thisclose);
10859 PL_realtokenstart = s - SvPVX(PL_linestr);
10863 first_start = PL_multi_start;
10864 s = scan_str(s,!!PL_madskills,FALSE);
10866 if (PL_lex_stuff) {
10867 SvREFCNT_dec(PL_lex_stuff);
10868 PL_lex_stuff = NULL;
10870 Perl_croak(aTHX_ "Substitution replacement not terminated");
10872 PL_multi_start = first_start; /* so whole substitution is taken together */
10874 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10877 if (PL_madskills) {
10878 CURMAD('z', PL_thisopen);
10879 CURMAD('R', PL_thisstuff);
10880 CURMAD('Z', PL_thisclose);
10890 else if (strchr("iogcmsx", *s))
10891 pmflag(&pm->op_pmflags,*s++);
10897 if (PL_madskills) {
10899 curmad('m', newSVpvn(modstart, s - modstart));
10900 append_madprops(PL_thismad, (OP*)pm, 0);
10904 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10905 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10909 SV * const repl = newSVpvs("");
10911 PL_sublex_info.super_bufptr = s;
10912 PL_sublex_info.super_bufend = PL_bufend;
10914 pm->op_pmflags |= PMf_EVAL;
10916 sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10917 sv_catpvs(repl, "{");
10918 sv_catsv(repl, PL_lex_repl);
10919 if (strchr(SvPVX(PL_lex_repl), '#'))
10920 sv_catpvs(repl, "\n");
10921 sv_catpvs(repl, "}");
10923 SvREFCNT_dec(PL_lex_repl);
10924 PL_lex_repl = repl;
10927 pm->op_pmpermflags = pm->op_pmflags;
10928 PL_lex_op = (OP*)pm;
10929 yylval.ival = OP_SUBST;
10934 S_scan_trans(pTHX_ char *start)
10947 yylval.ival = OP_NULL;
10949 s = scan_str(start,!!PL_madskills,FALSE);
10951 Perl_croak(aTHX_ "Transliteration pattern not terminated");
10953 if (s[-1] == PL_multi_open)
10956 if (PL_madskills) {
10957 CURMAD('q', PL_thisopen);
10958 CURMAD('_', PL_thiswhite);
10959 CURMAD('E', PL_thisstuff);
10960 CURMAD('Q', PL_thisclose);
10961 PL_realtokenstart = s - SvPVX(PL_linestr);
10965 s = scan_str(s,!!PL_madskills,FALSE);
10967 if (PL_lex_stuff) {
10968 SvREFCNT_dec(PL_lex_stuff);
10969 PL_lex_stuff = NULL;
10971 Perl_croak(aTHX_ "Transliteration replacement not terminated");
10973 if (PL_madskills) {
10974 CURMAD('z', PL_thisopen);
10975 CURMAD('R', PL_thisstuff);
10976 CURMAD('Z', PL_thisclose);
10979 complement = del = squash = 0;
10986 complement = OPpTRANS_COMPLEMENT;
10989 del = OPpTRANS_DELETE;
10992 squash = OPpTRANS_SQUASH;
11001 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11002 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11003 o->op_private &= ~OPpTRANS_ALL;
11004 o->op_private |= del|squash|complement|
11005 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11006 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11009 yylval.ival = OP_TRANS;
11012 if (PL_madskills) {
11014 curmad('m', newSVpvn(modstart, s - modstart));
11015 append_madprops(PL_thismad, o, 0);
11024 S_scan_heredoc(pTHX_ register char *s)
11028 I32 op_type = OP_SCALAR;
11032 const char *found_newline;
11036 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11038 I32 stuffstart = s - SvPVX(PL_linestr);
11041 PL_realtokenstart = -1;
11046 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11050 while (SPACE_OR_TAB(*peek))
11052 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11055 s = delimcpy(d, e, s, PL_bufend, term, &len);
11065 if (!isALNUM_lazy_if(s,UTF))
11066 deprecate_old("bare << to mean <<\"\"");
11067 for (; isALNUM_lazy_if(s,UTF); s++) {
11072 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11073 Perl_croak(aTHX_ "Delimiter for here document is too long");
11076 len = d - PL_tokenbuf;
11079 if (PL_madskills) {
11080 tstart = PL_tokenbuf + !outer;
11081 PL_thisclose = newSVpvn(tstart, len - !outer);
11082 tstart = SvPVX(PL_linestr) + stuffstart;
11083 PL_thisopen = newSVpvn(tstart, s - tstart);
11084 stuffstart = s - SvPVX(PL_linestr);
11087 #ifndef PERL_STRICT_CR
11088 d = strchr(s, '\r');
11090 char * const olds = s;
11092 while (s < PL_bufend) {
11098 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11107 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11114 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11115 herewas = newSVpvn(s,PL_bufend-s);
11119 herewas = newSVpvn(s-1,found_newline-s+1);
11122 herewas = newSVpvn(s,found_newline-s);
11126 if (PL_madskills) {
11127 tstart = SvPVX(PL_linestr) + stuffstart;
11129 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11131 PL_thisstuff = newSVpvn(tstart, s - tstart);
11134 s += SvCUR(herewas);
11137 stuffstart = s - SvPVX(PL_linestr);
11143 tmpstr = newSV(79);
11144 sv_upgrade(tmpstr, SVt_PVIV);
11145 if (term == '\'') {
11146 op_type = OP_CONST;
11147 SvIV_set(tmpstr, -1);
11149 else if (term == '`') {
11150 op_type = OP_BACKTICK;
11151 SvIV_set(tmpstr, '\\');
11155 PL_multi_start = CopLINE(PL_curcop);
11156 PL_multi_open = PL_multi_close = '<';
11157 term = *PL_tokenbuf;
11158 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11159 char * const bufptr = PL_sublex_info.super_bufptr;
11160 char * const bufend = PL_sublex_info.super_bufend;
11161 char * const olds = s - SvCUR(herewas);
11162 s = strchr(bufptr, '\n');
11166 while (s < bufend &&
11167 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11169 CopLINE_inc(PL_curcop);
11172 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11173 missingterm(PL_tokenbuf);
11175 sv_setpvn(herewas,bufptr,d-bufptr+1);
11176 sv_setpvn(tmpstr,d+1,s-d);
11178 sv_catpvn(herewas,s,bufend-s);
11179 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11186 while (s < PL_bufend &&
11187 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11189 CopLINE_inc(PL_curcop);
11191 if (s >= PL_bufend) {
11192 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11193 missingterm(PL_tokenbuf);
11195 sv_setpvn(tmpstr,d+1,s-d);
11197 if (PL_madskills) {
11199 sv_catpvn(PL_thisstuff, d + 1, s - d);
11201 PL_thisstuff = newSVpvn(d + 1, s - d);
11202 stuffstart = s - SvPVX(PL_linestr);
11206 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11208 sv_catpvn(herewas,s,PL_bufend-s);
11209 sv_setsv(PL_linestr,herewas);
11210 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11211 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11212 PL_last_lop = PL_last_uni = NULL;
11215 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
11216 while (s >= PL_bufend) { /* multiple line string? */
11218 if (PL_madskills) {
11219 tstart = SvPVX(PL_linestr) + stuffstart;
11221 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11223 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11227 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11228 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11229 missingterm(PL_tokenbuf);
11232 stuffstart = s - SvPVX(PL_linestr);
11234 CopLINE_inc(PL_curcop);
11235 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11236 PL_last_lop = PL_last_uni = NULL;
11237 #ifndef PERL_STRICT_CR
11238 if (PL_bufend - PL_linestart >= 2) {
11239 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11240 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11242 PL_bufend[-2] = '\n';
11244 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11246 else if (PL_bufend[-1] == '\r')
11247 PL_bufend[-1] = '\n';
11249 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11250 PL_bufend[-1] = '\n';
11252 if (PERLDB_LINE && PL_curstash != PL_debstash)
11253 update_debugger_info(PL_linestr, NULL, 0);
11254 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11255 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11256 *(SvPVX(PL_linestr) + off ) = ' ';
11257 sv_catsv(PL_linestr,herewas);
11258 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11259 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11263 sv_catsv(tmpstr,PL_linestr);
11268 PL_multi_end = CopLINE(PL_curcop);
11269 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11270 SvPV_shrink_to_cur(tmpstr);
11272 SvREFCNT_dec(herewas);
11274 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11276 else if (PL_encoding)
11277 sv_recode_to_utf8(tmpstr, PL_encoding);
11279 PL_lex_stuff = tmpstr;
11280 yylval.ival = op_type;
11284 /* scan_inputsymbol
11285 takes: current position in input buffer
11286 returns: new position in input buffer
11287 side-effects: yylval and lex_op are set.
11292 <FH> read from filehandle
11293 <pkg::FH> read from package qualified filehandle
11294 <pkg'FH> read from package qualified filehandle
11295 <$fh> read from filehandle in $fh
11296 <*.h> filename glob
11301 S_scan_inputsymbol(pTHX_ char *start)
11304 register char *s = start; /* current position in buffer */
11308 char *d = PL_tokenbuf; /* start of temp holding space */
11309 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11311 end = strchr(s, '\n');
11314 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11316 /* die if we didn't have space for the contents of the <>,
11317 or if it didn't end, or if we see a newline
11320 if (len >= (I32)sizeof PL_tokenbuf)
11321 Perl_croak(aTHX_ "Excessively long <> operator");
11323 Perl_croak(aTHX_ "Unterminated <> operator");
11328 Remember, only scalar variables are interpreted as filehandles by
11329 this code. Anything more complex (e.g., <$fh{$num}>) will be
11330 treated as a glob() call.
11331 This code makes use of the fact that except for the $ at the front,
11332 a scalar variable and a filehandle look the same.
11334 if (*d == '$' && d[1]) d++;
11336 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11337 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11340 /* If we've tried to read what we allow filehandles to look like, and
11341 there's still text left, then it must be a glob() and not a getline.
11342 Use scan_str to pull out the stuff between the <> and treat it
11343 as nothing more than a string.
11346 if (d - PL_tokenbuf != len) {
11347 yylval.ival = OP_GLOB;
11349 s = scan_str(start,!!PL_madskills,FALSE);
11351 Perl_croak(aTHX_ "Glob not terminated");
11355 bool readline_overriden = FALSE;
11358 /* we're in a filehandle read situation */
11361 /* turn <> into <ARGV> */
11363 Copy("ARGV",d,5,char);
11365 /* Check whether readline() is overriden */
11366 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11368 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11370 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11371 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
11372 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11373 readline_overriden = TRUE;
11375 /* if <$fh>, create the ops to turn the variable into a
11379 /* try to find it in the pad for this block, otherwise find
11380 add symbol table ops
11382 const PADOFFSET tmp = pad_findmy(d);
11383 if (tmp != NOT_IN_PAD) {
11384 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11385 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11386 HEK * const stashname = HvNAME_HEK(stash);
11387 SV * const sym = sv_2mortal(newSVhek(stashname));
11388 sv_catpvs(sym, "::");
11389 sv_catpv(sym, d+1);
11394 OP * const o = newOP(OP_PADSV, 0);
11396 PL_lex_op = readline_overriden
11397 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11398 append_elem(OP_LIST, o,
11399 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11400 : (OP*)newUNOP(OP_READLINE, 0, o);
11409 ? (GV_ADDMULTI | GV_ADDINEVAL)
11412 PL_lex_op = readline_overriden
11413 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11414 append_elem(OP_LIST,
11415 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11416 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11417 : (OP*)newUNOP(OP_READLINE, 0,
11418 newUNOP(OP_RV2SV, 0,
11419 newGVOP(OP_GV, 0, gv)));
11421 if (!readline_overriden)
11422 PL_lex_op->op_flags |= OPf_SPECIAL;
11423 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11424 yylval.ival = OP_NULL;
11427 /* If it's none of the above, it must be a literal filehandle
11428 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11430 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11431 PL_lex_op = readline_overriden
11432 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11433 append_elem(OP_LIST,
11434 newGVOP(OP_GV, 0, gv),
11435 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11436 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11437 yylval.ival = OP_NULL;
11446 takes: start position in buffer
11447 keep_quoted preserve \ on the embedded delimiter(s)
11448 keep_delims preserve the delimiters around the string
11449 returns: position to continue reading from buffer
11450 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11451 updates the read buffer.
11453 This subroutine pulls a string out of the input. It is called for:
11454 q single quotes q(literal text)
11455 ' single quotes 'literal text'
11456 qq double quotes qq(interpolate $here please)
11457 " double quotes "interpolate $here please"
11458 qx backticks qx(/bin/ls -l)
11459 ` backticks `/bin/ls -l`
11460 qw quote words @EXPORT_OK = qw( func() $spam )
11461 m// regexp match m/this/
11462 s/// regexp substitute s/this/that/
11463 tr/// string transliterate tr/this/that/
11464 y/// string transliterate y/this/that/
11465 ($*@) sub prototypes sub foo ($)
11466 (stuff) sub attr parameters sub foo : attr(stuff)
11467 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11469 In most of these cases (all but <>, patterns and transliterate)
11470 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11471 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11472 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11475 It skips whitespace before the string starts, and treats the first
11476 character as the delimiter. If the delimiter is one of ([{< then
11477 the corresponding "close" character )]}> is used as the closing
11478 delimiter. It allows quoting of delimiters, and if the string has
11479 balanced delimiters ([{<>}]) it allows nesting.
11481 On success, the SV with the resulting string is put into lex_stuff or,
11482 if that is already non-NULL, into lex_repl. The second case occurs only
11483 when parsing the RHS of the special constructs s/// and tr/// (y///).
11484 For convenience, the terminating delimiter character is stuffed into
11489 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11492 SV *sv; /* scalar value: string */
11493 const char *tmps; /* temp string, used for delimiter matching */
11494 register char *s = start; /* current position in the buffer */
11495 register char term; /* terminating character */
11496 register char *to; /* current position in the sv's data */
11497 I32 brackets = 1; /* bracket nesting level */
11498 bool has_utf8 = FALSE; /* is there any utf8 content? */
11499 I32 termcode; /* terminating char. code */
11500 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11501 STRLEN termlen; /* length of terminating string */
11502 int last_off = 0; /* last position for nesting bracket */
11508 /* skip space before the delimiter */
11514 if (PL_realtokenstart >= 0) {
11515 stuffstart = PL_realtokenstart;
11516 PL_realtokenstart = -1;
11519 stuffstart = start - SvPVX(PL_linestr);
11521 /* mark where we are, in case we need to report errors */
11524 /* after skipping whitespace, the next character is the terminator */
11527 termcode = termstr[0] = term;
11531 termcode = utf8_to_uvchr((U8*)s, &termlen);
11532 Copy(s, termstr, termlen, U8);
11533 if (!UTF8_IS_INVARIANT(term))
11537 /* mark where we are */
11538 PL_multi_start = CopLINE(PL_curcop);
11539 PL_multi_open = term;
11541 /* find corresponding closing delimiter */
11542 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11543 termcode = termstr[0] = term = tmps[5];
11545 PL_multi_close = term;
11547 /* create a new SV to hold the contents. 79 is the SV's initial length.
11548 What a random number. */
11550 sv_upgrade(sv, SVt_PVIV);
11551 SvIV_set(sv, termcode);
11552 (void)SvPOK_only(sv); /* validate pointer */
11554 /* move past delimiter and try to read a complete string */
11556 sv_catpvn(sv, s, termlen);
11559 tstart = SvPVX(PL_linestr) + stuffstart;
11560 if (!PL_thisopen && !keep_delims) {
11561 PL_thisopen = newSVpvn(tstart, s - tstart);
11562 stuffstart = s - SvPVX(PL_linestr);
11566 if (PL_encoding && !UTF) {
11570 int offset = s - SvPVX_const(PL_linestr);
11571 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11572 &offset, (char*)termstr, termlen);
11573 const char * const ns = SvPVX_const(PL_linestr) + offset;
11574 char * const svlast = SvEND(sv) - 1;
11576 for (; s < ns; s++) {
11577 if (*s == '\n' && !PL_rsfp)
11578 CopLINE_inc(PL_curcop);
11581 goto read_more_line;
11583 /* handle quoted delimiters */
11584 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11586 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11588 if ((svlast-1 - t) % 2) {
11589 if (!keep_quoted) {
11590 *(svlast-1) = term;
11592 SvCUR_set(sv, SvCUR(sv) - 1);
11597 if (PL_multi_open == PL_multi_close) {
11603 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11604 /* At here, all closes are "was quoted" one,
11605 so we don't check PL_multi_close. */
11607 if (!keep_quoted && *(t+1) == PL_multi_open)
11612 else if (*t == PL_multi_open)
11620 SvCUR_set(sv, w - SvPVX_const(sv));
11622 last_off = w - SvPVX(sv);
11623 if (--brackets <= 0)
11628 if (!keep_delims) {
11629 SvCUR_set(sv, SvCUR(sv) - 1);
11635 /* extend sv if need be */
11636 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11637 /* set 'to' to the next character in the sv's string */
11638 to = SvPVX(sv)+SvCUR(sv);
11640 /* if open delimiter is the close delimiter read unbridle */
11641 if (PL_multi_open == PL_multi_close) {
11642 for (; s < PL_bufend; s++,to++) {
11643 /* embedded newlines increment the current line number */
11644 if (*s == '\n' && !PL_rsfp)
11645 CopLINE_inc(PL_curcop);
11646 /* handle quoted delimiters */
11647 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11648 if (!keep_quoted && s[1] == term)
11650 /* any other quotes are simply copied straight through */
11654 /* terminate when run out of buffer (the for() condition), or
11655 have found the terminator */
11656 else if (*s == term) {
11659 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11662 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11668 /* if the terminator isn't the same as the start character (e.g.,
11669 matched brackets), we have to allow more in the quoting, and
11670 be prepared for nested brackets.
11673 /* read until we run out of string, or we find the terminator */
11674 for (; s < PL_bufend; s++,to++) {
11675 /* embedded newlines increment the line count */
11676 if (*s == '\n' && !PL_rsfp)
11677 CopLINE_inc(PL_curcop);
11678 /* backslashes can escape the open or closing characters */
11679 if (*s == '\\' && s+1 < PL_bufend) {
11680 if (!keep_quoted &&
11681 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11686 /* allow nested opens and closes */
11687 else if (*s == PL_multi_close && --brackets <= 0)
11689 else if (*s == PL_multi_open)
11691 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11696 /* terminate the copied string and update the sv's end-of-string */
11698 SvCUR_set(sv, to - SvPVX_const(sv));
11701 * this next chunk reads more into the buffer if we're not done yet
11705 break; /* handle case where we are done yet :-) */
11707 #ifndef PERL_STRICT_CR
11708 if (to - SvPVX_const(sv) >= 2) {
11709 if ((to[-2] == '\r' && to[-1] == '\n') ||
11710 (to[-2] == '\n' && to[-1] == '\r'))
11714 SvCUR_set(sv, to - SvPVX_const(sv));
11716 else if (to[-1] == '\r')
11719 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11724 /* if we're out of file, or a read fails, bail and reset the current
11725 line marker so we can report where the unterminated string began
11728 if (PL_madskills) {
11729 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11731 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11733 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11737 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11739 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11745 /* we read a line, so increment our line counter */
11746 CopLINE_inc(PL_curcop);
11748 /* update debugger info */
11749 if (PERLDB_LINE && PL_curstash != PL_debstash)
11750 update_debugger_info(PL_linestr, NULL, 0);
11752 /* having changed the buffer, we must update PL_bufend */
11753 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11754 PL_last_lop = PL_last_uni = NULL;
11757 /* at this point, we have successfully read the delimited string */
11759 if (!PL_encoding || UTF) {
11761 if (PL_madskills) {
11762 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11763 const int len = s - tstart;
11765 sv_catpvn(PL_thisstuff, tstart, len);
11767 PL_thisstuff = newSVpvn(tstart, len);
11768 if (!PL_thisclose && !keep_delims)
11769 PL_thisclose = newSVpvn(s,termlen);
11774 sv_catpvn(sv, s, termlen);
11779 if (PL_madskills) {
11780 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11781 const int len = s - tstart - termlen;
11783 sv_catpvn(PL_thisstuff, tstart, len);
11785 PL_thisstuff = newSVpvn(tstart, len);
11786 if (!PL_thisclose && !keep_delims)
11787 PL_thisclose = newSVpvn(s - termlen,termlen);
11791 if (has_utf8 || PL_encoding)
11794 PL_multi_end = CopLINE(PL_curcop);
11796 /* if we allocated too much space, give some back */
11797 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11798 SvLEN_set(sv, SvCUR(sv) + 1);
11799 SvPV_renew(sv, SvLEN(sv));
11802 /* decide whether this is the first or second quoted string we've read
11815 takes: pointer to position in buffer
11816 returns: pointer to new position in buffer
11817 side-effects: builds ops for the constant in yylval.op
11819 Read a number in any of the formats that Perl accepts:
11821 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11822 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11825 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11827 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11830 If it reads a number without a decimal point or an exponent, it will
11831 try converting the number to an integer and see if it can do so
11832 without loss of precision.
11836 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11839 register const char *s = start; /* current position in buffer */
11840 register char *d; /* destination in temp buffer */
11841 register char *e; /* end of temp buffer */
11842 NV nv; /* number read, as a double */
11843 SV *sv = NULL; /* place to put the converted number */
11844 bool floatit; /* boolean: int or float? */
11845 const char *lastub = NULL; /* position of last underbar */
11846 static char const number_too_long[] = "Number too long";
11848 /* We use the first character to decide what type of number this is */
11852 Perl_croak(aTHX_ "panic: scan_num");
11854 /* if it starts with a 0, it could be an octal number, a decimal in
11855 0.13 disguise, or a hexadecimal number, or a binary number. */
11859 u holds the "number so far"
11860 shift the power of 2 of the base
11861 (hex == 4, octal == 3, binary == 1)
11862 overflowed was the number more than we can hold?
11864 Shift is used when we add a digit. It also serves as an "are
11865 we in octal/hex/binary?" indicator to disallow hex characters
11866 when in octal mode.
11871 bool overflowed = FALSE;
11872 bool just_zero = TRUE; /* just plain 0 or binary number? */
11873 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11874 static const char* const bases[5] =
11875 { "", "binary", "", "octal", "hexadecimal" };
11876 static const char* const Bases[5] =
11877 { "", "Binary", "", "Octal", "Hexadecimal" };
11878 static const char* const maxima[5] =
11880 "0b11111111111111111111111111111111",
11884 const char *base, *Base, *max;
11886 /* check for hex */
11891 } else if (s[1] == 'b') {
11896 /* check for a decimal in disguise */
11897 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11899 /* so it must be octal */
11906 if (ckWARN(WARN_SYNTAX))
11907 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11908 "Misplaced _ in number");
11912 base = bases[shift];
11913 Base = Bases[shift];
11914 max = maxima[shift];
11916 /* read the rest of the number */
11918 /* x is used in the overflow test,
11919 b is the digit we're adding on. */
11924 /* if we don't mention it, we're done */
11928 /* _ are ignored -- but warned about if consecutive */
11930 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11931 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11932 "Misplaced _ in number");
11936 /* 8 and 9 are not octal */
11937 case '8': case '9':
11939 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11943 case '2': case '3': case '4':
11944 case '5': case '6': case '7':
11946 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11949 case '0': case '1':
11950 b = *s++ & 15; /* ASCII digit -> value of digit */
11954 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11955 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11956 /* make sure they said 0x */
11959 b = (*s++ & 7) + 9;
11961 /* Prepare to put the digit we have onto the end
11962 of the number so far. We check for overflows.
11968 x = u << shift; /* make room for the digit */
11970 if ((x >> shift) != u
11971 && !(PL_hints & HINT_NEW_BINARY)) {
11974 if (ckWARN_d(WARN_OVERFLOW))
11975 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11976 "Integer overflow in %s number",
11979 u = x | b; /* add the digit to the end */
11982 n *= nvshift[shift];
11983 /* If an NV has not enough bits in its
11984 * mantissa to represent an UV this summing of
11985 * small low-order numbers is a waste of time
11986 * (because the NV cannot preserve the
11987 * low-order bits anyway): we could just
11988 * remember when did we overflow and in the
11989 * end just multiply n by the right
11997 /* if we get here, we had success: make a scalar value from
12002 /* final misplaced underbar check */
12003 if (s[-1] == '_') {
12004 if (ckWARN(WARN_SYNTAX))
12005 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12010 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12011 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12012 "%s number > %s non-portable",
12018 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12019 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12020 "%s number > %s non-portable",
12025 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12026 sv = new_constant(start, s - start, "integer",
12028 else if (PL_hints & HINT_NEW_BINARY)
12029 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
12034 handle decimal numbers.
12035 we're also sent here when we read a 0 as the first digit
12037 case '1': case '2': case '3': case '4': case '5':
12038 case '6': case '7': case '8': case '9': case '.':
12041 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12044 /* read next group of digits and _ and copy into d */
12045 while (isDIGIT(*s) || *s == '_') {
12046 /* skip underscores, checking for misplaced ones
12050 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12051 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12052 "Misplaced _ in number");
12056 /* check for end of fixed-length buffer */
12058 Perl_croak(aTHX_ number_too_long);
12059 /* if we're ok, copy the character */
12064 /* final misplaced underbar check */
12065 if (lastub && s == lastub + 1) {
12066 if (ckWARN(WARN_SYNTAX))
12067 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12070 /* read a decimal portion if there is one. avoid
12071 3..5 being interpreted as the number 3. followed
12074 if (*s == '.' && s[1] != '.') {
12079 if (ckWARN(WARN_SYNTAX))
12080 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12081 "Misplaced _ in number");
12085 /* copy, ignoring underbars, until we run out of digits.
12087 for (; isDIGIT(*s) || *s == '_'; s++) {
12088 /* fixed length buffer check */
12090 Perl_croak(aTHX_ number_too_long);
12092 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12093 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12094 "Misplaced _ in number");
12100 /* fractional part ending in underbar? */
12101 if (s[-1] == '_') {
12102 if (ckWARN(WARN_SYNTAX))
12103 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12104 "Misplaced _ in number");
12106 if (*s == '.' && isDIGIT(s[1])) {
12107 /* oops, it's really a v-string, but without the "v" */
12113 /* read exponent part, if present */
12114 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12118 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12119 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12121 /* stray preinitial _ */
12123 if (ckWARN(WARN_SYNTAX))
12124 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12125 "Misplaced _ in number");
12129 /* allow positive or negative exponent */
12130 if (*s == '+' || *s == '-')
12133 /* stray initial _ */
12135 if (ckWARN(WARN_SYNTAX))
12136 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12137 "Misplaced _ in number");
12141 /* read digits of exponent */
12142 while (isDIGIT(*s) || *s == '_') {
12145 Perl_croak(aTHX_ number_too_long);
12149 if (((lastub && s == lastub + 1) ||
12150 (!isDIGIT(s[1]) && s[1] != '_'))
12151 && ckWARN(WARN_SYNTAX))
12152 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12153 "Misplaced _ in number");
12160 /* make an sv from the string */
12164 We try to do an integer conversion first if no characters
12165 indicating "float" have been found.
12170 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12172 if (flags == IS_NUMBER_IN_UV) {
12174 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12177 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12178 if (uv <= (UV) IV_MIN)
12179 sv_setiv(sv, -(IV)uv);
12186 /* terminate the string */
12188 nv = Atof(PL_tokenbuf);
12192 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12193 (PL_hints & HINT_NEW_INTEGER) )
12194 sv = new_constant(PL_tokenbuf,
12197 (floatit ? "float" : "integer"),
12201 /* if it starts with a v, it could be a v-string */
12204 sv = newSV(5); /* preallocate storage space */
12205 s = scan_vstring(s,sv);
12209 /* make the op for the constant and return */
12212 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12214 lvalp->opval = NULL;
12220 S_scan_formline(pTHX_ register char *s)
12223 register char *eol;
12225 SV * const stuff = newSVpvs("");
12226 bool needargs = FALSE;
12227 bool eofmt = FALSE;
12229 char *tokenstart = s;
12232 if (PL_madskills) {
12233 savewhite = PL_thiswhite;
12238 while (!needargs) {
12241 #ifdef PERL_STRICT_CR
12242 while (SPACE_OR_TAB(*t))
12245 while (SPACE_OR_TAB(*t) || *t == '\r')
12248 if (*t == '\n' || t == PL_bufend) {
12253 if (PL_in_eval && !PL_rsfp) {
12254 eol = (char *) memchr(s,'\n',PL_bufend-s);
12259 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12261 for (t = s; t < eol; t++) {
12262 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12264 goto enough; /* ~~ must be first line in formline */
12266 if (*t == '@' || *t == '^')
12270 sv_catpvn(stuff, s, eol-s);
12271 #ifndef PERL_STRICT_CR
12272 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12273 char *end = SvPVX(stuff) + SvCUR(stuff);
12276 SvCUR_set(stuff, SvCUR(stuff) - 1);
12286 if (PL_madskills) {
12288 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12290 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12293 s = filter_gets(PL_linestr, PL_rsfp, 0);
12295 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12297 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12299 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12300 PL_last_lop = PL_last_uni = NULL;
12309 if (SvCUR(stuff)) {
12312 PL_lex_state = LEX_NORMAL;
12313 start_force(PL_curforce);
12314 NEXTVAL_NEXTTOKE.ival = 0;
12318 PL_lex_state = LEX_FORMLINE;
12320 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12322 else if (PL_encoding)
12323 sv_recode_to_utf8(stuff, PL_encoding);
12325 start_force(PL_curforce);
12326 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12328 start_force(PL_curforce);
12329 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12333 SvREFCNT_dec(stuff);
12335 PL_lex_formbrack = 0;
12339 if (PL_madskills) {
12341 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12343 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12344 PL_thiswhite = savewhite;
12356 PL_cshlen = strlen(PL_cshname);
12358 #if defined(USE_ITHREADS)
12359 PERL_UNUSED_CONTEXT;
12365 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12368 const I32 oldsavestack_ix = PL_savestack_ix;
12369 CV* const outsidecv = PL_compcv;
12372 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12374 SAVEI32(PL_subline);
12375 save_item(PL_subname);
12376 SAVESPTR(PL_compcv);
12378 PL_compcv = (CV*)newSV(0);
12379 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
12380 CvFLAGS(PL_compcv) |= flags;
12382 PL_subline = CopLINE(PL_curcop);
12383 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12384 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12385 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12387 return oldsavestack_ix;
12391 #pragma segment Perl_yylex
12394 Perl_yywarn(pTHX_ const char *s)
12397 PL_in_eval |= EVAL_WARNONLY;
12399 PL_in_eval &= ~EVAL_WARNONLY;
12404 Perl_yyerror(pTHX_ const char *s)
12407 const char *where = NULL;
12408 const char *context = NULL;
12411 int yychar = PL_parser->yychar;
12413 if (!yychar || (yychar == ';' && !PL_rsfp))
12415 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12416 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12417 PL_oldbufptr != PL_bufptr) {
12420 The code below is removed for NetWare because it abends/crashes on NetWare
12421 when the script has error such as not having the closing quotes like:
12422 if ($var eq "value)
12423 Checking of white spaces is anyway done in NetWare code.
12426 while (isSPACE(*PL_oldoldbufptr))
12429 context = PL_oldoldbufptr;
12430 contlen = PL_bufptr - PL_oldoldbufptr;
12432 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12433 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12436 The code below is removed for NetWare because it abends/crashes on NetWare
12437 when the script has error such as not having the closing quotes like:
12438 if ($var eq "value)
12439 Checking of white spaces is anyway done in NetWare code.
12442 while (isSPACE(*PL_oldbufptr))
12445 context = PL_oldbufptr;
12446 contlen = PL_bufptr - PL_oldbufptr;
12448 else if (yychar > 255)
12449 where = "next token ???";
12450 else if (yychar == -2) { /* YYEMPTY */
12451 if (PL_lex_state == LEX_NORMAL ||
12452 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12453 where = "at end of line";
12454 else if (PL_lex_inpat)
12455 where = "within pattern";
12457 where = "within string";
12460 SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12462 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12463 else if (isPRINT_LC(yychar))
12464 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12466 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12467 where = SvPVX_const(where_sv);
12469 msg = sv_2mortal(newSVpv(s, 0));
12470 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12471 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12473 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12475 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12476 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12477 Perl_sv_catpvf(aTHX_ msg,
12478 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12479 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12482 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12483 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12486 if (PL_error_count >= 10) {
12487 if (PL_in_eval && SvCUR(ERRSV))
12488 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12489 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12491 Perl_croak(aTHX_ "%s has too many errors.\n",
12492 OutCopFILE(PL_curcop));
12495 PL_in_my_stash = NULL;
12499 #pragma segment Main
12503 S_swallow_bom(pTHX_ U8 *s)
12506 const STRLEN slen = SvCUR(PL_linestr);
12509 if (s[1] == 0xFE) {
12510 /* UTF-16 little-endian? (or UTF32-LE?) */
12511 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12512 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12513 #ifndef PERL_NO_UTF16_FILTER
12514 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12517 if (PL_bufend > (char*)s) {
12521 filter_add(utf16rev_textfilter, NULL);
12522 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12523 utf16_to_utf8_reversed(s, news,
12524 PL_bufend - (char*)s - 1,
12526 sv_setpvn(PL_linestr, (const char*)news, newlen);
12528 s = (U8*)SvPVX(PL_linestr);
12529 Copy(news, s, newlen, U8);
12533 SvUTF8_on(PL_linestr);
12534 s = (U8*)SvPVX(PL_linestr);
12536 /* FIXME - is this a general bug fix? */
12539 PL_bufend = SvPVX(PL_linestr) + newlen;
12542 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12547 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12548 #ifndef PERL_NO_UTF16_FILTER
12549 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12552 if (PL_bufend > (char *)s) {
12556 filter_add(utf16_textfilter, NULL);
12557 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12558 utf16_to_utf8(s, news,
12559 PL_bufend - (char*)s,
12561 sv_setpvn(PL_linestr, (const char*)news, newlen);
12563 SvUTF8_on(PL_linestr);
12564 s = (U8*)SvPVX(PL_linestr);
12565 PL_bufend = SvPVX(PL_linestr) + newlen;
12568 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12573 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12574 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12575 s += 3; /* UTF-8 */
12581 if (s[2] == 0xFE && s[3] == 0xFF) {
12582 /* UTF-32 big-endian */
12583 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12586 else if (s[2] == 0 && s[3] != 0) {
12589 * are a good indicator of UTF-16BE. */
12590 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12596 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12597 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12598 s += 4; /* UTF-8 */
12604 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12607 * are a good indicator of UTF-16LE. */
12608 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12617 * Restore a source filter.
12621 restore_rsfp(pTHX_ void *f)
12624 PerlIO * const fp = (PerlIO*)f;
12626 if (PL_rsfp == PerlIO_stdin())
12627 PerlIO_clearerr(PL_rsfp);
12628 else if (PL_rsfp && (PL_rsfp != fp))
12629 PerlIO_close(PL_rsfp);
12633 #ifndef PERL_NO_UTF16_FILTER
12635 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12638 const STRLEN old = SvCUR(sv);
12639 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12640 DEBUG_P(PerlIO_printf(Perl_debug_log,
12641 "utf16_textfilter(%p): %d %d (%d)\n",
12642 FPTR2DPTR(void *, utf16_textfilter),
12643 idx, maxlen, (int) count));
12647 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12648 Copy(SvPVX_const(sv), tmps, old, char);
12649 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12650 SvCUR(sv) - old, &newlen);
12651 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12653 DEBUG_P({sv_dump(sv);});
12658 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12661 const STRLEN old = SvCUR(sv);
12662 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12663 DEBUG_P(PerlIO_printf(Perl_debug_log,
12664 "utf16rev_textfilter(%p): %d %d (%d)\n",
12665 FPTR2DPTR(void *, utf16rev_textfilter),
12666 idx, maxlen, (int) count));
12670 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12671 Copy(SvPVX_const(sv), tmps, old, char);
12672 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12673 SvCUR(sv) - old, &newlen);
12674 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12676 DEBUG_P({ sv_dump(sv); });
12682 Returns a pointer to the next character after the parsed
12683 vstring, as well as updating the passed in sv.
12685 Function must be called like
12688 s = scan_vstring(s,sv);
12690 The sv should already be large enough to store the vstring
12691 passed in, for performance reasons.
12696 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
12699 const char *pos = s;
12700 const char *start = s;
12701 if (*pos == 'v') pos++; /* get past 'v' */
12702 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12704 if ( *pos != '.') {
12705 /* this may not be a v-string if followed by => */
12706 const char *next = pos;
12707 while (next < PL_bufend && isSPACE(*next))
12709 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
12710 /* return string not v-string */
12711 sv_setpvn(sv,(char *)s,pos-s);
12712 return (char *)pos;
12716 if (!isALPHA(*pos)) {
12717 U8 tmpbuf[UTF8_MAXBYTES+1];
12720 s++; /* get past 'v' */
12722 sv_setpvn(sv, "", 0);
12725 /* this is atoi() that tolerates underscores */
12728 const char *end = pos;
12730 while (--end >= s) {
12732 const UV orev = rev;
12733 rev += (*end - '0') * mult;
12735 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12736 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12737 "Integer overflow in decimal number");
12741 if (rev > 0x7FFFFFFF)
12742 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12744 /* Append native character for the rev point */
12745 tmpend = uvchr_to_utf8(tmpbuf, rev);
12746 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12747 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12749 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
12755 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12759 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12767 * c-indentation-style: bsd
12768 * c-basic-offset: 4
12769 * indent-tabs-mode: t
12772 * ex: set ts=8 sts=4 sw=4 noet: