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);
681 PL_lex_state = LEX_NORMAL;
683 Newx(parser->lex_brackstack, 120, char);
684 Newx(parser->lex_casestack, 12, char);
685 *parser->lex_casestack = '\0';
691 s = SvPV_const(line, len);
696 PL_linestr = newSVpvs("\n;");
697 } else if (SvREADONLY(line) || s[len-1] != ';') {
698 PL_linestr = newSVsv(line);
700 sv_catpvs(PL_linestr, "\n;");
703 SvREFCNT_inc_simple_void_NN(line);
706 /* PL_linestr needs to survive until end of scope, not just the next
707 FREETMPS. See changes 17505 and 17546 which fixed the symptoms only. */
708 SAVEFREESV(PL_linestr);
709 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
710 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
711 PL_last_lop = PL_last_uni = NULL;
717 * Finalizer for lexing operations. Must be called when the parser is
718 * done with the lexer.
725 PL_doextract = FALSE;
730 * This subroutine has nothing to do with tilting, whether at windmills
731 * or pinball tables. Its name is short for "increment line". It
732 * increments the current line number in CopLINE(PL_curcop) and checks
733 * to see whether the line starts with a comment of the form
734 * # line 500 "foo.pm"
735 * If so, it sets the current line number and file to the values in the comment.
739 S_incline(pTHX_ const 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 */
785 const STRLEN len = t - s;
787 const char * const cf = CopFILE(PL_curcop);
788 STRLEN tmplen = cf ? strlen(cf) : 0;
789 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
790 /* must copy *{"::_<(eval N)[oldfilename:L]"}
791 * to *{"::_<newfilename"} */
792 /* However, the long form of evals is only turned on by the
793 debugger - usually they're "(eval %lu)" */
797 STRLEN tmplen2 = len;
798 if (tmplen + 2 <= sizeof smallbuf)
801 Newx(tmpbuf, tmplen + 2, char);
804 memcpy(tmpbuf + 2, cf, tmplen);
806 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
811 if (tmplen2 + 2 <= sizeof smallbuf)
814 Newx(tmpbuf2, tmplen2 + 2, char);
816 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
817 /* Either they malloc'd it, or we malloc'd it,
818 so no prefix is present in ours. */
823 memcpy(tmpbuf2 + 2, s, tmplen2);
826 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
828 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
829 /* adjust ${"::_<newfilename"} to store the new file name */
830 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
831 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
832 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
835 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
837 if (tmpbuf != smallbuf) Safefree(tmpbuf);
840 CopFILE_free(PL_curcop);
841 CopFILE_setn(PL_curcop, s, len);
843 CopLINE_set(PL_curcop, atoi(n)-1);
847 /* skip space before PL_thistoken */
850 S_skipspace0(pTHX_ register char *s)
857 PL_thiswhite = newSVpvs("");
858 sv_catsv(PL_thiswhite, PL_skipwhite);
859 sv_free(PL_skipwhite);
862 PL_realtokenstart = s - SvPVX(PL_linestr);
866 /* skip space after PL_thistoken */
869 S_skipspace1(pTHX_ register char *s)
871 const char *start = s;
872 I32 startoff = start - SvPVX(PL_linestr);
877 start = SvPVX(PL_linestr) + startoff;
878 if (!PL_thistoken && PL_realtokenstart >= 0) {
879 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
880 PL_thistoken = newSVpvn(tstart, start - tstart);
882 PL_realtokenstart = -1;
885 PL_nextwhite = newSVpvs("");
886 sv_catsv(PL_nextwhite, PL_skipwhite);
887 sv_free(PL_skipwhite);
894 S_skipspace2(pTHX_ register char *s, SV **svp)
897 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
898 const I32 startoff = s - SvPVX(PL_linestr);
901 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
902 if (!PL_madskills || !svp)
904 start = SvPVX(PL_linestr) + startoff;
905 if (!PL_thistoken && PL_realtokenstart >= 0) {
906 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
907 PL_thistoken = newSVpvn(tstart, start - tstart);
908 PL_realtokenstart = -1;
913 sv_setsv(*svp, PL_skipwhite);
914 sv_free(PL_skipwhite);
923 S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len)
925 AV *av = CopFILEAVx(PL_curcop);
927 SV * const sv = newSV_type(SVt_PVMG);
929 sv_setsv(sv, orig_sv);
931 sv_setpvn(sv, buf, len);
934 av_store(av, (I32)CopLINE(PL_curcop), sv);
940 * Called to gobble the appropriate amount and type of whitespace.
941 * Skips comments as well.
945 S_skipspace(pTHX_ register char *s)
950 int startoff = s - SvPVX(PL_linestr);
953 sv_free(PL_skipwhite);
958 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
959 while (s < PL_bufend && SPACE_OR_TAB(*s))
969 SSize_t oldprevlen, oldoldprevlen;
970 SSize_t oldloplen = 0, oldunilen = 0;
971 while (s < PL_bufend && isSPACE(*s)) {
972 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
977 if (s < PL_bufend && *s == '#') {
978 while (s < PL_bufend && *s != '\n')
982 if (PL_in_eval && !PL_rsfp) {
989 /* only continue to recharge the buffer if we're at the end
990 * of the buffer, we're not reading from a source filter, and
991 * we're in normal lexing mode
993 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
994 PL_lex_state == LEX_FORMLINE)
1001 /* try to recharge the buffer */
1003 curoff = s - SvPVX(PL_linestr);
1006 if ((s = filter_gets(PL_linestr, PL_rsfp,
1007 (prevlen = SvCUR(PL_linestr)))) == NULL)
1010 if (PL_madskills && curoff != startoff) {
1012 PL_skipwhite = newSVpvs("");
1013 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1017 /* mustn't throw out old stuff yet if madpropping */
1018 SvCUR(PL_linestr) = curoff;
1019 s = SvPVX(PL_linestr) + curoff;
1021 if (curoff && s[-1] == '\n')
1025 /* end of file. Add on the -p or -n magic */
1026 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1029 sv_catpvs(PL_linestr,
1030 ";}continue{print or die qq(-p destination: $!\\n);}");
1032 sv_setpvs(PL_linestr,
1033 ";}continue{print or die qq(-p destination: $!\\n);}");
1035 PL_minus_n = PL_minus_p = 0;
1037 else if (PL_minus_n) {
1039 sv_catpvn(PL_linestr, ";}", 2);
1041 sv_setpvn(PL_linestr, ";}", 2);
1047 sv_catpvn(PL_linestr,";", 1);
1049 sv_setpvn(PL_linestr,";", 1);
1052 /* reset variables for next time we lex */
1053 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1059 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1060 PL_last_lop = PL_last_uni = NULL;
1062 /* Close the filehandle. Could be from -P preprocessor,
1063 * STDIN, or a regular file. If we were reading code from
1064 * STDIN (because the commandline held no -e or filename)
1065 * then we don't close it, we reset it so the code can
1066 * read from STDIN too.
1069 if (PL_preprocess && !PL_in_eval)
1070 (void)PerlProc_pclose(PL_rsfp);
1071 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1072 PerlIO_clearerr(PL_rsfp);
1074 (void)PerlIO_close(PL_rsfp);
1079 /* not at end of file, so we only read another line */
1080 /* make corresponding updates to old pointers, for yyerror() */
1081 oldprevlen = PL_oldbufptr - PL_bufend;
1082 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1084 oldunilen = PL_last_uni - PL_bufend;
1086 oldloplen = PL_last_lop - PL_bufend;
1087 PL_linestart = PL_bufptr = s + prevlen;
1088 PL_bufend = s + SvCUR(PL_linestr);
1090 PL_oldbufptr = s + oldprevlen;
1091 PL_oldoldbufptr = s + oldoldprevlen;
1093 PL_last_uni = s + oldunilen;
1095 PL_last_lop = s + oldloplen;
1098 /* debugger active and we're not compiling the debugger code,
1099 * so store the line into the debugger's array of lines
1101 if (PERLDB_LINE && PL_curstash != PL_debstash)
1102 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1109 PL_skipwhite = newSVpvs("");
1110 curoff = s - SvPVX(PL_linestr);
1111 if (curoff - startoff)
1112 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1121 * Check the unary operators to ensure there's no ambiguity in how they're
1122 * used. An ambiguous piece of code would be:
1124 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1125 * the +5 is its argument.
1135 if (PL_oldoldbufptr != PL_last_uni)
1137 while (isSPACE(*PL_last_uni))
1140 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1142 if ((t = strchr(s, '(')) && t < PL_bufptr)
1145 if (ckWARN_d(WARN_AMBIGUOUS)){
1146 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1147 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1148 (int)(s - PL_last_uni), PL_last_uni);
1153 * LOP : macro to build a list operator. Its behaviour has been replaced
1154 * with a subroutine, S_lop() for which LOP is just another name.
1157 #define LOP(f,x) return lop(f,x,s)
1161 * Build a list operator (or something that might be one). The rules:
1162 * - if we have a next token, then it's a list operator [why?]
1163 * - if the next thing is an opening paren, then it's a function
1164 * - else it's a list operator
1168 S_lop(pTHX_ I32 f, int x, char *s)
1175 PL_last_lop = PL_oldbufptr;
1176 PL_last_lop_op = (OPCODE)f;
1179 return REPORT(LSTOP);
1182 return REPORT(LSTOP);
1185 return REPORT(FUNC);
1188 return REPORT(FUNC);
1190 return REPORT(LSTOP);
1196 * Sets up for an eventual force_next(). start_force(0) basically does
1197 * an unshift, while start_force(-1) does a push. yylex removes items
1202 S_start_force(pTHX_ int where)
1206 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1207 where = PL_lasttoke;
1208 assert(PL_curforce < 0 || PL_curforce == where);
1209 if (PL_curforce != where) {
1210 for (i = PL_lasttoke; i > where; --i) {
1211 PL_nexttoke[i] = PL_nexttoke[i-1];
1215 if (PL_curforce < 0) /* in case of duplicate start_force() */
1216 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1217 PL_curforce = where;
1220 curmad('^', newSVpvs(""));
1221 CURMAD('_', PL_nextwhite);
1226 S_curmad(pTHX_ char slot, SV *sv)
1232 if (PL_curforce < 0)
1233 where = &PL_thismad;
1235 where = &PL_nexttoke[PL_curforce].next_mad;
1238 sv_setpvn(sv, "", 0);
1241 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1243 else if (PL_encoding) {
1244 sv_recode_to_utf8(sv, PL_encoding);
1249 /* keep a slot open for the head of the list? */
1250 if (slot != '_' && *where && (*where)->mad_key == '^') {
1251 (*where)->mad_key = slot;
1252 sv_free((*where)->mad_val);
1253 (*where)->mad_val = (void*)sv;
1256 addmad(newMADsv(slot, sv), where, 0);
1259 # define start_force(where) NOOP
1260 # define curmad(slot, sv) NOOP
1265 * When the lexer realizes it knows the next token (for instance,
1266 * it is reordering tokens for the parser) then it can call S_force_next
1267 * to know what token to return the next time the lexer is called. Caller
1268 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1269 * and possibly PL_expect to ensure the lexer handles the token correctly.
1273 S_force_next(pTHX_ I32 type)
1277 if (PL_curforce < 0)
1278 start_force(PL_lasttoke);
1279 PL_nexttoke[PL_curforce].next_type = type;
1280 if (PL_lex_state != LEX_KNOWNEXT)
1281 PL_lex_defer = PL_lex_state;
1282 PL_lex_state = LEX_KNOWNEXT;
1283 PL_lex_expect = PL_expect;
1286 PL_nexttype[PL_nexttoke] = type;
1288 if (PL_lex_state != LEX_KNOWNEXT) {
1289 PL_lex_defer = PL_lex_state;
1290 PL_lex_expect = PL_expect;
1291 PL_lex_state = LEX_KNOWNEXT;
1297 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
1300 SV * const sv = newSVpvn(start,len);
1301 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
1308 * When the lexer knows the next thing is a word (for instance, it has
1309 * just seen -> and it knows that the next char is a word char, then
1310 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1314 * char *start : buffer position (must be within PL_linestr)
1315 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1316 * int check_keyword : if true, Perl checks to make sure the word isn't
1317 * a keyword (do this if the word is a label, e.g. goto FOO)
1318 * int allow_pack : if true, : characters will also be allowed (require,
1319 * use, etc. do this)
1320 * int allow_initial_tick : used by the "sub" lexer only.
1324 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1330 start = SKIPSPACE1(start);
1332 if (isIDFIRST_lazy_if(s,UTF) ||
1333 (allow_pack && *s == ':') ||
1334 (allow_initial_tick && *s == '\'') )
1336 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1337 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1339 start_force(PL_curforce);
1341 curmad('X', newSVpvn(start,s-start));
1342 if (token == METHOD) {
1347 PL_expect = XOPERATOR;
1350 NEXTVAL_NEXTTOKE.opval
1351 = (OP*)newSVOP(OP_CONST,0,
1352 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1353 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1361 * Called when the lexer wants $foo *foo &foo etc, but the program
1362 * text only contains the "foo" portion. The first argument is a pointer
1363 * to the "foo", and the second argument is the type symbol to prefix.
1364 * Forces the next token to be a "WORD".
1365 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1369 S_force_ident(pTHX_ register const char *s, int kind)
1373 const STRLEN len = strlen(s);
1374 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1375 start_force(PL_curforce);
1376 NEXTVAL_NEXTTOKE.opval = o;
1379 o->op_private = OPpCONST_ENTERED;
1380 /* XXX see note in pp_entereval() for why we forgo typo
1381 warnings if the symbol must be introduced in an eval.
1383 gv_fetchpvn_flags(s, len,
1384 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1386 kind == '$' ? SVt_PV :
1387 kind == '@' ? SVt_PVAV :
1388 kind == '%' ? SVt_PVHV :
1396 Perl_str_to_version(pTHX_ SV *sv)
1401 const char *start = SvPV_const(sv,len);
1402 const char * const end = start + len;
1403 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1404 while (start < end) {
1408 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1413 retval += ((NV)n)/nshift;
1422 * Forces the next token to be a version number.
1423 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1424 * and if "guessing" is TRUE, then no new token is created (and the caller
1425 * must use an alternative parsing method).
1429 S_force_version(pTHX_ char *s, int guessing)
1435 I32 startoff = s - SvPVX(PL_linestr);
1444 while (isDIGIT(*d) || *d == '_' || *d == '.')
1448 start_force(PL_curforce);
1449 curmad('X', newSVpvn(s,d-s));
1452 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1454 s = scan_num(s, &yylval);
1455 version = yylval.opval;
1456 ver = cSVOPx(version)->op_sv;
1457 if (SvPOK(ver) && !SvNIOK(ver)) {
1458 SvUPGRADE(ver, SVt_PVNV);
1459 SvNV_set(ver, str_to_version(ver));
1460 SvNOK_on(ver); /* hint that it is a version */
1463 else if (guessing) {
1466 sv_free(PL_nextwhite); /* let next token collect whitespace */
1468 s = SvPVX(PL_linestr) + startoff;
1476 if (PL_madskills && !version) {
1477 sv_free(PL_nextwhite); /* let next token collect whitespace */
1479 s = SvPVX(PL_linestr) + startoff;
1482 /* NOTE: The parser sees the package name and the VERSION swapped */
1483 start_force(PL_curforce);
1484 NEXTVAL_NEXTTOKE.opval = version;
1492 * Tokenize a quoted string passed in as an SV. It finds the next
1493 * chunk, up to end of string or a backslash. It may make a new
1494 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1499 S_tokeq(pTHX_ SV *sv)
1503 register char *send;
1511 s = SvPV_force(sv, len);
1512 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1515 while (s < send && *s != '\\')
1520 if ( PL_hints & HINT_NEW_STRING ) {
1521 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1527 if (s + 1 < send && (s[1] == '\\'))
1528 s++; /* all that, just for this */
1533 SvCUR_set(sv, d - SvPVX_const(sv));
1535 if ( PL_hints & HINT_NEW_STRING )
1536 return new_constant(NULL, 0, "q", sv, pv, "q");
1541 * Now come three functions related to double-quote context,
1542 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1543 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1544 * interact with PL_lex_state, and create fake ( ... ) argument lists
1545 * to handle functions and concatenation.
1546 * They assume that whoever calls them will be setting up a fake
1547 * join call, because each subthing puts a ',' after it. This lets
1550 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1552 * (I'm not sure whether the spurious commas at the end of lcfirst's
1553 * arguments and join's arguments are created or not).
1558 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1560 * Pattern matching will set PL_lex_op to the pattern-matching op to
1561 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1563 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1565 * Everything else becomes a FUNC.
1567 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1568 * had an OP_CONST or OP_READLINE). This just sets us up for a
1569 * call to S_sublex_push().
1573 S_sublex_start(pTHX)
1576 register const I32 op_type = yylval.ival;
1578 if (op_type == OP_NULL) {
1579 yylval.opval = PL_lex_op;
1583 if (op_type == OP_CONST || op_type == OP_READLINE) {
1584 SV *sv = tokeq(PL_lex_stuff);
1586 if (SvTYPE(sv) == SVt_PVIV) {
1587 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1589 const char * const p = SvPV_const(sv, len);
1590 SV * const nsv = newSVpvn(p, len);
1596 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1597 PL_lex_stuff = NULL;
1598 /* Allow <FH> // "foo" */
1599 if (op_type == OP_READLINE)
1600 PL_expect = XTERMORDORDOR;
1603 else if (op_type == OP_BACKTICK && PL_lex_op) {
1604 /* readpipe() vas overriden */
1605 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1606 yylval.opval = PL_lex_op;
1608 PL_lex_stuff = NULL;
1612 PL_sublex_info.super_state = PL_lex_state;
1613 PL_sublex_info.sub_inwhat = op_type;
1614 PL_sublex_info.sub_op = PL_lex_op;
1615 PL_lex_state = LEX_INTERPPUSH;
1619 yylval.opval = PL_lex_op;
1629 * Create a new scope to save the lexing state. The scope will be
1630 * ended in S_sublex_done. Returns a '(', starting the function arguments
1631 * to the uc, lc, etc. found before.
1632 * Sets PL_lex_state to LEX_INTERPCONCAT.
1641 PL_lex_state = PL_sublex_info.super_state;
1642 SAVEI32(PL_lex_dojoin);
1643 SAVEI32(PL_lex_brackets);
1644 SAVEI32(PL_lex_casemods);
1645 SAVEI32(PL_lex_starts);
1646 SAVEI32(PL_lex_state);
1647 SAVEVPTR(PL_lex_inpat);
1648 SAVEI32(PL_lex_inwhat);
1649 SAVECOPLINE(PL_curcop);
1650 SAVEPPTR(PL_bufptr);
1651 SAVEPPTR(PL_bufend);
1652 SAVEPPTR(PL_oldbufptr);
1653 SAVEPPTR(PL_oldoldbufptr);
1654 SAVEPPTR(PL_last_lop);
1655 SAVEPPTR(PL_last_uni);
1656 SAVEPPTR(PL_linestart);
1657 SAVESPTR(PL_linestr);
1658 SAVEGENERICPV(PL_lex_brackstack);
1659 SAVEGENERICPV(PL_lex_casestack);
1661 PL_linestr = PL_lex_stuff;
1662 PL_lex_stuff = NULL;
1664 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1665 = SvPVX(PL_linestr);
1666 PL_bufend += SvCUR(PL_linestr);
1667 PL_last_lop = PL_last_uni = NULL;
1668 SAVEFREESV(PL_linestr);
1670 PL_lex_dojoin = FALSE;
1671 PL_lex_brackets = 0;
1672 Newx(PL_lex_brackstack, 120, char);
1673 Newx(PL_lex_casestack, 12, char);
1674 PL_lex_casemods = 0;
1675 *PL_lex_casestack = '\0';
1677 PL_lex_state = LEX_INTERPCONCAT;
1678 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1680 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1681 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1682 PL_lex_inpat = PL_sublex_info.sub_op;
1684 PL_lex_inpat = NULL;
1691 * Restores lexer state after a S_sublex_push.
1698 if (!PL_lex_starts++) {
1699 SV * const sv = newSVpvs("");
1700 if (SvUTF8(PL_linestr))
1702 PL_expect = XOPERATOR;
1703 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1707 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1708 PL_lex_state = LEX_INTERPCASEMOD;
1712 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1713 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1714 PL_linestr = PL_lex_repl;
1716 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1717 PL_bufend += SvCUR(PL_linestr);
1718 PL_last_lop = PL_last_uni = NULL;
1719 SAVEFREESV(PL_linestr);
1720 PL_lex_dojoin = FALSE;
1721 PL_lex_brackets = 0;
1722 PL_lex_casemods = 0;
1723 *PL_lex_casestack = '\0';
1725 if (SvEVALED(PL_lex_repl)) {
1726 PL_lex_state = LEX_INTERPNORMAL;
1728 /* we don't clear PL_lex_repl here, so that we can check later
1729 whether this is an evalled subst; that means we rely on the
1730 logic to ensure sublex_done() is called again only via the
1731 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1734 PL_lex_state = LEX_INTERPCONCAT;
1744 PL_endwhite = newSVpvs("");
1745 sv_catsv(PL_endwhite, PL_thiswhite);
1749 sv_setpvn(PL_thistoken,"",0);
1751 PL_realtokenstart = -1;
1755 PL_bufend = SvPVX(PL_linestr);
1756 PL_bufend += SvCUR(PL_linestr);
1757 PL_expect = XOPERATOR;
1758 PL_sublex_info.sub_inwhat = 0;
1766 Extracts a pattern, double-quoted string, or transliteration. This
1769 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1770 processing a pattern (PL_lex_inpat is true), a transliteration
1771 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1773 Returns a pointer to the character scanned up to. If this is
1774 advanced from the start pointer supplied (i.e. if anything was
1775 successfully parsed), will leave an OP for the substring scanned
1776 in yylval. Caller must intuit reason for not parsing further
1777 by looking at the next characters herself.
1781 double-quoted style: \r and \n
1782 regexp special ones: \D \s
1785 case and quoting: \U \Q \E
1786 stops on @ and $, but not for $ as tail anchor
1788 In transliterations:
1789 characters are VERY literal, except for - not at the start or end
1790 of the string, which indicates a range. If the range is in bytes,
1791 scan_const expands the range to the full set of intermediate
1792 characters. If the range is in utf8, the hyphen is replaced with
1793 a certain range mark which will be handled by pmtrans() in op.c.
1795 In double-quoted strings:
1797 double-quoted style: \r and \n
1799 deprecated backrefs: \1 (in substitution replacements)
1800 case and quoting: \U \Q \E
1803 scan_const does *not* construct ops to handle interpolated strings.
1804 It stops processing as soon as it finds an embedded $ or @ variable
1805 and leaves it to the caller to work out what's going on.
1807 embedded arrays (whether in pattern or not) could be:
1808 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1810 $ in double-quoted strings must be the symbol of an embedded scalar.
1812 $ in pattern could be $foo or could be tail anchor. Assumption:
1813 it's a tail anchor if $ is the last thing in the string, or if it's
1814 followed by one of "()| \r\n\t"
1816 \1 (backreferences) are turned into $1
1818 The structure of the code is
1819 while (there's a character to process) {
1820 handle transliteration ranges
1821 skip regexp comments /(?#comment)/ and codes /(?{code})/
1822 skip #-initiated comments in //x patterns
1823 check for embedded arrays
1824 check for embedded scalars
1826 leave intact backslashes from leaveit (below)
1827 deprecate \1 in substitution replacements
1828 handle string-changing backslashes \l \U \Q \E, etc.
1829 switch (what was escaped) {
1830 handle \- in a transliteration (becomes a literal -)
1831 handle \132 (octal characters)
1832 handle \x15 and \x{1234} (hex characters)
1833 handle \N{name} (named characters)
1834 handle \cV (control characters)
1835 handle printf-style backslashes (\f, \r, \n, etc)
1837 } (end if backslash)
1838 } (end while character to read)
1843 S_scan_const(pTHX_ char *start)
1846 register char *send = PL_bufend; /* end of the constant */
1847 SV *sv = newSV(send - start); /* sv for the constant */
1848 register char *s = start; /* start of the constant */
1849 register char *d = SvPVX(sv); /* destination for copies */
1850 bool dorange = FALSE; /* are we in a translit range? */
1851 bool didrange = FALSE; /* did we just finish a range? */
1852 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1853 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1856 UV literal_endpoint = 0;
1857 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1860 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1861 /* If we are doing a trans and we know we want UTF8 set expectation */
1862 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1863 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1867 while (s < send || dorange) {
1868 /* get transliterations out of the way (they're most literal) */
1869 if (PL_lex_inwhat == OP_TRANS) {
1870 /* expand a range A-Z to the full set of characters. AIE! */
1872 I32 i; /* current expanded character */
1873 I32 min; /* first character in range */
1874 I32 max; /* last character in range */
1885 char * const c = (char*)utf8_hop((U8*)d, -1);
1889 *c = (char)UTF_TO_NATIVE(0xff);
1890 /* mark the range as done, and continue */
1896 i = d - SvPVX_const(sv); /* remember current offset */
1899 SvLEN(sv) + (has_utf8 ?
1900 (512 - UTF_CONTINUATION_MARK +
1903 /* How many two-byte within 0..255: 128 in UTF-8,
1904 * 96 in UTF-8-mod. */
1906 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1908 d = SvPVX(sv) + i; /* refresh d after realloc */
1912 for (j = 0; j <= 1; j++) {
1913 char * const c = (char*)utf8_hop((U8*)d, -1);
1914 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
1920 max = (U8)0xff; /* only to \xff */
1921 uvmax = uv; /* \x{100} to uvmax */
1923 d = c; /* eat endpoint chars */
1928 d -= 2; /* eat the first char and the - */
1929 min = (U8)*d; /* first char in range */
1930 max = (U8)d[1]; /* last char in range */
1937 "Invalid range \"%c-%c\" in transliteration operator",
1938 (char)min, (char)max);
1942 if (literal_endpoint == 2 &&
1943 ((isLOWER(min) && isLOWER(max)) ||
1944 (isUPPER(min) && isUPPER(max)))) {
1946 for (i = min; i <= max; i++)
1948 *d++ = NATIVE_TO_NEED(has_utf8,i);
1950 for (i = min; i <= max; i++)
1952 *d++ = NATIVE_TO_NEED(has_utf8,i);
1957 for (i = min; i <= max; i++)
1960 const U8 ch = (U8)NATIVE_TO_UTF(i);
1961 if (UNI_IS_INVARIANT(ch))
1964 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
1965 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
1974 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
1976 *d++ = (char)UTF_TO_NATIVE(0xff);
1978 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
1982 /* mark the range as done, and continue */
1986 literal_endpoint = 0;
1991 /* range begins (ignore - as first or last char) */
1992 else if (*s == '-' && s+1 < send && s != start) {
1994 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2001 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2011 literal_endpoint = 0;
2012 native_range = TRUE;
2017 /* if we get here, we're not doing a transliteration */
2019 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2020 except for the last char, which will be done separately. */
2021 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2023 while (s+1 < send && *s != ')')
2024 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2026 else if (s[2] == '{' /* This should match regcomp.c */
2027 || (s[2] == '?' && s[3] == '{'))
2030 char *regparse = s + (s[2] == '{' ? 3 : 4);
2033 while (count && (c = *regparse)) {
2034 if (c == '\\' && regparse[1])
2042 if (*regparse != ')')
2043 regparse--; /* Leave one char for continuation. */
2044 while (s < regparse)
2045 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2049 /* likewise skip #-initiated comments in //x patterns */
2050 else if (*s == '#' && PL_lex_inpat &&
2051 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2052 while (s+1 < send && *s != '\n')
2053 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2056 /* check for embedded arrays
2057 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2059 else if (*s == '@' && s[1]) {
2060 if (isALNUM_lazy_if(s+1,UTF))
2062 if (strchr(":'{$", s[1]))
2064 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2065 break; /* in regexp, neither @+ nor @- are interpolated */
2068 /* check for embedded scalars. only stop if we're sure it's a
2071 else if (*s == '$') {
2072 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2074 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
2075 break; /* in regexp, $ might be tail anchor */
2078 /* End of else if chain - OP_TRANS rejoin rest */
2081 if (*s == '\\' && s+1 < send) {
2084 /* deprecate \1 in strings and substitution replacements */
2085 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2086 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2088 if (ckWARN(WARN_SYNTAX))
2089 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2094 /* string-change backslash escapes */
2095 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2099 /* skip any other backslash escapes in a pattern */
2100 else if (PL_lex_inpat) {
2101 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2102 goto default_action;
2105 /* if we get here, it's either a quoted -, or a digit */
2108 /* quoted - in transliterations */
2110 if (PL_lex_inwhat == OP_TRANS) {
2117 if ((isALPHA(*s) || isDIGIT(*s)) &&
2119 Perl_warner(aTHX_ packWARN(WARN_MISC),
2120 "Unrecognized escape \\%c passed through",
2122 /* default action is to copy the quoted character */
2123 goto default_action;
2126 /* \132 indicates an octal constant */
2127 case '0': case '1': case '2': case '3':
2128 case '4': case '5': case '6': case '7':
2132 uv = grok_oct(s, &len, &flags, NULL);
2135 goto NUM_ESCAPE_INSERT;
2137 /* \x24 indicates a hex constant */
2141 char* const e = strchr(s, '}');
2142 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2143 PERL_SCAN_DISALLOW_PREFIX;
2148 yyerror("Missing right brace on \\x{}");
2152 uv = grok_hex(s, &len, &flags, NULL);
2158 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2159 uv = grok_hex(s, &len, &flags, NULL);
2165 /* Insert oct or hex escaped character.
2166 * There will always enough room in sv since such
2167 * escapes will be longer than any UTF-8 sequence
2168 * they can end up as. */
2170 /* We need to map to chars to ASCII before doing the tests
2173 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2174 if (!has_utf8 && uv > 255) {
2175 /* Might need to recode whatever we have
2176 * accumulated so far if it contains any
2179 * (Can't we keep track of that and avoid
2180 * this rescan? --jhi)
2184 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2185 if (!NATIVE_IS_INVARIANT(*c)) {
2190 const STRLEN offset = d - SvPVX_const(sv);
2192 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2196 while (src >= (const U8 *)SvPVX_const(sv)) {
2197 if (!NATIVE_IS_INVARIANT(*src)) {
2198 const U8 ch = NATIVE_TO_ASCII(*src);
2199 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2200 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2210 if (has_utf8 || uv > 255) {
2211 d = (char*)uvchr_to_utf8((U8*)d, uv);
2213 if (PL_lex_inwhat == OP_TRANS &&
2214 PL_sublex_info.sub_op) {
2215 PL_sublex_info.sub_op->op_private |=
2216 (PL_lex_repl ? OPpTRANS_FROM_UTF
2220 if (uv > 255 && !dorange)
2221 native_range = FALSE;
2233 /* \N{LATIN SMALL LETTER A} is a named character */
2237 char* e = strchr(s, '}');
2244 yyerror("Missing right brace on \\N{}");
2248 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2250 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2251 PERL_SCAN_DISALLOW_PREFIX;
2254 uv = grok_hex(s, &len, &flags, NULL);
2255 if ( e > s && len != (STRLEN)(e - s) ) {
2259 goto NUM_ESCAPE_INSERT;
2261 res = newSVpvn(s + 1, e - s - 1);
2262 type = newSVpvn(s - 2,e - s + 3);
2263 res = new_constant( NULL, 0, "charnames",
2264 res, NULL, SvPVX(type) );
2267 sv_utf8_upgrade(res);
2268 str = SvPV_const(res,len);
2269 #ifdef EBCDIC_NEVER_MIND
2270 /* charnames uses pack U and that has been
2271 * recently changed to do the below uni->native
2272 * mapping, so this would be redundant (and wrong,
2273 * the code point would be doubly converted).
2274 * But leave this in just in case the pack U change
2275 * gets revoked, but the semantics is still
2276 * desireable for charnames. --jhi */
2278 UV uv = utf8_to_uvchr((const U8*)str, 0);
2281 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2283 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2284 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2285 str = SvPV_const(res, len);
2289 if (!has_utf8 && SvUTF8(res)) {
2290 const char * const ostart = SvPVX_const(sv);
2291 SvCUR_set(sv, d - ostart);
2294 sv_utf8_upgrade(sv);
2295 /* this just broke our allocation above... */
2296 SvGROW(sv, (STRLEN)(send - start));
2297 d = SvPVX(sv) + SvCUR(sv);
2300 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2301 const char * const odest = SvPVX_const(sv);
2303 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2304 d = SvPVX(sv) + (d - odest);
2308 native_range = FALSE; /* \N{} is guessed to be Unicode */
2310 Copy(str, d, len, char);
2317 yyerror("Missing braces on \\N{}");
2320 /* \c is a control character */
2329 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2332 yyerror("Missing control char name in \\c");
2336 /* printf-style backslashes, formfeeds, newlines, etc */
2338 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2341 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2344 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2347 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2350 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2353 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2356 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2362 } /* end if (backslash) */
2369 /* If we started with encoded form, or already know we want it
2370 and then encode the next character */
2371 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2373 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2374 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2377 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2378 const STRLEN off = d - SvPVX_const(sv);
2379 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2381 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2384 if (uv > 255 && !dorange)
2385 native_range = FALSE;
2389 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2391 } /* while loop to process each character */
2393 /* terminate the string and set up the sv */
2395 SvCUR_set(sv, d - SvPVX_const(sv));
2396 if (SvCUR(sv) >= SvLEN(sv))
2397 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2400 if (PL_encoding && !has_utf8) {
2401 sv_recode_to_utf8(sv, PL_encoding);
2407 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2408 PL_sublex_info.sub_op->op_private |=
2409 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2413 /* shrink the sv if we allocated more than we used */
2414 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2415 SvPV_shrink_to_cur(sv);
2418 /* return the substring (via yylval) only if we parsed anything */
2419 if (s > PL_bufptr) {
2420 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2421 sv = new_constant(start, s - start,
2422 (const char *)(PL_lex_inpat ? "qr" : "q"),
2425 (( PL_lex_inwhat == OP_TRANS
2427 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2430 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2437 * Returns TRUE if there's more to the expression (e.g., a subscript),
2440 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2442 * ->[ and ->{ return TRUE
2443 * { and [ outside a pattern are always subscripts, so return TRUE
2444 * if we're outside a pattern and it's not { or [, then return FALSE
2445 * if we're in a pattern and the first char is a {
2446 * {4,5} (any digits around the comma) returns FALSE
2447 * if we're in a pattern and the first char is a [
2449 * [SOMETHING] has a funky algorithm to decide whether it's a
2450 * character class or not. It has to deal with things like
2451 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2452 * anything else returns TRUE
2455 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2458 S_intuit_more(pTHX_ register char *s)
2461 if (PL_lex_brackets)
2463 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2465 if (*s != '{' && *s != '[')
2470 /* In a pattern, so maybe we have {n,m}. */
2487 /* On the other hand, maybe we have a character class */
2490 if (*s == ']' || *s == '^')
2493 /* this is terrifying, and it works */
2494 int weight = 2; /* let's weigh the evidence */
2496 unsigned char un_char = 255, last_un_char;
2497 const char * const send = strchr(s,']');
2498 char tmpbuf[sizeof PL_tokenbuf * 4];
2500 if (!send) /* has to be an expression */
2503 Zero(seen,256,char);
2506 else if (isDIGIT(*s)) {
2508 if (isDIGIT(s[1]) && s[2] == ']')
2514 for (; s < send; s++) {
2515 last_un_char = un_char;
2516 un_char = (unsigned char)*s;
2521 weight -= seen[un_char] * 10;
2522 if (isALNUM_lazy_if(s+1,UTF)) {
2524 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2525 len = (int)strlen(tmpbuf);
2526 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2531 else if (*s == '$' && s[1] &&
2532 strchr("[#!%*<>()-=",s[1])) {
2533 if (/*{*/ strchr("])} =",s[2]))
2542 if (strchr("wds]",s[1]))
2544 else if (seen[(U8)'\''] || seen[(U8)'"'])
2546 else if (strchr("rnftbxcav",s[1]))
2548 else if (isDIGIT(s[1])) {
2550 while (s[1] && isDIGIT(s[1]))
2560 if (strchr("aA01! ",last_un_char))
2562 if (strchr("zZ79~",s[1]))
2564 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2565 weight -= 5; /* cope with negative subscript */
2568 if (!isALNUM(last_un_char)
2569 && !(last_un_char == '$' || last_un_char == '@'
2570 || last_un_char == '&')
2571 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2576 if (keyword(tmpbuf, d - tmpbuf, 0))
2579 if (un_char == last_un_char + 1)
2581 weight -= seen[un_char];
2586 if (weight >= 0) /* probably a character class */
2596 * Does all the checking to disambiguate
2598 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2599 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2601 * First argument is the stuff after the first token, e.g. "bar".
2603 * Not a method if bar is a filehandle.
2604 * Not a method if foo is a subroutine prototyped to take a filehandle.
2605 * Not a method if it's really "Foo $bar"
2606 * Method if it's "foo $bar"
2607 * Not a method if it's really "print foo $bar"
2608 * Method if it's really "foo package::" (interpreted as package->foo)
2609 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2610 * Not a method if bar is a filehandle or package, but is quoted with
2615 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2618 char *s = start + (*start == '$');
2619 char tmpbuf[sizeof PL_tokenbuf];
2627 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2631 const char *proto = SvPVX_const(cv);
2642 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2643 /* start is the beginning of the possible filehandle/object,
2644 * and s is the end of it
2645 * tmpbuf is a copy of it
2648 if (*start == '$') {
2649 if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2652 len = start - SvPVX(PL_linestr);
2656 start = SvPVX(PL_linestr) + len;
2660 return *s == '(' ? FUNCMETH : METHOD;
2662 if (!keyword(tmpbuf, len, 0)) {
2663 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2667 soff = s - SvPVX(PL_linestr);
2671 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2672 if (indirgv && GvCVu(indirgv))
2674 /* filehandle or package name makes it a method */
2675 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2677 soff = s - SvPVX(PL_linestr);
2680 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2681 return 0; /* no assumptions -- "=>" quotes bearword */
2683 start_force(PL_curforce);
2684 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2685 newSVpvn(tmpbuf,len));
2686 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2688 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2693 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2695 return *s == '(' ? FUNCMETH : METHOD;
2703 * Return a string of Perl code to load the debugger. If PERL5DB
2704 * is set, it will return the contents of that, otherwise a
2705 * compile-time require of perl5db.pl.
2713 const char * const pdb = PerlEnv_getenv("PERL5DB");
2717 SETERRNO(0,SS_NORMAL);
2718 return "BEGIN { require 'perl5db.pl' }";
2724 /* Encoded script support. filter_add() effectively inserts a
2725 * 'pre-processing' function into the current source input stream.
2726 * Note that the filter function only applies to the current source file
2727 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2729 * The datasv parameter (which may be NULL) can be used to pass
2730 * private data to this instance of the filter. The filter function
2731 * can recover the SV using the FILTER_DATA macro and use it to
2732 * store private buffers and state information.
2734 * The supplied datasv parameter is upgraded to a PVIO type
2735 * and the IoDIRP/IoANY field is used to store the function pointer,
2736 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2737 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2738 * private use must be set using malloc'd pointers.
2742 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2748 if (!PL_rsfp_filters)
2749 PL_rsfp_filters = newAV();
2752 SvUPGRADE(datasv, SVt_PVIO);
2753 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2754 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2755 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2756 FPTR2DPTR(void *, IoANY(datasv)),
2757 SvPV_nolen(datasv)));
2758 av_unshift(PL_rsfp_filters, 1);
2759 av_store(PL_rsfp_filters, 0, datasv) ;
2764 /* Delete most recently added instance of this filter function. */
2766 Perl_filter_del(pTHX_ filter_t funcp)
2772 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2773 FPTR2DPTR(void*, funcp)));
2775 if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2777 /* if filter is on top of stack (usual case) just pop it off */
2778 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2779 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2780 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2781 IoANY(datasv) = (void *)NULL;
2782 sv_free(av_pop(PL_rsfp_filters));
2786 /* we need to search for the correct entry and clear it */
2787 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2791 /* Invoke the idxth filter function for the current rsfp. */
2792 /* maxlen 0 = read one text line */
2794 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2799 /* This API is bad. It should have been using unsigned int for maxlen.
2800 Not sure if we want to change the API, but if not we should sanity
2801 check the value here. */
2802 const unsigned int correct_length
2811 if (!PL_rsfp_filters)
2813 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2814 /* Provide a default input filter to make life easy. */
2815 /* Note that we append to the line. This is handy. */
2816 DEBUG_P(PerlIO_printf(Perl_debug_log,
2817 "filter_read %d: from rsfp\n", idx));
2818 if (correct_length) {
2821 const int old_len = SvCUR(buf_sv);
2823 /* ensure buf_sv is large enough */
2824 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2825 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2826 correct_length)) <= 0) {
2827 if (PerlIO_error(PL_rsfp))
2828 return -1; /* error */
2830 return 0 ; /* end of file */
2832 SvCUR_set(buf_sv, old_len + len) ;
2835 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2836 if (PerlIO_error(PL_rsfp))
2837 return -1; /* error */
2839 return 0 ; /* end of file */
2842 return SvCUR(buf_sv);
2844 /* Skip this filter slot if filter has been deleted */
2845 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2846 DEBUG_P(PerlIO_printf(Perl_debug_log,
2847 "filter_read %d: skipped (filter deleted)\n",
2849 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2851 /* Get function pointer hidden within datasv */
2852 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2853 DEBUG_P(PerlIO_printf(Perl_debug_log,
2854 "filter_read %d: via function %p (%s)\n",
2855 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2856 /* Call function. The function is expected to */
2857 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2858 /* Return: <0:error, =0:eof, >0:not eof */
2859 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2863 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2866 #ifdef PERL_CR_FILTER
2867 if (!PL_rsfp_filters) {
2868 filter_add(S_cr_textfilter,NULL);
2871 if (PL_rsfp_filters) {
2873 SvCUR_set(sv, 0); /* start with empty line */
2874 if (FILTER_READ(0, sv, 0) > 0)
2875 return ( SvPVX(sv) ) ;
2880 return (sv_gets(sv, fp, append));
2884 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2889 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2893 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2894 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2896 return GvHV(gv); /* Foo:: */
2899 /* use constant CLASS => 'MyClass' */
2900 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
2901 if (gv && GvCV(gv)) {
2902 SV * const sv = cv_const_sv(GvCV(gv));
2904 pkgname = SvPV_nolen_const(sv);
2907 return gv_stashpv(pkgname, 0);
2911 * S_readpipe_override
2912 * Check whether readpipe() is overriden, and generates the appropriate
2913 * optree, provided sublex_start() is called afterwards.
2916 S_readpipe_override(pTHX)
2919 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
2920 yylval.ival = OP_BACKTICK;
2922 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
2924 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
2925 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
2926 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
2928 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
2929 append_elem(OP_LIST,
2930 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
2931 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
2941 * The intent of this yylex wrapper is to minimize the changes to the
2942 * tokener when we aren't interested in collecting madprops. It remains
2943 * to be seen how successful this strategy will be...
2950 char *s = PL_bufptr;
2952 /* make sure PL_thiswhite is initialized */
2956 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2957 if (PL_pending_ident)
2958 return S_pending_ident(aTHX);
2960 /* previous token ate up our whitespace? */
2961 if (!PL_lasttoke && PL_nextwhite) {
2962 PL_thiswhite = PL_nextwhite;
2966 /* isolate the token, and figure out where it is without whitespace */
2967 PL_realtokenstart = -1;
2971 assert(PL_curforce < 0);
2973 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
2974 if (!PL_thistoken) {
2975 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
2976 PL_thistoken = newSVpvs("");
2978 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
2979 PL_thistoken = newSVpvn(tstart, s - tstart);
2982 if (PL_thismad) /* install head */
2983 CURMAD('X', PL_thistoken);
2986 /* last whitespace of a sublex? */
2987 if (optype == ')' && PL_endwhite) {
2988 CURMAD('X', PL_endwhite);
2993 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
2994 if (!PL_thiswhite && !PL_endwhite && !optype) {
2995 sv_free(PL_thistoken);
3000 /* put off final whitespace till peg */
3001 if (optype == ';' && !PL_rsfp) {
3002 PL_nextwhite = PL_thiswhite;
3005 else if (PL_thisopen) {
3006 CURMAD('q', PL_thisopen);
3008 sv_free(PL_thistoken);
3012 /* Store actual token text as madprop X */
3013 CURMAD('X', PL_thistoken);
3017 /* add preceding whitespace as madprop _ */
3018 CURMAD('_', PL_thiswhite);
3022 /* add quoted material as madprop = */
3023 CURMAD('=', PL_thisstuff);
3027 /* add terminating quote as madprop Q */
3028 CURMAD('Q', PL_thisclose);
3032 /* special processing based on optype */
3036 /* opval doesn't need a TOKEN since it can already store mp */
3047 append_madprops(PL_thismad, yylval.opval, 0);
3055 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3064 /* remember any fake bracket that lexer is about to discard */
3065 if (PL_lex_brackets == 1 &&
3066 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3069 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3072 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3073 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3076 break; /* don't bother looking for trailing comment */
3085 /* attach a trailing comment to its statement instead of next token */
3089 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3091 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3093 if (*s == '\n' || *s == '#') {
3094 while (s < PL_bufend && *s != '\n')
3098 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3099 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3116 /* Create new token struct. Note: opvals return early above. */
3117 yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
3124 S_tokenize_use(pTHX_ int is_use, char *s) {
3126 if (PL_expect != XSTATE)
3127 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3128 is_use ? "use" : "no"));
3130 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3131 s = force_version(s, TRUE);
3132 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3133 start_force(PL_curforce);
3134 NEXTVAL_NEXTTOKE.opval = NULL;
3137 else if (*s == 'v') {
3138 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3139 s = force_version(s, FALSE);
3143 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3144 s = force_version(s, FALSE);
3146 yylval.ival = is_use;
3150 static const char* const exp_name[] =
3151 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3152 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3159 Works out what to call the token just pulled out of the input
3160 stream. The yacc parser takes care of taking the ops we return and
3161 stitching them into a tree.
3167 if read an identifier
3168 if we're in a my declaration
3169 croak if they tried to say my($foo::bar)
3170 build the ops for a my() declaration
3171 if it's an access to a my() variable
3172 are we in a sort block?
3173 croak if my($a); $a <=> $b
3174 build ops for access to a my() variable
3175 if in a dq string, and they've said @foo and we can't find @foo
3177 build ops for a bareword
3178 if we already built the token before, use it.
3183 #pragma segment Perl_yylex
3189 register char *s = PL_bufptr;
3194 /* orig_keyword, gvp, and gv are initialized here because
3195 * jump to the label just_a_word_zero can bypass their
3196 * initialization later. */
3197 I32 orig_keyword = 0;
3202 SV* tmp = newSVpvs("");
3203 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3204 (IV)CopLINE(PL_curcop),
3205 lex_state_names[PL_lex_state],
3206 exp_name[PL_expect],
3207 pv_display(tmp, s, strlen(s), 0, 60));
3210 /* check if there's an identifier for us to look at */
3211 if (PL_pending_ident)
3212 return REPORT(S_pending_ident(aTHX));
3214 /* no identifier pending identification */
3216 switch (PL_lex_state) {
3218 case LEX_NORMAL: /* Some compilers will produce faster */
3219 case LEX_INTERPNORMAL: /* code if we comment these out. */
3223 /* when we've already built the next token, just pull it out of the queue */
3227 yylval = PL_nexttoke[PL_lasttoke].next_val;
3229 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3230 PL_nexttoke[PL_lasttoke].next_mad = 0;
3231 if (PL_thismad && PL_thismad->mad_key == '_') {
3232 PL_thiswhite = (SV*)PL_thismad->mad_val;
3233 PL_thismad->mad_val = 0;
3234 mad_free(PL_thismad);
3239 PL_lex_state = PL_lex_defer;
3240 PL_expect = PL_lex_expect;
3241 PL_lex_defer = LEX_NORMAL;
3242 if (!PL_nexttoke[PL_lasttoke].next_type)
3247 yylval = PL_nextval[PL_nexttoke];
3249 PL_lex_state = PL_lex_defer;
3250 PL_expect = PL_lex_expect;
3251 PL_lex_defer = LEX_NORMAL;
3255 /* FIXME - can these be merged? */
3256 return(PL_nexttoke[PL_lasttoke].next_type);
3258 return REPORT(PL_nexttype[PL_nexttoke]);
3261 /* interpolated case modifiers like \L \U, including \Q and \E.
3262 when we get here, PL_bufptr is at the \
3264 case LEX_INTERPCASEMOD:
3266 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3267 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3269 /* handle \E or end of string */
3270 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3272 if (PL_lex_casemods) {
3273 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3274 PL_lex_casestack[PL_lex_casemods] = '\0';
3276 if (PL_bufptr != PL_bufend
3277 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3279 PL_lex_state = LEX_INTERPCONCAT;
3282 PL_thistoken = newSVpvs("\\E");
3288 while (PL_bufptr != PL_bufend &&
3289 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3291 PL_thiswhite = newSVpvs("");
3292 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3296 if (PL_bufptr != PL_bufend)
3299 PL_lex_state = LEX_INTERPCONCAT;
3303 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3304 "### Saw case modifier\n"); });
3306 if (s[1] == '\\' && s[2] == 'E') {
3309 PL_thiswhite = newSVpvs("");
3310 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3313 PL_lex_state = LEX_INTERPCONCAT;
3318 if (!PL_madskills) /* when just compiling don't need correct */
3319 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3320 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3321 if ((*s == 'L' || *s == 'U') &&
3322 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3323 PL_lex_casestack[--PL_lex_casemods] = '\0';
3326 if (PL_lex_casemods > 10)
3327 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3328 PL_lex_casestack[PL_lex_casemods++] = *s;
3329 PL_lex_casestack[PL_lex_casemods] = '\0';
3330 PL_lex_state = LEX_INTERPCONCAT;
3331 start_force(PL_curforce);
3332 NEXTVAL_NEXTTOKE.ival = 0;
3334 start_force(PL_curforce);
3336 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3338 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3340 NEXTVAL_NEXTTOKE.ival = OP_LC;
3342 NEXTVAL_NEXTTOKE.ival = OP_UC;
3344 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3346 Perl_croak(aTHX_ "panic: yylex");
3348 SV* const tmpsv = newSVpvs("");
3349 Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3355 if (PL_lex_starts) {
3361 sv_free(PL_thistoken);
3362 PL_thistoken = newSVpvs("");
3365 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3366 if (PL_lex_casemods == 1 && PL_lex_inpat)
3375 case LEX_INTERPPUSH:
3376 return REPORT(sublex_push());
3378 case LEX_INTERPSTART:
3379 if (PL_bufptr == PL_bufend)
3380 return REPORT(sublex_done());
3381 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3382 "### Interpolated variable\n"); });
3384 PL_lex_dojoin = (*PL_bufptr == '@');
3385 PL_lex_state = LEX_INTERPNORMAL;
3386 if (PL_lex_dojoin) {
3387 start_force(PL_curforce);
3388 NEXTVAL_NEXTTOKE.ival = 0;
3390 start_force(PL_curforce);
3391 force_ident("\"", '$');
3392 start_force(PL_curforce);
3393 NEXTVAL_NEXTTOKE.ival = 0;
3395 start_force(PL_curforce);
3396 NEXTVAL_NEXTTOKE.ival = 0;
3398 start_force(PL_curforce);
3399 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3402 if (PL_lex_starts++) {
3407 sv_free(PL_thistoken);
3408 PL_thistoken = newSVpvs("");
3411 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3412 if (!PL_lex_casemods && PL_lex_inpat)
3419 case LEX_INTERPENDMAYBE:
3420 if (intuit_more(PL_bufptr)) {
3421 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3427 if (PL_lex_dojoin) {
3428 PL_lex_dojoin = FALSE;
3429 PL_lex_state = LEX_INTERPCONCAT;
3433 sv_free(PL_thistoken);
3434 PL_thistoken = newSVpvs("");
3439 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3440 && SvEVALED(PL_lex_repl))
3442 if (PL_bufptr != PL_bufend)
3443 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3447 case LEX_INTERPCONCAT:
3449 if (PL_lex_brackets)
3450 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3452 if (PL_bufptr == PL_bufend)
3453 return REPORT(sublex_done());
3455 if (SvIVX(PL_linestr) == '\'') {
3456 SV *sv = newSVsv(PL_linestr);
3459 else if ( PL_hints & HINT_NEW_RE )
3460 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3461 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3465 s = scan_const(PL_bufptr);
3467 PL_lex_state = LEX_INTERPCASEMOD;
3469 PL_lex_state = LEX_INTERPSTART;
3472 if (s != PL_bufptr) {
3473 start_force(PL_curforce);
3475 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3477 NEXTVAL_NEXTTOKE = yylval;
3480 if (PL_lex_starts++) {
3484 sv_free(PL_thistoken);
3485 PL_thistoken = newSVpvs("");
3488 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3489 if (!PL_lex_casemods && PL_lex_inpat)
3502 PL_lex_state = LEX_NORMAL;
3503 s = scan_formline(PL_bufptr);
3504 if (!PL_lex_formbrack)
3510 PL_oldoldbufptr = PL_oldbufptr;
3516 sv_free(PL_thistoken);
3519 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3523 if (isIDFIRST_lazy_if(s,UTF))
3525 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3528 goto fake_eof; /* emulate EOF on ^D or ^Z */
3537 if (PL_lex_brackets) {
3538 yyerror((const char *)
3540 ? "Format not terminated"
3541 : "Missing right curly or square bracket"));
3543 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3544 "### Tokener got EOF\n");
3548 if (s++ < PL_bufend)
3549 goto retry; /* ignore stray nulls */
3552 if (!PL_in_eval && !PL_preambled) {
3553 PL_preambled = TRUE;
3558 sv_setpv(PL_linestr,incl_perldb());
3559 if (SvCUR(PL_linestr))
3560 sv_catpvs(PL_linestr,";");
3562 while(AvFILLp(PL_preambleav) >= 0) {
3563 SV *tmpsv = av_shift(PL_preambleav);
3564 sv_catsv(PL_linestr, tmpsv);
3565 sv_catpvs(PL_linestr, ";");
3568 sv_free((SV*)PL_preambleav);
3569 PL_preambleav = NULL;
3571 if (PL_minus_n || PL_minus_p) {
3572 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3574 sv_catpvs(PL_linestr,"chomp;");
3577 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3578 || *PL_splitstr == '"')
3579 && strchr(PL_splitstr + 1, *PL_splitstr))
3580 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3582 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3583 bytes can be used as quoting characters. :-) */
3584 const char *splits = PL_splitstr;
3585 sv_catpvs(PL_linestr, "our @F=split(q\0");
3588 if (*splits == '\\')
3589 sv_catpvn(PL_linestr, splits, 1);
3590 sv_catpvn(PL_linestr, splits, 1);
3591 } while (*splits++);
3592 /* This loop will embed the trailing NUL of
3593 PL_linestr as the last thing it does before
3595 sv_catpvs(PL_linestr, ");");
3599 sv_catpvs(PL_linestr,"our @F=split(' ');");
3603 sv_catpvs(PL_linestr,"use feature ':5.10';");
3604 sv_catpvs(PL_linestr, "\n");
3605 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3606 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3607 PL_last_lop = PL_last_uni = NULL;
3608 if (PERLDB_LINE && PL_curstash != PL_debstash)
3609 update_debugger_info(PL_linestr, NULL, 0);
3613 bof = PL_rsfp ? TRUE : FALSE;
3614 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3617 PL_realtokenstart = -1;
3620 if (PL_preprocess && !PL_in_eval)
3621 (void)PerlProc_pclose(PL_rsfp);
3622 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3623 PerlIO_clearerr(PL_rsfp);
3625 (void)PerlIO_close(PL_rsfp);
3627 PL_doextract = FALSE;
3629 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3634 sv_setpv(PL_linestr,
3637 ? ";}continue{print;}" : ";}"));
3638 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3639 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3640 PL_last_lop = PL_last_uni = NULL;
3641 PL_minus_n = PL_minus_p = 0;
3644 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3645 PL_last_lop = PL_last_uni = NULL;
3646 sv_setpvn(PL_linestr,"",0);
3647 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3649 /* If it looks like the start of a BOM or raw UTF-16,
3650 * check if it in fact is. */
3656 #ifdef PERLIO_IS_STDIO
3657 # ifdef __GNU_LIBRARY__
3658 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3659 # define FTELL_FOR_PIPE_IS_BROKEN
3663 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3664 # define FTELL_FOR_PIPE_IS_BROKEN
3669 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3670 /* This loses the possibility to detect the bof
3671 * situation on perl -P when the libc5 is being used.
3672 * Workaround? Maybe attach some extra state to PL_rsfp?
3675 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3677 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3680 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3681 s = swallow_bom((U8*)s);
3685 /* Incest with pod. */
3688 sv_catsv(PL_thiswhite, PL_linestr);
3690 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3691 sv_setpvn(PL_linestr, "", 0);
3692 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3693 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3694 PL_last_lop = PL_last_uni = NULL;
3695 PL_doextract = FALSE;
3699 } while (PL_doextract);
3700 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3701 if (PERLDB_LINE && PL_curstash != PL_debstash)
3702 update_debugger_info(PL_linestr, NULL, 0);
3703 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3704 PL_last_lop = PL_last_uni = NULL;
3705 if (CopLINE(PL_curcop) == 1) {
3706 while (s < PL_bufend && isSPACE(*s))
3708 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3712 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3716 if (*s == '#' && *(s+1) == '!')
3718 #ifdef ALTERNATE_SHEBANG
3720 static char const as[] = ALTERNATE_SHEBANG;
3721 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3722 d = s + (sizeof(as) - 1);
3724 #endif /* ALTERNATE_SHEBANG */
3733 while (*d && !isSPACE(*d))
3737 #ifdef ARG_ZERO_IS_SCRIPT
3738 if (ipathend > ipath) {
3740 * HP-UX (at least) sets argv[0] to the script name,
3741 * which makes $^X incorrect. And Digital UNIX and Linux,
3742 * at least, set argv[0] to the basename of the Perl
3743 * interpreter. So, having found "#!", we'll set it right.
3745 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3747 assert(SvPOK(x) || SvGMAGICAL(x));
3748 if (sv_eq(x, CopFILESV(PL_curcop))) {
3749 sv_setpvn(x, ipath, ipathend - ipath);
3755 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3756 const char * const lstart = SvPV_const(x,llen);
3758 bstart += blen - llen;
3759 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3760 sv_setpvn(x, ipath, ipathend - ipath);
3765 TAINT_NOT; /* $^X is always tainted, but that's OK */
3767 #endif /* ARG_ZERO_IS_SCRIPT */
3772 d = instr(s,"perl -");
3774 d = instr(s,"perl");
3776 /* avoid getting into infinite loops when shebang
3777 * line contains "Perl" rather than "perl" */
3779 for (d = ipathend-4; d >= ipath; --d) {
3780 if ((*d == 'p' || *d == 'P')
3781 && !ibcmp(d, "perl", 4))
3791 #ifdef ALTERNATE_SHEBANG
3793 * If the ALTERNATE_SHEBANG on this system starts with a
3794 * character that can be part of a Perl expression, then if
3795 * we see it but not "perl", we're probably looking at the
3796 * start of Perl code, not a request to hand off to some
3797 * other interpreter. Similarly, if "perl" is there, but
3798 * not in the first 'word' of the line, we assume the line
3799 * contains the start of the Perl program.
3801 if (d && *s != '#') {
3802 const char *c = ipath;
3803 while (*c && !strchr("; \t\r\n\f\v#", *c))
3806 d = NULL; /* "perl" not in first word; ignore */
3808 *s = '#'; /* Don't try to parse shebang line */
3810 #endif /* ALTERNATE_SHEBANG */
3811 #ifndef MACOS_TRADITIONAL
3816 !instr(s,"indir") &&
3817 instr(PL_origargv[0],"perl"))
3824 while (s < PL_bufend && isSPACE(*s))
3826 if (s < PL_bufend) {
3827 Newxz(newargv,PL_origargc+3,char*);
3829 while (s < PL_bufend && !isSPACE(*s))
3832 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3835 newargv = PL_origargv;
3838 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3840 Perl_croak(aTHX_ "Can't exec %s", ipath);
3844 while (*d && !isSPACE(*d))
3846 while (SPACE_OR_TAB(*d))
3850 const bool switches_done = PL_doswitches;
3851 const U32 oldpdb = PL_perldb;
3852 const bool oldn = PL_minus_n;
3853 const bool oldp = PL_minus_p;
3856 if (*d == 'M' || *d == 'm' || *d == 'C') {
3857 const char * const m = d;
3858 while (*d && !isSPACE(*d))
3860 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3863 d = moreswitches(d);
3865 if (PL_doswitches && !switches_done) {
3866 int argc = PL_origargc;
3867 char **argv = PL_origargv;
3870 } while (argc && argv[0][0] == '-' && argv[0][1]);
3871 init_argv_symbols(argc,argv);
3873 if ((PERLDB_LINE && !oldpdb) ||
3874 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3875 /* if we have already added "LINE: while (<>) {",
3876 we must not do it again */
3878 sv_setpvn(PL_linestr, "", 0);
3879 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3880 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3881 PL_last_lop = PL_last_uni = NULL;
3882 PL_preambled = FALSE;
3884 (void)gv_fetchfile(PL_origfilename);
3891 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3893 PL_lex_state = LEX_FORMLINE;
3898 #ifdef PERL_STRICT_CR
3899 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3901 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3903 case ' ': case '\t': case '\f': case 013:
3904 #ifdef MACOS_TRADITIONAL
3908 PL_realtokenstart = -1;
3917 PL_realtokenstart = -1;
3921 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3922 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3923 /* handle eval qq[#line 1 "foo"\n ...] */
3924 CopLINE_dec(PL_curcop);
3927 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3929 if (!PL_in_eval || PL_rsfp)
3934 while (d < PL_bufend && *d != '\n')
3938 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3939 Perl_croak(aTHX_ "panic: input overflow");
3942 PL_thiswhite = newSVpvn(s, d - s);
3947 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3949 PL_lex_state = LEX_FORMLINE;
3955 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3956 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3959 TOKEN(PEG); /* make sure any #! line is accessible */
3964 /* if (PL_madskills && PL_lex_formbrack) { */
3966 while (d < PL_bufend && *d != '\n')
3970 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3971 Perl_croak(aTHX_ "panic: input overflow");
3972 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
3974 PL_thiswhite = newSVpvs("");
3975 if (CopLINE(PL_curcop) == 1) {
3976 sv_setpvn(PL_thiswhite, "", 0);
3979 sv_catpvn(PL_thiswhite, s, d - s);
3993 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4001 while (s < PL_bufend && SPACE_OR_TAB(*s))
4004 if (strnEQ(s,"=>",2)) {
4005 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4006 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4007 OPERATOR('-'); /* unary minus */
4009 PL_last_uni = PL_oldbufptr;
4011 case 'r': ftst = OP_FTEREAD; break;
4012 case 'w': ftst = OP_FTEWRITE; break;
4013 case 'x': ftst = OP_FTEEXEC; break;
4014 case 'o': ftst = OP_FTEOWNED; break;
4015 case 'R': ftst = OP_FTRREAD; break;
4016 case 'W': ftst = OP_FTRWRITE; break;
4017 case 'X': ftst = OP_FTREXEC; break;
4018 case 'O': ftst = OP_FTROWNED; break;
4019 case 'e': ftst = OP_FTIS; break;
4020 case 'z': ftst = OP_FTZERO; break;
4021 case 's': ftst = OP_FTSIZE; break;
4022 case 'f': ftst = OP_FTFILE; break;
4023 case 'd': ftst = OP_FTDIR; break;
4024 case 'l': ftst = OP_FTLINK; break;
4025 case 'p': ftst = OP_FTPIPE; break;
4026 case 'S': ftst = OP_FTSOCK; break;
4027 case 'u': ftst = OP_FTSUID; break;
4028 case 'g': ftst = OP_FTSGID; break;
4029 case 'k': ftst = OP_FTSVTX; break;
4030 case 'b': ftst = OP_FTBLK; break;
4031 case 'c': ftst = OP_FTCHR; break;
4032 case 't': ftst = OP_FTTTY; break;
4033 case 'T': ftst = OP_FTTEXT; break;
4034 case 'B': ftst = OP_FTBINARY; break;
4035 case 'M': case 'A': case 'C':
4036 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4038 case 'M': ftst = OP_FTMTIME; break;
4039 case 'A': ftst = OP_FTATIME; break;
4040 case 'C': ftst = OP_FTCTIME; break;
4048 PL_last_lop_op = (OPCODE)ftst;
4049 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4050 "### Saw file test %c\n", (int)tmp);
4055 /* Assume it was a minus followed by a one-letter named
4056 * subroutine call (or a -bareword), then. */
4057 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4058 "### '-%c' looked like a file test but was not\n",
4065 const char tmp = *s++;
4068 if (PL_expect == XOPERATOR)
4073 else if (*s == '>') {
4076 if (isIDFIRST_lazy_if(s,UTF)) {
4077 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4085 if (PL_expect == XOPERATOR)
4088 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4090 OPERATOR('-'); /* unary minus */
4096 const char tmp = *s++;
4099 if (PL_expect == XOPERATOR)
4104 if (PL_expect == XOPERATOR)
4107 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4114 if (PL_expect != XOPERATOR) {
4115 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4116 PL_expect = XOPERATOR;
4117 force_ident(PL_tokenbuf, '*');
4130 if (PL_expect == XOPERATOR) {
4134 PL_tokenbuf[0] = '%';
4135 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4136 sizeof PL_tokenbuf - 1, FALSE);
4137 if (!PL_tokenbuf[1]) {
4140 PL_pending_ident = '%';
4151 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4158 const char tmp = *s++;
4164 goto just_a_word_zero_gv;
4167 switch (PL_expect) {
4173 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4175 PL_bufptr = s; /* update in case we back off */
4181 PL_expect = XTERMBLOCK;
4184 stuffstart = s - SvPVX(PL_linestr) - 1;
4188 while (isIDFIRST_lazy_if(s,UTF)) {
4191 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4192 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4193 if (tmp < 0) tmp = -tmp;
4208 sv = newSVpvn(s, len);
4210 d = scan_str(d,TRUE,TRUE);
4212 /* MUST advance bufptr here to avoid bogus
4213 "at end of line" context messages from yyerror().
4215 PL_bufptr = s + len;
4216 yyerror("Unterminated attribute parameter in attribute list");
4220 return REPORT(0); /* EOF indicator */
4224 sv_catsv(sv, PL_lex_stuff);
4225 attrs = append_elem(OP_LIST, attrs,
4226 newSVOP(OP_CONST, 0, sv));
4227 SvREFCNT_dec(PL_lex_stuff);
4228 PL_lex_stuff = NULL;
4231 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4233 if (PL_in_my == KEY_our) {
4235 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4237 /* skip to avoid loading attributes.pm */
4239 deprecate(":unique");
4242 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4245 /* NOTE: any CV attrs applied here need to be part of
4246 the CVf_BUILTIN_ATTRS define in cv.h! */
4247 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4249 CvLVALUE_on(PL_compcv);
4251 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4253 CvLOCKED_on(PL_compcv);
4255 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4257 CvMETHOD_on(PL_compcv);
4259 else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4261 CvASSERTION_on(PL_compcv);
4263 /* After we've set the flags, it could be argued that
4264 we don't need to do the attributes.pm-based setting
4265 process, and shouldn't bother appending recognized
4266 flags. To experiment with that, uncomment the
4267 following "else". (Note that's already been
4268 uncommented. That keeps the above-applied built-in
4269 attributes from being intercepted (and possibly
4270 rejected) by a package's attribute routines, but is
4271 justified by the performance win for the common case
4272 of applying only built-in attributes.) */
4274 attrs = append_elem(OP_LIST, attrs,
4275 newSVOP(OP_CONST, 0,
4279 if (*s == ':' && s[1] != ':')
4282 break; /* require real whitespace or :'s */
4283 /* XXX losing whitespace on sequential attributes here */
4287 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4288 if (*s != ';' && *s != '}' && *s != tmp
4289 && (tmp != '=' || *s != ')')) {
4290 const char q = ((*s == '\'') ? '"' : '\'');
4291 /* If here for an expression, and parsed no attrs, back
4293 if (tmp == '=' && !attrs) {
4297 /* MUST advance bufptr here to avoid bogus "at end of line"
4298 context messages from yyerror().
4301 yyerror( (const char *)
4303 ? Perl_form(aTHX_ "Invalid separator character "
4304 "%c%c%c in attribute list", q, *s, q)
4305 : "Unterminated attribute list" ) );
4313 start_force(PL_curforce);
4314 NEXTVAL_NEXTTOKE.opval = attrs;
4315 CURMAD('_', PL_nextwhite);
4320 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4321 (s - SvPVX(PL_linestr)) - stuffstart);
4329 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4330 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4338 const char tmp = *s++;
4343 const char tmp = *s++;
4351 if (PL_lex_brackets <= 0)
4352 yyerror("Unmatched right square bracket");
4355 if (PL_lex_state == LEX_INTERPNORMAL) {
4356 if (PL_lex_brackets == 0) {
4357 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4358 PL_lex_state = LEX_INTERPEND;
4365 if (PL_lex_brackets > 100) {
4366 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4368 switch (PL_expect) {
4370 if (PL_lex_formbrack) {
4374 if (PL_oldoldbufptr == PL_last_lop)
4375 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4377 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4378 OPERATOR(HASHBRACK);
4380 while (s < PL_bufend && SPACE_OR_TAB(*s))
4383 PL_tokenbuf[0] = '\0';
4384 if (d < PL_bufend && *d == '-') {
4385 PL_tokenbuf[0] = '-';
4387 while (d < PL_bufend && SPACE_OR_TAB(*d))
4390 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4391 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4393 while (d < PL_bufend && SPACE_OR_TAB(*d))
4396 const char minus = (PL_tokenbuf[0] == '-');
4397 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4405 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4410 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4415 if (PL_oldoldbufptr == PL_last_lop)
4416 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4418 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4421 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4423 /* This hack is to get the ${} in the message. */
4425 yyerror("syntax error");
4428 OPERATOR(HASHBRACK);
4430 /* This hack serves to disambiguate a pair of curlies
4431 * as being a block or an anon hash. Normally, expectation
4432 * determines that, but in cases where we're not in a
4433 * position to expect anything in particular (like inside
4434 * eval"") we have to resolve the ambiguity. This code
4435 * covers the case where the first term in the curlies is a
4436 * quoted string. Most other cases need to be explicitly
4437 * disambiguated by prepending a "+" before the opening
4438 * curly in order to force resolution as an anon hash.
4440 * XXX should probably propagate the outer expectation
4441 * into eval"" to rely less on this hack, but that could
4442 * potentially break current behavior of eval"".
4446 if (*s == '\'' || *s == '"' || *s == '`') {
4447 /* common case: get past first string, handling escapes */
4448 for (t++; t < PL_bufend && *t != *s;)
4449 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4453 else if (*s == 'q') {
4456 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4459 /* skip q//-like construct */
4461 char open, close, term;
4464 while (t < PL_bufend && isSPACE(*t))
4466 /* check for q => */
4467 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4468 OPERATOR(HASHBRACK);
4472 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4476 for (t++; t < PL_bufend; t++) {
4477 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4479 else if (*t == open)
4483 for (t++; t < PL_bufend; t++) {
4484 if (*t == '\\' && t+1 < PL_bufend)
4486 else if (*t == close && --brackets <= 0)
4488 else if (*t == open)
4495 /* skip plain q word */
4496 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4499 else if (isALNUM_lazy_if(t,UTF)) {
4501 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4504 while (t < PL_bufend && isSPACE(*t))
4506 /* if comma follows first term, call it an anon hash */
4507 /* XXX it could be a comma expression with loop modifiers */
4508 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4509 || (*t == '=' && t[1] == '>')))
4510 OPERATOR(HASHBRACK);
4511 if (PL_expect == XREF)
4514 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4520 yylval.ival = CopLINE(PL_curcop);
4521 if (isSPACE(*s) || *s == '#')
4522 PL_copline = NOLINE; /* invalidate current command line number */
4527 if (PL_lex_brackets <= 0)
4528 yyerror("Unmatched right curly bracket");
4530 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4531 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4532 PL_lex_formbrack = 0;
4533 if (PL_lex_state == LEX_INTERPNORMAL) {
4534 if (PL_lex_brackets == 0) {
4535 if (PL_expect & XFAKEBRACK) {
4536 PL_expect &= XENUMMASK;
4537 PL_lex_state = LEX_INTERPEND;
4542 PL_thiswhite = newSVpvs("");
4543 sv_catpvn(PL_thiswhite,"}",1);
4546 return yylex(); /* ignore fake brackets */
4548 if (*s == '-' && s[1] == '>')
4549 PL_lex_state = LEX_INTERPENDMAYBE;
4550 else if (*s != '[' && *s != '{')
4551 PL_lex_state = LEX_INTERPEND;
4554 if (PL_expect & XFAKEBRACK) {
4555 PL_expect &= XENUMMASK;
4557 return yylex(); /* ignore fake brackets */
4559 start_force(PL_curforce);
4561 curmad('X', newSVpvn(s-1,1));
4562 CURMAD('_', PL_thiswhite);
4567 PL_thistoken = newSVpvs("");
4575 if (PL_expect == XOPERATOR) {
4576 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4577 && isIDFIRST_lazy_if(s,UTF))
4579 CopLINE_dec(PL_curcop);
4580 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4581 CopLINE_inc(PL_curcop);
4586 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4588 PL_expect = XOPERATOR;
4589 force_ident(PL_tokenbuf, '&');
4593 yylval.ival = (OPpENTERSUB_AMPER<<8);
4605 const char tmp = *s++;
4612 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4613 && strchr("+-*/%.^&|<",tmp))
4614 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4615 "Reversed %c= operator",(int)tmp);
4617 if (PL_expect == XSTATE && isALPHA(tmp) &&
4618 (s == PL_linestart+1 || s[-2] == '\n') )
4620 if (PL_in_eval && !PL_rsfp) {
4625 if (strnEQ(s,"=cut",4)) {
4641 PL_thiswhite = newSVpvs("");
4642 sv_catpvn(PL_thiswhite, PL_linestart,
4643 PL_bufend - PL_linestart);
4647 PL_doextract = TRUE;
4651 if (PL_lex_brackets < PL_lex_formbrack) {
4653 #ifdef PERL_STRICT_CR
4654 while (SPACE_OR_TAB(*t))
4656 while (SPACE_OR_TAB(*t) || *t == '\r')
4659 if (*t == '\n' || *t == '#') {
4670 const char tmp = *s++;
4672 /* was this !=~ where !~ was meant?
4673 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4675 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4676 const char *t = s+1;
4678 while (t < PL_bufend && isSPACE(*t))
4681 if (*t == '/' || *t == '?' ||
4682 ((*t == 'm' || *t == 's' || *t == 'y')
4683 && !isALNUM(t[1])) ||
4684 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4685 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4686 "!=~ should be !~");
4696 if (PL_expect != XOPERATOR) {
4697 if (s[1] != '<' && !strchr(s,'>'))
4700 s = scan_heredoc(s);
4702 s = scan_inputsymbol(s);
4703 TERM(sublex_start());
4709 SHop(OP_LEFT_SHIFT);
4723 const char tmp = *s++;
4725 SHop(OP_RIGHT_SHIFT);
4726 else if (tmp == '=')
4735 if (PL_expect == XOPERATOR) {
4736 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4738 deprecate_old(commaless_variable_list);
4739 return REPORT(','); /* grandfather non-comma-format format */
4743 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4744 PL_tokenbuf[0] = '@';
4745 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4746 sizeof PL_tokenbuf - 1, FALSE);
4747 if (PL_expect == XOPERATOR)
4748 no_op("Array length", s);
4749 if (!PL_tokenbuf[1])
4751 PL_expect = XOPERATOR;
4752 PL_pending_ident = '#';
4756 PL_tokenbuf[0] = '$';
4757 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4758 sizeof PL_tokenbuf - 1, FALSE);
4759 if (PL_expect == XOPERATOR)
4761 if (!PL_tokenbuf[1]) {
4763 yyerror("Final $ should be \\$ or $name");
4767 /* This kludge not intended to be bulletproof. */
4768 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4769 yylval.opval = newSVOP(OP_CONST, 0,
4770 newSViv(CopARYBASE_get(&PL_compiling)));
4771 yylval.opval->op_private = OPpCONST_ARYBASE;
4777 const char tmp = *s;
4778 if (PL_lex_state == LEX_NORMAL)
4781 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4782 && intuit_more(s)) {
4784 PL_tokenbuf[0] = '@';
4785 if (ckWARN(WARN_SYNTAX)) {
4788 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4791 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4792 while (t < PL_bufend && *t != ']')
4794 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4795 "Multidimensional syntax %.*s not supported",
4796 (int)((t - PL_bufptr) + 1), PL_bufptr);
4800 else if (*s == '{') {
4802 PL_tokenbuf[0] = '%';
4803 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4804 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4806 char tmpbuf[sizeof PL_tokenbuf];
4809 } while (isSPACE(*t));
4810 if (isIDFIRST_lazy_if(t,UTF)) {
4812 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4816 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4817 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4818 "You need to quote \"%s\"",
4825 PL_expect = XOPERATOR;
4826 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4827 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4828 if (!islop || PL_last_lop_op == OP_GREPSTART)
4829 PL_expect = XOPERATOR;
4830 else if (strchr("$@\"'`q", *s))
4831 PL_expect = XTERM; /* e.g. print $fh "foo" */
4832 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4833 PL_expect = XTERM; /* e.g. print $fh &sub */
4834 else if (isIDFIRST_lazy_if(s,UTF)) {
4835 char tmpbuf[sizeof PL_tokenbuf];
4837 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4838 if ((t2 = keyword(tmpbuf, len, 0))) {
4839 /* binary operators exclude handle interpretations */
4851 PL_expect = XTERM; /* e.g. print $fh length() */
4856 PL_expect = XTERM; /* e.g. print $fh subr() */
4859 else if (isDIGIT(*s))
4860 PL_expect = XTERM; /* e.g. print $fh 3 */
4861 else if (*s == '.' && isDIGIT(s[1]))
4862 PL_expect = XTERM; /* e.g. print $fh .3 */
4863 else if ((*s == '?' || *s == '-' || *s == '+')
4864 && !isSPACE(s[1]) && s[1] != '=')
4865 PL_expect = XTERM; /* e.g. print $fh -1 */
4866 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4868 PL_expect = XTERM; /* e.g. print $fh /.../
4869 XXX except DORDOR operator
4871 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4873 PL_expect = XTERM; /* print $fh <<"EOF" */
4876 PL_pending_ident = '$';
4880 if (PL_expect == XOPERATOR)
4882 PL_tokenbuf[0] = '@';
4883 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4884 if (!PL_tokenbuf[1]) {
4887 if (PL_lex_state == LEX_NORMAL)
4889 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4891 PL_tokenbuf[0] = '%';
4893 /* Warn about @ where they meant $. */
4894 if (*s == '[' || *s == '{') {
4895 if (ckWARN(WARN_SYNTAX)) {
4896 const char *t = s + 1;
4897 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4899 if (*t == '}' || *t == ']') {
4901 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4902 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4903 "Scalar value %.*s better written as $%.*s",
4904 (int)(t-PL_bufptr), PL_bufptr,
4905 (int)(t-PL_bufptr-1), PL_bufptr+1);
4910 PL_pending_ident = '@';
4913 case '/': /* may be division, defined-or, or pattern */
4914 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4918 case '?': /* may either be conditional or pattern */
4919 if(PL_expect == XOPERATOR) {
4927 /* A // operator. */
4937 /* Disable warning on "study /blah/" */
4938 if (PL_oldoldbufptr == PL_last_uni
4939 && (*PL_last_uni != 's' || s - PL_last_uni < 5
4940 || memNE(PL_last_uni, "study", 5)
4941 || isALNUM_lazy_if(PL_last_uni+5,UTF)
4944 s = scan_pat(s,OP_MATCH);
4945 TERM(sublex_start());
4949 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4950 #ifdef PERL_STRICT_CR
4953 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4955 && (s == PL_linestart || s[-1] == '\n') )
4957 PL_lex_formbrack = 0;
4961 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4967 yylval.ival = OPf_SPECIAL;
4973 if (PL_expect != XOPERATOR)
4978 case '0': case '1': case '2': case '3': case '4':
4979 case '5': case '6': case '7': case '8': case '9':
4980 s = scan_num(s, &yylval);
4981 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
4982 if (PL_expect == XOPERATOR)
4987 s = scan_str(s,!!PL_madskills,FALSE);
4988 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4989 if (PL_expect == XOPERATOR) {
4990 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4992 deprecate_old(commaless_variable_list);
4993 return REPORT(','); /* grandfather non-comma-format format */
5000 yylval.ival = OP_CONST;
5001 TERM(sublex_start());
5004 s = scan_str(s,!!PL_madskills,FALSE);
5005 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5006 if (PL_expect == XOPERATOR) {
5007 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5009 deprecate_old(commaless_variable_list);
5010 return REPORT(','); /* grandfather non-comma-format format */
5017 yylval.ival = OP_CONST;
5018 /* FIXME. I think that this can be const if char *d is replaced by
5019 more localised variables. */
5020 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5021 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5022 yylval.ival = OP_STRINGIFY;
5026 TERM(sublex_start());
5029 s = scan_str(s,!!PL_madskills,FALSE);
5030 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5031 if (PL_expect == XOPERATOR)
5032 no_op("Backticks",s);
5035 readpipe_override();
5036 TERM(sublex_start());
5040 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5041 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5043 if (PL_expect == XOPERATOR)
5044 no_op("Backslash",s);
5048 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5049 char *start = s + 2;
5050 while (isDIGIT(*start) || *start == '_')
5052 if (*start == '.' && isDIGIT(start[1])) {
5053 s = scan_num(s, &yylval);
5056 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5057 else if (!isALPHA(*start) && (PL_expect == XTERM
5058 || PL_expect == XREF || PL_expect == XSTATE
5059 || PL_expect == XTERMORDORDOR)) {
5060 /* XXX Use gv_fetchpvn rather than stomping on a const string */
5061 const char c = *start;
5064 gv = gv_fetchpv(s, 0, SVt_PVCV);
5067 s = scan_num(s, &yylval);
5074 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5116 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5118 /* Some keywords can be followed by any delimiter, including ':' */
5119 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5120 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5121 (PL_tokenbuf[0] == 'q' &&
5122 strchr("qwxr", PL_tokenbuf[1])))));
5124 /* x::* is just a word, unless x is "CORE" */
5125 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5129 while (d < PL_bufend && isSPACE(*d))
5130 d++; /* no comments skipped here, or s### is misparsed */
5132 /* Is this a label? */
5133 if (!tmp && PL_expect == XSTATE
5134 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5136 yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5141 /* Check for keywords */
5142 tmp = keyword(PL_tokenbuf, len, 0);
5144 /* Is this a word before a => operator? */
5145 if (*d == '=' && d[1] == '>') {
5148 = (OP*)newSVOP(OP_CONST, 0,
5149 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5150 yylval.opval->op_private = OPpCONST_BARE;
5154 if (tmp < 0) { /* second-class keyword? */
5155 GV *ogv = NULL; /* override (winner) */
5156 GV *hgv = NULL; /* hidden (loser) */
5157 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5159 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5162 if (GvIMPORTED_CV(gv))
5164 else if (! CvMETHOD(cv))
5168 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5169 (gv = *gvp) && isGV_with_GP(gv) &&
5170 GvCVu(gv) && GvIMPORTED_CV(gv))
5177 tmp = 0; /* overridden by import or by GLOBAL */
5180 && -tmp==KEY_lock /* XXX generalizable kludge */
5182 && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
5184 tmp = 0; /* any sub overrides "weak" keyword */
5186 else { /* no override */
5188 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5189 Perl_warner(aTHX_ packWARN(WARN_MISC),
5190 "dump() better written as CORE::dump()");
5194 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5195 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
5196 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5197 "Ambiguous call resolved as CORE::%s(), %s",
5198 GvENAME(hgv), "qualify as such or use &");
5205 default: /* not a keyword */
5206 /* Trade off - by using this evil construction we can pull the
5207 variable gv into the block labelled keylookup. If not, then
5208 we have to give it function scope so that the goto from the
5209 earlier ':' case doesn't bypass the initialisation. */
5211 just_a_word_zero_gv:
5219 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5222 SV *nextPL_nextwhite = 0;
5226 /* Get the rest if it looks like a package qualifier */
5228 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5230 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5233 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5234 *s == '\'' ? "'" : "::");
5239 if (PL_expect == XOPERATOR) {
5240 if (PL_bufptr == PL_linestart) {
5241 CopLINE_dec(PL_curcop);
5242 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5243 CopLINE_inc(PL_curcop);
5246 no_op("Bareword",s);
5249 /* Look for a subroutine with this name in current package,
5250 unless name is "Foo::", in which case Foo is a bearword
5251 (and a package name). */
5253 if (len > 2 && !PL_madskills &&
5254 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5256 if (ckWARN(WARN_BAREWORD)
5257 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5258 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5259 "Bareword \"%s\" refers to nonexistent package",
5262 PL_tokenbuf[len] = '\0';
5268 /* Mustn't actually add anything to a symbol table.
5269 But also don't want to "initialise" any placeholder
5270 constants that might already be there into full
5271 blown PVGVs with attached PVCV. */
5272 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5273 GV_NOADD_NOINIT, SVt_PVCV);
5278 /* if we saw a global override before, get the right name */
5281 sv = newSVpvs("CORE::GLOBAL::");
5282 sv_catpv(sv,PL_tokenbuf);
5285 /* If len is 0, newSVpv does strlen(), which is correct.
5286 If len is non-zero, then it will be the true length,
5287 and so the scalar will be created correctly. */
5288 sv = newSVpv(PL_tokenbuf,len);
5291 if (PL_madskills && !PL_thistoken) {
5292 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5293 PL_thistoken = newSVpv(start,s - start);
5294 PL_realtokenstart = s - SvPVX(PL_linestr);
5298 /* Presume this is going to be a bareword of some sort. */
5301 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5302 yylval.opval->op_private = OPpCONST_BARE;
5303 /* UTF-8 package name? */
5304 if (UTF && !IN_BYTES &&
5305 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5308 /* And if "Foo::", then that's what it certainly is. */
5313 /* Do the explicit type check so that we don't need to force
5314 the initialisation of the symbol table to have a real GV.
5315 Beware - gv may not really be a PVGV, cv may not really be
5316 a PVCV, (because of the space optimisations that gv_init
5317 understands) But they're true if for this symbol there is
5318 respectively a typeglob and a subroutine.
5320 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5321 /* Real typeglob, so get the real subroutine: */
5323 /* A proxy for a subroutine in this package? */
5324 : SvOK(gv) ? (CV *) gv : NULL)
5327 /* See if it's the indirect object for a list operator. */
5329 if (PL_oldoldbufptr &&
5330 PL_oldoldbufptr < PL_bufptr &&
5331 (PL_oldoldbufptr == PL_last_lop
5332 || PL_oldoldbufptr == PL_last_uni) &&
5333 /* NO SKIPSPACE BEFORE HERE! */
5334 (PL_expect == XREF ||
5335 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5337 bool immediate_paren = *s == '(';
5339 /* (Now we can afford to cross potential line boundary.) */
5340 s = SKIPSPACE2(s,nextPL_nextwhite);
5342 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5345 /* Two barewords in a row may indicate method call. */
5347 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5348 (tmp = intuit_method(s, gv, cv)))
5351 /* If not a declared subroutine, it's an indirect object. */
5352 /* (But it's an indir obj regardless for sort.) */
5353 /* Also, if "_" follows a filetest operator, it's a bareword */
5356 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5358 (PL_last_lop_op != OP_MAPSTART &&
5359 PL_last_lop_op != OP_GREPSTART))))
5360 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5361 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5364 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5369 PL_expect = XOPERATOR;
5372 s = SKIPSPACE2(s,nextPL_nextwhite);
5373 PL_nextwhite = nextPL_nextwhite;
5378 /* Is this a word before a => operator? */
5379 if (*s == '=' && s[1] == '>' && !pkgname) {
5381 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5382 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5383 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5387 /* If followed by a paren, it's certainly a subroutine. */
5392 while (SPACE_OR_TAB(*d))
5394 if (*d == ')' && (sv = gv_const_sv(gv))) {
5398 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5399 sv_catpvn(PL_thistoken, par, s - par);
5401 sv_free(PL_nextwhite);
5411 PL_nextwhite = PL_thiswhite;
5414 start_force(PL_curforce);
5416 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5417 PL_expect = XOPERATOR;
5420 PL_nextwhite = nextPL_nextwhite;
5421 curmad('X', PL_thistoken);
5422 PL_thistoken = newSVpvs("");
5430 /* If followed by var or block, call it a method (unless sub) */
5432 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5433 PL_last_lop = PL_oldbufptr;
5434 PL_last_lop_op = OP_METHOD;
5438 /* If followed by a bareword, see if it looks like indir obj. */
5441 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5442 && (tmp = intuit_method(s, gv, cv)))
5445 /* Not a method, so call it a subroutine (if defined) */
5448 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5449 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5450 "Ambiguous use of -%s resolved as -&%s()",
5451 PL_tokenbuf, PL_tokenbuf);
5452 /* Check for a constant sub */
5453 if ((sv = gv_const_sv(gv))) {
5455 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5456 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5457 yylval.opval->op_private = 0;
5461 /* Resolve to GV now. */
5462 if (SvTYPE(gv) != SVt_PVGV) {
5463 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5464 assert (SvTYPE(gv) == SVt_PVGV);
5465 /* cv must have been some sort of placeholder, so
5466 now needs replacing with a real code reference. */
5470 op_free(yylval.opval);
5471 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5472 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5473 PL_last_lop = PL_oldbufptr;
5474 PL_last_lop_op = OP_ENTERSUB;
5475 /* Is there a prototype? */
5483 const char *proto = SvPV_const((SV*)cv, protolen);
5486 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5488 while (*proto == ';')
5490 if (*proto == '&' && *s == '{') {
5491 sv_setpv(PL_subname,
5494 "__ANON__" : "__ANON__::__ANON__"));
5501 PL_nextwhite = PL_thiswhite;
5504 start_force(PL_curforce);
5505 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5508 PL_nextwhite = nextPL_nextwhite;
5509 curmad('X', PL_thistoken);
5510 PL_thistoken = newSVpvs("");
5517 /* Guess harder when madskills require "best effort". */
5518 if (PL_madskills && (!gv || !GvCVu(gv))) {
5519 int probable_sub = 0;
5520 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5522 else if (isALPHA(*s)) {
5526 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5527 if (!keyword(tmpbuf, tmplen, 0))
5530 while (d < PL_bufend && isSPACE(*d))
5532 if (*d == '=' && d[1] == '>')
5537 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5538 op_free(yylval.opval);
5539 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5540 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5541 PL_last_lop = PL_oldbufptr;
5542 PL_last_lop_op = OP_ENTERSUB;
5543 PL_nextwhite = PL_thiswhite;
5545 start_force(PL_curforce);
5546 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5548 PL_nextwhite = nextPL_nextwhite;
5549 curmad('X', PL_thistoken);
5550 PL_thistoken = newSVpvs("");
5555 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5562 /* Call it a bare word */
5564 if (PL_hints & HINT_STRICT_SUBS)
5565 yylval.opval->op_private |= OPpCONST_STRICT;
5568 if (lastchar != '-') {
5569 if (ckWARN(WARN_RESERVED)) {
5573 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5574 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5581 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5582 && ckWARN_d(WARN_AMBIGUOUS)) {
5583 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5584 "Operator or semicolon missing before %c%s",
5585 lastchar, PL_tokenbuf);
5586 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5587 "Ambiguous use of %c resolved as operator %c",
5588 lastchar, lastchar);
5594 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5595 newSVpv(CopFILE(PL_curcop),0));
5599 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5600 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5603 case KEY___PACKAGE__:
5604 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5606 ? newSVhek(HvNAME_HEK(PL_curstash))
5613 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5614 const char *pname = "main";
5615 if (PL_tokenbuf[2] == 'D')
5616 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5617 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5621 GvIOp(gv) = newIO();
5622 IoIFP(GvIOp(gv)) = PL_rsfp;
5623 #if defined(HAS_FCNTL) && defined(F_SETFD)
5625 const int fd = PerlIO_fileno(PL_rsfp);
5626 fcntl(fd,F_SETFD,fd >= 3);
5629 /* Mark this internal pseudo-handle as clean */
5630 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5632 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5633 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5634 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5636 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5637 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5638 /* if the script was opened in binmode, we need to revert
5639 * it to text mode for compatibility; but only iff it has CRs
5640 * XXX this is a questionable hack at best. */
5641 if (PL_bufend-PL_bufptr > 2
5642 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5645 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5646 loc = PerlIO_tell(PL_rsfp);
5647 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5650 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5652 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5653 #endif /* NETWARE */
5654 #ifdef PERLIO_IS_STDIO /* really? */
5655 # if defined(__BORLANDC__)
5656 /* XXX see note in do_binmode() */
5657 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5661 PerlIO_seek(PL_rsfp, loc, 0);
5665 #ifdef PERLIO_LAYERS
5668 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5669 else if (PL_encoding) {
5676 XPUSHs(PL_encoding);
5678 call_method("name", G_SCALAR);
5682 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5683 Perl_form(aTHX_ ":encoding(%"SVf")",
5692 if (PL_realtokenstart >= 0) {
5693 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5695 PL_endwhite = newSVpvs("");
5696 sv_catsv(PL_endwhite, PL_thiswhite);
5698 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5699 PL_realtokenstart = -1;
5701 while ((s = filter_gets(PL_endwhite, PL_rsfp,
5702 SvCUR(PL_endwhite))) != Nullch) ;
5717 if (PL_expect == XSTATE) {
5724 if (*s == ':' && s[1] == ':') {
5727 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5728 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5729 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5732 else if (tmp == KEY_require || tmp == KEY_do)
5733 /* that's a way to remember we saw "CORE::" */
5746 LOP(OP_ACCEPT,XTERM);
5752 LOP(OP_ATAN2,XTERM);
5758 LOP(OP_BINMODE,XTERM);
5761 LOP(OP_BLESS,XTERM);
5770 /* When 'use switch' is in effect, continue has a dual
5771 life as a control operator. */
5773 if (!FEATURE_IS_ENABLED("switch"))
5776 /* We have to disambiguate the two senses of
5777 "continue". If the next token is a '{' then
5778 treat it as the start of a continue block;
5779 otherwise treat it as a control operator.
5791 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5808 if (!PL_cryptseen) {
5809 PL_cryptseen = TRUE;
5813 LOP(OP_CRYPT,XTERM);
5816 LOP(OP_CHMOD,XTERM);
5819 LOP(OP_CHOWN,XTERM);
5822 LOP(OP_CONNECT,XTERM);
5841 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5842 if (orig_keyword == KEY_do) {
5851 PL_hints |= HINT_BLOCK_SCOPE;
5861 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5862 LOP(OP_DBMOPEN,XTERM);
5868 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5875 yylval.ival = CopLINE(PL_curcop);
5891 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5892 UNIBRACK(OP_ENTEREVAL);
5910 case KEY_endhostent:
5916 case KEY_endservent:
5919 case KEY_endprotoent:
5930 yylval.ival = CopLINE(PL_curcop);
5932 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5935 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5938 if ((PL_bufend - p) >= 3 &&
5939 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5941 else if ((PL_bufend - p) >= 4 &&
5942 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5945 if (isIDFIRST_lazy_if(p,UTF)) {
5946 p = scan_ident(p, PL_bufend,
5947 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5951 Perl_croak(aTHX_ "Missing $ on loop variable");
5953 s = SvPVX(PL_linestr) + soff;
5959 LOP(OP_FORMLINE,XTERM);
5965 LOP(OP_FCNTL,XTERM);
5971 LOP(OP_FLOCK,XTERM);
5980 LOP(OP_GREPSTART, XREF);
5983 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5998 case KEY_getpriority:
5999 LOP(OP_GETPRIORITY,XTERM);
6001 case KEY_getprotobyname:
6004 case KEY_getprotobynumber:
6005 LOP(OP_GPBYNUMBER,XTERM);
6007 case KEY_getprotoent:
6019 case KEY_getpeername:
6020 UNI(OP_GETPEERNAME);
6022 case KEY_gethostbyname:
6025 case KEY_gethostbyaddr:
6026 LOP(OP_GHBYADDR,XTERM);
6028 case KEY_gethostent:
6031 case KEY_getnetbyname:
6034 case KEY_getnetbyaddr:
6035 LOP(OP_GNBYADDR,XTERM);
6040 case KEY_getservbyname:
6041 LOP(OP_GSBYNAME,XTERM);
6043 case KEY_getservbyport:
6044 LOP(OP_GSBYPORT,XTERM);
6046 case KEY_getservent:
6049 case KEY_getsockname:
6050 UNI(OP_GETSOCKNAME);
6052 case KEY_getsockopt:
6053 LOP(OP_GSOCKOPT,XTERM);
6068 yylval.ival = CopLINE(PL_curcop);
6079 yylval.ival = CopLINE(PL_curcop);
6083 LOP(OP_INDEX,XTERM);
6089 LOP(OP_IOCTL,XTERM);
6101 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6133 LOP(OP_LISTEN,XTERM);
6142 s = scan_pat(s,OP_MATCH);
6143 TERM(sublex_start());
6146 LOP(OP_MAPSTART, XREF);
6149 LOP(OP_MKDIR,XTERM);
6152 LOP(OP_MSGCTL,XTERM);
6155 LOP(OP_MSGGET,XTERM);
6158 LOP(OP_MSGRCV,XTERM);
6161 LOP(OP_MSGSND,XTERM);
6168 if (isIDFIRST_lazy_if(s,UTF)) {
6172 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6173 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6175 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6176 if (!PL_in_my_stash) {
6179 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6183 if (PL_madskills) { /* just add type to declarator token */
6184 sv_catsv(PL_thistoken, PL_nextwhite);
6186 sv_catpvn(PL_thistoken, start, s - start);
6194 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6201 s = tokenize_use(0, s);
6205 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6212 if (isIDFIRST_lazy_if(s,UTF)) {
6214 for (d = s; isALNUM_lazy_if(d,UTF);)
6216 for (t=d; isSPACE(*t);)
6218 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6220 && !(t[0] == '=' && t[1] == '>')
6222 int parms_len = (int)(d-s);
6223 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6224 "Precedence problem: open %.*s should be open(%.*s)",
6225 parms_len, s, parms_len, s);
6231 yylval.ival = OP_OR;
6241 LOP(OP_OPEN_DIR,XTERM);
6244 checkcomma(s,PL_tokenbuf,"filehandle");
6248 checkcomma(s,PL_tokenbuf,"filehandle");
6267 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6271 LOP(OP_PIPE_OP,XTERM);
6274 s = scan_str(s,!!PL_madskills,FALSE);
6277 yylval.ival = OP_CONST;
6278 TERM(sublex_start());
6284 s = scan_str(s,!!PL_madskills,FALSE);
6287 PL_expect = XOPERATOR;
6289 if (SvCUR(PL_lex_stuff)) {
6292 d = SvPV_force(PL_lex_stuff, len);
6294 for (; isSPACE(*d) && len; --len, ++d)
6299 if (!warned && ckWARN(WARN_QW)) {
6300 for (; !isSPACE(*d) && len; --len, ++d) {
6302 Perl_warner(aTHX_ packWARN(WARN_QW),
6303 "Possible attempt to separate words with commas");
6306 else if (*d == '#') {
6307 Perl_warner(aTHX_ packWARN(WARN_QW),
6308 "Possible attempt to put comments in qw() list");
6314 for (; !isSPACE(*d) && len; --len, ++d)
6317 sv = newSVpvn(b, d-b);
6318 if (DO_UTF8(PL_lex_stuff))
6320 words = append_elem(OP_LIST, words,
6321 newSVOP(OP_CONST, 0, tokeq(sv)));
6325 start_force(PL_curforce);
6326 NEXTVAL_NEXTTOKE.opval = words;
6331 SvREFCNT_dec(PL_lex_stuff);
6332 PL_lex_stuff = NULL;
6338 s = scan_str(s,!!PL_madskills,FALSE);
6341 yylval.ival = OP_STRINGIFY;
6342 if (SvIVX(PL_lex_stuff) == '\'')
6343 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6344 TERM(sublex_start());
6347 s = scan_pat(s,OP_QR);
6348 TERM(sublex_start());
6351 s = scan_str(s,!!PL_madskills,FALSE);
6354 readpipe_override();
6355 TERM(sublex_start());
6363 s = force_version(s, FALSE);
6365 else if (*s != 'v' || !isDIGIT(s[1])
6366 || (s = force_version(s, TRUE), *s == 'v'))
6368 *PL_tokenbuf = '\0';
6369 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6370 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6371 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6373 yyerror("<> should be quotes");
6375 if (orig_keyword == KEY_require) {
6383 PL_last_uni = PL_oldbufptr;
6384 PL_last_lop_op = OP_REQUIRE;
6386 return REPORT( (int)REQUIRE );
6392 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6396 LOP(OP_RENAME,XTERM);
6405 LOP(OP_RINDEX,XTERM);
6415 UNIDOR(OP_READLINE);
6428 LOP(OP_REVERSE,XTERM);
6431 UNIDOR(OP_READLINK);
6439 TERM(sublex_start());
6441 TOKEN(1); /* force error */
6444 checkcomma(s,PL_tokenbuf,"filehandle");
6454 LOP(OP_SELECT,XTERM);
6460 LOP(OP_SEMCTL,XTERM);
6463 LOP(OP_SEMGET,XTERM);
6466 LOP(OP_SEMOP,XTERM);
6472 LOP(OP_SETPGRP,XTERM);
6474 case KEY_setpriority:
6475 LOP(OP_SETPRIORITY,XTERM);
6477 case KEY_sethostent:
6483 case KEY_setservent:
6486 case KEY_setprotoent:
6496 LOP(OP_SEEKDIR,XTERM);
6498 case KEY_setsockopt:
6499 LOP(OP_SSOCKOPT,XTERM);
6505 LOP(OP_SHMCTL,XTERM);
6508 LOP(OP_SHMGET,XTERM);
6511 LOP(OP_SHMREAD,XTERM);
6514 LOP(OP_SHMWRITE,XTERM);
6517 LOP(OP_SHUTDOWN,XTERM);
6526 LOP(OP_SOCKET,XTERM);
6528 case KEY_socketpair:
6529 LOP(OP_SOCKPAIR,XTERM);
6532 checkcomma(s,PL_tokenbuf,"subroutine name");
6534 if (*s == ';' || *s == ')') /* probably a close */
6535 Perl_croak(aTHX_ "sort is now a reserved word");
6537 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6541 LOP(OP_SPLIT,XTERM);
6544 LOP(OP_SPRINTF,XTERM);
6547 LOP(OP_SPLICE,XTERM);
6562 LOP(OP_SUBSTR,XTERM);
6568 char tmpbuf[sizeof PL_tokenbuf];
6569 SSize_t tboffset = 0;
6570 expectation attrful;
6571 bool have_name, have_proto;
6572 const int key = tmp;
6577 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6578 SV *subtoken = newSVpvn(tstart, s - tstart);
6582 s = SKIPSPACE2(s,tmpwhite);
6587 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6588 (*s == ':' && s[1] == ':'))
6595 attrful = XATTRBLOCK;
6596 /* remember buffer pos'n for later force_word */
6597 tboffset = s - PL_oldbufptr;
6598 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6601 nametoke = newSVpvn(s, d - s);
6603 if (memchr(tmpbuf, ':', len))
6604 sv_setpvn(PL_subname, tmpbuf, len);
6606 sv_setsv(PL_subname,PL_curstname);
6607 sv_catpvs(PL_subname,"::");
6608 sv_catpvn(PL_subname,tmpbuf,len);
6615 CURMAD('X', nametoke);
6616 CURMAD('_', tmpwhite);
6617 (void) force_word(PL_oldbufptr + tboffset, WORD,
6620 s = SKIPSPACE2(d,tmpwhite);
6627 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6628 PL_expect = XTERMBLOCK;
6629 attrful = XATTRTERM;
6630 sv_setpvn(PL_subname,"?",1);
6634 if (key == KEY_format) {
6636 PL_lex_formbrack = PL_lex_brackets + 1;
6638 PL_thistoken = subtoken;
6642 (void) force_word(PL_oldbufptr + tboffset, WORD,
6648 /* Look for a prototype */
6651 bool bad_proto = FALSE;
6652 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6654 s = scan_str(s,!!PL_madskills,FALSE);
6656 Perl_croak(aTHX_ "Prototype not terminated");
6657 /* strip spaces and check for bad characters */
6658 d = SvPVX(PL_lex_stuff);
6660 for (p = d; *p; ++p) {
6663 if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
6669 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6670 "Illegal character in prototype for %"SVf" : %s",
6671 SVfARG(PL_subname), d);
6672 SvCUR_set(PL_lex_stuff, tmp);
6677 CURMAD('q', PL_thisopen);
6678 CURMAD('_', tmpwhite);
6679 CURMAD('=', PL_thisstuff);
6680 CURMAD('Q', PL_thisclose);
6681 NEXTVAL_NEXTTOKE.opval =
6682 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6683 PL_lex_stuff = Nullsv;
6686 s = SKIPSPACE2(s,tmpwhite);
6694 if (*s == ':' && s[1] != ':')
6695 PL_expect = attrful;
6696 else if (*s != '{' && key == KEY_sub) {
6698 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6700 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6707 curmad('^', newSVpvs(""));
6708 CURMAD('_', tmpwhite);
6712 PL_thistoken = subtoken;
6715 NEXTVAL_NEXTTOKE.opval =
6716 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6717 PL_lex_stuff = NULL;
6722 sv_setpv(PL_subname,
6724 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
6728 (void) force_word(PL_oldbufptr + tboffset, WORD,
6738 LOP(OP_SYSTEM,XREF);
6741 LOP(OP_SYMLINK,XTERM);
6744 LOP(OP_SYSCALL,XTERM);
6747 LOP(OP_SYSOPEN,XTERM);
6750 LOP(OP_SYSSEEK,XTERM);
6753 LOP(OP_SYSREAD,XTERM);
6756 LOP(OP_SYSWRITE,XTERM);
6760 TERM(sublex_start());
6781 LOP(OP_TRUNCATE,XTERM);
6793 yylval.ival = CopLINE(PL_curcop);
6797 yylval.ival = CopLINE(PL_curcop);
6801 LOP(OP_UNLINK,XTERM);
6807 LOP(OP_UNPACK,XTERM);
6810 LOP(OP_UTIME,XTERM);
6816 LOP(OP_UNSHIFT,XTERM);
6819 s = tokenize_use(1, s);
6829 yylval.ival = CopLINE(PL_curcop);
6833 yylval.ival = CopLINE(PL_curcop);
6837 PL_hints |= HINT_BLOCK_SCOPE;
6844 LOP(OP_WAITPID,XTERM);
6853 ctl_l[0] = toCTRL('L');
6855 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6858 /* Make sure $^L is defined */
6859 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6864 if (PL_expect == XOPERATOR)
6870 yylval.ival = OP_XOR;
6875 TERM(sublex_start());
6880 #pragma segment Main
6884 S_pending_ident(pTHX)
6889 /* pit holds the identifier we read and pending_ident is reset */
6890 char pit = PL_pending_ident;
6891 PL_pending_ident = 0;
6893 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6894 DEBUG_T({ PerlIO_printf(Perl_debug_log,
6895 "### Pending identifier '%s'\n", PL_tokenbuf); });
6897 /* if we're in a my(), we can't allow dynamics here.
6898 $foo'bar has already been turned into $foo::bar, so
6899 just check for colons.
6901 if it's a legal name, the OP is a PADANY.
6904 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
6905 if (strchr(PL_tokenbuf,':'))
6906 yyerror(Perl_form(aTHX_ "No package name allowed for "
6907 "variable %s in \"our\"",
6909 tmp = allocmy(PL_tokenbuf);
6912 if (strchr(PL_tokenbuf,':'))
6913 yyerror(Perl_form(aTHX_ PL_no_myglob,
6914 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
6916 yylval.opval = newOP(OP_PADANY, 0);
6917 yylval.opval->op_targ = allocmy(PL_tokenbuf);
6923 build the ops for accesses to a my() variable.
6925 Deny my($a) or my($b) in a sort block, *if* $a or $b is
6926 then used in a comparison. This catches most, but not
6927 all cases. For instance, it catches
6928 sort { my($a); $a <=> $b }
6930 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6931 (although why you'd do that is anyone's guess).
6934 if (!strchr(PL_tokenbuf,':')) {
6936 tmp = pad_findmy(PL_tokenbuf);
6937 if (tmp != NOT_IN_PAD) {
6938 /* might be an "our" variable" */
6939 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6940 /* build ops for a bareword */
6941 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
6942 HEK * const stashname = HvNAME_HEK(stash);
6943 SV * const sym = newSVhek(stashname);
6944 sv_catpvs(sym, "::");
6945 sv_catpv(sym, PL_tokenbuf+1);
6946 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6947 yylval.opval->op_private = OPpCONST_ENTERED;
6950 ? (GV_ADDMULTI | GV_ADDINEVAL)
6953 ((PL_tokenbuf[0] == '$') ? SVt_PV
6954 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6959 /* if it's a sort block and they're naming $a or $b */
6960 if (PL_last_lop_op == OP_SORT &&
6961 PL_tokenbuf[0] == '$' &&
6962 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
6965 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
6966 d < PL_bufend && *d != '\n';
6969 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
6970 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
6976 yylval.opval = newOP(OP_PADANY, 0);
6977 yylval.opval->op_targ = tmp;
6983 Whine if they've said @foo in a doublequoted string,
6984 and @foo isn't a variable we can find in the symbol
6987 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
6988 GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
6989 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
6990 && ckWARN(WARN_AMBIGUOUS)
6991 /* DO NOT warn for @- and @+ */
6992 && !( PL_tokenbuf[2] == '\0' &&
6993 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
6996 /* Downgraded from fatal to warning 20000522 mjd */
6997 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6998 "Possible unintended interpolation of %s in string",
7003 /* build ops for a bareword */
7004 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
7005 yylval.opval->op_private = OPpCONST_ENTERED;
7008 /* If the identifier refers to a stash, don't autovivify it.
7009 * Change 24660 had the side effect of causing symbol table
7010 * hashes to always be defined, even if they were freshly
7011 * created and the only reference in the entire program was
7012 * the single statement with the defined %foo::bar:: test.
7013 * It appears that all code in the wild doing this actually
7014 * wants to know whether sub-packages have been loaded, so
7015 * by avoiding auto-vivifying symbol tables, we ensure that
7016 * defined %foo::bar:: continues to be false, and the existing
7017 * tests still give the expected answers, even though what
7018 * they're actually testing has now changed subtly.
7020 (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
7022 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7023 ((PL_tokenbuf[0] == '$') ? SVt_PV
7024 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7030 * The following code was generated by perl_keyword.pl.
7034 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7039 case 1: /* 5 tokens of length 1 */
7071 case 2: /* 18 tokens of length 2 */
7217 case 3: /* 29 tokens of length 3 */
7221 if (name[1] == 'N' &&
7284 if (name[1] == 'i' &&
7306 return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7324 if (name[1] == 'o' &&
7333 if (name[1] == 'e' &&
7342 if (name[1] == 'n' &&
7351 if (name[1] == 'o' &&
7360 if (name[1] == 'a' &&
7369 if (name[1] == 'o' &&
7431 if (name[1] == 'e' &&
7445 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7471 if (name[1] == 'i' &&
7480 if (name[1] == 's' &&
7489 if (name[1] == 'e' &&
7498 if (name[1] == 'o' &&
7510 case 4: /* 41 tokens of length 4 */
7514 if (name[1] == 'O' &&
7524 if (name[1] == 'N' &&
7534 if (name[1] == 'i' &&
7544 if (name[1] == 'h' &&
7554 if (name[1] == 'u' &&
7567 if (name[2] == 'c' &&
7576 if (name[2] == 's' &&
7585 if (name[2] == 'a' &&
7621 if (name[1] == 'o' &&
7634 if (name[2] == 't' &&
7643 if (name[2] == 'o' &&
7652 if (name[2] == 't' &&
7661 if (name[2] == 'e' &&
7674 if (name[1] == 'o' &&
7687 if (name[2] == 'y' &&
7696 if (name[2] == 'l' &&
7712 if (name[2] == 's' &&
7721 if (name[2] == 'n' &&
7730 if (name[2] == 'c' &&
7743 if (name[1] == 'e' &&
7753 if (name[1] == 'p' &&
7766 if (name[2] == 'c' &&
7775 if (name[2] == 'p' &&
7784 if (name[2] == 's' &&
7800 if (name[2] == 'n' &&
7870 if (name[2] == 'r' &&
7879 if (name[2] == 'r' &&
7888 if (name[2] == 'a' &&
7904 if (name[2] == 'l' &&
7966 if (name[2] == 'e' &&
7969 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
7982 case 5: /* 39 tokens of length 5 */
7986 if (name[1] == 'E' &&
7997 if (name[1] == 'H' &&
8011 if (name[2] == 'a' &&
8021 if (name[2] == 'a' &&
8038 if (name[2] == 'e' &&
8048 if (name[2] == 'e' &&
8052 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8068 if (name[3] == 'i' &&
8077 if (name[3] == 'o' &&
8113 if (name[2] == 'o' &&
8123 if (name[2] == 'y' &&
8137 if (name[1] == 'l' &&
8151 if (name[2] == 'n' &&
8161 if (name[2] == 'o' &&
8175 if (name[1] == 'i' &&
8180 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8189 if (name[2] == 'd' &&
8199 if (name[2] == 'c' &&
8216 if (name[2] == 'c' &&
8226 if (name[2] == 't' &&
8240 if (name[1] == 'k' &&
8251 if (name[1] == 'r' &&
8265 if (name[2] == 's' &&
8275 if (name[2] == 'd' &&
8292 if (name[2] == 'm' &&
8302 if (name[2] == 'i' &&
8312 if (name[2] == 'e' &&
8322 if (name[2] == 'l' &&
8332 if (name[2] == 'a' &&
8345 if (name[3] == 't' &&
8348 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8354 if (name[3] == 'd' &&
8371 if (name[1] == 'i' &&
8385 if (name[2] == 'a' &&
8398 if (name[3] == 'e' &&
8433 if (name[2] == 'i' &&
8450 if (name[2] == 'i' &&
8460 if (name[2] == 'i' &&
8477 case 6: /* 33 tokens of length 6 */
8481 if (name[1] == 'c' &&
8496 if (name[2] == 'l' &&
8507 if (name[2] == 'r' &&
8522 if (name[1] == 'e' &&
8537 if (name[2] == 's' &&
8542 if(ckWARN_d(WARN_SYNTAX))
8543 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8549 if (name[2] == 'i' &&
8567 if (name[2] == 'l' &&
8578 if (name[2] == 'r' &&
8593 if (name[1] == 'm' &&
8608 if (name[2] == 'n' &&
8619 if (name[2] == 's' &&
8634 if (name[1] == 's' &&
8640 if (name[4] == 't' &&
8649 if (name[4] == 'e' &&
8658 if (name[4] == 'c' &&
8667 if (name[4] == 'n' &&
8683 if (name[1] == 'r' &&
8701 if (name[3] == 'a' &&
8711 if (name[3] == 'u' &&
8725 if (name[2] == 'n' &&
8743 if (name[2] == 'a' &&
8757 if (name[3] == 'e' &&
8770 if (name[4] == 't' &&
8779 if (name[4] == 'e' &&
8801 if (name[4] == 't' &&
8810 if (name[4] == 'e' &&
8826 if (name[2] == 'c' &&
8837 if (name[2] == 'l' &&
8848 if (name[2] == 'b' &&
8859 if (name[2] == 's' &&
8882 if (name[4] == 's' &&
8891 if (name[4] == 'n' &&
8904 if (name[3] == 'a' &&
8921 if (name[1] == 'a' &&
8936 case 7: /* 29 tokens of length 7 */
8940 if (name[1] == 'E' &&
8953 if (name[1] == '_' &&
8966 if (name[1] == 'i' &&
8973 return -KEY_binmode;
8979 if (name[1] == 'o' &&
8986 return -KEY_connect;
8995 if (name[2] == 'm' &&
9001 return -KEY_dbmopen;
9012 if (name[4] == 'u' &&
9016 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9022 if (name[4] == 'n' &&
9043 if (name[1] == 'o' &&
9056 if (name[1] == 'e' &&
9063 if (name[5] == 'r' &&
9066 return -KEY_getpgrp;
9072 if (name[5] == 'i' &&
9075 return -KEY_getppid;
9088 if (name[1] == 'c' &&
9095 return -KEY_lcfirst;
9101 if (name[1] == 'p' &&
9108 return -KEY_opendir;
9114 if (name[1] == 'a' &&
9132 if (name[3] == 'd' &&
9137 return -KEY_readdir;
9143 if (name[3] == 'u' &&
9154 if (name[3] == 'e' &&
9159 return -KEY_reverse;
9178 if (name[3] == 'k' &&
9183 return -KEY_seekdir;
9189 if (name[3] == 'p' &&
9194 return -KEY_setpgrp;
9204 if (name[2] == 'm' &&
9210 return -KEY_shmread;
9216 if (name[2] == 'r' &&
9222 return -KEY_sprintf;
9231 if (name[3] == 'l' &&
9236 return -KEY_symlink;
9245 if (name[4] == 'a' &&
9249 return -KEY_syscall;
9255 if (name[4] == 'p' &&
9259 return -KEY_sysopen;
9265 if (name[4] == 'e' &&
9269 return -KEY_sysread;
9275 if (name[4] == 'e' &&
9279 return -KEY_sysseek;
9297 if (name[1] == 'e' &&
9304 return -KEY_telldir;
9313 if (name[2] == 'f' &&
9319 return -KEY_ucfirst;
9325 if (name[2] == 's' &&
9331 return -KEY_unshift;
9341 if (name[1] == 'a' &&
9348 return -KEY_waitpid;
9357 case 8: /* 26 tokens of length 8 */
9361 if (name[1] == 'U' &&
9369 return KEY_AUTOLOAD;
9380 if (name[3] == 'A' &&
9386 return KEY___DATA__;
9392 if (name[3] == 'I' &&
9398 return -KEY___FILE__;
9404 if (name[3] == 'I' &&
9410 return -KEY___LINE__;
9426 if (name[2] == 'o' &&
9433 return -KEY_closedir;
9439 if (name[2] == 'n' &&
9446 return -KEY_continue;
9456 if (name[1] == 'b' &&
9464 return -KEY_dbmclose;
9470 if (name[1] == 'n' &&
9476 if (name[4] == 'r' &&
9481 return -KEY_endgrent;
9487 if (name[4] == 'w' &&
9492 return -KEY_endpwent;
9505 if (name[1] == 'o' &&
9513 return -KEY_formline;
9519 if (name[1] == 'e' &&
9530 if (name[6] == 'n' &&
9533 return -KEY_getgrent;
9539 if (name[6] == 'i' &&
9542 return -KEY_getgrgid;
9548 if (name[6] == 'a' &&
9551 return -KEY_getgrnam;
9564 if (name[4] == 'o' &&
9569 return -KEY_getlogin;
9580 if (name[6] == 'n' &&
9583 return -KEY_getpwent;
9589 if (name[6] == 'a' &&
9592 return -KEY_getpwnam;
9598 if (name[6] == 'i' &&
9601 return -KEY_getpwuid;
9621 if (name[1] == 'e' &&
9628 if (name[5] == 'i' &&
9635 return -KEY_readline;
9640 return -KEY_readlink;
9651 if (name[5] == 'i' &&
9655 return -KEY_readpipe;
9676 if (name[4] == 'r' &&
9681 return -KEY_setgrent;
9687 if (name[4] == 'w' &&
9692 return -KEY_setpwent;
9708 if (name[3] == 'w' &&
9714 return -KEY_shmwrite;
9720 if (name[3] == 't' &&
9726 return -KEY_shutdown;
9736 if (name[2] == 's' &&
9743 return -KEY_syswrite;
9753 if (name[1] == 'r' &&
9761 return -KEY_truncate;
9770 case 9: /* 9 tokens of length 9 */
9774 if (name[1] == 'N' &&
9783 return KEY_UNITCHECK;
9789 if (name[1] == 'n' &&
9798 return -KEY_endnetent;
9804 if (name[1] == 'e' &&
9813 return -KEY_getnetent;
9819 if (name[1] == 'o' &&
9828 return -KEY_localtime;
9834 if (name[1] == 'r' &&
9843 return KEY_prototype;
9849 if (name[1] == 'u' &&
9858 return -KEY_quotemeta;
9864 if (name[1] == 'e' &&
9873 return -KEY_rewinddir;
9879 if (name[1] == 'e' &&
9888 return -KEY_setnetent;
9894 if (name[1] == 'a' &&
9903 return -KEY_wantarray;
9912 case 10: /* 9 tokens of length 10 */
9916 if (name[1] == 'n' &&
9922 if (name[4] == 'o' &&
9929 return -KEY_endhostent;
9935 if (name[4] == 'e' &&
9942 return -KEY_endservent;
9955 if (name[1] == 'e' &&
9961 if (name[4] == 'o' &&
9968 return -KEY_gethostent;
9977 if (name[5] == 'r' &&
9983 return -KEY_getservent;
9989 if (name[5] == 'c' &&
9995 return -KEY_getsockopt;
10015 if (name[2] == 't')
10020 if (name[4] == 'o' &&
10027 return -KEY_sethostent;
10036 if (name[5] == 'r' &&
10042 return -KEY_setservent;
10048 if (name[5] == 'c' &&
10054 return -KEY_setsockopt;
10071 if (name[2] == 'c' &&
10080 return -KEY_socketpair;
10093 case 11: /* 8 tokens of length 11 */
10097 if (name[1] == '_' &&
10107 { /* __PACKAGE__ */
10108 return -KEY___PACKAGE__;
10114 if (name[1] == 'n' &&
10124 { /* endprotoent */
10125 return -KEY_endprotoent;
10131 if (name[1] == 'e' &&
10140 if (name[5] == 'e' &&
10146 { /* getpeername */
10147 return -KEY_getpeername;
10156 if (name[6] == 'o' &&
10161 { /* getpriority */
10162 return -KEY_getpriority;
10168 if (name[6] == 't' &&
10173 { /* getprotoent */
10174 return -KEY_getprotoent;
10188 if (name[4] == 'o' &&
10195 { /* getsockname */
10196 return -KEY_getsockname;
10209 if (name[1] == 'e' &&
10217 if (name[6] == 'o' &&
10222 { /* setpriority */
10223 return -KEY_setpriority;
10229 if (name[6] == 't' &&
10234 { /* setprotoent */
10235 return -KEY_setprotoent;
10251 case 12: /* 2 tokens of length 12 */
10252 if (name[0] == 'g' &&
10264 if (name[9] == 'd' &&
10267 { /* getnetbyaddr */
10268 return -KEY_getnetbyaddr;
10274 if (name[9] == 'a' &&
10277 { /* getnetbyname */
10278 return -KEY_getnetbyname;
10290 case 13: /* 4 tokens of length 13 */
10291 if (name[0] == 'g' &&
10298 if (name[4] == 'o' &&
10307 if (name[10] == 'd' &&
10310 { /* gethostbyaddr */
10311 return -KEY_gethostbyaddr;
10317 if (name[10] == 'a' &&
10320 { /* gethostbyname */
10321 return -KEY_gethostbyname;
10334 if (name[4] == 'e' &&
10343 if (name[10] == 'a' &&
10346 { /* getservbyname */
10347 return -KEY_getservbyname;
10353 if (name[10] == 'o' &&
10356 { /* getservbyport */
10357 return -KEY_getservbyport;
10376 case 14: /* 1 tokens of length 14 */
10377 if (name[0] == 'g' &&
10391 { /* getprotobyname */
10392 return -KEY_getprotobyname;
10397 case 16: /* 1 tokens of length 16 */
10398 if (name[0] == 'g' &&
10414 { /* getprotobynumber */
10415 return -KEY_getprotobynumber;
10429 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10433 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10434 if (ckWARN(WARN_SYNTAX)) {
10437 for (w = s+2; *w && level; w++) {
10440 else if (*w == ')')
10443 while (isSPACE(*w))
10445 if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
10446 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10447 "%s (...) interpreted as function",name);
10450 while (s < PL_bufend && isSPACE(*s))
10454 while (s < PL_bufend && isSPACE(*s))
10456 if (isIDFIRST_lazy_if(s,UTF)) {
10457 const char * const w = s++;
10458 while (isALNUM_lazy_if(s,UTF))
10460 while (s < PL_bufend && isSPACE(*s))
10464 if (keyword(w, s - w, 0))
10467 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10468 if (gv && GvCVu(gv))
10470 Perl_croak(aTHX_ "No comma allowed after %s", what);
10475 /* Either returns sv, or mortalizes sv and returns a new SV*.
10476 Best used as sv=new_constant(..., sv, ...).
10477 If s, pv are NULL, calls subroutine with one argument,
10478 and type is used with error messages only. */
10481 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10485 HV * const table = GvHV(PL_hintgv); /* ^H */
10489 const char *why1 = "", *why2 = "", *why3 = "";
10491 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10494 why2 = (const char *)
10495 (strEQ(key,"charnames")
10496 ? "(possibly a missing \"use charnames ...\")"
10498 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10499 (type ? type: "undef"), why2);
10501 /* This is convoluted and evil ("goto considered harmful")
10502 * but I do not understand the intricacies of all the different
10503 * failure modes of %^H in here. The goal here is to make
10504 * the most probable error message user-friendly. --jhi */
10509 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10510 (type ? type: "undef"), why1, why2, why3);
10512 yyerror(SvPVX_const(msg));
10516 cvp = hv_fetch(table, key, strlen(key), FALSE);
10517 if (!cvp || !SvOK(*cvp)) {
10520 why3 = "} is not defined";
10523 sv_2mortal(sv); /* Parent created it permanently */
10526 pv = sv_2mortal(newSVpvn(s, len));
10528 typesv = sv_2mortal(newSVpv(type, 0));
10530 typesv = &PL_sv_undef;
10532 PUSHSTACKi(PERLSI_OVERLOAD);
10544 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10548 /* Check the eval first */
10549 if (!PL_in_eval && SvTRUE(ERRSV)) {
10550 sv_catpvs(ERRSV, "Propagated");
10551 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10553 res = SvREFCNT_inc_simple(sv);
10557 SvREFCNT_inc_simple_void(res);
10566 why1 = "Call to &{$^H{";
10568 why3 = "}} did not return a defined value";
10576 /* Returns a NUL terminated string, with the length of the string written to
10580 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10583 register char *d = dest;
10584 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10587 Perl_croak(aTHX_ ident_too_long);
10588 if (isALNUM(*s)) /* UTF handled below */
10590 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10595 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10599 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10600 char *t = s + UTF8SKIP(s);
10602 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10606 Perl_croak(aTHX_ ident_too_long);
10607 Copy(s, d, len, char);
10620 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10623 char *bracket = NULL;
10625 register char *d = dest;
10626 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10631 while (isDIGIT(*s)) {
10633 Perl_croak(aTHX_ ident_too_long);
10640 Perl_croak(aTHX_ ident_too_long);
10641 if (isALNUM(*s)) /* UTF handled below */
10643 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10648 else if (*s == ':' && s[1] == ':') {
10652 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10653 char *t = s + UTF8SKIP(s);
10654 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10656 if (d + (t - s) > e)
10657 Perl_croak(aTHX_ ident_too_long);
10658 Copy(s, d, t - s, char);
10669 if (PL_lex_state != LEX_NORMAL)
10670 PL_lex_state = LEX_INTERPENDMAYBE;
10673 if (*s == '$' && s[1] &&
10674 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10687 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10692 if (isSPACE(s[-1])) {
10694 const char ch = *s++;
10695 if (!SPACE_OR_TAB(ch)) {
10701 if (isIDFIRST_lazy_if(d,UTF)) {
10705 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10706 end += UTF8SKIP(end);
10707 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10708 end += UTF8SKIP(end);
10710 Copy(s, d, end - s, char);
10715 while ((isALNUM(*s) || *s == ':') && d < e)
10718 Perl_croak(aTHX_ ident_too_long);
10721 while (s < send && SPACE_OR_TAB(*s))
10723 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10724 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10725 const char * const brack =
10727 ((*s == '[') ? "[...]" : "{...}");
10728 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10729 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10730 funny, dest, brack, funny, dest, brack);
10733 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10737 /* Handle extended ${^Foo} variables
10738 * 1999-02-27 mjd-perl-patch@plover.com */
10739 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10743 while (isALNUM(*s) && d < e) {
10747 Perl_croak(aTHX_ ident_too_long);
10752 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10753 PL_lex_state = LEX_INTERPEND;
10756 if (PL_lex_state == LEX_NORMAL) {
10757 if (ckWARN(WARN_AMBIGUOUS) &&
10758 (keyword(dest, d - dest, 0)
10759 || get_cvn_flags(dest, d - dest, 0)))
10763 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10764 "Ambiguous use of %c{%s} resolved to %c%s",
10765 funny, dest, funny, dest);
10770 s = bracket; /* let the parser handle it */
10774 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10775 PL_lex_state = LEX_INTERPEND;
10780 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10782 PERL_UNUSED_CONTEXT;
10786 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
10787 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
10788 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
10789 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
10790 case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break;
10796 S_scan_pat(pTHX_ char *start, I32 type)
10800 char *s = scan_str(start,!!PL_madskills,FALSE);
10801 const char * const valid_flags =
10802 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10809 const char * const delimiter = skipspace(start);
10813 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10814 : "Search pattern not terminated" ));
10817 pm = (PMOP*)newPMOP(type, 0);
10818 if (PL_multi_open == '?')
10819 pm->op_pmflags |= PMf_ONCE;
10823 while (*s && strchr(valid_flags, *s))
10824 pmflag(&pm->op_pmflags,*s++);
10826 if (PL_madskills && modstart != s) {
10827 SV* tmptoken = newSVpvn(modstart, s - modstart);
10828 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10831 /* issue a warning if /c is specified,but /g is not */
10832 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10833 && ckWARN(WARN_REGEXP))
10835 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
10836 "Use of /c modifier is meaningless without /g" );
10839 pm->op_pmpermflags = pm->op_pmflags;
10841 PL_lex_op = (OP*)pm;
10842 yylval.ival = OP_MATCH;
10847 S_scan_subst(pTHX_ char *start)
10858 yylval.ival = OP_NULL;
10860 s = scan_str(start,!!PL_madskills,FALSE);
10863 Perl_croak(aTHX_ "Substitution pattern not terminated");
10865 if (s[-1] == PL_multi_open)
10868 if (PL_madskills) {
10869 CURMAD('q', PL_thisopen);
10870 CURMAD('_', PL_thiswhite);
10871 CURMAD('E', PL_thisstuff);
10872 CURMAD('Q', PL_thisclose);
10873 PL_realtokenstart = s - SvPVX(PL_linestr);
10877 first_start = PL_multi_start;
10878 s = scan_str(s,!!PL_madskills,FALSE);
10880 if (PL_lex_stuff) {
10881 SvREFCNT_dec(PL_lex_stuff);
10882 PL_lex_stuff = NULL;
10884 Perl_croak(aTHX_ "Substitution replacement not terminated");
10886 PL_multi_start = first_start; /* so whole substitution is taken together */
10888 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10891 if (PL_madskills) {
10892 CURMAD('z', PL_thisopen);
10893 CURMAD('R', PL_thisstuff);
10894 CURMAD('Z', PL_thisclose);
10900 if (*s == EXEC_PAT_MOD) {
10904 else if (strchr(S_PAT_MODS, *s))
10905 pmflag(&pm->op_pmflags,*s++);
10911 if (PL_madskills) {
10913 curmad('m', newSVpvn(modstart, s - modstart));
10914 append_madprops(PL_thismad, (OP*)pm, 0);
10918 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10919 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10923 SV * const repl = newSVpvs("");
10925 PL_sublex_info.super_bufptr = s;
10926 PL_sublex_info.super_bufend = PL_bufend;
10928 pm->op_pmflags |= PMf_EVAL;
10930 sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10931 sv_catpvs(repl, "{");
10932 sv_catsv(repl, PL_lex_repl);
10933 if (strchr(SvPVX(PL_lex_repl), '#'))
10934 sv_catpvs(repl, "\n");
10935 sv_catpvs(repl, "}");
10937 SvREFCNT_dec(PL_lex_repl);
10938 PL_lex_repl = repl;
10941 pm->op_pmpermflags = pm->op_pmflags;
10942 PL_lex_op = (OP*)pm;
10943 yylval.ival = OP_SUBST;
10948 S_scan_trans(pTHX_ char *start)
10961 yylval.ival = OP_NULL;
10963 s = scan_str(start,!!PL_madskills,FALSE);
10965 Perl_croak(aTHX_ "Transliteration pattern not terminated");
10967 if (s[-1] == PL_multi_open)
10970 if (PL_madskills) {
10971 CURMAD('q', PL_thisopen);
10972 CURMAD('_', PL_thiswhite);
10973 CURMAD('E', PL_thisstuff);
10974 CURMAD('Q', PL_thisclose);
10975 PL_realtokenstart = s - SvPVX(PL_linestr);
10979 s = scan_str(s,!!PL_madskills,FALSE);
10981 if (PL_lex_stuff) {
10982 SvREFCNT_dec(PL_lex_stuff);
10983 PL_lex_stuff = NULL;
10985 Perl_croak(aTHX_ "Transliteration replacement not terminated");
10987 if (PL_madskills) {
10988 CURMAD('z', PL_thisopen);
10989 CURMAD('R', PL_thisstuff);
10990 CURMAD('Z', PL_thisclose);
10993 complement = del = squash = 0;
11000 complement = OPpTRANS_COMPLEMENT;
11003 del = OPpTRANS_DELETE;
11006 squash = OPpTRANS_SQUASH;
11015 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11016 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11017 o->op_private &= ~OPpTRANS_ALL;
11018 o->op_private |= del|squash|complement|
11019 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11020 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11023 yylval.ival = OP_TRANS;
11026 if (PL_madskills) {
11028 curmad('m', newSVpvn(modstart, s - modstart));
11029 append_madprops(PL_thismad, o, 0);
11038 S_scan_heredoc(pTHX_ register char *s)
11042 I32 op_type = OP_SCALAR;
11046 const char *found_newline;
11050 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11052 I32 stuffstart = s - SvPVX(PL_linestr);
11055 PL_realtokenstart = -1;
11060 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11064 while (SPACE_OR_TAB(*peek))
11066 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11069 s = delimcpy(d, e, s, PL_bufend, term, &len);
11079 if (!isALNUM_lazy_if(s,UTF))
11080 deprecate_old("bare << to mean <<\"\"");
11081 for (; isALNUM_lazy_if(s,UTF); s++) {
11086 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11087 Perl_croak(aTHX_ "Delimiter for here document is too long");
11090 len = d - PL_tokenbuf;
11093 if (PL_madskills) {
11094 tstart = PL_tokenbuf + !outer;
11095 PL_thisclose = newSVpvn(tstart, len - !outer);
11096 tstart = SvPVX(PL_linestr) + stuffstart;
11097 PL_thisopen = newSVpvn(tstart, s - tstart);
11098 stuffstart = s - SvPVX(PL_linestr);
11101 #ifndef PERL_STRICT_CR
11102 d = strchr(s, '\r');
11104 char * const olds = s;
11106 while (s < PL_bufend) {
11112 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11121 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11128 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11129 herewas = newSVpvn(s,PL_bufend-s);
11133 herewas = newSVpvn(s-1,found_newline-s+1);
11136 herewas = newSVpvn(s,found_newline-s);
11140 if (PL_madskills) {
11141 tstart = SvPVX(PL_linestr) + stuffstart;
11143 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11145 PL_thisstuff = newSVpvn(tstart, s - tstart);
11148 s += SvCUR(herewas);
11151 stuffstart = s - SvPVX(PL_linestr);
11157 tmpstr = newSV_type(SVt_PVIV);
11158 SvGROW(tmpstr, 80);
11159 if (term == '\'') {
11160 op_type = OP_CONST;
11161 SvIV_set(tmpstr, -1);
11163 else if (term == '`') {
11164 op_type = OP_BACKTICK;
11165 SvIV_set(tmpstr, '\\');
11169 PL_multi_start = CopLINE(PL_curcop);
11170 PL_multi_open = PL_multi_close = '<';
11171 term = *PL_tokenbuf;
11172 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11173 char * const bufptr = PL_sublex_info.super_bufptr;
11174 char * const bufend = PL_sublex_info.super_bufend;
11175 char * const olds = s - SvCUR(herewas);
11176 s = strchr(bufptr, '\n');
11180 while (s < bufend &&
11181 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11183 CopLINE_inc(PL_curcop);
11186 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11187 missingterm(PL_tokenbuf);
11189 sv_setpvn(herewas,bufptr,d-bufptr+1);
11190 sv_setpvn(tmpstr,d+1,s-d);
11192 sv_catpvn(herewas,s,bufend-s);
11193 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11200 while (s < PL_bufend &&
11201 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11203 CopLINE_inc(PL_curcop);
11205 if (s >= PL_bufend) {
11206 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11207 missingterm(PL_tokenbuf);
11209 sv_setpvn(tmpstr,d+1,s-d);
11211 if (PL_madskills) {
11213 sv_catpvn(PL_thisstuff, d + 1, s - d);
11215 PL_thisstuff = newSVpvn(d + 1, s - d);
11216 stuffstart = s - SvPVX(PL_linestr);
11220 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11222 sv_catpvn(herewas,s,PL_bufend-s);
11223 sv_setsv(PL_linestr,herewas);
11224 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11225 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11226 PL_last_lop = PL_last_uni = NULL;
11229 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
11230 while (s >= PL_bufend) { /* multiple line string? */
11232 if (PL_madskills) {
11233 tstart = SvPVX(PL_linestr) + stuffstart;
11235 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11237 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11241 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11242 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11243 missingterm(PL_tokenbuf);
11246 stuffstart = s - SvPVX(PL_linestr);
11248 CopLINE_inc(PL_curcop);
11249 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11250 PL_last_lop = PL_last_uni = NULL;
11251 #ifndef PERL_STRICT_CR
11252 if (PL_bufend - PL_linestart >= 2) {
11253 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11254 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11256 PL_bufend[-2] = '\n';
11258 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11260 else if (PL_bufend[-1] == '\r')
11261 PL_bufend[-1] = '\n';
11263 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11264 PL_bufend[-1] = '\n';
11266 if (PERLDB_LINE && PL_curstash != PL_debstash)
11267 update_debugger_info(PL_linestr, NULL, 0);
11268 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11269 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11270 *(SvPVX(PL_linestr) + off ) = ' ';
11271 sv_catsv(PL_linestr,herewas);
11272 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11273 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11277 sv_catsv(tmpstr,PL_linestr);
11282 PL_multi_end = CopLINE(PL_curcop);
11283 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11284 SvPV_shrink_to_cur(tmpstr);
11286 SvREFCNT_dec(herewas);
11288 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11290 else if (PL_encoding)
11291 sv_recode_to_utf8(tmpstr, PL_encoding);
11293 PL_lex_stuff = tmpstr;
11294 yylval.ival = op_type;
11298 /* scan_inputsymbol
11299 takes: current position in input buffer
11300 returns: new position in input buffer
11301 side-effects: yylval and lex_op are set.
11306 <FH> read from filehandle
11307 <pkg::FH> read from package qualified filehandle
11308 <pkg'FH> read from package qualified filehandle
11309 <$fh> read from filehandle in $fh
11310 <*.h> filename glob
11315 S_scan_inputsymbol(pTHX_ char *start)
11318 register char *s = start; /* current position in buffer */
11322 char *d = PL_tokenbuf; /* start of temp holding space */
11323 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11325 end = strchr(s, '\n');
11328 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11330 /* die if we didn't have space for the contents of the <>,
11331 or if it didn't end, or if we see a newline
11334 if (len >= (I32)sizeof PL_tokenbuf)
11335 Perl_croak(aTHX_ "Excessively long <> operator");
11337 Perl_croak(aTHX_ "Unterminated <> operator");
11342 Remember, only scalar variables are interpreted as filehandles by
11343 this code. Anything more complex (e.g., <$fh{$num}>) will be
11344 treated as a glob() call.
11345 This code makes use of the fact that except for the $ at the front,
11346 a scalar variable and a filehandle look the same.
11348 if (*d == '$' && d[1]) d++;
11350 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11351 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11354 /* If we've tried to read what we allow filehandles to look like, and
11355 there's still text left, then it must be a glob() and not a getline.
11356 Use scan_str to pull out the stuff between the <> and treat it
11357 as nothing more than a string.
11360 if (d - PL_tokenbuf != len) {
11361 yylval.ival = OP_GLOB;
11363 s = scan_str(start,!!PL_madskills,FALSE);
11365 Perl_croak(aTHX_ "Glob not terminated");
11369 bool readline_overriden = FALSE;
11372 /* we're in a filehandle read situation */
11375 /* turn <> into <ARGV> */
11377 Copy("ARGV",d,5,char);
11379 /* Check whether readline() is overriden */
11380 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11382 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11384 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11385 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11386 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11387 readline_overriden = TRUE;
11389 /* if <$fh>, create the ops to turn the variable into a
11393 /* try to find it in the pad for this block, otherwise find
11394 add symbol table ops
11396 const PADOFFSET tmp = pad_findmy(d);
11397 if (tmp != NOT_IN_PAD) {
11398 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11399 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11400 HEK * const stashname = HvNAME_HEK(stash);
11401 SV * const sym = sv_2mortal(newSVhek(stashname));
11402 sv_catpvs(sym, "::");
11403 sv_catpv(sym, d+1);
11408 OP * const o = newOP(OP_PADSV, 0);
11410 PL_lex_op = readline_overriden
11411 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11412 append_elem(OP_LIST, o,
11413 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11414 : (OP*)newUNOP(OP_READLINE, 0, o);
11423 ? (GV_ADDMULTI | GV_ADDINEVAL)
11426 PL_lex_op = readline_overriden
11427 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11428 append_elem(OP_LIST,
11429 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11430 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11431 : (OP*)newUNOP(OP_READLINE, 0,
11432 newUNOP(OP_RV2SV, 0,
11433 newGVOP(OP_GV, 0, gv)));
11435 if (!readline_overriden)
11436 PL_lex_op->op_flags |= OPf_SPECIAL;
11437 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11438 yylval.ival = OP_NULL;
11441 /* If it's none of the above, it must be a literal filehandle
11442 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11444 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11445 PL_lex_op = readline_overriden
11446 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11447 append_elem(OP_LIST,
11448 newGVOP(OP_GV, 0, gv),
11449 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11450 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11451 yylval.ival = OP_NULL;
11460 takes: start position in buffer
11461 keep_quoted preserve \ on the embedded delimiter(s)
11462 keep_delims preserve the delimiters around the string
11463 returns: position to continue reading from buffer
11464 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11465 updates the read buffer.
11467 This subroutine pulls a string out of the input. It is called for:
11468 q single quotes q(literal text)
11469 ' single quotes 'literal text'
11470 qq double quotes qq(interpolate $here please)
11471 " double quotes "interpolate $here please"
11472 qx backticks qx(/bin/ls -l)
11473 ` backticks `/bin/ls -l`
11474 qw quote words @EXPORT_OK = qw( func() $spam )
11475 m// regexp match m/this/
11476 s/// regexp substitute s/this/that/
11477 tr/// string transliterate tr/this/that/
11478 y/// string transliterate y/this/that/
11479 ($*@) sub prototypes sub foo ($)
11480 (stuff) sub attr parameters sub foo : attr(stuff)
11481 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11483 In most of these cases (all but <>, patterns and transliterate)
11484 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11485 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11486 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11489 It skips whitespace before the string starts, and treats the first
11490 character as the delimiter. If the delimiter is one of ([{< then
11491 the corresponding "close" character )]}> is used as the closing
11492 delimiter. It allows quoting of delimiters, and if the string has
11493 balanced delimiters ([{<>}]) it allows nesting.
11495 On success, the SV with the resulting string is put into lex_stuff or,
11496 if that is already non-NULL, into lex_repl. The second case occurs only
11497 when parsing the RHS of the special constructs s/// and tr/// (y///).
11498 For convenience, the terminating delimiter character is stuffed into
11503 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11506 SV *sv; /* scalar value: string */
11507 const char *tmps; /* temp string, used for delimiter matching */
11508 register char *s = start; /* current position in the buffer */
11509 register char term; /* terminating character */
11510 register char *to; /* current position in the sv's data */
11511 I32 brackets = 1; /* bracket nesting level */
11512 bool has_utf8 = FALSE; /* is there any utf8 content? */
11513 I32 termcode; /* terminating char. code */
11514 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11515 STRLEN termlen; /* length of terminating string */
11516 int last_off = 0; /* last position for nesting bracket */
11522 /* skip space before the delimiter */
11528 if (PL_realtokenstart >= 0) {
11529 stuffstart = PL_realtokenstart;
11530 PL_realtokenstart = -1;
11533 stuffstart = start - SvPVX(PL_linestr);
11535 /* mark where we are, in case we need to report errors */
11538 /* after skipping whitespace, the next character is the terminator */
11541 termcode = termstr[0] = term;
11545 termcode = utf8_to_uvchr((U8*)s, &termlen);
11546 Copy(s, termstr, termlen, U8);
11547 if (!UTF8_IS_INVARIANT(term))
11551 /* mark where we are */
11552 PL_multi_start = CopLINE(PL_curcop);
11553 PL_multi_open = term;
11555 /* find corresponding closing delimiter */
11556 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11557 termcode = termstr[0] = term = tmps[5];
11559 PL_multi_close = term;
11561 /* create a new SV to hold the contents. 79 is the SV's initial length.
11562 What a random number. */
11563 sv = newSV_type(SVt_PVIV);
11565 SvIV_set(sv, termcode);
11566 (void)SvPOK_only(sv); /* validate pointer */
11568 /* move past delimiter and try to read a complete string */
11570 sv_catpvn(sv, s, termlen);
11573 tstart = SvPVX(PL_linestr) + stuffstart;
11574 if (!PL_thisopen && !keep_delims) {
11575 PL_thisopen = newSVpvn(tstart, s - tstart);
11576 stuffstart = s - SvPVX(PL_linestr);
11580 if (PL_encoding && !UTF) {
11584 int offset = s - SvPVX_const(PL_linestr);
11585 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11586 &offset, (char*)termstr, termlen);
11587 const char * const ns = SvPVX_const(PL_linestr) + offset;
11588 char * const svlast = SvEND(sv) - 1;
11590 for (; s < ns; s++) {
11591 if (*s == '\n' && !PL_rsfp)
11592 CopLINE_inc(PL_curcop);
11595 goto read_more_line;
11597 /* handle quoted delimiters */
11598 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11600 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11602 if ((svlast-1 - t) % 2) {
11603 if (!keep_quoted) {
11604 *(svlast-1) = term;
11606 SvCUR_set(sv, SvCUR(sv) - 1);
11611 if (PL_multi_open == PL_multi_close) {
11617 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11618 /* At here, all closes are "was quoted" one,
11619 so we don't check PL_multi_close. */
11621 if (!keep_quoted && *(t+1) == PL_multi_open)
11626 else if (*t == PL_multi_open)
11634 SvCUR_set(sv, w - SvPVX_const(sv));
11636 last_off = w - SvPVX(sv);
11637 if (--brackets <= 0)
11642 if (!keep_delims) {
11643 SvCUR_set(sv, SvCUR(sv) - 1);
11649 /* extend sv if need be */
11650 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11651 /* set 'to' to the next character in the sv's string */
11652 to = SvPVX(sv)+SvCUR(sv);
11654 /* if open delimiter is the close delimiter read unbridle */
11655 if (PL_multi_open == PL_multi_close) {
11656 for (; s < PL_bufend; s++,to++) {
11657 /* embedded newlines increment the current line number */
11658 if (*s == '\n' && !PL_rsfp)
11659 CopLINE_inc(PL_curcop);
11660 /* handle quoted delimiters */
11661 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11662 if (!keep_quoted && s[1] == term)
11664 /* any other quotes are simply copied straight through */
11668 /* terminate when run out of buffer (the for() condition), or
11669 have found the terminator */
11670 else if (*s == term) {
11673 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11676 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11682 /* if the terminator isn't the same as the start character (e.g.,
11683 matched brackets), we have to allow more in the quoting, and
11684 be prepared for nested brackets.
11687 /* read until we run out of string, or we find the terminator */
11688 for (; s < PL_bufend; s++,to++) {
11689 /* embedded newlines increment the line count */
11690 if (*s == '\n' && !PL_rsfp)
11691 CopLINE_inc(PL_curcop);
11692 /* backslashes can escape the open or closing characters */
11693 if (*s == '\\' && s+1 < PL_bufend) {
11694 if (!keep_quoted &&
11695 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11700 /* allow nested opens and closes */
11701 else if (*s == PL_multi_close && --brackets <= 0)
11703 else if (*s == PL_multi_open)
11705 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11710 /* terminate the copied string and update the sv's end-of-string */
11712 SvCUR_set(sv, to - SvPVX_const(sv));
11715 * this next chunk reads more into the buffer if we're not done yet
11719 break; /* handle case where we are done yet :-) */
11721 #ifndef PERL_STRICT_CR
11722 if (to - SvPVX_const(sv) >= 2) {
11723 if ((to[-2] == '\r' && to[-1] == '\n') ||
11724 (to[-2] == '\n' && to[-1] == '\r'))
11728 SvCUR_set(sv, to - SvPVX_const(sv));
11730 else if (to[-1] == '\r')
11733 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11738 /* if we're out of file, or a read fails, bail and reset the current
11739 line marker so we can report where the unterminated string began
11742 if (PL_madskills) {
11743 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11745 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11747 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11751 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11753 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11759 /* we read a line, so increment our line counter */
11760 CopLINE_inc(PL_curcop);
11762 /* update debugger info */
11763 if (PERLDB_LINE && PL_curstash != PL_debstash)
11764 update_debugger_info(PL_linestr, NULL, 0);
11766 /* having changed the buffer, we must update PL_bufend */
11767 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11768 PL_last_lop = PL_last_uni = NULL;
11771 /* at this point, we have successfully read the delimited string */
11773 if (!PL_encoding || UTF) {
11775 if (PL_madskills) {
11776 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11777 const int len = s - tstart;
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);
11788 sv_catpvn(sv, s, termlen);
11793 if (PL_madskills) {
11794 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11795 const int len = s - tstart - termlen;
11797 sv_catpvn(PL_thisstuff, tstart, len);
11799 PL_thisstuff = newSVpvn(tstart, len);
11800 if (!PL_thisclose && !keep_delims)
11801 PL_thisclose = newSVpvn(s - termlen,termlen);
11805 if (has_utf8 || PL_encoding)
11808 PL_multi_end = CopLINE(PL_curcop);
11810 /* if we allocated too much space, give some back */
11811 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11812 SvLEN_set(sv, SvCUR(sv) + 1);
11813 SvPV_renew(sv, SvLEN(sv));
11816 /* decide whether this is the first or second quoted string we've read
11829 takes: pointer to position in buffer
11830 returns: pointer to new position in buffer
11831 side-effects: builds ops for the constant in yylval.op
11833 Read a number in any of the formats that Perl accepts:
11835 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11836 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11839 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11841 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11844 If it reads a number without a decimal point or an exponent, it will
11845 try converting the number to an integer and see if it can do so
11846 without loss of precision.
11850 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11853 register const char *s = start; /* current position in buffer */
11854 register char *d; /* destination in temp buffer */
11855 register char *e; /* end of temp buffer */
11856 NV nv; /* number read, as a double */
11857 SV *sv = NULL; /* place to put the converted number */
11858 bool floatit; /* boolean: int or float? */
11859 const char *lastub = NULL; /* position of last underbar */
11860 static char const number_too_long[] = "Number too long";
11862 /* We use the first character to decide what type of number this is */
11866 Perl_croak(aTHX_ "panic: scan_num");
11868 /* if it starts with a 0, it could be an octal number, a decimal in
11869 0.13 disguise, or a hexadecimal number, or a binary number. */
11873 u holds the "number so far"
11874 shift the power of 2 of the base
11875 (hex == 4, octal == 3, binary == 1)
11876 overflowed was the number more than we can hold?
11878 Shift is used when we add a digit. It also serves as an "are
11879 we in octal/hex/binary?" indicator to disallow hex characters
11880 when in octal mode.
11885 bool overflowed = FALSE;
11886 bool just_zero = TRUE; /* just plain 0 or binary number? */
11887 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11888 static const char* const bases[5] =
11889 { "", "binary", "", "octal", "hexadecimal" };
11890 static const char* const Bases[5] =
11891 { "", "Binary", "", "Octal", "Hexadecimal" };
11892 static const char* const maxima[5] =
11894 "0b11111111111111111111111111111111",
11898 const char *base, *Base, *max;
11900 /* check for hex */
11905 } else if (s[1] == 'b') {
11910 /* check for a decimal in disguise */
11911 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11913 /* so it must be octal */
11920 if (ckWARN(WARN_SYNTAX))
11921 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11922 "Misplaced _ in number");
11926 base = bases[shift];
11927 Base = Bases[shift];
11928 max = maxima[shift];
11930 /* read the rest of the number */
11932 /* x is used in the overflow test,
11933 b is the digit we're adding on. */
11938 /* if we don't mention it, we're done */
11942 /* _ are ignored -- but warned about if consecutive */
11944 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11945 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11946 "Misplaced _ in number");
11950 /* 8 and 9 are not octal */
11951 case '8': case '9':
11953 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11957 case '2': case '3': case '4':
11958 case '5': case '6': case '7':
11960 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11963 case '0': case '1':
11964 b = *s++ & 15; /* ASCII digit -> value of digit */
11968 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11969 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11970 /* make sure they said 0x */
11973 b = (*s++ & 7) + 9;
11975 /* Prepare to put the digit we have onto the end
11976 of the number so far. We check for overflows.
11982 x = u << shift; /* make room for the digit */
11984 if ((x >> shift) != u
11985 && !(PL_hints & HINT_NEW_BINARY)) {
11988 if (ckWARN_d(WARN_OVERFLOW))
11989 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11990 "Integer overflow in %s number",
11993 u = x | b; /* add the digit to the end */
11996 n *= nvshift[shift];
11997 /* If an NV has not enough bits in its
11998 * mantissa to represent an UV this summing of
11999 * small low-order numbers is a waste of time
12000 * (because the NV cannot preserve the
12001 * low-order bits anyway): we could just
12002 * remember when did we overflow and in the
12003 * end just multiply n by the right
12011 /* if we get here, we had success: make a scalar value from
12016 /* final misplaced underbar check */
12017 if (s[-1] == '_') {
12018 if (ckWARN(WARN_SYNTAX))
12019 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12024 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12025 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12026 "%s number > %s non-portable",
12032 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12033 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12034 "%s number > %s non-portable",
12039 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12040 sv = new_constant(start, s - start, "integer",
12042 else if (PL_hints & HINT_NEW_BINARY)
12043 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
12048 handle decimal numbers.
12049 we're also sent here when we read a 0 as the first digit
12051 case '1': case '2': case '3': case '4': case '5':
12052 case '6': case '7': case '8': case '9': case '.':
12055 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12058 /* read next group of digits and _ and copy into d */
12059 while (isDIGIT(*s) || *s == '_') {
12060 /* skip underscores, checking for misplaced ones
12064 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12065 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12066 "Misplaced _ in number");
12070 /* check for end of fixed-length buffer */
12072 Perl_croak(aTHX_ number_too_long);
12073 /* if we're ok, copy the character */
12078 /* final misplaced underbar check */
12079 if (lastub && s == lastub + 1) {
12080 if (ckWARN(WARN_SYNTAX))
12081 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12084 /* read a decimal portion if there is one. avoid
12085 3..5 being interpreted as the number 3. followed
12088 if (*s == '.' && s[1] != '.') {
12093 if (ckWARN(WARN_SYNTAX))
12094 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12095 "Misplaced _ in number");
12099 /* copy, ignoring underbars, until we run out of digits.
12101 for (; isDIGIT(*s) || *s == '_'; s++) {
12102 /* fixed length buffer check */
12104 Perl_croak(aTHX_ number_too_long);
12106 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12107 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12108 "Misplaced _ in number");
12114 /* fractional part ending in underbar? */
12115 if (s[-1] == '_') {
12116 if (ckWARN(WARN_SYNTAX))
12117 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12118 "Misplaced _ in number");
12120 if (*s == '.' && isDIGIT(s[1])) {
12121 /* oops, it's really a v-string, but without the "v" */
12127 /* read exponent part, if present */
12128 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12132 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12133 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12135 /* stray preinitial _ */
12137 if (ckWARN(WARN_SYNTAX))
12138 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12139 "Misplaced _ in number");
12143 /* allow positive or negative exponent */
12144 if (*s == '+' || *s == '-')
12147 /* stray initial _ */
12149 if (ckWARN(WARN_SYNTAX))
12150 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12151 "Misplaced _ in number");
12155 /* read digits of exponent */
12156 while (isDIGIT(*s) || *s == '_') {
12159 Perl_croak(aTHX_ number_too_long);
12163 if (((lastub && s == lastub + 1) ||
12164 (!isDIGIT(s[1]) && s[1] != '_'))
12165 && ckWARN(WARN_SYNTAX))
12166 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12167 "Misplaced _ in number");
12174 /* make an sv from the string */
12178 We try to do an integer conversion first if no characters
12179 indicating "float" have been found.
12184 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12186 if (flags == IS_NUMBER_IN_UV) {
12188 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12191 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12192 if (uv <= (UV) IV_MIN)
12193 sv_setiv(sv, -(IV)uv);
12200 /* terminate the string */
12202 nv = Atof(PL_tokenbuf);
12206 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12207 (PL_hints & HINT_NEW_INTEGER) )
12208 sv = new_constant(PL_tokenbuf,
12211 (floatit ? "float" : "integer"),
12215 /* if it starts with a v, it could be a v-string */
12218 sv = newSV(5); /* preallocate storage space */
12219 s = scan_vstring(s,sv);
12223 /* make the op for the constant and return */
12226 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12228 lvalp->opval = NULL;
12234 S_scan_formline(pTHX_ register char *s)
12237 register char *eol;
12239 SV * const stuff = newSVpvs("");
12240 bool needargs = FALSE;
12241 bool eofmt = FALSE;
12243 char *tokenstart = s;
12246 if (PL_madskills) {
12247 savewhite = PL_thiswhite;
12252 while (!needargs) {
12255 #ifdef PERL_STRICT_CR
12256 while (SPACE_OR_TAB(*t))
12259 while (SPACE_OR_TAB(*t) || *t == '\r')
12262 if (*t == '\n' || t == PL_bufend) {
12267 if (PL_in_eval && !PL_rsfp) {
12268 eol = (char *) memchr(s,'\n',PL_bufend-s);
12273 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12275 for (t = s; t < eol; t++) {
12276 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12278 goto enough; /* ~~ must be first line in formline */
12280 if (*t == '@' || *t == '^')
12284 sv_catpvn(stuff, s, eol-s);
12285 #ifndef PERL_STRICT_CR
12286 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12287 char *end = SvPVX(stuff) + SvCUR(stuff);
12290 SvCUR_set(stuff, SvCUR(stuff) - 1);
12300 if (PL_madskills) {
12302 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12304 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12307 s = filter_gets(PL_linestr, PL_rsfp, 0);
12309 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12311 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12313 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12314 PL_last_lop = PL_last_uni = NULL;
12323 if (SvCUR(stuff)) {
12326 PL_lex_state = LEX_NORMAL;
12327 start_force(PL_curforce);
12328 NEXTVAL_NEXTTOKE.ival = 0;
12332 PL_lex_state = LEX_FORMLINE;
12334 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12336 else if (PL_encoding)
12337 sv_recode_to_utf8(stuff, PL_encoding);
12339 start_force(PL_curforce);
12340 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12342 start_force(PL_curforce);
12343 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12347 SvREFCNT_dec(stuff);
12349 PL_lex_formbrack = 0;
12353 if (PL_madskills) {
12355 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12357 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12358 PL_thiswhite = savewhite;
12370 PL_cshlen = strlen(PL_cshname);
12372 #if defined(USE_ITHREADS)
12373 PERL_UNUSED_CONTEXT;
12379 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12382 const I32 oldsavestack_ix = PL_savestack_ix;
12383 CV* const outsidecv = PL_compcv;
12386 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12388 SAVEI32(PL_subline);
12389 save_item(PL_subname);
12390 SAVESPTR(PL_compcv);
12392 PL_compcv = (CV*)newSV_type(is_format ? SVt_PVFM : SVt_PVCV);
12393 CvFLAGS(PL_compcv) |= flags;
12395 PL_subline = CopLINE(PL_curcop);
12396 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12397 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12398 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12400 return oldsavestack_ix;
12404 #pragma segment Perl_yylex
12407 Perl_yywarn(pTHX_ const char *s)
12410 PL_in_eval |= EVAL_WARNONLY;
12412 PL_in_eval &= ~EVAL_WARNONLY;
12417 Perl_yyerror(pTHX_ const char *s)
12420 const char *where = NULL;
12421 const char *context = NULL;
12424 int yychar = PL_parser->yychar;
12426 if (!yychar || (yychar == ';' && !PL_rsfp))
12428 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12429 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12430 PL_oldbufptr != PL_bufptr) {
12433 The code below is removed for NetWare because it abends/crashes on NetWare
12434 when the script has error such as not having the closing quotes like:
12435 if ($var eq "value)
12436 Checking of white spaces is anyway done in NetWare code.
12439 while (isSPACE(*PL_oldoldbufptr))
12442 context = PL_oldoldbufptr;
12443 contlen = PL_bufptr - PL_oldoldbufptr;
12445 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12446 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12449 The code below is removed for NetWare because it abends/crashes on NetWare
12450 when the script has error such as not having the closing quotes like:
12451 if ($var eq "value)
12452 Checking of white spaces is anyway done in NetWare code.
12455 while (isSPACE(*PL_oldbufptr))
12458 context = PL_oldbufptr;
12459 contlen = PL_bufptr - PL_oldbufptr;
12461 else if (yychar > 255)
12462 where = "next token ???";
12463 else if (yychar == -2) { /* YYEMPTY */
12464 if (PL_lex_state == LEX_NORMAL ||
12465 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12466 where = "at end of line";
12467 else if (PL_lex_inpat)
12468 where = "within pattern";
12470 where = "within string";
12473 SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12475 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12476 else if (isPRINT_LC(yychar))
12477 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12479 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12480 where = SvPVX_const(where_sv);
12482 msg = sv_2mortal(newSVpv(s, 0));
12483 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12484 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12486 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12488 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12489 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12490 Perl_sv_catpvf(aTHX_ msg,
12491 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12492 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12495 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12496 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12499 if (PL_error_count >= 10) {
12500 if (PL_in_eval && SvCUR(ERRSV))
12501 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12502 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12504 Perl_croak(aTHX_ "%s has too many errors.\n",
12505 OutCopFILE(PL_curcop));
12508 PL_in_my_stash = NULL;
12512 #pragma segment Main
12516 S_swallow_bom(pTHX_ U8 *s)
12519 const STRLEN slen = SvCUR(PL_linestr);
12522 if (s[1] == 0xFE) {
12523 /* UTF-16 little-endian? (or UTF32-LE?) */
12524 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12525 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12526 #ifndef PERL_NO_UTF16_FILTER
12527 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12530 if (PL_bufend > (char*)s) {
12534 filter_add(utf16rev_textfilter, NULL);
12535 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12536 utf16_to_utf8_reversed(s, news,
12537 PL_bufend - (char*)s - 1,
12539 sv_setpvn(PL_linestr, (const char*)news, newlen);
12541 s = (U8*)SvPVX(PL_linestr);
12542 Copy(news, s, newlen, U8);
12546 SvUTF8_on(PL_linestr);
12547 s = (U8*)SvPVX(PL_linestr);
12549 /* FIXME - is this a general bug fix? */
12552 PL_bufend = SvPVX(PL_linestr) + newlen;
12555 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12560 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12561 #ifndef PERL_NO_UTF16_FILTER
12562 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12565 if (PL_bufend > (char *)s) {
12569 filter_add(utf16_textfilter, NULL);
12570 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12571 utf16_to_utf8(s, news,
12572 PL_bufend - (char*)s,
12574 sv_setpvn(PL_linestr, (const char*)news, newlen);
12576 SvUTF8_on(PL_linestr);
12577 s = (U8*)SvPVX(PL_linestr);
12578 PL_bufend = SvPVX(PL_linestr) + newlen;
12581 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12586 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12587 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12588 s += 3; /* UTF-8 */
12594 if (s[2] == 0xFE && s[3] == 0xFF) {
12595 /* UTF-32 big-endian */
12596 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12599 else if (s[2] == 0 && s[3] != 0) {
12602 * are a good indicator of UTF-16BE. */
12603 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12609 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12610 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12611 s += 4; /* UTF-8 */
12617 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12620 * are a good indicator of UTF-16LE. */
12621 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12630 * Restore a source filter.
12634 restore_rsfp(pTHX_ void *f)
12637 PerlIO * const fp = (PerlIO*)f;
12639 if (PL_rsfp == PerlIO_stdin())
12640 PerlIO_clearerr(PL_rsfp);
12641 else if (PL_rsfp && (PL_rsfp != fp))
12642 PerlIO_close(PL_rsfp);
12646 #ifndef PERL_NO_UTF16_FILTER
12648 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12651 const STRLEN old = SvCUR(sv);
12652 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12653 DEBUG_P(PerlIO_printf(Perl_debug_log,
12654 "utf16_textfilter(%p): %d %d (%d)\n",
12655 FPTR2DPTR(void *, utf16_textfilter),
12656 idx, maxlen, (int) count));
12660 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12661 Copy(SvPVX_const(sv), tmps, old, char);
12662 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12663 SvCUR(sv) - old, &newlen);
12664 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12666 DEBUG_P({sv_dump(sv);});
12671 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12674 const STRLEN old = SvCUR(sv);
12675 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12676 DEBUG_P(PerlIO_printf(Perl_debug_log,
12677 "utf16rev_textfilter(%p): %d %d (%d)\n",
12678 FPTR2DPTR(void *, utf16rev_textfilter),
12679 idx, maxlen, (int) count));
12683 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12684 Copy(SvPVX_const(sv), tmps, old, char);
12685 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12686 SvCUR(sv) - old, &newlen);
12687 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12689 DEBUG_P({ sv_dump(sv); });
12695 Returns a pointer to the next character after the parsed
12696 vstring, as well as updating the passed in sv.
12698 Function must be called like
12701 s = scan_vstring(s,sv);
12703 The sv should already be large enough to store the vstring
12704 passed in, for performance reasons.
12709 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
12712 const char *pos = s;
12713 const char *start = s;
12714 if (*pos == 'v') pos++; /* get past 'v' */
12715 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12717 if ( *pos != '.') {
12718 /* this may not be a v-string if followed by => */
12719 const char *next = pos;
12720 while (next < PL_bufend && isSPACE(*next))
12722 if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
12723 /* return string not v-string */
12724 sv_setpvn(sv,(char *)s,pos-s);
12725 return (char *)pos;
12729 if (!isALPHA(*pos)) {
12730 U8 tmpbuf[UTF8_MAXBYTES+1];
12733 s++; /* get past 'v' */
12735 sv_setpvn(sv, "", 0);
12738 /* this is atoi() that tolerates underscores */
12741 const char *end = pos;
12743 while (--end >= s) {
12745 const UV orev = rev;
12746 rev += (*end - '0') * mult;
12748 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12749 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12750 "Integer overflow in decimal number");
12754 if (rev > 0x7FFFFFFF)
12755 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12757 /* Append native character for the rev point */
12758 tmpend = uvchr_to_utf8(tmpbuf, rev);
12759 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12760 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12762 if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
12768 while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12772 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12780 * c-indentation-style: bsd
12781 * c-basic-offset: 4
12782 * indent-tabs-mode: t
12785 * ex: set ts=8 sts=4 sw=4 noet: