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[128], smallbuf2[128];
794 char *tmpbuf, *tmpbuf2;
796 STRLEN tmplen2 = strlen(s);
797 if (tmplen + 2 <= sizeof smallbuf)
800 Newx(tmpbuf, tmplen + 2, char);
801 if (tmplen2 + 2 <= sizeof smallbuf2)
804 Newx(tmpbuf2, tmplen2 + 2, char);
805 tmpbuf[0] = tmpbuf2[0] = '_';
806 tmpbuf[1] = tmpbuf2[1] = '<';
807 memcpy(tmpbuf + 2, cf, tmplen);
808 memcpy(tmpbuf2 + 2, s, tmplen2);
809 tmplen += 2; tmplen2 += 2;
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, 0)) {
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, 0);
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))
4144 const char tmp = *s++;
4150 goto just_a_word_zero_gv;
4153 switch (PL_expect) {
4159 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4161 PL_bufptr = s; /* update in case we back off */
4167 PL_expect = XTERMBLOCK;
4170 stuffstart = s - SvPVX(PL_linestr) - 1;
4174 while (isIDFIRST_lazy_if(s,UTF)) {
4177 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4178 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4179 if (tmp < 0) tmp = -tmp;
4194 sv = newSVpvn(s, len);
4196 d = scan_str(d,TRUE,TRUE);
4198 /* MUST advance bufptr here to avoid bogus
4199 "at end of line" context messages from yyerror().
4201 PL_bufptr = s + len;
4202 yyerror("Unterminated attribute parameter in attribute list");
4206 return REPORT(0); /* EOF indicator */
4210 sv_catsv(sv, PL_lex_stuff);
4211 attrs = append_elem(OP_LIST, attrs,
4212 newSVOP(OP_CONST, 0, sv));
4213 SvREFCNT_dec(PL_lex_stuff);
4214 PL_lex_stuff = NULL;
4217 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4219 if (PL_in_my == KEY_our) {
4221 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4223 /* skip to avoid loading attributes.pm */
4225 deprecate(":unique");
4228 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4231 /* NOTE: any CV attrs applied here need to be part of
4232 the CVf_BUILTIN_ATTRS define in cv.h! */
4233 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4235 CvLVALUE_on(PL_compcv);
4237 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4239 CvLOCKED_on(PL_compcv);
4241 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4243 CvMETHOD_on(PL_compcv);
4245 else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4247 CvASSERTION_on(PL_compcv);
4249 /* After we've set the flags, it could be argued that
4250 we don't need to do the attributes.pm-based setting
4251 process, and shouldn't bother appending recognized
4252 flags. To experiment with that, uncomment the
4253 following "else". (Note that's already been
4254 uncommented. That keeps the above-applied built-in
4255 attributes from being intercepted (and possibly
4256 rejected) by a package's attribute routines, but is
4257 justified by the performance win for the common case
4258 of applying only built-in attributes.) */
4260 attrs = append_elem(OP_LIST, attrs,
4261 newSVOP(OP_CONST, 0,
4265 if (*s == ':' && s[1] != ':')
4268 break; /* require real whitespace or :'s */
4269 /* XXX losing whitespace on sequential attributes here */
4273 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4274 if (*s != ';' && *s != '}' && *s != tmp
4275 && (tmp != '=' || *s != ')')) {
4276 const char q = ((*s == '\'') ? '"' : '\'');
4277 /* If here for an expression, and parsed no attrs, back
4279 if (tmp == '=' && !attrs) {
4283 /* MUST advance bufptr here to avoid bogus "at end of line"
4284 context messages from yyerror().
4287 yyerror( (const char *)
4289 ? Perl_form(aTHX_ "Invalid separator character "
4290 "%c%c%c in attribute list", q, *s, q)
4291 : "Unterminated attribute list" ) );
4299 start_force(PL_curforce);
4300 NEXTVAL_NEXTTOKE.opval = attrs;
4301 CURMAD('_', PL_nextwhite);
4306 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4307 (s - SvPVX(PL_linestr)) - stuffstart);
4315 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4316 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4324 const char tmp = *s++;
4329 const char tmp = *s++;
4337 if (PL_lex_brackets <= 0)
4338 yyerror("Unmatched right square bracket");
4341 if (PL_lex_state == LEX_INTERPNORMAL) {
4342 if (PL_lex_brackets == 0) {
4343 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4344 PL_lex_state = LEX_INTERPEND;
4351 if (PL_lex_brackets > 100) {
4352 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4354 switch (PL_expect) {
4356 if (PL_lex_formbrack) {
4360 if (PL_oldoldbufptr == PL_last_lop)
4361 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4363 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4364 OPERATOR(HASHBRACK);
4366 while (s < PL_bufend && SPACE_OR_TAB(*s))
4369 PL_tokenbuf[0] = '\0';
4370 if (d < PL_bufend && *d == '-') {
4371 PL_tokenbuf[0] = '-';
4373 while (d < PL_bufend && SPACE_OR_TAB(*d))
4376 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4377 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4379 while (d < PL_bufend && SPACE_OR_TAB(*d))
4382 const char minus = (PL_tokenbuf[0] == '-');
4383 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4391 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4396 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4401 if (PL_oldoldbufptr == PL_last_lop)
4402 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4404 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4407 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4409 /* This hack is to get the ${} in the message. */
4411 yyerror("syntax error");
4414 OPERATOR(HASHBRACK);
4416 /* This hack serves to disambiguate a pair of curlies
4417 * as being a block or an anon hash. Normally, expectation
4418 * determines that, but in cases where we're not in a
4419 * position to expect anything in particular (like inside
4420 * eval"") we have to resolve the ambiguity. This code
4421 * covers the case where the first term in the curlies is a
4422 * quoted string. Most other cases need to be explicitly
4423 * disambiguated by prepending a "+" before the opening
4424 * curly in order to force resolution as an anon hash.
4426 * XXX should probably propagate the outer expectation
4427 * into eval"" to rely less on this hack, but that could
4428 * potentially break current behavior of eval"".
4432 if (*s == '\'' || *s == '"' || *s == '`') {
4433 /* common case: get past first string, handling escapes */
4434 for (t++; t < PL_bufend && *t != *s;)
4435 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4439 else if (*s == 'q') {
4442 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4445 /* skip q//-like construct */
4447 char open, close, term;
4450 while (t < PL_bufend && isSPACE(*t))
4452 /* check for q => */
4453 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4454 OPERATOR(HASHBRACK);
4458 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4462 for (t++; t < PL_bufend; t++) {
4463 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4465 else if (*t == open)
4469 for (t++; t < PL_bufend; t++) {
4470 if (*t == '\\' && t+1 < PL_bufend)
4472 else if (*t == close && --brackets <= 0)
4474 else if (*t == open)
4481 /* skip plain q word */
4482 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4485 else if (isALNUM_lazy_if(t,UTF)) {
4487 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4490 while (t < PL_bufend && isSPACE(*t))
4492 /* if comma follows first term, call it an anon hash */
4493 /* XXX it could be a comma expression with loop modifiers */
4494 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4495 || (*t == '=' && t[1] == '>')))
4496 OPERATOR(HASHBRACK);
4497 if (PL_expect == XREF)
4500 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4506 yylval.ival = CopLINE(PL_curcop);
4507 if (isSPACE(*s) || *s == '#')
4508 PL_copline = NOLINE; /* invalidate current command line number */
4513 if (PL_lex_brackets <= 0)
4514 yyerror("Unmatched right curly bracket");
4516 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4517 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4518 PL_lex_formbrack = 0;
4519 if (PL_lex_state == LEX_INTERPNORMAL) {
4520 if (PL_lex_brackets == 0) {
4521 if (PL_expect & XFAKEBRACK) {
4522 PL_expect &= XENUMMASK;
4523 PL_lex_state = LEX_INTERPEND;
4528 PL_thiswhite = newSVpvs("");
4529 sv_catpvn(PL_thiswhite,"}",1);
4532 return yylex(); /* ignore fake brackets */
4534 if (*s == '-' && s[1] == '>')
4535 PL_lex_state = LEX_INTERPENDMAYBE;
4536 else if (*s != '[' && *s != '{')
4537 PL_lex_state = LEX_INTERPEND;
4540 if (PL_expect & XFAKEBRACK) {
4541 PL_expect &= XENUMMASK;
4543 return yylex(); /* ignore fake brackets */
4545 start_force(PL_curforce);
4547 curmad('X', newSVpvn(s-1,1));
4548 CURMAD('_', PL_thiswhite);
4553 PL_thistoken = newSVpvs("");
4561 if (PL_expect == XOPERATOR) {
4562 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4563 && isIDFIRST_lazy_if(s,UTF))
4565 CopLINE_dec(PL_curcop);
4566 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4567 CopLINE_inc(PL_curcop);
4572 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4574 PL_expect = XOPERATOR;
4575 force_ident(PL_tokenbuf, '&');
4579 yylval.ival = (OPpENTERSUB_AMPER<<8);
4591 const char tmp = *s++;
4598 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4599 && strchr("+-*/%.^&|<",tmp))
4600 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4601 "Reversed %c= operator",(int)tmp);
4603 if (PL_expect == XSTATE && isALPHA(tmp) &&
4604 (s == PL_linestart+1 || s[-2] == '\n') )
4606 if (PL_in_eval && !PL_rsfp) {
4611 if (strnEQ(s,"=cut",4)) {
4627 PL_thiswhite = newSVpvs("");
4628 sv_catpvn(PL_thiswhite, PL_linestart,
4629 PL_bufend - PL_linestart);
4633 PL_doextract = TRUE;
4637 if (PL_lex_brackets < PL_lex_formbrack) {
4639 #ifdef PERL_STRICT_CR
4640 while (SPACE_OR_TAB(*t))
4642 while (SPACE_OR_TAB(*t) || *t == '\r')
4645 if (*t == '\n' || *t == '#') {
4656 const char tmp = *s++;
4658 /* was this !=~ where !~ was meant?
4659 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4661 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4662 const char *t = s+1;
4664 while (t < PL_bufend && isSPACE(*t))
4667 if (*t == '/' || *t == '?' ||
4668 ((*t == 'm' || *t == 's' || *t == 'y')
4669 && !isALNUM(t[1])) ||
4670 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4671 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4672 "!=~ should be !~");
4682 if (PL_expect != XOPERATOR) {
4683 if (s[1] != '<' && !strchr(s,'>'))
4686 s = scan_heredoc(s);
4688 s = scan_inputsymbol(s);
4689 TERM(sublex_start());
4695 SHop(OP_LEFT_SHIFT);
4709 const char tmp = *s++;
4711 SHop(OP_RIGHT_SHIFT);
4712 else if (tmp == '=')
4721 if (PL_expect == XOPERATOR) {
4722 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4724 deprecate_old(commaless_variable_list);
4725 return REPORT(','); /* grandfather non-comma-format format */
4729 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4730 PL_tokenbuf[0] = '@';
4731 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4732 sizeof PL_tokenbuf - 1, FALSE);
4733 if (PL_expect == XOPERATOR)
4734 no_op("Array length", s);
4735 if (!PL_tokenbuf[1])
4737 PL_expect = XOPERATOR;
4738 PL_pending_ident = '#';
4742 PL_tokenbuf[0] = '$';
4743 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4744 sizeof PL_tokenbuf - 1, FALSE);
4745 if (PL_expect == XOPERATOR)
4747 if (!PL_tokenbuf[1]) {
4749 yyerror("Final $ should be \\$ or $name");
4753 /* This kludge not intended to be bulletproof. */
4754 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4755 yylval.opval = newSVOP(OP_CONST, 0,
4756 newSViv(CopARYBASE_get(&PL_compiling)));
4757 yylval.opval->op_private = OPpCONST_ARYBASE;
4763 const char tmp = *s;
4764 if (PL_lex_state == LEX_NORMAL)
4767 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4768 && intuit_more(s)) {
4770 PL_tokenbuf[0] = '@';
4771 if (ckWARN(WARN_SYNTAX)) {
4774 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4777 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4778 while (t < PL_bufend && *t != ']')
4780 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4781 "Multidimensional syntax %.*s not supported",
4782 (int)((t - PL_bufptr) + 1), PL_bufptr);
4786 else if (*s == '{') {
4788 PL_tokenbuf[0] = '%';
4789 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4790 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4792 char tmpbuf[sizeof PL_tokenbuf];
4795 } while (isSPACE(*t));
4796 if (isIDFIRST_lazy_if(t,UTF)) {
4798 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4802 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4803 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4804 "You need to quote \"%s\"",
4811 PL_expect = XOPERATOR;
4812 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4813 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4814 if (!islop || PL_last_lop_op == OP_GREPSTART)
4815 PL_expect = XOPERATOR;
4816 else if (strchr("$@\"'`q", *s))
4817 PL_expect = XTERM; /* e.g. print $fh "foo" */
4818 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4819 PL_expect = XTERM; /* e.g. print $fh &sub */
4820 else if (isIDFIRST_lazy_if(s,UTF)) {
4821 char tmpbuf[sizeof PL_tokenbuf];
4823 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4824 if ((t2 = keyword(tmpbuf, len, 0))) {
4825 /* binary operators exclude handle interpretations */
4837 PL_expect = XTERM; /* e.g. print $fh length() */
4842 PL_expect = XTERM; /* e.g. print $fh subr() */
4845 else if (isDIGIT(*s))
4846 PL_expect = XTERM; /* e.g. print $fh 3 */
4847 else if (*s == '.' && isDIGIT(s[1]))
4848 PL_expect = XTERM; /* e.g. print $fh .3 */
4849 else if ((*s == '?' || *s == '-' || *s == '+')
4850 && !isSPACE(s[1]) && s[1] != '=')
4851 PL_expect = XTERM; /* e.g. print $fh -1 */
4852 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4854 PL_expect = XTERM; /* e.g. print $fh /.../
4855 XXX except DORDOR operator
4857 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4859 PL_expect = XTERM; /* print $fh <<"EOF" */
4862 PL_pending_ident = '$';
4866 if (PL_expect == XOPERATOR)
4868 PL_tokenbuf[0] = '@';
4869 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4870 if (!PL_tokenbuf[1]) {
4873 if (PL_lex_state == LEX_NORMAL)
4875 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4877 PL_tokenbuf[0] = '%';
4879 /* Warn about @ where they meant $. */
4880 if (*s == '[' || *s == '{') {
4881 if (ckWARN(WARN_SYNTAX)) {
4882 const char *t = s + 1;
4883 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4885 if (*t == '}' || *t == ']') {
4887 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4888 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4889 "Scalar value %.*s better written as $%.*s",
4890 (int)(t-PL_bufptr), PL_bufptr,
4891 (int)(t-PL_bufptr-1), PL_bufptr+1);
4896 PL_pending_ident = '@';
4899 case '/': /* may be division, defined-or, or pattern */
4900 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4904 case '?': /* may either be conditional or pattern */
4905 if(PL_expect == XOPERATOR) {
4913 /* A // operator. */
4923 /* Disable warning on "study /blah/" */
4924 if (PL_oldoldbufptr == PL_last_uni
4925 && (*PL_last_uni != 's' || s - PL_last_uni < 5
4926 || memNE(PL_last_uni, "study", 5)
4927 || isALNUM_lazy_if(PL_last_uni+5,UTF)
4930 s = scan_pat(s,OP_MATCH);
4931 TERM(sublex_start());
4935 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4936 #ifdef PERL_STRICT_CR
4939 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4941 && (s == PL_linestart || s[-1] == '\n') )
4943 PL_lex_formbrack = 0;
4947 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4953 yylval.ival = OPf_SPECIAL;
4959 if (PL_expect != XOPERATOR)
4964 case '0': case '1': case '2': case '3': case '4':
4965 case '5': case '6': case '7': case '8': case '9':
4966 s = scan_num(s, &yylval);
4967 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
4968 if (PL_expect == XOPERATOR)
4973 s = scan_str(s,!!PL_madskills,FALSE);
4974 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4975 if (PL_expect == XOPERATOR) {
4976 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4978 deprecate_old(commaless_variable_list);
4979 return REPORT(','); /* grandfather non-comma-format format */
4986 yylval.ival = OP_CONST;
4987 TERM(sublex_start());
4990 s = scan_str(s,!!PL_madskills,FALSE);
4991 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4992 if (PL_expect == XOPERATOR) {
4993 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4995 deprecate_old(commaless_variable_list);
4996 return REPORT(','); /* grandfather non-comma-format format */
5003 yylval.ival = OP_CONST;
5004 /* FIXME. I think that this can be const if char *d is replaced by
5005 more localised variables. */
5006 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5007 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5008 yylval.ival = OP_STRINGIFY;
5012 TERM(sublex_start());
5015 s = scan_str(s,!!PL_madskills,FALSE);
5016 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5017 if (PL_expect == XOPERATOR)
5018 no_op("Backticks",s);
5021 readpipe_override();
5022 TERM(sublex_start());
5026 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5027 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5029 if (PL_expect == XOPERATOR)
5030 no_op("Backslash",s);
5034 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5035 char *start = s + 2;
5036 while (isDIGIT(*start) || *start == '_')
5038 if (*start == '.' && isDIGIT(start[1])) {
5039 s = scan_num(s, &yylval);
5042 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5043 else if (!isALPHA(*start) && (PL_expect == XTERM
5044 || PL_expect == XREF || PL_expect == XSTATE
5045 || PL_expect == XTERMORDORDOR)) {
5046 /* XXX Use gv_fetchpvn rather than stomping on a const string */
5047 const char c = *start;
5050 gv = gv_fetchpv(s, 0, SVt_PVCV);
5053 s = scan_num(s, &yylval);
5060 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5102 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5104 /* Some keywords can be followed by any delimiter, including ':' */
5105 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5106 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5107 (PL_tokenbuf[0] == 'q' &&
5108 strchr("qwxr", PL_tokenbuf[1])))));
5110 /* x::* is just a word, unless x is "CORE" */
5111 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5115 while (d < PL_bufend && isSPACE(*d))
5116 d++; /* no comments skipped here, or s### is misparsed */
5118 /* Is this a label? */
5119 if (!tmp && PL_expect == XSTATE
5120 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5122 yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5127 /* Check for keywords */
5128 tmp = keyword(PL_tokenbuf, len, 0);
5130 /* Is this a word before a => operator? */
5131 if (*d == '=' && d[1] == '>') {
5134 = (OP*)newSVOP(OP_CONST, 0,
5135 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5136 yylval.opval->op_private = OPpCONST_BARE;
5140 if (tmp < 0) { /* second-class keyword? */
5141 GV *ogv = NULL; /* override (winner) */
5142 GV *hgv = NULL; /* hidden (loser) */
5143 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5145 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5148 if (GvIMPORTED_CV(gv))
5150 else if (! CvMETHOD(cv))
5154 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5155 (gv = *gvp) != (GV*)&PL_sv_undef &&
5156 GvCVu(gv) && GvIMPORTED_CV(gv))
5163 tmp = 0; /* overridden by import or by GLOBAL */
5166 && -tmp==KEY_lock /* XXX generalizable kludge */
5168 && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
5170 tmp = 0; /* any sub overrides "weak" keyword */
5172 else { /* no override */
5174 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5175 Perl_warner(aTHX_ packWARN(WARN_MISC),
5176 "dump() better written as CORE::dump()");
5180 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5181 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
5182 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5183 "Ambiguous call resolved as CORE::%s(), %s",
5184 GvENAME(hgv), "qualify as such or use &");
5191 default: /* not a keyword */
5192 /* Trade off - by using this evil construction we can pull the
5193 variable gv into the block labelled keylookup. If not, then
5194 we have to give it function scope so that the goto from the
5195 earlier ':' case doesn't bypass the initialisation. */
5197 just_a_word_zero_gv:
5205 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5208 SV *nextPL_nextwhite = 0;
5212 /* Get the rest if it looks like a package qualifier */
5214 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5216 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5219 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5220 *s == '\'' ? "'" : "::");
5225 if (PL_expect == XOPERATOR) {
5226 if (PL_bufptr == PL_linestart) {
5227 CopLINE_dec(PL_curcop);
5228 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5229 CopLINE_inc(PL_curcop);
5232 no_op("Bareword",s);
5235 /* Look for a subroutine with this name in current package,
5236 unless name is "Foo::", in which case Foo is a bearword
5237 (and a package name). */
5239 if (len > 2 && !PL_madskills &&
5240 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5242 if (ckWARN(WARN_BAREWORD)
5243 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5244 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5245 "Bareword \"%s\" refers to nonexistent package",
5248 PL_tokenbuf[len] = '\0';
5254 /* Mustn't actually add anything to a symbol table.
5255 But also don't want to "initialise" any placeholder
5256 constants that might already be there into full
5257 blown PVGVs with attached PVCV. */
5258 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5259 GV_NOADD_NOINIT, SVt_PVCV);
5264 /* if we saw a global override before, get the right name */
5267 sv = newSVpvs("CORE::GLOBAL::");
5268 sv_catpv(sv,PL_tokenbuf);
5271 /* If len is 0, newSVpv does strlen(), which is correct.
5272 If len is non-zero, then it will be the true length,
5273 and so the scalar will be created correctly. */
5274 sv = newSVpv(PL_tokenbuf,len);
5277 if (PL_madskills && !PL_thistoken) {
5278 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5279 PL_thistoken = newSVpv(start,s - start);
5280 PL_realtokenstart = s - SvPVX(PL_linestr);
5284 /* Presume this is going to be a bareword of some sort. */
5287 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5288 yylval.opval->op_private = OPpCONST_BARE;
5289 /* UTF-8 package name? */
5290 if (UTF && !IN_BYTES &&
5291 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5294 /* And if "Foo::", then that's what it certainly is. */
5299 /* Do the explicit type check so that we don't need to force
5300 the initialisation of the symbol table to have a real GV.
5301 Beware - gv may not really be a PVGV, cv may not really be
5302 a PVCV, (because of the space optimisations that gv_init
5303 understands) But they're true if for this symbol there is
5304 respectively a typeglob and a subroutine.
5306 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5307 /* Real typeglob, so get the real subroutine: */
5309 /* A proxy for a subroutine in this package? */
5310 : SvOK(gv) ? (CV *) gv : NULL)
5313 /* See if it's the indirect object for a list operator. */
5315 if (PL_oldoldbufptr &&
5316 PL_oldoldbufptr < PL_bufptr &&
5317 (PL_oldoldbufptr == PL_last_lop
5318 || PL_oldoldbufptr == PL_last_uni) &&
5319 /* NO SKIPSPACE BEFORE HERE! */
5320 (PL_expect == XREF ||
5321 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5323 bool immediate_paren = *s == '(';
5325 /* (Now we can afford to cross potential line boundary.) */
5326 s = SKIPSPACE2(s,nextPL_nextwhite);
5328 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5331 /* Two barewords in a row may indicate method call. */
5333 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5334 (tmp = intuit_method(s, gv, cv)))
5337 /* If not a declared subroutine, it's an indirect object. */
5338 /* (But it's an indir obj regardless for sort.) */
5339 /* Also, if "_" follows a filetest operator, it's a bareword */
5342 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5344 (PL_last_lop_op != OP_MAPSTART &&
5345 PL_last_lop_op != OP_GREPSTART))))
5346 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5347 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5350 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5355 PL_expect = XOPERATOR;
5358 s = SKIPSPACE2(s,nextPL_nextwhite);
5359 PL_nextwhite = nextPL_nextwhite;
5364 /* Is this a word before a => operator? */
5365 if (*s == '=' && s[1] == '>' && !pkgname) {
5367 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5368 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5369 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5373 /* If followed by a paren, it's certainly a subroutine. */
5378 while (SPACE_OR_TAB(*d))
5380 if (*d == ')' && (sv = gv_const_sv(gv))) {
5384 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5385 sv_catpvn(PL_thistoken, par, s - par);
5387 sv_free(PL_nextwhite);
5397 PL_nextwhite = PL_thiswhite;
5400 start_force(PL_curforce);
5402 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5403 PL_expect = XOPERATOR;
5406 PL_nextwhite = nextPL_nextwhite;
5407 curmad('X', PL_thistoken);
5408 PL_thistoken = newSVpvs("");
5416 /* If followed by var or block, call it a method (unless sub) */
5418 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5419 PL_last_lop = PL_oldbufptr;
5420 PL_last_lop_op = OP_METHOD;
5424 /* If followed by a bareword, see if it looks like indir obj. */
5427 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5428 && (tmp = intuit_method(s, gv, cv)))
5431 /* Not a method, so call it a subroutine (if defined) */
5434 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5435 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5436 "Ambiguous use of -%s resolved as -&%s()",
5437 PL_tokenbuf, PL_tokenbuf);
5438 /* Check for a constant sub */
5439 if ((sv = gv_const_sv(gv))) {
5441 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5442 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5443 yylval.opval->op_private = 0;
5447 /* Resolve to GV now. */
5448 if (SvTYPE(gv) != SVt_PVGV) {
5449 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5450 assert (SvTYPE(gv) == SVt_PVGV);
5451 /* cv must have been some sort of placeholder, so
5452 now needs replacing with a real code reference. */
5456 op_free(yylval.opval);
5457 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5458 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5459 PL_last_lop = PL_oldbufptr;
5460 PL_last_lop_op = OP_ENTERSUB;
5461 /* Is there a prototype? */
5469 const char *proto = SvPV_const((SV*)cv, protolen);
5472 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5474 while (*proto == ';')
5476 if (*proto == '&' && *s == '{') {
5477 sv_setpv(PL_subname,
5480 "__ANON__" : "__ANON__::__ANON__"));
5487 PL_nextwhite = PL_thiswhite;
5490 start_force(PL_curforce);
5491 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5494 PL_nextwhite = nextPL_nextwhite;
5495 curmad('X', PL_thistoken);
5496 PL_thistoken = newSVpvs("");
5503 /* Guess harder when madskills require "best effort". */
5504 if (PL_madskills && (!gv || !GvCVu(gv))) {
5505 int probable_sub = 0;
5506 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5508 else if (isALPHA(*s)) {
5512 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5513 if (!keyword(tmpbuf, tmplen, 0))
5516 while (d < PL_bufend && isSPACE(*d))
5518 if (*d == '=' && d[1] == '>')
5523 gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
5524 op_free(yylval.opval);
5525 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5526 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5527 PL_last_lop = PL_oldbufptr;
5528 PL_last_lop_op = OP_ENTERSUB;
5529 PL_nextwhite = PL_thiswhite;
5531 start_force(PL_curforce);
5532 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5534 PL_nextwhite = nextPL_nextwhite;
5535 curmad('X', PL_thistoken);
5536 PL_thistoken = newSVpvs("");
5541 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5548 /* Call it a bare word */
5550 if (PL_hints & HINT_STRICT_SUBS)
5551 yylval.opval->op_private |= OPpCONST_STRICT;
5554 if (lastchar != '-') {
5555 if (ckWARN(WARN_RESERVED)) {
5559 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5560 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5567 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5568 && ckWARN_d(WARN_AMBIGUOUS)) {
5569 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5570 "Operator or semicolon missing before %c%s",
5571 lastchar, PL_tokenbuf);
5572 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5573 "Ambiguous use of %c resolved as operator %c",
5574 lastchar, lastchar);
5580 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5581 newSVpv(CopFILE(PL_curcop),0));
5585 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5586 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5589 case KEY___PACKAGE__:
5590 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5592 ? newSVhek(HvNAME_HEK(PL_curstash))
5599 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5600 const char *pname = "main";
5601 if (PL_tokenbuf[2] == 'D')
5602 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5603 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5607 GvIOp(gv) = newIO();
5608 IoIFP(GvIOp(gv)) = PL_rsfp;
5609 #if defined(HAS_FCNTL) && defined(F_SETFD)
5611 const int fd = PerlIO_fileno(PL_rsfp);
5612 fcntl(fd,F_SETFD,fd >= 3);
5615 /* Mark this internal pseudo-handle as clean */
5616 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5618 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5619 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5620 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5622 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5623 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5624 /* if the script was opened in binmode, we need to revert
5625 * it to text mode for compatibility; but only iff it has CRs
5626 * XXX this is a questionable hack at best. */
5627 if (PL_bufend-PL_bufptr > 2
5628 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5631 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5632 loc = PerlIO_tell(PL_rsfp);
5633 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5636 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5638 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5639 #endif /* NETWARE */
5640 #ifdef PERLIO_IS_STDIO /* really? */
5641 # if defined(__BORLANDC__)
5642 /* XXX see note in do_binmode() */
5643 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5647 PerlIO_seek(PL_rsfp, loc, 0);
5651 #ifdef PERLIO_LAYERS
5654 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5655 else if (PL_encoding) {
5662 XPUSHs(PL_encoding);
5664 call_method("name", G_SCALAR);
5668 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5669 Perl_form(aTHX_ ":encoding(%"SVf")",
5678 if (PL_realtokenstart >= 0) {
5679 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5681 PL_endwhite = newSVpvs("");
5682 sv_catsv(PL_endwhite, PL_thiswhite);
5684 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5685 PL_realtokenstart = -1;
5687 while ((s = filter_gets(PL_endwhite, PL_rsfp,
5688 SvCUR(PL_endwhite))) != Nullch) ;
5703 if (PL_expect == XSTATE) {
5710 if (*s == ':' && s[1] == ':') {
5713 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5714 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5715 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5718 else if (tmp == KEY_require || tmp == KEY_do)
5719 /* that's a way to remember we saw "CORE::" */
5732 LOP(OP_ACCEPT,XTERM);
5738 LOP(OP_ATAN2,XTERM);
5744 LOP(OP_BINMODE,XTERM);
5747 LOP(OP_BLESS,XTERM);
5756 /* When 'use switch' is in effect, continue has a dual
5757 life as a control operator. */
5759 if (!FEATURE_IS_ENABLED("switch"))
5762 /* We have to disambiguate the two senses of
5763 "continue". If the next token is a '{' then
5764 treat it as the start of a continue block;
5765 otherwise treat it as a control operator.
5777 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5794 if (!PL_cryptseen) {
5795 PL_cryptseen = TRUE;
5799 LOP(OP_CRYPT,XTERM);
5802 LOP(OP_CHMOD,XTERM);
5805 LOP(OP_CHOWN,XTERM);
5808 LOP(OP_CONNECT,XTERM);
5827 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5828 if (orig_keyword == KEY_do) {
5837 PL_hints |= HINT_BLOCK_SCOPE;
5847 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5848 LOP(OP_DBMOPEN,XTERM);
5854 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5861 yylval.ival = CopLINE(PL_curcop);
5877 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5878 UNIBRACK(OP_ENTEREVAL);
5896 case KEY_endhostent:
5902 case KEY_endservent:
5905 case KEY_endprotoent:
5916 yylval.ival = CopLINE(PL_curcop);
5918 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5921 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5924 if ((PL_bufend - p) >= 3 &&
5925 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5927 else if ((PL_bufend - p) >= 4 &&
5928 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5931 if (isIDFIRST_lazy_if(p,UTF)) {
5932 p = scan_ident(p, PL_bufend,
5933 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5937 Perl_croak(aTHX_ "Missing $ on loop variable");
5939 s = SvPVX(PL_linestr) + soff;
5945 LOP(OP_FORMLINE,XTERM);
5951 LOP(OP_FCNTL,XTERM);
5957 LOP(OP_FLOCK,XTERM);
5966 LOP(OP_GREPSTART, XREF);
5969 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5984 case KEY_getpriority:
5985 LOP(OP_GETPRIORITY,XTERM);
5987 case KEY_getprotobyname:
5990 case KEY_getprotobynumber:
5991 LOP(OP_GPBYNUMBER,XTERM);
5993 case KEY_getprotoent:
6005 case KEY_getpeername:
6006 UNI(OP_GETPEERNAME);
6008 case KEY_gethostbyname:
6011 case KEY_gethostbyaddr:
6012 LOP(OP_GHBYADDR,XTERM);
6014 case KEY_gethostent:
6017 case KEY_getnetbyname:
6020 case KEY_getnetbyaddr:
6021 LOP(OP_GNBYADDR,XTERM);
6026 case KEY_getservbyname:
6027 LOP(OP_GSBYNAME,XTERM);
6029 case KEY_getservbyport:
6030 LOP(OP_GSBYPORT,XTERM);
6032 case KEY_getservent:
6035 case KEY_getsockname:
6036 UNI(OP_GETSOCKNAME);
6038 case KEY_getsockopt:
6039 LOP(OP_GSOCKOPT,XTERM);
6054 yylval.ival = CopLINE(PL_curcop);
6065 yylval.ival = CopLINE(PL_curcop);
6069 LOP(OP_INDEX,XTERM);
6075 LOP(OP_IOCTL,XTERM);
6087 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6119 LOP(OP_LISTEN,XTERM);
6128 s = scan_pat(s,OP_MATCH);
6129 TERM(sublex_start());
6132 LOP(OP_MAPSTART, XREF);
6135 LOP(OP_MKDIR,XTERM);
6138 LOP(OP_MSGCTL,XTERM);
6141 LOP(OP_MSGGET,XTERM);
6144 LOP(OP_MSGRCV,XTERM);
6147 LOP(OP_MSGSND,XTERM);
6154 if (isIDFIRST_lazy_if(s,UTF)) {
6158 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6159 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6161 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6162 if (!PL_in_my_stash) {
6165 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6169 if (PL_madskills) { /* just add type to declarator token */
6170 sv_catsv(PL_thistoken, PL_nextwhite);
6172 sv_catpvn(PL_thistoken, start, s - start);
6180 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6187 s = tokenize_use(0, s);
6191 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6198 if (isIDFIRST_lazy_if(s,UTF)) {
6200 for (d = s; isALNUM_lazy_if(d,UTF);)
6202 for (t=d; isSPACE(*t);)
6204 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6206 && !(t[0] == '=' && t[1] == '>')
6208 int parms_len = (int)(d-s);
6209 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6210 "Precedence problem: open %.*s should be open(%.*s)",
6211 parms_len, s, parms_len, s);
6217 yylval.ival = OP_OR;
6227 LOP(OP_OPEN_DIR,XTERM);
6230 checkcomma(s,PL_tokenbuf,"filehandle");
6234 checkcomma(s,PL_tokenbuf,"filehandle");
6253 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6257 LOP(OP_PIPE_OP,XTERM);
6260 s = scan_str(s,!!PL_madskills,FALSE);
6263 yylval.ival = OP_CONST;
6264 TERM(sublex_start());
6270 s = scan_str(s,!!PL_madskills,FALSE);
6273 PL_expect = XOPERATOR;
6275 if (SvCUR(PL_lex_stuff)) {
6278 d = SvPV_force(PL_lex_stuff, len);
6280 for (; isSPACE(*d) && len; --len, ++d)
6285 if (!warned && ckWARN(WARN_QW)) {
6286 for (; !isSPACE(*d) && len; --len, ++d) {
6288 Perl_warner(aTHX_ packWARN(WARN_QW),
6289 "Possible attempt to separate words with commas");
6292 else if (*d == '#') {
6293 Perl_warner(aTHX_ packWARN(WARN_QW),
6294 "Possible attempt to put comments in qw() list");
6300 for (; !isSPACE(*d) && len; --len, ++d)
6303 sv = newSVpvn(b, d-b);
6304 if (DO_UTF8(PL_lex_stuff))
6306 words = append_elem(OP_LIST, words,
6307 newSVOP(OP_CONST, 0, tokeq(sv)));
6311 start_force(PL_curforce);
6312 NEXTVAL_NEXTTOKE.opval = words;
6317 SvREFCNT_dec(PL_lex_stuff);
6318 PL_lex_stuff = NULL;
6324 s = scan_str(s,!!PL_madskills,FALSE);
6327 yylval.ival = OP_STRINGIFY;
6328 if (SvIVX(PL_lex_stuff) == '\'')
6329 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6330 TERM(sublex_start());
6333 s = scan_pat(s,OP_QR);
6334 TERM(sublex_start());
6337 s = scan_str(s,!!PL_madskills,FALSE);
6340 readpipe_override();
6341 TERM(sublex_start());
6349 s = force_version(s, FALSE);
6351 else if (*s != 'v' || !isDIGIT(s[1])
6352 || (s = force_version(s, TRUE), *s == 'v'))
6354 *PL_tokenbuf = '\0';
6355 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6356 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6357 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6359 yyerror("<> should be quotes");
6361 if (orig_keyword == KEY_require) {
6369 PL_last_uni = PL_oldbufptr;
6370 PL_last_lop_op = OP_REQUIRE;
6372 return REPORT( (int)REQUIRE );
6378 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6382 LOP(OP_RENAME,XTERM);
6391 LOP(OP_RINDEX,XTERM);
6401 UNIDOR(OP_READLINE);
6414 LOP(OP_REVERSE,XTERM);
6417 UNIDOR(OP_READLINK);
6425 TERM(sublex_start());
6427 TOKEN(1); /* force error */
6430 checkcomma(s,PL_tokenbuf,"filehandle");
6440 LOP(OP_SELECT,XTERM);
6446 LOP(OP_SEMCTL,XTERM);
6449 LOP(OP_SEMGET,XTERM);
6452 LOP(OP_SEMOP,XTERM);
6458 LOP(OP_SETPGRP,XTERM);
6460 case KEY_setpriority:
6461 LOP(OP_SETPRIORITY,XTERM);
6463 case KEY_sethostent:
6469 case KEY_setservent:
6472 case KEY_setprotoent:
6482 LOP(OP_SEEKDIR,XTERM);
6484 case KEY_setsockopt:
6485 LOP(OP_SSOCKOPT,XTERM);
6491 LOP(OP_SHMCTL,XTERM);
6494 LOP(OP_SHMGET,XTERM);
6497 LOP(OP_SHMREAD,XTERM);
6500 LOP(OP_SHMWRITE,XTERM);
6503 LOP(OP_SHUTDOWN,XTERM);
6512 LOP(OP_SOCKET,XTERM);
6514 case KEY_socketpair:
6515 LOP(OP_SOCKPAIR,XTERM);
6518 checkcomma(s,PL_tokenbuf,"subroutine name");
6520 if (*s == ';' || *s == ')') /* probably a close */
6521 Perl_croak(aTHX_ "sort is now a reserved word");
6523 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6527 LOP(OP_SPLIT,XTERM);
6530 LOP(OP_SPRINTF,XTERM);
6533 LOP(OP_SPLICE,XTERM);
6548 LOP(OP_SUBSTR,XTERM);
6554 char tmpbuf[sizeof PL_tokenbuf];
6555 SSize_t tboffset = 0;
6556 expectation attrful;
6557 bool have_name, have_proto;
6558 const int key = tmp;
6563 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6564 SV *subtoken = newSVpvn(tstart, s - tstart);
6568 s = SKIPSPACE2(s,tmpwhite);
6573 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6574 (*s == ':' && s[1] == ':'))
6581 attrful = XATTRBLOCK;
6582 /* remember buffer pos'n for later force_word */
6583 tboffset = s - PL_oldbufptr;
6584 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6587 nametoke = newSVpvn(s, d - s);
6589 if (strchr(tmpbuf, ':'))
6590 sv_setpv(PL_subname, tmpbuf);
6592 sv_setsv(PL_subname,PL_curstname);
6593 sv_catpvs(PL_subname,"::");
6594 sv_catpvn(PL_subname,tmpbuf,len);
6601 CURMAD('X', nametoke);
6602 CURMAD('_', tmpwhite);
6603 (void) force_word(PL_oldbufptr + tboffset, WORD,
6606 s = SKIPSPACE2(d,tmpwhite);
6613 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6614 PL_expect = XTERMBLOCK;
6615 attrful = XATTRTERM;
6616 sv_setpvn(PL_subname,"?",1);
6620 if (key == KEY_format) {
6622 PL_lex_formbrack = PL_lex_brackets + 1;
6624 PL_thistoken = subtoken;
6628 (void) force_word(PL_oldbufptr + tboffset, WORD,
6634 /* Look for a prototype */
6637 bool bad_proto = FALSE;
6638 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6640 s = scan_str(s,!!PL_madskills,FALSE);
6642 Perl_croak(aTHX_ "Prototype not terminated");
6643 /* strip spaces and check for bad characters */
6644 d = SvPVX(PL_lex_stuff);
6646 for (p = d; *p; ++p) {
6649 if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
6655 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6656 "Illegal character in prototype for %"SVf" : %s",
6657 SVfARG(PL_subname), d);
6658 SvCUR_set(PL_lex_stuff, tmp);
6663 CURMAD('q', PL_thisopen);
6664 CURMAD('_', tmpwhite);
6665 CURMAD('=', PL_thisstuff);
6666 CURMAD('Q', PL_thisclose);
6667 NEXTVAL_NEXTTOKE.opval =
6668 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6669 PL_lex_stuff = Nullsv;
6672 s = SKIPSPACE2(s,tmpwhite);
6680 if (*s == ':' && s[1] != ':')
6681 PL_expect = attrful;
6682 else if (*s != '{' && key == KEY_sub) {
6684 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6686 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6693 curmad('^', newSVpvs(""));
6694 CURMAD('_', tmpwhite);
6698 PL_thistoken = subtoken;
6701 NEXTVAL_NEXTTOKE.opval =
6702 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6703 PL_lex_stuff = NULL;
6708 sv_setpv(PL_subname,
6710 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
6714 (void) force_word(PL_oldbufptr + tboffset, WORD,
6724 LOP(OP_SYSTEM,XREF);
6727 LOP(OP_SYMLINK,XTERM);
6730 LOP(OP_SYSCALL,XTERM);
6733 LOP(OP_SYSOPEN,XTERM);
6736 LOP(OP_SYSSEEK,XTERM);
6739 LOP(OP_SYSREAD,XTERM);
6742 LOP(OP_SYSWRITE,XTERM);
6746 TERM(sublex_start());
6767 LOP(OP_TRUNCATE,XTERM);
6779 yylval.ival = CopLINE(PL_curcop);
6783 yylval.ival = CopLINE(PL_curcop);
6787 LOP(OP_UNLINK,XTERM);
6793 LOP(OP_UNPACK,XTERM);
6796 LOP(OP_UTIME,XTERM);
6802 LOP(OP_UNSHIFT,XTERM);
6805 s = tokenize_use(1, s);
6815 yylval.ival = CopLINE(PL_curcop);
6819 yylval.ival = CopLINE(PL_curcop);
6823 PL_hints |= HINT_BLOCK_SCOPE;
6830 LOP(OP_WAITPID,XTERM);
6839 ctl_l[0] = toCTRL('L');
6841 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6844 /* Make sure $^L is defined */
6845 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6850 if (PL_expect == XOPERATOR)
6856 yylval.ival = OP_XOR;
6861 TERM(sublex_start());
6866 #pragma segment Main
6870 S_pending_ident(pTHX)
6875 /* pit holds the identifier we read and pending_ident is reset */
6876 char pit = PL_pending_ident;
6877 PL_pending_ident = 0;
6879 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6880 DEBUG_T({ PerlIO_printf(Perl_debug_log,
6881 "### Pending identifier '%s'\n", PL_tokenbuf); });
6883 /* if we're in a my(), we can't allow dynamics here.
6884 $foo'bar has already been turned into $foo::bar, so
6885 just check for colons.
6887 if it's a legal name, the OP is a PADANY.
6890 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
6891 if (strchr(PL_tokenbuf,':'))
6892 yyerror(Perl_form(aTHX_ "No package name allowed for "
6893 "variable %s in \"our\"",
6895 tmp = allocmy(PL_tokenbuf);
6898 if (strchr(PL_tokenbuf,':'))
6899 yyerror(Perl_form(aTHX_ PL_no_myglob,
6900 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
6902 yylval.opval = newOP(OP_PADANY, 0);
6903 yylval.opval->op_targ = allocmy(PL_tokenbuf);
6909 build the ops for accesses to a my() variable.
6911 Deny my($a) or my($b) in a sort block, *if* $a or $b is
6912 then used in a comparison. This catches most, but not
6913 all cases. For instance, it catches
6914 sort { my($a); $a <=> $b }
6916 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6917 (although why you'd do that is anyone's guess).
6920 if (!strchr(PL_tokenbuf,':')) {
6922 tmp = pad_findmy(PL_tokenbuf);
6923 if (tmp != NOT_IN_PAD) {
6924 /* might be an "our" variable" */
6925 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6926 /* build ops for a bareword */
6927 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
6928 HEK * const stashname = HvNAME_HEK(stash);
6929 SV * const sym = newSVhek(stashname);
6930 sv_catpvs(sym, "::");
6931 sv_catpv(sym, PL_tokenbuf+1);
6932 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6933 yylval.opval->op_private = OPpCONST_ENTERED;
6936 ? (GV_ADDMULTI | GV_ADDINEVAL)
6939 ((PL_tokenbuf[0] == '$') ? SVt_PV
6940 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6945 /* if it's a sort block and they're naming $a or $b */
6946 if (PL_last_lop_op == OP_SORT &&
6947 PL_tokenbuf[0] == '$' &&
6948 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
6951 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
6952 d < PL_bufend && *d != '\n';
6955 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
6956 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
6962 yylval.opval = newOP(OP_PADANY, 0);
6963 yylval.opval->op_targ = tmp;
6969 Whine if they've said @foo in a doublequoted string,
6970 and @foo isn't a variable we can find in the symbol
6973 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
6974 GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
6975 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
6976 && ckWARN(WARN_AMBIGUOUS))
6978 /* Downgraded from fatal to warning 20000522 mjd */
6979 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6980 "Possible unintended interpolation of %s in string",
6985 /* build ops for a bareword */
6986 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
6987 yylval.opval->op_private = OPpCONST_ENTERED;
6990 /* If the identifier refers to a stash, don't autovivify it.
6991 * Change 24660 had the side effect of causing symbol table
6992 * hashes to always be defined, even if they were freshly
6993 * created and the only reference in the entire program was
6994 * the single statement with the defined %foo::bar:: test.
6995 * It appears that all code in the wild doing this actually
6996 * wants to know whether sub-packages have been loaded, so
6997 * by avoiding auto-vivifying symbol tables, we ensure that
6998 * defined %foo::bar:: continues to be false, and the existing
6999 * tests still give the expected answers, even though what
7000 * they're actually testing has now changed subtly.
7002 (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
7004 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7005 ((PL_tokenbuf[0] == '$') ? SVt_PV
7006 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7012 * The following code was generated by perl_keyword.pl.
7016 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7021 case 1: /* 5 tokens of length 1 */
7053 case 2: /* 18 tokens of length 2 */
7199 case 3: /* 29 tokens of length 3 */
7203 if (name[1] == 'N' &&
7266 if (name[1] == 'i' &&
7288 return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7306 if (name[1] == 'o' &&
7315 if (name[1] == 'e' &&
7324 if (name[1] == 'n' &&
7333 if (name[1] == 'o' &&
7342 if (name[1] == 'a' &&
7351 if (name[1] == 'o' &&
7413 if (name[1] == 'e' &&
7427 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7453 if (name[1] == 'i' &&
7462 if (name[1] == 's' &&
7471 if (name[1] == 'e' &&
7480 if (name[1] == 'o' &&
7492 case 4: /* 41 tokens of length 4 */
7496 if (name[1] == 'O' &&
7506 if (name[1] == 'N' &&
7516 if (name[1] == 'i' &&
7526 if (name[1] == 'h' &&
7536 if (name[1] == 'u' &&
7549 if (name[2] == 'c' &&
7558 if (name[2] == 's' &&
7567 if (name[2] == 'a' &&
7603 if (name[1] == 'o' &&
7616 if (name[2] == 't' &&
7625 if (name[2] == 'o' &&
7634 if (name[2] == 't' &&
7643 if (name[2] == 'e' &&
7656 if (name[1] == 'o' &&
7669 if (name[2] == 'y' &&
7678 if (name[2] == 'l' &&
7694 if (name[2] == 's' &&
7703 if (name[2] == 'n' &&
7712 if (name[2] == 'c' &&
7725 if (name[1] == 'e' &&
7735 if (name[1] == 'p' &&
7748 if (name[2] == 'c' &&
7757 if (name[2] == 'p' &&
7766 if (name[2] == 's' &&
7782 if (name[2] == 'n' &&
7852 if (name[2] == 'r' &&
7861 if (name[2] == 'r' &&
7870 if (name[2] == 'a' &&
7886 if (name[2] == 'l' &&
7948 if (name[2] == 'e' &&
7951 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
7964 case 5: /* 39 tokens of length 5 */
7968 if (name[1] == 'E' &&
7979 if (name[1] == 'H' &&
7993 if (name[2] == 'a' &&
8003 if (name[2] == 'a' &&
8020 if (name[2] == 'e' &&
8030 if (name[2] == 'e' &&
8034 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8050 if (name[3] == 'i' &&
8059 if (name[3] == 'o' &&
8095 if (name[2] == 'o' &&
8105 if (name[2] == 'y' &&
8119 if (name[1] == 'l' &&
8133 if (name[2] == 'n' &&
8143 if (name[2] == 'o' &&
8157 if (name[1] == 'i' &&
8162 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8171 if (name[2] == 'd' &&
8181 if (name[2] == 'c' &&
8198 if (name[2] == 'c' &&
8208 if (name[2] == 't' &&
8222 if (name[1] == 'k' &&
8233 if (name[1] == 'r' &&
8247 if (name[2] == 's' &&
8257 if (name[2] == 'd' &&
8274 if (name[2] == 'm' &&
8284 if (name[2] == 'i' &&
8294 if (name[2] == 'e' &&
8304 if (name[2] == 'l' &&
8314 if (name[2] == 'a' &&
8327 if (name[3] == 't' &&
8330 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8336 if (name[3] == 'd' &&
8353 if (name[1] == 'i' &&
8367 if (name[2] == 'a' &&
8380 if (name[3] == 'e' &&
8415 if (name[2] == 'i' &&
8432 if (name[2] == 'i' &&
8442 if (name[2] == 'i' &&
8459 case 6: /* 33 tokens of length 6 */
8463 if (name[1] == 'c' &&
8478 if (name[2] == 'l' &&
8489 if (name[2] == 'r' &&
8504 if (name[1] == 'e' &&
8519 if (name[2] == 's' &&
8524 if(ckWARN_d(WARN_SYNTAX))
8525 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8531 if (name[2] == 'i' &&
8549 if (name[2] == 'l' &&
8560 if (name[2] == 'r' &&
8575 if (name[1] == 'm' &&
8590 if (name[2] == 'n' &&
8601 if (name[2] == 's' &&
8616 if (name[1] == 's' &&
8622 if (name[4] == 't' &&
8631 if (name[4] == 'e' &&
8640 if (name[4] == 'c' &&
8649 if (name[4] == 'n' &&
8665 if (name[1] == 'r' &&
8683 if (name[3] == 'a' &&
8693 if (name[3] == 'u' &&
8707 if (name[2] == 'n' &&
8725 if (name[2] == 'a' &&
8739 if (name[3] == 'e' &&
8752 if (name[4] == 't' &&
8761 if (name[4] == 'e' &&
8783 if (name[4] == 't' &&
8792 if (name[4] == 'e' &&
8808 if (name[2] == 'c' &&
8819 if (name[2] == 'l' &&
8830 if (name[2] == 'b' &&
8841 if (name[2] == 's' &&
8864 if (name[4] == 's' &&
8873 if (name[4] == 'n' &&
8886 if (name[3] == 'a' &&
8903 if (name[1] == 'a' &&
8918 case 7: /* 29 tokens of length 7 */
8922 if (name[1] == 'E' &&
8935 if (name[1] == '_' &&
8948 if (name[1] == 'i' &&
8955 return -KEY_binmode;
8961 if (name[1] == 'o' &&
8968 return -KEY_connect;
8977 if (name[2] == 'm' &&
8983 return -KEY_dbmopen;
8994 if (name[4] == 'u' &&
8998 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9004 if (name[4] == 'n' &&
9025 if (name[1] == 'o' &&
9038 if (name[1] == 'e' &&
9045 if (name[5] == 'r' &&
9048 return -KEY_getpgrp;
9054 if (name[5] == 'i' &&
9057 return -KEY_getppid;
9070 if (name[1] == 'c' &&
9077 return -KEY_lcfirst;
9083 if (name[1] == 'p' &&
9090 return -KEY_opendir;
9096 if (name[1] == 'a' &&
9114 if (name[3] == 'd' &&
9119 return -KEY_readdir;
9125 if (name[3] == 'u' &&
9136 if (name[3] == 'e' &&
9141 return -KEY_reverse;
9160 if (name[3] == 'k' &&
9165 return -KEY_seekdir;
9171 if (name[3] == 'p' &&
9176 return -KEY_setpgrp;
9186 if (name[2] == 'm' &&
9192 return -KEY_shmread;
9198 if (name[2] == 'r' &&
9204 return -KEY_sprintf;
9213 if (name[3] == 'l' &&
9218 return -KEY_symlink;
9227 if (name[4] == 'a' &&
9231 return -KEY_syscall;
9237 if (name[4] == 'p' &&
9241 return -KEY_sysopen;
9247 if (name[4] == 'e' &&
9251 return -KEY_sysread;
9257 if (name[4] == 'e' &&
9261 return -KEY_sysseek;
9279 if (name[1] == 'e' &&
9286 return -KEY_telldir;
9295 if (name[2] == 'f' &&
9301 return -KEY_ucfirst;
9307 if (name[2] == 's' &&
9313 return -KEY_unshift;
9323 if (name[1] == 'a' &&
9330 return -KEY_waitpid;
9339 case 8: /* 26 tokens of length 8 */
9343 if (name[1] == 'U' &&
9351 return KEY_AUTOLOAD;
9362 if (name[3] == 'A' &&
9368 return KEY___DATA__;
9374 if (name[3] == 'I' &&
9380 return -KEY___FILE__;
9386 if (name[3] == 'I' &&
9392 return -KEY___LINE__;
9408 if (name[2] == 'o' &&
9415 return -KEY_closedir;
9421 if (name[2] == 'n' &&
9428 return -KEY_continue;
9438 if (name[1] == 'b' &&
9446 return -KEY_dbmclose;
9452 if (name[1] == 'n' &&
9458 if (name[4] == 'r' &&
9463 return -KEY_endgrent;
9469 if (name[4] == 'w' &&
9474 return -KEY_endpwent;
9487 if (name[1] == 'o' &&
9495 return -KEY_formline;
9501 if (name[1] == 'e' &&
9512 if (name[6] == 'n' &&
9515 return -KEY_getgrent;
9521 if (name[6] == 'i' &&
9524 return -KEY_getgrgid;
9530 if (name[6] == 'a' &&
9533 return -KEY_getgrnam;
9546 if (name[4] == 'o' &&
9551 return -KEY_getlogin;
9562 if (name[6] == 'n' &&
9565 return -KEY_getpwent;
9571 if (name[6] == 'a' &&
9574 return -KEY_getpwnam;
9580 if (name[6] == 'i' &&
9583 return -KEY_getpwuid;
9603 if (name[1] == 'e' &&
9610 if (name[5] == 'i' &&
9617 return -KEY_readline;
9622 return -KEY_readlink;
9633 if (name[5] == 'i' &&
9637 return -KEY_readpipe;
9658 if (name[4] == 'r' &&
9663 return -KEY_setgrent;
9669 if (name[4] == 'w' &&
9674 return -KEY_setpwent;
9690 if (name[3] == 'w' &&
9696 return -KEY_shmwrite;
9702 if (name[3] == 't' &&
9708 return -KEY_shutdown;
9718 if (name[2] == 's' &&
9725 return -KEY_syswrite;
9735 if (name[1] == 'r' &&
9743 return -KEY_truncate;
9752 case 9: /* 9 tokens of length 9 */
9756 if (name[1] == 'N' &&
9765 return KEY_UNITCHECK;
9771 if (name[1] == 'n' &&
9780 return -KEY_endnetent;
9786 if (name[1] == 'e' &&
9795 return -KEY_getnetent;
9801 if (name[1] == 'o' &&
9810 return -KEY_localtime;
9816 if (name[1] == 'r' &&
9825 return KEY_prototype;
9831 if (name[1] == 'u' &&
9840 return -KEY_quotemeta;
9846 if (name[1] == 'e' &&
9855 return -KEY_rewinddir;
9861 if (name[1] == 'e' &&
9870 return -KEY_setnetent;
9876 if (name[1] == 'a' &&
9885 return -KEY_wantarray;
9894 case 10: /* 9 tokens of length 10 */
9898 if (name[1] == 'n' &&
9904 if (name[4] == 'o' &&
9911 return -KEY_endhostent;
9917 if (name[4] == 'e' &&
9924 return -KEY_endservent;
9937 if (name[1] == 'e' &&
9943 if (name[4] == 'o' &&
9950 return -KEY_gethostent;
9959 if (name[5] == 'r' &&
9965 return -KEY_getservent;
9971 if (name[5] == 'c' &&
9977 return -KEY_getsockopt;
10002 if (name[4] == 'o' &&
10009 return -KEY_sethostent;
10018 if (name[5] == 'r' &&
10024 return -KEY_setservent;
10030 if (name[5] == 'c' &&
10036 return -KEY_setsockopt;
10053 if (name[2] == 'c' &&
10062 return -KEY_socketpair;
10075 case 11: /* 8 tokens of length 11 */
10079 if (name[1] == '_' &&
10089 { /* __PACKAGE__ */
10090 return -KEY___PACKAGE__;
10096 if (name[1] == 'n' &&
10106 { /* endprotoent */
10107 return -KEY_endprotoent;
10113 if (name[1] == 'e' &&
10122 if (name[5] == 'e' &&
10128 { /* getpeername */
10129 return -KEY_getpeername;
10138 if (name[6] == 'o' &&
10143 { /* getpriority */
10144 return -KEY_getpriority;
10150 if (name[6] == 't' &&
10155 { /* getprotoent */
10156 return -KEY_getprotoent;
10170 if (name[4] == 'o' &&
10177 { /* getsockname */
10178 return -KEY_getsockname;
10191 if (name[1] == 'e' &&
10199 if (name[6] == 'o' &&
10204 { /* setpriority */
10205 return -KEY_setpriority;
10211 if (name[6] == 't' &&
10216 { /* setprotoent */
10217 return -KEY_setprotoent;
10233 case 12: /* 2 tokens of length 12 */
10234 if (name[0] == 'g' &&
10246 if (name[9] == 'd' &&
10249 { /* getnetbyaddr */
10250 return -KEY_getnetbyaddr;
10256 if (name[9] == 'a' &&
10259 { /* getnetbyname */
10260 return -KEY_getnetbyname;
10272 case 13: /* 4 tokens of length 13 */
10273 if (name[0] == 'g' &&
10280 if (name[4] == 'o' &&
10289 if (name[10] == 'd' &&
10292 { /* gethostbyaddr */
10293 return -KEY_gethostbyaddr;
10299 if (name[10] == 'a' &&
10302 { /* gethostbyname */
10303 return -KEY_gethostbyname;
10316 if (name[4] == 'e' &&
10325 if (name[10] == 'a' &&
10328 { /* getservbyname */
10329 return -KEY_getservbyname;
10335 if (name[10] == 'o' &&
10338 { /* getservbyport */
10339 return -KEY_getservbyport;
10358 case 14: /* 1 tokens of length 14 */
10359 if (name[0] == 'g' &&
10373 { /* getprotobyname */
10374 return -KEY_getprotobyname;
10379 case 16: /* 1 tokens of length 16 */
10380 if (name[0] == 'g' &&
10396 { /* getprotobynumber */
10397 return -KEY_getprotobynumber;
10411 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10415 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10416 if (ckWARN(WARN_SYNTAX)) {
10419 for (w = s+2; *w && level; w++) {
10422 else if (*w == ')')
10425 while (isSPACE(*w))
10427 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
10428 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10429 "%s (...) interpreted as function",name);
10432 while (s < PL_bufend && isSPACE(*s))
10436 while (s < PL_bufend && isSPACE(*s))
10438 if (isIDFIRST_lazy_if(s,UTF)) {
10439 const char * const w = s++;
10440 while (isALNUM_lazy_if(s,UTF))
10442 while (s < PL_bufend && isSPACE(*s))
10446 if (keyword(w, s - w, 0))
10449 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10450 if (gv && GvCVu(gv))
10452 Perl_croak(aTHX_ "No comma allowed after %s", what);
10457 /* Either returns sv, or mortalizes sv and returns a new SV*.
10458 Best used as sv=new_constant(..., sv, ...).
10459 If s, pv are NULL, calls subroutine with one argument,
10460 and type is used with error messages only. */
10463 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10467 HV * const table = GvHV(PL_hintgv); /* ^H */
10471 const char *why1 = "", *why2 = "", *why3 = "";
10473 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10476 why2 = (const char *)
10477 (strEQ(key,"charnames")
10478 ? "(possibly a missing \"use charnames ...\")"
10480 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10481 (type ? type: "undef"), why2);
10483 /* This is convoluted and evil ("goto considered harmful")
10484 * but I do not understand the intricacies of all the different
10485 * failure modes of %^H in here. The goal here is to make
10486 * the most probable error message user-friendly. --jhi */
10491 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10492 (type ? type: "undef"), why1, why2, why3);
10494 yyerror(SvPVX_const(msg));
10498 cvp = hv_fetch(table, key, strlen(key), FALSE);
10499 if (!cvp || !SvOK(*cvp)) {
10502 why3 = "} is not defined";
10505 sv_2mortal(sv); /* Parent created it permanently */
10508 pv = sv_2mortal(newSVpvn(s, len));
10510 typesv = sv_2mortal(newSVpv(type, 0));
10512 typesv = &PL_sv_undef;
10514 PUSHSTACKi(PERLSI_OVERLOAD);
10526 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10530 /* Check the eval first */
10531 if (!PL_in_eval && SvTRUE(ERRSV)) {
10532 sv_catpvs(ERRSV, "Propagated");
10533 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10535 res = SvREFCNT_inc_simple(sv);
10539 SvREFCNT_inc_simple_void(res);
10548 why1 = "Call to &{$^H{";
10550 why3 = "}} did not return a defined value";
10558 /* Returns a NUL terminated string, with the length of the string written to
10562 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10565 register char *d = dest;
10566 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10569 Perl_croak(aTHX_ ident_too_long);
10570 if (isALNUM(*s)) /* UTF handled below */
10572 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10577 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10581 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10582 char *t = s + UTF8SKIP(s);
10584 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10588 Perl_croak(aTHX_ ident_too_long);
10589 Copy(s, d, len, char);
10602 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10605 char *bracket = NULL;
10607 register char *d = dest;
10608 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10613 while (isDIGIT(*s)) {
10615 Perl_croak(aTHX_ ident_too_long);
10622 Perl_croak(aTHX_ ident_too_long);
10623 if (isALNUM(*s)) /* UTF handled below */
10625 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10630 else if (*s == ':' && s[1] == ':') {
10634 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10635 char *t = s + UTF8SKIP(s);
10636 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10638 if (d + (t - s) > e)
10639 Perl_croak(aTHX_ ident_too_long);
10640 Copy(s, d, t - s, char);
10651 if (PL_lex_state != LEX_NORMAL)
10652 PL_lex_state = LEX_INTERPENDMAYBE;
10655 if (*s == '$' && s[1] &&
10656 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10669 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10674 if (isSPACE(s[-1])) {
10676 const char ch = *s++;
10677 if (!SPACE_OR_TAB(ch)) {
10683 if (isIDFIRST_lazy_if(d,UTF)) {
10687 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10688 end += UTF8SKIP(end);
10689 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10690 end += UTF8SKIP(end);
10692 Copy(s, d, end - s, char);
10697 while ((isALNUM(*s) || *s == ':') && d < e)
10700 Perl_croak(aTHX_ ident_too_long);
10703 while (s < send && SPACE_OR_TAB(*s))
10705 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10706 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10707 const char * const brack =
10709 ((*s == '[') ? "[...]" : "{...}");
10710 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10711 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10712 funny, dest, brack, funny, dest, brack);
10715 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10719 /* Handle extended ${^Foo} variables
10720 * 1999-02-27 mjd-perl-patch@plover.com */
10721 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10725 while (isALNUM(*s) && d < e) {
10729 Perl_croak(aTHX_ ident_too_long);
10734 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10735 PL_lex_state = LEX_INTERPEND;
10738 if (PL_lex_state == LEX_NORMAL) {
10739 if (ckWARN(WARN_AMBIGUOUS) &&
10740 (keyword(dest, d - dest, 0)
10741 || get_cvn_flags(dest, d - dest, 0)))
10745 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10746 "Ambiguous use of %c{%s} resolved to %c%s",
10747 funny, dest, funny, dest);
10752 s = bracket; /* let the parser handle it */
10756 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10757 PL_lex_state = LEX_INTERPEND;
10762 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10764 PERL_UNUSED_CONTEXT;
10768 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
10769 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
10770 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
10771 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
10772 case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break;
10778 S_scan_pat(pTHX_ char *start, I32 type)
10782 char *s = scan_str(start,!!PL_madskills,FALSE);
10783 const char * const valid_flags =
10784 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10791 const char * const delimiter = skipspace(start);
10795 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10796 : "Search pattern not terminated" ));
10799 pm = (PMOP*)newPMOP(type, 0);
10800 if (PL_multi_open == '?')
10801 pm->op_pmflags |= PMf_ONCE;
10805 while (*s && strchr(valid_flags, *s))
10806 pmflag(&pm->op_pmflags,*s++);
10808 if (PL_madskills && modstart != s) {
10809 SV* tmptoken = newSVpvn(modstart, s - modstart);
10810 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10813 /* issue a warning if /c is specified,but /g is not */
10814 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10815 && ckWARN(WARN_REGEXP))
10817 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
10818 "Use of /c modifier is meaningless without /g" );
10821 pm->op_pmpermflags = pm->op_pmflags;
10823 PL_lex_op = (OP*)pm;
10824 yylval.ival = OP_MATCH;
10829 S_scan_subst(pTHX_ char *start)
10840 yylval.ival = OP_NULL;
10842 s = scan_str(start,!!PL_madskills,FALSE);
10845 Perl_croak(aTHX_ "Substitution pattern not terminated");
10847 if (s[-1] == PL_multi_open)
10850 if (PL_madskills) {
10851 CURMAD('q', PL_thisopen);
10852 CURMAD('_', PL_thiswhite);
10853 CURMAD('E', PL_thisstuff);
10854 CURMAD('Q', PL_thisclose);
10855 PL_realtokenstart = s - SvPVX(PL_linestr);
10859 first_start = PL_multi_start;
10860 s = scan_str(s,!!PL_madskills,FALSE);
10862 if (PL_lex_stuff) {
10863 SvREFCNT_dec(PL_lex_stuff);
10864 PL_lex_stuff = NULL;
10866 Perl_croak(aTHX_ "Substitution replacement not terminated");
10868 PL_multi_start = first_start; /* so whole substitution is taken together */
10870 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10873 if (PL_madskills) {
10874 CURMAD('z', PL_thisopen);
10875 CURMAD('R', PL_thisstuff);
10876 CURMAD('Z', PL_thisclose);
10882 if (*s == EXEC_PAT_MOD) {
10886 else if (strchr(S_PAT_MODS, *s))
10887 pmflag(&pm->op_pmflags,*s++);
10893 if (PL_madskills) {
10895 curmad('m', newSVpvn(modstart, s - modstart));
10896 append_madprops(PL_thismad, (OP*)pm, 0);
10900 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10901 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10905 SV * const repl = newSVpvs("");
10907 PL_sublex_info.super_bufptr = s;
10908 PL_sublex_info.super_bufend = PL_bufend;
10910 pm->op_pmflags |= PMf_EVAL;
10912 sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10913 sv_catpvs(repl, "{");
10914 sv_catsv(repl, PL_lex_repl);
10915 if (strchr(SvPVX(PL_lex_repl), '#'))
10916 sv_catpvs(repl, "\n");
10917 sv_catpvs(repl, "}");
10919 SvREFCNT_dec(PL_lex_repl);
10920 PL_lex_repl = repl;
10923 pm->op_pmpermflags = pm->op_pmflags;
10924 PL_lex_op = (OP*)pm;
10925 yylval.ival = OP_SUBST;
10930 S_scan_trans(pTHX_ char *start)
10943 yylval.ival = OP_NULL;
10945 s = scan_str(start,!!PL_madskills,FALSE);
10947 Perl_croak(aTHX_ "Transliteration pattern not terminated");
10949 if (s[-1] == PL_multi_open)
10952 if (PL_madskills) {
10953 CURMAD('q', PL_thisopen);
10954 CURMAD('_', PL_thiswhite);
10955 CURMAD('E', PL_thisstuff);
10956 CURMAD('Q', PL_thisclose);
10957 PL_realtokenstart = s - SvPVX(PL_linestr);
10961 s = scan_str(s,!!PL_madskills,FALSE);
10963 if (PL_lex_stuff) {
10964 SvREFCNT_dec(PL_lex_stuff);
10965 PL_lex_stuff = NULL;
10967 Perl_croak(aTHX_ "Transliteration replacement not terminated");
10969 if (PL_madskills) {
10970 CURMAD('z', PL_thisopen);
10971 CURMAD('R', PL_thisstuff);
10972 CURMAD('Z', PL_thisclose);
10975 complement = del = squash = 0;
10982 complement = OPpTRANS_COMPLEMENT;
10985 del = OPpTRANS_DELETE;
10988 squash = OPpTRANS_SQUASH;
10997 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
10998 o = newPVOP(OP_TRANS, 0, (char*)tbl);
10999 o->op_private &= ~OPpTRANS_ALL;
11000 o->op_private |= del|squash|complement|
11001 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11002 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11005 yylval.ival = OP_TRANS;
11008 if (PL_madskills) {
11010 curmad('m', newSVpvn(modstart, s - modstart));
11011 append_madprops(PL_thismad, o, 0);
11020 S_scan_heredoc(pTHX_ register char *s)
11024 I32 op_type = OP_SCALAR;
11028 const char *found_newline;
11032 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11034 I32 stuffstart = s - SvPVX(PL_linestr);
11037 PL_realtokenstart = -1;
11042 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11046 while (SPACE_OR_TAB(*peek))
11048 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11051 s = delimcpy(d, e, s, PL_bufend, term, &len);
11061 if (!isALNUM_lazy_if(s,UTF))
11062 deprecate_old("bare << to mean <<\"\"");
11063 for (; isALNUM_lazy_if(s,UTF); s++) {
11068 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11069 Perl_croak(aTHX_ "Delimiter for here document is too long");
11072 len = d - PL_tokenbuf;
11075 if (PL_madskills) {
11076 tstart = PL_tokenbuf + !outer;
11077 PL_thisclose = newSVpvn(tstart, len - !outer);
11078 tstart = SvPVX(PL_linestr) + stuffstart;
11079 PL_thisopen = newSVpvn(tstart, s - tstart);
11080 stuffstart = s - SvPVX(PL_linestr);
11083 #ifndef PERL_STRICT_CR
11084 d = strchr(s, '\r');
11086 char * const olds = s;
11088 while (s < PL_bufend) {
11094 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11103 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11110 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11111 herewas = newSVpvn(s,PL_bufend-s);
11115 herewas = newSVpvn(s-1,found_newline-s+1);
11118 herewas = newSVpvn(s,found_newline-s);
11122 if (PL_madskills) {
11123 tstart = SvPVX(PL_linestr) + stuffstart;
11125 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11127 PL_thisstuff = newSVpvn(tstart, s - tstart);
11130 s += SvCUR(herewas);
11133 stuffstart = s - SvPVX(PL_linestr);
11139 tmpstr = newSV(79);
11140 sv_upgrade(tmpstr, SVt_PVIV);
11141 if (term == '\'') {
11142 op_type = OP_CONST;
11143 SvIV_set(tmpstr, -1);
11145 else if (term == '`') {
11146 op_type = OP_BACKTICK;
11147 SvIV_set(tmpstr, '\\');
11151 PL_multi_start = CopLINE(PL_curcop);
11152 PL_multi_open = PL_multi_close = '<';
11153 term = *PL_tokenbuf;
11154 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11155 char * const bufptr = PL_sublex_info.super_bufptr;
11156 char * const bufend = PL_sublex_info.super_bufend;
11157 char * const olds = s - SvCUR(herewas);
11158 s = strchr(bufptr, '\n');
11162 while (s < bufend &&
11163 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11165 CopLINE_inc(PL_curcop);
11168 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11169 missingterm(PL_tokenbuf);
11171 sv_setpvn(herewas,bufptr,d-bufptr+1);
11172 sv_setpvn(tmpstr,d+1,s-d);
11174 sv_catpvn(herewas,s,bufend-s);
11175 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11182 while (s < PL_bufend &&
11183 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11185 CopLINE_inc(PL_curcop);
11187 if (s >= PL_bufend) {
11188 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11189 missingterm(PL_tokenbuf);
11191 sv_setpvn(tmpstr,d+1,s-d);
11193 if (PL_madskills) {
11195 sv_catpvn(PL_thisstuff, d + 1, s - d);
11197 PL_thisstuff = newSVpvn(d + 1, s - d);
11198 stuffstart = s - SvPVX(PL_linestr);
11202 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11204 sv_catpvn(herewas,s,PL_bufend-s);
11205 sv_setsv(PL_linestr,herewas);
11206 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11207 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11208 PL_last_lop = PL_last_uni = NULL;
11211 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
11212 while (s >= PL_bufend) { /* multiple line string? */
11214 if (PL_madskills) {
11215 tstart = SvPVX(PL_linestr) + stuffstart;
11217 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11219 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11223 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11224 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11225 missingterm(PL_tokenbuf);
11228 stuffstart = s - SvPVX(PL_linestr);
11230 CopLINE_inc(PL_curcop);
11231 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11232 PL_last_lop = PL_last_uni = NULL;
11233 #ifndef PERL_STRICT_CR
11234 if (PL_bufend - PL_linestart >= 2) {
11235 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11236 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11238 PL_bufend[-2] = '\n';
11240 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11242 else if (PL_bufend[-1] == '\r')
11243 PL_bufend[-1] = '\n';
11245 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11246 PL_bufend[-1] = '\n';
11248 if (PERLDB_LINE && PL_curstash != PL_debstash)
11249 update_debugger_info(PL_linestr, NULL, 0);
11250 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11251 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11252 *(SvPVX(PL_linestr) + off ) = ' ';
11253 sv_catsv(PL_linestr,herewas);
11254 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11255 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11259 sv_catsv(tmpstr,PL_linestr);
11264 PL_multi_end = CopLINE(PL_curcop);
11265 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11266 SvPV_shrink_to_cur(tmpstr);
11268 SvREFCNT_dec(herewas);
11270 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11272 else if (PL_encoding)
11273 sv_recode_to_utf8(tmpstr, PL_encoding);
11275 PL_lex_stuff = tmpstr;
11276 yylval.ival = op_type;
11280 /* scan_inputsymbol
11281 takes: current position in input buffer
11282 returns: new position in input buffer
11283 side-effects: yylval and lex_op are set.
11288 <FH> read from filehandle
11289 <pkg::FH> read from package qualified filehandle
11290 <pkg'FH> read from package qualified filehandle
11291 <$fh> read from filehandle in $fh
11292 <*.h> filename glob
11297 S_scan_inputsymbol(pTHX_ char *start)
11300 register char *s = start; /* current position in buffer */
11304 char *d = PL_tokenbuf; /* start of temp holding space */
11305 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11307 end = strchr(s, '\n');
11310 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11312 /* die if we didn't have space for the contents of the <>,
11313 or if it didn't end, or if we see a newline
11316 if (len >= (I32)sizeof PL_tokenbuf)
11317 Perl_croak(aTHX_ "Excessively long <> operator");
11319 Perl_croak(aTHX_ "Unterminated <> operator");
11324 Remember, only scalar variables are interpreted as filehandles by
11325 this code. Anything more complex (e.g., <$fh{$num}>) will be
11326 treated as a glob() call.
11327 This code makes use of the fact that except for the $ at the front,
11328 a scalar variable and a filehandle look the same.
11330 if (*d == '$' && d[1]) d++;
11332 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11333 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11336 /* If we've tried to read what we allow filehandles to look like, and
11337 there's still text left, then it must be a glob() and not a getline.
11338 Use scan_str to pull out the stuff between the <> and treat it
11339 as nothing more than a string.
11342 if (d - PL_tokenbuf != len) {
11343 yylval.ival = OP_GLOB;
11345 s = scan_str(start,!!PL_madskills,FALSE);
11347 Perl_croak(aTHX_ "Glob not terminated");
11351 bool readline_overriden = FALSE;
11354 /* we're in a filehandle read situation */
11357 /* turn <> into <ARGV> */
11359 Copy("ARGV",d,5,char);
11361 /* Check whether readline() is overriden */
11362 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11364 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11366 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11367 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
11368 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11369 readline_overriden = TRUE;
11371 /* if <$fh>, create the ops to turn the variable into a
11375 /* try to find it in the pad for this block, otherwise find
11376 add symbol table ops
11378 const PADOFFSET tmp = pad_findmy(d);
11379 if (tmp != NOT_IN_PAD) {
11380 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11381 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11382 HEK * const stashname = HvNAME_HEK(stash);
11383 SV * const sym = sv_2mortal(newSVhek(stashname));
11384 sv_catpvs(sym, "::");
11385 sv_catpv(sym, d+1);
11390 OP * const o = newOP(OP_PADSV, 0);
11392 PL_lex_op = readline_overriden
11393 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11394 append_elem(OP_LIST, o,
11395 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11396 : (OP*)newUNOP(OP_READLINE, 0, o);
11405 ? (GV_ADDMULTI | GV_ADDINEVAL)
11408 PL_lex_op = readline_overriden
11409 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11410 append_elem(OP_LIST,
11411 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11412 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11413 : (OP*)newUNOP(OP_READLINE, 0,
11414 newUNOP(OP_RV2SV, 0,
11415 newGVOP(OP_GV, 0, gv)));
11417 if (!readline_overriden)
11418 PL_lex_op->op_flags |= OPf_SPECIAL;
11419 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11420 yylval.ival = OP_NULL;
11423 /* If it's none of the above, it must be a literal filehandle
11424 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11426 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11427 PL_lex_op = readline_overriden
11428 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11429 append_elem(OP_LIST,
11430 newGVOP(OP_GV, 0, gv),
11431 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11432 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11433 yylval.ival = OP_NULL;
11442 takes: start position in buffer
11443 keep_quoted preserve \ on the embedded delimiter(s)
11444 keep_delims preserve the delimiters around the string
11445 returns: position to continue reading from buffer
11446 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11447 updates the read buffer.
11449 This subroutine pulls a string out of the input. It is called for:
11450 q single quotes q(literal text)
11451 ' single quotes 'literal text'
11452 qq double quotes qq(interpolate $here please)
11453 " double quotes "interpolate $here please"
11454 qx backticks qx(/bin/ls -l)
11455 ` backticks `/bin/ls -l`
11456 qw quote words @EXPORT_OK = qw( func() $spam )
11457 m// regexp match m/this/
11458 s/// regexp substitute s/this/that/
11459 tr/// string transliterate tr/this/that/
11460 y/// string transliterate y/this/that/
11461 ($*@) sub prototypes sub foo ($)
11462 (stuff) sub attr parameters sub foo : attr(stuff)
11463 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11465 In most of these cases (all but <>, patterns and transliterate)
11466 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11467 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11468 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11471 It skips whitespace before the string starts, and treats the first
11472 character as the delimiter. If the delimiter is one of ([{< then
11473 the corresponding "close" character )]}> is used as the closing
11474 delimiter. It allows quoting of delimiters, and if the string has
11475 balanced delimiters ([{<>}]) it allows nesting.
11477 On success, the SV with the resulting string is put into lex_stuff or,
11478 if that is already non-NULL, into lex_repl. The second case occurs only
11479 when parsing the RHS of the special constructs s/// and tr/// (y///).
11480 For convenience, the terminating delimiter character is stuffed into
11485 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11488 SV *sv; /* scalar value: string */
11489 const char *tmps; /* temp string, used for delimiter matching */
11490 register char *s = start; /* current position in the buffer */
11491 register char term; /* terminating character */
11492 register char *to; /* current position in the sv's data */
11493 I32 brackets = 1; /* bracket nesting level */
11494 bool has_utf8 = FALSE; /* is there any utf8 content? */
11495 I32 termcode; /* terminating char. code */
11496 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11497 STRLEN termlen; /* length of terminating string */
11498 int last_off = 0; /* last position for nesting bracket */
11504 /* skip space before the delimiter */
11510 if (PL_realtokenstart >= 0) {
11511 stuffstart = PL_realtokenstart;
11512 PL_realtokenstart = -1;
11515 stuffstart = start - SvPVX(PL_linestr);
11517 /* mark where we are, in case we need to report errors */
11520 /* after skipping whitespace, the next character is the terminator */
11523 termcode = termstr[0] = term;
11527 termcode = utf8_to_uvchr((U8*)s, &termlen);
11528 Copy(s, termstr, termlen, U8);
11529 if (!UTF8_IS_INVARIANT(term))
11533 /* mark where we are */
11534 PL_multi_start = CopLINE(PL_curcop);
11535 PL_multi_open = term;
11537 /* find corresponding closing delimiter */
11538 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11539 termcode = termstr[0] = term = tmps[5];
11541 PL_multi_close = term;
11543 /* create a new SV to hold the contents. 79 is the SV's initial length.
11544 What a random number. */
11546 sv_upgrade(sv, SVt_PVIV);
11547 SvIV_set(sv, termcode);
11548 (void)SvPOK_only(sv); /* validate pointer */
11550 /* move past delimiter and try to read a complete string */
11552 sv_catpvn(sv, s, termlen);
11555 tstart = SvPVX(PL_linestr) + stuffstart;
11556 if (!PL_thisopen && !keep_delims) {
11557 PL_thisopen = newSVpvn(tstart, s - tstart);
11558 stuffstart = s - SvPVX(PL_linestr);
11562 if (PL_encoding && !UTF) {
11566 int offset = s - SvPVX_const(PL_linestr);
11567 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11568 &offset, (char*)termstr, termlen);
11569 const char * const ns = SvPVX_const(PL_linestr) + offset;
11570 char * const svlast = SvEND(sv) - 1;
11572 for (; s < ns; s++) {
11573 if (*s == '\n' && !PL_rsfp)
11574 CopLINE_inc(PL_curcop);
11577 goto read_more_line;
11579 /* handle quoted delimiters */
11580 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11582 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11584 if ((svlast-1 - t) % 2) {
11585 if (!keep_quoted) {
11586 *(svlast-1) = term;
11588 SvCUR_set(sv, SvCUR(sv) - 1);
11593 if (PL_multi_open == PL_multi_close) {
11599 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11600 /* At here, all closes are "was quoted" one,
11601 so we don't check PL_multi_close. */
11603 if (!keep_quoted && *(t+1) == PL_multi_open)
11608 else if (*t == PL_multi_open)
11616 SvCUR_set(sv, w - SvPVX_const(sv));
11618 last_off = w - SvPVX(sv);
11619 if (--brackets <= 0)
11624 if (!keep_delims) {
11625 SvCUR_set(sv, SvCUR(sv) - 1);
11631 /* extend sv if need be */
11632 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11633 /* set 'to' to the next character in the sv's string */
11634 to = SvPVX(sv)+SvCUR(sv);
11636 /* if open delimiter is the close delimiter read unbridle */
11637 if (PL_multi_open == PL_multi_close) {
11638 for (; s < PL_bufend; s++,to++) {
11639 /* embedded newlines increment the current line number */
11640 if (*s == '\n' && !PL_rsfp)
11641 CopLINE_inc(PL_curcop);
11642 /* handle quoted delimiters */
11643 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11644 if (!keep_quoted && s[1] == term)
11646 /* any other quotes are simply copied straight through */
11650 /* terminate when run out of buffer (the for() condition), or
11651 have found the terminator */
11652 else if (*s == term) {
11655 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11658 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11664 /* if the terminator isn't the same as the start character (e.g.,
11665 matched brackets), we have to allow more in the quoting, and
11666 be prepared for nested brackets.
11669 /* read until we run out of string, or we find the terminator */
11670 for (; s < PL_bufend; s++,to++) {
11671 /* embedded newlines increment the line count */
11672 if (*s == '\n' && !PL_rsfp)
11673 CopLINE_inc(PL_curcop);
11674 /* backslashes can escape the open or closing characters */
11675 if (*s == '\\' && s+1 < PL_bufend) {
11676 if (!keep_quoted &&
11677 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11682 /* allow nested opens and closes */
11683 else if (*s == PL_multi_close && --brackets <= 0)
11685 else if (*s == PL_multi_open)
11687 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11692 /* terminate the copied string and update the sv's end-of-string */
11694 SvCUR_set(sv, to - SvPVX_const(sv));
11697 * this next chunk reads more into the buffer if we're not done yet
11701 break; /* handle case where we are done yet :-) */
11703 #ifndef PERL_STRICT_CR
11704 if (to - SvPVX_const(sv) >= 2) {
11705 if ((to[-2] == '\r' && to[-1] == '\n') ||
11706 (to[-2] == '\n' && to[-1] == '\r'))
11710 SvCUR_set(sv, to - SvPVX_const(sv));
11712 else if (to[-1] == '\r')
11715 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11720 /* if we're out of file, or a read fails, bail and reset the current
11721 line marker so we can report where the unterminated string began
11724 if (PL_madskills) {
11725 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11727 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11729 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11733 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11735 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11741 /* we read a line, so increment our line counter */
11742 CopLINE_inc(PL_curcop);
11744 /* update debugger info */
11745 if (PERLDB_LINE && PL_curstash != PL_debstash)
11746 update_debugger_info(PL_linestr, NULL, 0);
11748 /* having changed the buffer, we must update PL_bufend */
11749 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11750 PL_last_lop = PL_last_uni = NULL;
11753 /* at this point, we have successfully read the delimited string */
11755 if (!PL_encoding || UTF) {
11757 if (PL_madskills) {
11758 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11759 const int len = s - tstart;
11761 sv_catpvn(PL_thisstuff, tstart, len);
11763 PL_thisstuff = newSVpvn(tstart, len);
11764 if (!PL_thisclose && !keep_delims)
11765 PL_thisclose = newSVpvn(s,termlen);
11770 sv_catpvn(sv, s, termlen);
11775 if (PL_madskills) {
11776 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11777 const int len = s - tstart - termlen;
11779 sv_catpvn(PL_thisstuff, tstart, len);
11781 PL_thisstuff = newSVpvn(tstart, len);
11782 if (!PL_thisclose && !keep_delims)
11783 PL_thisclose = newSVpvn(s - termlen,termlen);
11787 if (has_utf8 || PL_encoding)
11790 PL_multi_end = CopLINE(PL_curcop);
11792 /* if we allocated too much space, give some back */
11793 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11794 SvLEN_set(sv, SvCUR(sv) + 1);
11795 SvPV_renew(sv, SvLEN(sv));
11798 /* decide whether this is the first or second quoted string we've read
11811 takes: pointer to position in buffer
11812 returns: pointer to new position in buffer
11813 side-effects: builds ops for the constant in yylval.op
11815 Read a number in any of the formats that Perl accepts:
11817 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11818 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11821 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11823 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11826 If it reads a number without a decimal point or an exponent, it will
11827 try converting the number to an integer and see if it can do so
11828 without loss of precision.
11832 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11835 register const char *s = start; /* current position in buffer */
11836 register char *d; /* destination in temp buffer */
11837 register char *e; /* end of temp buffer */
11838 NV nv; /* number read, as a double */
11839 SV *sv = NULL; /* place to put the converted number */
11840 bool floatit; /* boolean: int or float? */
11841 const char *lastub = NULL; /* position of last underbar */
11842 static char const number_too_long[] = "Number too long";
11844 /* We use the first character to decide what type of number this is */
11848 Perl_croak(aTHX_ "panic: scan_num");
11850 /* if it starts with a 0, it could be an octal number, a decimal in
11851 0.13 disguise, or a hexadecimal number, or a binary number. */
11855 u holds the "number so far"
11856 shift the power of 2 of the base
11857 (hex == 4, octal == 3, binary == 1)
11858 overflowed was the number more than we can hold?
11860 Shift is used when we add a digit. It also serves as an "are
11861 we in octal/hex/binary?" indicator to disallow hex characters
11862 when in octal mode.
11867 bool overflowed = FALSE;
11868 bool just_zero = TRUE; /* just plain 0 or binary number? */
11869 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11870 static const char* const bases[5] =
11871 { "", "binary", "", "octal", "hexadecimal" };
11872 static const char* const Bases[5] =
11873 { "", "Binary", "", "Octal", "Hexadecimal" };
11874 static const char* const maxima[5] =
11876 "0b11111111111111111111111111111111",
11880 const char *base, *Base, *max;
11882 /* check for hex */
11887 } else if (s[1] == 'b') {
11892 /* check for a decimal in disguise */
11893 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11895 /* so it must be octal */
11902 if (ckWARN(WARN_SYNTAX))
11903 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11904 "Misplaced _ in number");
11908 base = bases[shift];
11909 Base = Bases[shift];
11910 max = maxima[shift];
11912 /* read the rest of the number */
11914 /* x is used in the overflow test,
11915 b is the digit we're adding on. */
11920 /* if we don't mention it, we're done */
11924 /* _ are ignored -- but warned about if consecutive */
11926 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11927 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11928 "Misplaced _ in number");
11932 /* 8 and 9 are not octal */
11933 case '8': case '9':
11935 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11939 case '2': case '3': case '4':
11940 case '5': case '6': case '7':
11942 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11945 case '0': case '1':
11946 b = *s++ & 15; /* ASCII digit -> value of digit */
11950 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11951 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11952 /* make sure they said 0x */
11955 b = (*s++ & 7) + 9;
11957 /* Prepare to put the digit we have onto the end
11958 of the number so far. We check for overflows.
11964 x = u << shift; /* make room for the digit */
11966 if ((x >> shift) != u
11967 && !(PL_hints & HINT_NEW_BINARY)) {
11970 if (ckWARN_d(WARN_OVERFLOW))
11971 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11972 "Integer overflow in %s number",
11975 u = x | b; /* add the digit to the end */
11978 n *= nvshift[shift];
11979 /* If an NV has not enough bits in its
11980 * mantissa to represent an UV this summing of
11981 * small low-order numbers is a waste of time
11982 * (because the NV cannot preserve the
11983 * low-order bits anyway): we could just
11984 * remember when did we overflow and in the
11985 * end just multiply n by the right
11993 /* if we get here, we had success: make a scalar value from
11998 /* final misplaced underbar check */
11999 if (s[-1] == '_') {
12000 if (ckWARN(WARN_SYNTAX))
12001 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12006 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12007 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12008 "%s number > %s non-portable",
12014 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12015 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12016 "%s number > %s non-portable",
12021 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12022 sv = new_constant(start, s - start, "integer",
12024 else if (PL_hints & HINT_NEW_BINARY)
12025 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
12030 handle decimal numbers.
12031 we're also sent here when we read a 0 as the first digit
12033 case '1': case '2': case '3': case '4': case '5':
12034 case '6': case '7': case '8': case '9': case '.':
12037 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12040 /* read next group of digits and _ and copy into d */
12041 while (isDIGIT(*s) || *s == '_') {
12042 /* skip underscores, checking for misplaced ones
12046 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12047 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12048 "Misplaced _ in number");
12052 /* check for end of fixed-length buffer */
12054 Perl_croak(aTHX_ number_too_long);
12055 /* if we're ok, copy the character */
12060 /* final misplaced underbar check */
12061 if (lastub && s == lastub + 1) {
12062 if (ckWARN(WARN_SYNTAX))
12063 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12066 /* read a decimal portion if there is one. avoid
12067 3..5 being interpreted as the number 3. followed
12070 if (*s == '.' && s[1] != '.') {
12075 if (ckWARN(WARN_SYNTAX))
12076 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12077 "Misplaced _ in number");
12081 /* copy, ignoring underbars, until we run out of digits.
12083 for (; isDIGIT(*s) || *s == '_'; s++) {
12084 /* fixed length buffer check */
12086 Perl_croak(aTHX_ number_too_long);
12088 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12089 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12090 "Misplaced _ in number");
12096 /* fractional part ending in underbar? */
12097 if (s[-1] == '_') {
12098 if (ckWARN(WARN_SYNTAX))
12099 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12100 "Misplaced _ in number");
12102 if (*s == '.' && isDIGIT(s[1])) {
12103 /* oops, it's really a v-string, but without the "v" */
12109 /* read exponent part, if present */
12110 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12114 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12115 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12117 /* stray preinitial _ */
12119 if (ckWARN(WARN_SYNTAX))
12120 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12121 "Misplaced _ in number");
12125 /* allow positive or negative exponent */
12126 if (*s == '+' || *s == '-')
12129 /* stray initial _ */
12131 if (ckWARN(WARN_SYNTAX))
12132 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12133 "Misplaced _ in number");
12137 /* read digits of exponent */
12138 while (isDIGIT(*s) || *s == '_') {
12141 Perl_croak(aTHX_ number_too_long);
12145 if (((lastub && s == lastub + 1) ||
12146 (!isDIGIT(s[1]) && s[1] != '_'))
12147 && ckWARN(WARN_SYNTAX))
12148 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12149 "Misplaced _ in number");
12156 /* make an sv from the string */
12160 We try to do an integer conversion first if no characters
12161 indicating "float" have been found.
12166 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12168 if (flags == IS_NUMBER_IN_UV) {
12170 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12173 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12174 if (uv <= (UV) IV_MIN)
12175 sv_setiv(sv, -(IV)uv);
12182 /* terminate the string */
12184 nv = Atof(PL_tokenbuf);
12188 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12189 (PL_hints & HINT_NEW_INTEGER) )
12190 sv = new_constant(PL_tokenbuf,
12193 (floatit ? "float" : "integer"),
12197 /* if it starts with a v, it could be a v-string */
12200 sv = newSV(5); /* preallocate storage space */
12201 s = scan_vstring(s,sv);
12205 /* make the op for the constant and return */
12208 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12210 lvalp->opval = NULL;
12216 S_scan_formline(pTHX_ register char *s)
12219 register char *eol;
12221 SV * const stuff = newSVpvs("");
12222 bool needargs = FALSE;
12223 bool eofmt = FALSE;
12225 char *tokenstart = s;
12228 if (PL_madskills) {
12229 savewhite = PL_thiswhite;
12234 while (!needargs) {
12237 #ifdef PERL_STRICT_CR
12238 while (SPACE_OR_TAB(*t))
12241 while (SPACE_OR_TAB(*t) || *t == '\r')
12244 if (*t == '\n' || t == PL_bufend) {
12249 if (PL_in_eval && !PL_rsfp) {
12250 eol = (char *) memchr(s,'\n',PL_bufend-s);
12255 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12257 for (t = s; t < eol; t++) {
12258 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12260 goto enough; /* ~~ must be first line in formline */
12262 if (*t == '@' || *t == '^')
12266 sv_catpvn(stuff, s, eol-s);
12267 #ifndef PERL_STRICT_CR
12268 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12269 char *end = SvPVX(stuff) + SvCUR(stuff);
12272 SvCUR_set(stuff, SvCUR(stuff) - 1);
12282 if (PL_madskills) {
12284 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12286 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12289 s = filter_gets(PL_linestr, PL_rsfp, 0);
12291 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12293 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12295 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12296 PL_last_lop = PL_last_uni = NULL;
12305 if (SvCUR(stuff)) {
12308 PL_lex_state = LEX_NORMAL;
12309 start_force(PL_curforce);
12310 NEXTVAL_NEXTTOKE.ival = 0;
12314 PL_lex_state = LEX_FORMLINE;
12316 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12318 else if (PL_encoding)
12319 sv_recode_to_utf8(stuff, PL_encoding);
12321 start_force(PL_curforce);
12322 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12324 start_force(PL_curforce);
12325 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12329 SvREFCNT_dec(stuff);
12331 PL_lex_formbrack = 0;
12335 if (PL_madskills) {
12337 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12339 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12340 PL_thiswhite = savewhite;
12352 PL_cshlen = strlen(PL_cshname);
12354 #if defined(USE_ITHREADS)
12355 PERL_UNUSED_CONTEXT;
12361 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12364 const I32 oldsavestack_ix = PL_savestack_ix;
12365 CV* const outsidecv = PL_compcv;
12368 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12370 SAVEI32(PL_subline);
12371 save_item(PL_subname);
12372 SAVESPTR(PL_compcv);
12374 PL_compcv = (CV*)newSV(0);
12375 sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
12376 CvFLAGS(PL_compcv) |= flags;
12378 PL_subline = CopLINE(PL_curcop);
12379 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12380 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12381 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12383 return oldsavestack_ix;
12387 #pragma segment Perl_yylex
12390 Perl_yywarn(pTHX_ const char *s)
12393 PL_in_eval |= EVAL_WARNONLY;
12395 PL_in_eval &= ~EVAL_WARNONLY;
12400 Perl_yyerror(pTHX_ const char *s)
12403 const char *where = NULL;
12404 const char *context = NULL;
12407 int yychar = PL_parser->yychar;
12409 if (!yychar || (yychar == ';' && !PL_rsfp))
12411 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12412 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12413 PL_oldbufptr != PL_bufptr) {
12416 The code below is removed for NetWare because it abends/crashes on NetWare
12417 when the script has error such as not having the closing quotes like:
12418 if ($var eq "value)
12419 Checking of white spaces is anyway done in NetWare code.
12422 while (isSPACE(*PL_oldoldbufptr))
12425 context = PL_oldoldbufptr;
12426 contlen = PL_bufptr - PL_oldoldbufptr;
12428 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12429 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12432 The code below is removed for NetWare because it abends/crashes on NetWare
12433 when the script has error such as not having the closing quotes like:
12434 if ($var eq "value)
12435 Checking of white spaces is anyway done in NetWare code.
12438 while (isSPACE(*PL_oldbufptr))
12441 context = PL_oldbufptr;
12442 contlen = PL_bufptr - PL_oldbufptr;
12444 else if (yychar > 255)
12445 where = "next token ???";
12446 else if (yychar == -2) { /* YYEMPTY */
12447 if (PL_lex_state == LEX_NORMAL ||
12448 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12449 where = "at end of line";
12450 else if (PL_lex_inpat)
12451 where = "within pattern";
12453 where = "within string";
12456 SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12458 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12459 else if (isPRINT_LC(yychar))
12460 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12462 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12463 where = SvPVX_const(where_sv);
12465 msg = sv_2mortal(newSVpv(s, 0));
12466 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12467 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12469 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12471 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12472 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12473 Perl_sv_catpvf(aTHX_ msg,
12474 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12475 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12478 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12479 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12482 if (PL_error_count >= 10) {
12483 if (PL_in_eval && SvCUR(ERRSV))
12484 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12485 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12487 Perl_croak(aTHX_ "%s has too many errors.\n",
12488 OutCopFILE(PL_curcop));
12491 PL_in_my_stash = NULL;
12495 #pragma segment Main
12499 S_swallow_bom(pTHX_ U8 *s)
12502 const STRLEN slen = SvCUR(PL_linestr);
12505 if (s[1] == 0xFE) {
12506 /* UTF-16 little-endian? (or UTF32-LE?) */
12507 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12508 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12509 #ifndef PERL_NO_UTF16_FILTER
12510 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12513 if (PL_bufend > (char*)s) {
12517 filter_add(utf16rev_textfilter, NULL);
12518 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12519 utf16_to_utf8_reversed(s, news,
12520 PL_bufend - (char*)s - 1,
12522 sv_setpvn(PL_linestr, (const char*)news, newlen);
12524 s = (U8*)SvPVX(PL_linestr);
12525 Copy(news, s, newlen, U8);
12529 SvUTF8_on(PL_linestr);
12530 s = (U8*)SvPVX(PL_linestr);
12532 /* FIXME - is this a general bug fix? */
12535 PL_bufend = SvPVX(PL_linestr) + newlen;
12538 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12543 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12544 #ifndef PERL_NO_UTF16_FILTER
12545 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12548 if (PL_bufend > (char *)s) {
12552 filter_add(utf16_textfilter, NULL);
12553 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12554 utf16_to_utf8(s, news,
12555 PL_bufend - (char*)s,
12557 sv_setpvn(PL_linestr, (const char*)news, newlen);
12559 SvUTF8_on(PL_linestr);
12560 s = (U8*)SvPVX(PL_linestr);
12561 PL_bufend = SvPVX(PL_linestr) + newlen;
12564 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12569 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12570 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12571 s += 3; /* UTF-8 */
12577 if (s[2] == 0xFE && s[3] == 0xFF) {
12578 /* UTF-32 big-endian */
12579 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12582 else if (s[2] == 0 && s[3] != 0) {
12585 * are a good indicator of UTF-16BE. */
12586 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12592 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12593 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12594 s += 4; /* UTF-8 */
12600 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12603 * are a good indicator of UTF-16LE. */
12604 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12613 * Restore a source filter.
12617 restore_rsfp(pTHX_ void *f)
12620 PerlIO * const fp = (PerlIO*)f;
12622 if (PL_rsfp == PerlIO_stdin())
12623 PerlIO_clearerr(PL_rsfp);
12624 else if (PL_rsfp && (PL_rsfp != fp))
12625 PerlIO_close(PL_rsfp);
12629 #ifndef PERL_NO_UTF16_FILTER
12631 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12634 const STRLEN old = SvCUR(sv);
12635 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12636 DEBUG_P(PerlIO_printf(Perl_debug_log,
12637 "utf16_textfilter(%p): %d %d (%d)\n",
12638 FPTR2DPTR(void *, utf16_textfilter),
12639 idx, maxlen, (int) count));
12643 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12644 Copy(SvPVX_const(sv), tmps, old, char);
12645 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12646 SvCUR(sv) - old, &newlen);
12647 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12649 DEBUG_P({sv_dump(sv);});
12654 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12657 const STRLEN old = SvCUR(sv);
12658 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12659 DEBUG_P(PerlIO_printf(Perl_debug_log,
12660 "utf16rev_textfilter(%p): %d %d (%d)\n",
12661 FPTR2DPTR(void *, utf16rev_textfilter),
12662 idx, maxlen, (int) count));
12666 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12667 Copy(SvPVX_const(sv), tmps, old, char);
12668 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12669 SvCUR(sv) - old, &newlen);
12670 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12672 DEBUG_P({ sv_dump(sv); });
12678 Returns a pointer to the next character after the parsed
12679 vstring, as well as updating the passed in sv.
12681 Function must be called like
12684 s = scan_vstring(s,sv);
12686 The sv should already be large enough to store the vstring
12687 passed in, for performance reasons.
12692 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
12695 const char *pos = s;
12696 const char *start = s;
12697 if (*pos == 'v') pos++; /* get past 'v' */
12698 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12700 if ( *pos != '.') {
12701 /* this may not be a v-string if followed by => */
12702 const char *next = pos;
12703 while (next < PL_bufend && isSPACE(*next))
12705 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
12706 /* return string not v-string */
12707 sv_setpvn(sv,(char *)s,pos-s);
12708 return (char *)pos;
12712 if (!isALPHA(*pos)) {
12713 U8 tmpbuf[UTF8_MAXBYTES+1];
12716 s++; /* get past 'v' */
12718 sv_setpvn(sv, "", 0);
12721 /* this is atoi() that tolerates underscores */
12724 const char *end = pos;
12726 while (--end >= s) {
12728 const UV orev = rev;
12729 rev += (*end - '0') * mult;
12731 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12732 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12733 "Integer overflow in decimal number");
12737 if (rev > 0x7FFFFFFF)
12738 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12740 /* Append native character for the rev point */
12741 tmpend = uvchr_to_utf8(tmpbuf, rev);
12742 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12743 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12745 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
12751 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12755 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12763 * c-indentation-style: bsd
12764 * c-basic-offset: 4
12765 * indent-tabs-mode: t
12768 * ex: set ts=8 sts=4 sw=4 noet: