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)
52 #define PL_linestr (PL_parser->linestr)
53 #define PL_expect (PL_parser->expect)
54 #define PL_copline (PL_parser->copline)
55 #define PL_bufptr (PL_parser->bufptr)
56 #define PL_oldbufptr (PL_parser->oldbufptr)
57 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
58 #define PL_linestart (PL_parser->linestart)
59 #define PL_bufend (PL_parser->bufend)
60 #define PL_last_uni (PL_parser->last_uni)
61 #define PL_last_lop (PL_parser->last_lop)
62 #define PL_last_lop_op (PL_parser->last_lop_op)
63 #define PL_lex_state (PL_parser->lex_state)
64 #define PL_rsfp (PL_parser->rsfp)
65 #define PL_rsfp_filters (PL_parser->rsfp_filters)
66 #define PL_in_my (PL_parser->in_my)
67 #define PL_in_my_stash (PL_parser->in_my_stash)
70 # define PL_endwhite (PL_parser->endwhite)
71 # define PL_faketokens (PL_parser->faketokens)
72 # define PL_lasttoke (PL_parser->lasttoke)
73 # define PL_nextwhite (PL_parser->nextwhite)
74 # define PL_realtokenstart (PL_parser->realtokenstart)
75 # define PL_skipwhite (PL_parser->skipwhite)
76 # define PL_thisclose (PL_parser->thisclose)
77 # define PL_thismad (PL_parser->thismad)
78 # define PL_thisopen (PL_parser->thisopen)
79 # define PL_thisstuff (PL_parser->thisstuff)
80 # define PL_thistoken (PL_parser->thistoken)
81 # define PL_thiswhite (PL_parser->thiswhite)
82 # define PL_thiswhite (PL_parser->thiswhite)
83 # define PL_nexttoke (PL_parser->nexttoke)
84 # define PL_curforce (PL_parser->curforce)
86 # define PL_nexttoke (PL_parser->nexttoke)
87 # define PL_nexttype (PL_parser->nexttype)
88 # define PL_nextval (PL_parser->nextval)
92 S_pending_ident(pTHX);
94 static const char ident_too_long[] = "Identifier too long";
95 static const char commaless_variable_list[] = "comma-less variable list";
97 #ifndef PERL_NO_UTF16_FILTER
98 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
99 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
103 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
104 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
106 # define CURMAD(slot,sv)
107 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
110 #define XFAKEBRACK 128
111 #define XENUMMASK 127
113 #ifdef USE_UTF8_SCRIPTS
114 # define UTF (!IN_BYTES)
116 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
119 /* In variables named $^X, these are the legal values for X.
120 * 1999-02-27 mjd-perl-patch@plover.com */
121 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
123 /* On MacOS, respect nonbreaking spaces */
124 #ifdef MACOS_TRADITIONAL
125 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
127 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
130 /* LEX_* are values for PL_lex_state, the state of the lexer.
131 * They are arranged oddly so that the guard on the switch statement
132 * can get by with a single comparison (if the compiler is smart enough).
135 /* #define LEX_NOTPARSING 11 is done in perl.h. */
137 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
138 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
139 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
140 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
141 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
143 /* at end of code, eg "$x" followed by: */
144 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
145 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
147 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
148 string or after \E, $foo, etc */
149 #define LEX_INTERPCONST 2 /* NOT USED */
150 #define LEX_FORMLINE 1 /* expecting a format line */
151 #define LEX_KNOWNEXT 0 /* next token known; just return it */
155 static const char* const lex_state_names[] = {
174 #include "keywords.h"
176 /* CLINE is a macro that ensures PL_copline has a sane value */
181 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
184 # define SKIPSPACE0(s) skipspace0(s)
185 # define SKIPSPACE1(s) skipspace1(s)
186 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
187 # define PEEKSPACE(s) skipspace2(s,0)
189 # define SKIPSPACE0(s) skipspace(s)
190 # define SKIPSPACE1(s) skipspace(s)
191 # define SKIPSPACE2(s,tsv) skipspace(s)
192 # define PEEKSPACE(s) skipspace(s)
196 * Convenience functions to return different tokens and prime the
197 * lexer for the next token. They all take an argument.
199 * TOKEN : generic token (used for '(', DOLSHARP, etc)
200 * OPERATOR : generic operator
201 * AOPERATOR : assignment operator
202 * PREBLOCK : beginning the block after an if, while, foreach, ...
203 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
204 * PREREF : *EXPR where EXPR is not a simple identifier
205 * TERM : expression term
206 * LOOPX : loop exiting command (goto, last, dump, etc)
207 * FTST : file test operator
208 * FUN0 : zero-argument function
209 * FUN1 : not used, except for not, which isn't a UNIOP
210 * BOop : bitwise or or xor
212 * SHop : shift operator
213 * PWop : power operator
214 * PMop : pattern-matching operator
215 * Aop : addition-level operator
216 * Mop : multiplication-level operator
217 * Eop : equality-testing operator
218 * Rop : relational operator <= != gt
220 * Also see LOP and lop() below.
223 #ifdef DEBUGGING /* Serve -DT. */
224 # define REPORT(retval) tokereport((I32)retval)
226 # define REPORT(retval) (retval)
229 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
230 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
231 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
232 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
233 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
234 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
235 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
236 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
237 #define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
238 #define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
239 #define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
240 #define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
241 #define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
242 #define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
243 #define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
244 #define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
245 #define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
246 #define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
247 #define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
248 #define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
250 /* This bit of chicanery makes a unary function followed by
251 * a parenthesis into a function with one argument, highest precedence.
252 * The UNIDOR macro is for unary functions that can be followed by the //
253 * operator (such as C<shift // 0>).
255 #define UNI2(f,x) { \
259 PL_last_uni = PL_oldbufptr; \
260 PL_last_lop_op = f; \
262 return REPORT( (int)FUNC1 ); \
264 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
266 #define UNI(f) UNI2(f,XTERM)
267 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
269 #define UNIBRACK(f) { \
272 PL_last_uni = PL_oldbufptr; \
274 return REPORT( (int)FUNC1 ); \
276 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
279 /* grandfather return to old style */
280 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
284 /* how to interpret the yylval associated with the token */
288 TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
294 static struct debug_tokens {
296 enum token_type type;
298 } const debug_tokens[] =
300 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
301 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
302 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
303 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
304 { ARROW, TOKENTYPE_NONE, "ARROW" },
305 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
306 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
307 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
308 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
309 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
310 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
311 { DO, TOKENTYPE_NONE, "DO" },
312 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
313 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
314 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
315 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
316 { ELSE, TOKENTYPE_NONE, "ELSE" },
317 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
318 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
319 { FOR, TOKENTYPE_IVAL, "FOR" },
320 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
321 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
322 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
323 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
324 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
325 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
326 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
327 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
328 { IF, TOKENTYPE_IVAL, "IF" },
329 { LABEL, TOKENTYPE_PVAL, "LABEL" },
330 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
331 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
332 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
333 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
334 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
335 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
336 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
337 { MY, TOKENTYPE_IVAL, "MY" },
338 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
339 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
340 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
341 { OROP, TOKENTYPE_IVAL, "OROP" },
342 { OROR, TOKENTYPE_NONE, "OROR" },
343 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
344 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
345 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
346 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
347 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
348 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
349 { PREINC, TOKENTYPE_NONE, "PREINC" },
350 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
351 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
352 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
353 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
354 { SUB, TOKENTYPE_NONE, "SUB" },
355 { THING, TOKENTYPE_OPVAL, "THING" },
356 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
357 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
358 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
359 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
360 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
361 { USE, TOKENTYPE_IVAL, "USE" },
362 { WHEN, TOKENTYPE_IVAL, "WHEN" },
363 { WHILE, TOKENTYPE_IVAL, "WHILE" },
364 { WORD, TOKENTYPE_OPVAL, "WORD" },
365 { 0, TOKENTYPE_NONE, NULL }
368 /* dump the returned token in rv, plus any optional arg in yylval */
371 S_tokereport(pTHX_ I32 rv)
375 const char *name = NULL;
376 enum token_type type = TOKENTYPE_NONE;
377 const struct debug_tokens *p;
378 SV* const report = newSVpvs("<== ");
380 for (p = debug_tokens; p->token; p++) {
381 if (p->token == (int)rv) {
388 Perl_sv_catpv(aTHX_ report, name);
389 else if ((char)rv > ' ' && (char)rv < '~')
390 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
392 sv_catpvs(report, "EOF");
394 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
397 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
400 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
402 case TOKENTYPE_OPNUM:
403 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
404 PL_op_name[yylval.ival]);
407 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
409 case TOKENTYPE_OPVAL:
411 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
412 PL_op_name[yylval.opval->op_type]);
413 if (yylval.opval->op_type == OP_CONST) {
414 Perl_sv_catpvf(aTHX_ report, " %s",
415 SvPEEK(cSVOPx_sv(yylval.opval)));
420 sv_catpvs(report, "(opval=null)");
423 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
429 /* print the buffer with suitable escapes */
432 S_printbuf(pTHX_ const char* fmt, const char* s)
434 SV* const tmp = newSVpvs("");
435 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
444 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
445 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
449 S_ao(pTHX_ int toketype)
452 if (*PL_bufptr == '=') {
454 if (toketype == ANDAND)
455 yylval.ival = OP_ANDASSIGN;
456 else if (toketype == OROR)
457 yylval.ival = OP_ORASSIGN;
458 else if (toketype == DORDOR)
459 yylval.ival = OP_DORASSIGN;
467 * When Perl expects an operator and finds something else, no_op
468 * prints the warning. It always prints "<something> found where
469 * operator expected. It prints "Missing semicolon on previous line?"
470 * if the surprise occurs at the start of the line. "do you need to
471 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
472 * where the compiler doesn't know if foo is a method call or a function.
473 * It prints "Missing operator before end of line" if there's nothing
474 * after the missing operator, or "... before <...>" if there is something
475 * after the missing operator.
479 S_no_op(pTHX_ const char *what, char *s)
482 char * const oldbp = PL_bufptr;
483 const bool is_first = (PL_oldbufptr == PL_linestart);
489 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
490 if (ckWARN_d(WARN_SYNTAX)) {
492 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
493 "\t(Missing semicolon on previous line?)\n");
494 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
496 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
498 if (t < PL_bufptr && isSPACE(*t))
499 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
500 "\t(Do you need to predeclare %.*s?)\n",
501 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
505 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
506 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
514 * Complain about missing quote/regexp/heredoc terminator.
515 * If it's called with NULL then it cauterizes the line buffer.
516 * If we're in a delimited string and the delimiter is a control
517 * character, it's reformatted into a two-char sequence like ^C.
522 S_missingterm(pTHX_ char *s)
528 char * const nl = strrchr(s,'\n');
534 iscntrl(PL_multi_close)
536 PL_multi_close < 32 || PL_multi_close == 127
540 tmpbuf[1] = (char)toCTRL(PL_multi_close);
545 *tmpbuf = (char)PL_multi_close;
549 q = strchr(s,'"') ? '\'' : '"';
550 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
553 #define FEATURE_IS_ENABLED(name) \
554 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
555 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
557 * S_feature_is_enabled
558 * Check whether the named feature is enabled.
561 S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
564 HV * const hinthv = GvHV(PL_hintgv);
565 char he_name[32] = "feature_";
566 (void) my_strlcpy(&he_name[8], name, 24);
568 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
576 Perl_deprecate(pTHX_ const char *s)
578 if (ckWARN(WARN_DEPRECATED))
579 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
583 Perl_deprecate_old(pTHX_ const char *s)
585 /* This function should NOT be called for any new deprecated warnings */
586 /* Use Perl_deprecate instead */
588 /* It is here to maintain backward compatibility with the pre-5.8 */
589 /* warnings category hierarchy. The "deprecated" category used to */
590 /* live under the "syntax" category. It is now a top-level category */
591 /* in its own right. */
593 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
594 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
595 "Use of %s is deprecated", s);
599 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
600 * utf16-to-utf8-reversed.
603 #ifdef PERL_CR_FILTER
607 register const char *s = SvPVX_const(sv);
608 register const char * const e = s + SvCUR(sv);
609 /* outer loop optimized to do nothing if there are no CR-LFs */
611 if (*s++ == '\r' && *s == '\n') {
612 /* hit a CR-LF, need to copy the rest */
613 register char *d = s - 1;
616 if (*s == '\r' && s[1] == '\n')
627 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
629 const I32 count = FILTER_READ(idx+1, sv, maxlen);
630 if (count > 0 && !maxlen)
641 * Create a parser object and initialise its parser and lexer fields
643 * rsfp is the opened file handle to read from (if any),
645 * line holds any initial content already read from the file (or in
646 * the case of no file, such as an eval, the whole contents);
648 * new_filter indicates that this is a new file and it shouldn't inherit
649 * the filters from the current parser (ie require).
653 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
656 const char *s = NULL;
658 yy_parser *parser, *oparser;
660 /* create and initialise a parser */
662 Newxz(parser, 1, yy_parser);
663 parser->old_parser = oparser = PL_parser;
666 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
667 parser->ps = parser->stack;
668 parser->stack_size = YYINITDEPTH;
670 parser->stack->state = 0;
671 parser->yyerrstatus = 0;
672 parser->yychar = YYEMPTY; /* Cause a token to be read. */
674 /* on scope exit, free this parser and restore any outer one */
676 parser->saved_curcop = PL_curcop;
678 /* initialise lexer state */
681 parser->curforce = -1;
683 parser->nexttoke = 0;
685 parser->copline = NOLINE;
686 parser->lex_state = LEX_NORMAL;
687 parser->expect = XSTATE;
689 parser->rsfp_filters = (new_filter || !oparser) ? NULL
690 : (AV*)SvREFCNT_inc(oparser->rsfp_filters);
692 Newx(parser->lex_brackstack, 120, char);
693 Newx(parser->lex_casestack, 12, char);
694 *parser->lex_casestack = '\0';
697 s = SvPV_const(line, len);
703 parser->linestr = newSVpvs("\n;");
704 } else if (SvREADONLY(line) || s[len-1] != ';') {
705 parser->linestr = newSVsv(line);
707 sv_catpvs(parser->linestr, "\n;");
710 SvREFCNT_inc_simple_void_NN(line);
711 parser->linestr = line;
713 parser->oldoldbufptr =
716 parser->linestart = SvPVX(parser->linestr);
717 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
718 parser->last_lop = parser->last_uni = NULL;
722 /* delete a parser object */
725 Perl_parser_free(pTHX_ const yy_parser *parser)
727 PL_curcop = parser->saved_curcop;
728 SvREFCNT_dec(parser->linestr);
730 if (parser->rsfp == PerlIO_stdin())
731 PerlIO_clearerr(parser->rsfp);
732 else if (parser->rsfp && parser->old_parser
733 && parser->rsfp != parser->old_parser->rsfp)
734 PerlIO_close(parser->rsfp);
735 SvREFCNT_dec(parser->rsfp_filters);
737 Safefree(parser->stack);
738 Safefree(parser->lex_brackstack);
739 Safefree(parser->lex_casestack);
740 PL_parser = parser->old_parser;
747 * Finalizer for lexing operations. Must be called when the parser is
748 * done with the lexer.
755 PL_doextract = FALSE;
760 * This subroutine has nothing to do with tilting, whether at windmills
761 * or pinball tables. Its name is short for "increment line". It
762 * increments the current line number in CopLINE(PL_curcop) and checks
763 * to see whether the line starts with a comment of the form
764 * # line 500 "foo.pm"
765 * If so, it sets the current line number and file to the values in the comment.
769 S_incline(pTHX_ const char *s)
776 CopLINE_inc(PL_curcop);
779 while (SPACE_OR_TAB(*s))
781 if (strnEQ(s, "line", 4))
785 if (SPACE_OR_TAB(*s))
789 while (SPACE_OR_TAB(*s))
797 while (SPACE_OR_TAB(*s))
799 if (*s == '"' && (t = strchr(s+1, '"'))) {
809 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
811 if (*e != '\n' && *e != '\0')
812 return; /* false alarm */
815 const STRLEN len = t - s;
817 const char * const cf = CopFILE(PL_curcop);
818 STRLEN tmplen = cf ? strlen(cf) : 0;
819 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
820 /* must copy *{"::_<(eval N)[oldfilename:L]"}
821 * to *{"::_<newfilename"} */
822 /* However, the long form of evals is only turned on by the
823 debugger - usually they're "(eval %lu)" */
827 STRLEN tmplen2 = len;
828 if (tmplen + 2 <= sizeof smallbuf)
831 Newx(tmpbuf, tmplen + 2, char);
834 memcpy(tmpbuf + 2, cf, tmplen);
836 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
841 if (tmplen2 + 2 <= sizeof smallbuf)
844 Newx(tmpbuf2, tmplen2 + 2, char);
846 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
847 /* Either they malloc'd it, or we malloc'd it,
848 so no prefix is present in ours. */
853 memcpy(tmpbuf2 + 2, s, tmplen2);
856 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
858 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
859 /* adjust ${"::_<newfilename"} to store the new file name */
860 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
861 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
862 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
865 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
867 if (tmpbuf != smallbuf) Safefree(tmpbuf);
870 CopFILE_free(PL_curcop);
871 CopFILE_setn(PL_curcop, s, len);
873 CopLINE_set(PL_curcop, atoi(n)-1);
877 /* skip space before PL_thistoken */
880 S_skipspace0(pTHX_ register char *s)
887 PL_thiswhite = newSVpvs("");
888 sv_catsv(PL_thiswhite, PL_skipwhite);
889 sv_free(PL_skipwhite);
892 PL_realtokenstart = s - SvPVX(PL_linestr);
896 /* skip space after PL_thistoken */
899 S_skipspace1(pTHX_ register char *s)
901 const char *start = s;
902 I32 startoff = start - SvPVX(PL_linestr);
907 start = SvPVX(PL_linestr) + startoff;
908 if (!PL_thistoken && PL_realtokenstart >= 0) {
909 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
910 PL_thistoken = newSVpvn(tstart, start - tstart);
912 PL_realtokenstart = -1;
915 PL_nextwhite = newSVpvs("");
916 sv_catsv(PL_nextwhite, PL_skipwhite);
917 sv_free(PL_skipwhite);
924 S_skipspace2(pTHX_ register char *s, SV **svp)
927 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
928 const I32 startoff = s - SvPVX(PL_linestr);
931 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
932 if (!PL_madskills || !svp)
934 start = SvPVX(PL_linestr) + startoff;
935 if (!PL_thistoken && PL_realtokenstart >= 0) {
936 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
937 PL_thistoken = newSVpvn(tstart, start - tstart);
938 PL_realtokenstart = -1;
943 sv_setsv(*svp, PL_skipwhite);
944 sv_free(PL_skipwhite);
953 S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len)
955 AV *av = CopFILEAVx(PL_curcop);
957 SV * const sv = newSV_type(SVt_PVMG);
959 sv_setsv(sv, orig_sv);
961 sv_setpvn(sv, buf, len);
964 av_store(av, (I32)CopLINE(PL_curcop), sv);
970 * Called to gobble the appropriate amount and type of whitespace.
971 * Skips comments as well.
975 S_skipspace(pTHX_ register char *s)
980 int startoff = s - SvPVX(PL_linestr);
983 sv_free(PL_skipwhite);
988 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
989 while (s < PL_bufend && SPACE_OR_TAB(*s))
999 SSize_t oldprevlen, oldoldprevlen;
1000 SSize_t oldloplen = 0, oldunilen = 0;
1001 while (s < PL_bufend && isSPACE(*s)) {
1002 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1007 if (s < PL_bufend && *s == '#') {
1008 while (s < PL_bufend && *s != '\n')
1010 if (s < PL_bufend) {
1012 if (PL_in_eval && !PL_rsfp) {
1019 /* only continue to recharge the buffer if we're at the end
1020 * of the buffer, we're not reading from a source filter, and
1021 * we're in normal lexing mode
1023 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1024 PL_lex_state == LEX_FORMLINE)
1031 /* try to recharge the buffer */
1033 curoff = s - SvPVX(PL_linestr);
1036 if ((s = filter_gets(PL_linestr, PL_rsfp,
1037 (prevlen = SvCUR(PL_linestr)))) == NULL)
1040 if (PL_madskills && curoff != startoff) {
1042 PL_skipwhite = newSVpvs("");
1043 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1047 /* mustn't throw out old stuff yet if madpropping */
1048 SvCUR(PL_linestr) = curoff;
1049 s = SvPVX(PL_linestr) + curoff;
1051 if (curoff && s[-1] == '\n')
1055 /* end of file. Add on the -p or -n magic */
1056 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1059 sv_catpvs(PL_linestr,
1060 ";}continue{print or die qq(-p destination: $!\\n);}");
1062 sv_setpvs(PL_linestr,
1063 ";}continue{print or die qq(-p destination: $!\\n);}");
1065 PL_minus_n = PL_minus_p = 0;
1067 else if (PL_minus_n) {
1069 sv_catpvn(PL_linestr, ";}", 2);
1071 sv_setpvn(PL_linestr, ";}", 2);
1077 sv_catpvn(PL_linestr,";", 1);
1079 sv_setpvn(PL_linestr,";", 1);
1082 /* reset variables for next time we lex */
1083 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1089 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1090 PL_last_lop = PL_last_uni = NULL;
1092 /* Close the filehandle. Could be from -P preprocessor,
1093 * STDIN, or a regular file. If we were reading code from
1094 * STDIN (because the commandline held no -e or filename)
1095 * then we don't close it, we reset it so the code can
1096 * read from STDIN too.
1099 if (PL_preprocess && !PL_in_eval)
1100 (void)PerlProc_pclose(PL_rsfp);
1101 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1102 PerlIO_clearerr(PL_rsfp);
1104 (void)PerlIO_close(PL_rsfp);
1109 /* not at end of file, so we only read another line */
1110 /* make corresponding updates to old pointers, for yyerror() */
1111 oldprevlen = PL_oldbufptr - PL_bufend;
1112 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1114 oldunilen = PL_last_uni - PL_bufend;
1116 oldloplen = PL_last_lop - PL_bufend;
1117 PL_linestart = PL_bufptr = s + prevlen;
1118 PL_bufend = s + SvCUR(PL_linestr);
1120 PL_oldbufptr = s + oldprevlen;
1121 PL_oldoldbufptr = s + oldoldprevlen;
1123 PL_last_uni = s + oldunilen;
1125 PL_last_lop = s + oldloplen;
1128 /* debugger active and we're not compiling the debugger code,
1129 * so store the line into the debugger's array of lines
1131 if (PERLDB_LINE && PL_curstash != PL_debstash)
1132 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1139 PL_skipwhite = newSVpvs("");
1140 curoff = s - SvPVX(PL_linestr);
1141 if (curoff - startoff)
1142 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1151 * Check the unary operators to ensure there's no ambiguity in how they're
1152 * used. An ambiguous piece of code would be:
1154 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1155 * the +5 is its argument.
1165 if (PL_oldoldbufptr != PL_last_uni)
1167 while (isSPACE(*PL_last_uni))
1170 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1172 if ((t = strchr(s, '(')) && t < PL_bufptr)
1175 if (ckWARN_d(WARN_AMBIGUOUS)){
1176 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1177 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1178 (int)(s - PL_last_uni), PL_last_uni);
1183 * LOP : macro to build a list operator. Its behaviour has been replaced
1184 * with a subroutine, S_lop() for which LOP is just another name.
1187 #define LOP(f,x) return lop(f,x,s)
1191 * Build a list operator (or something that might be one). The rules:
1192 * - if we have a next token, then it's a list operator [why?]
1193 * - if the next thing is an opening paren, then it's a function
1194 * - else it's a list operator
1198 S_lop(pTHX_ I32 f, int x, char *s)
1205 PL_last_lop = PL_oldbufptr;
1206 PL_last_lop_op = (OPCODE)f;
1209 return REPORT(LSTOP);
1212 return REPORT(LSTOP);
1215 return REPORT(FUNC);
1218 return REPORT(FUNC);
1220 return REPORT(LSTOP);
1226 * Sets up for an eventual force_next(). start_force(0) basically does
1227 * an unshift, while start_force(-1) does a push. yylex removes items
1232 S_start_force(pTHX_ int where)
1236 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1237 where = PL_lasttoke;
1238 assert(PL_curforce < 0 || PL_curforce == where);
1239 if (PL_curforce != where) {
1240 for (i = PL_lasttoke; i > where; --i) {
1241 PL_nexttoke[i] = PL_nexttoke[i-1];
1245 if (PL_curforce < 0) /* in case of duplicate start_force() */
1246 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1247 PL_curforce = where;
1250 curmad('^', newSVpvs(""));
1251 CURMAD('_', PL_nextwhite);
1256 S_curmad(pTHX_ char slot, SV *sv)
1262 if (PL_curforce < 0)
1263 where = &PL_thismad;
1265 where = &PL_nexttoke[PL_curforce].next_mad;
1268 sv_setpvn(sv, "", 0);
1271 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1273 else if (PL_encoding) {
1274 sv_recode_to_utf8(sv, PL_encoding);
1279 /* keep a slot open for the head of the list? */
1280 if (slot != '_' && *where && (*where)->mad_key == '^') {
1281 (*where)->mad_key = slot;
1282 sv_free((SV*)((*where)->mad_val));
1283 (*where)->mad_val = (void*)sv;
1286 addmad(newMADsv(slot, sv), where, 0);
1289 # define start_force(where) NOOP
1290 # define curmad(slot, sv) NOOP
1295 * When the lexer realizes it knows the next token (for instance,
1296 * it is reordering tokens for the parser) then it can call S_force_next
1297 * to know what token to return the next time the lexer is called. Caller
1298 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1299 * and possibly PL_expect to ensure the lexer handles the token correctly.
1303 S_force_next(pTHX_ I32 type)
1307 if (PL_curforce < 0)
1308 start_force(PL_lasttoke);
1309 PL_nexttoke[PL_curforce].next_type = type;
1310 if (PL_lex_state != LEX_KNOWNEXT)
1311 PL_lex_defer = PL_lex_state;
1312 PL_lex_state = LEX_KNOWNEXT;
1313 PL_lex_expect = PL_expect;
1316 PL_nexttype[PL_nexttoke] = type;
1318 if (PL_lex_state != LEX_KNOWNEXT) {
1319 PL_lex_defer = PL_lex_state;
1320 PL_lex_expect = PL_expect;
1321 PL_lex_state = LEX_KNOWNEXT;
1327 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
1330 SV * const sv = newSVpvn(start,len);
1331 if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
1338 * When the lexer knows the next thing is a word (for instance, it has
1339 * just seen -> and it knows that the next char is a word char, then
1340 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1344 * char *start : buffer position (must be within PL_linestr)
1345 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1346 * int check_keyword : if true, Perl checks to make sure the word isn't
1347 * a keyword (do this if the word is a label, e.g. goto FOO)
1348 * int allow_pack : if true, : characters will also be allowed (require,
1349 * use, etc. do this)
1350 * int allow_initial_tick : used by the "sub" lexer only.
1354 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1360 start = SKIPSPACE1(start);
1362 if (isIDFIRST_lazy_if(s,UTF) ||
1363 (allow_pack && *s == ':') ||
1364 (allow_initial_tick && *s == '\'') )
1366 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1367 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1369 start_force(PL_curforce);
1371 curmad('X', newSVpvn(start,s-start));
1372 if (token == METHOD) {
1377 PL_expect = XOPERATOR;
1381 curmad('g', newSVpvs( "forced" ));
1382 NEXTVAL_NEXTTOKE.opval
1383 = (OP*)newSVOP(OP_CONST,0,
1384 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1385 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1393 * Called when the lexer wants $foo *foo &foo etc, but the program
1394 * text only contains the "foo" portion. The first argument is a pointer
1395 * to the "foo", and the second argument is the type symbol to prefix.
1396 * Forces the next token to be a "WORD".
1397 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1401 S_force_ident(pTHX_ register const char *s, int kind)
1405 const STRLEN len = strlen(s);
1406 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1407 start_force(PL_curforce);
1408 NEXTVAL_NEXTTOKE.opval = o;
1411 o->op_private = OPpCONST_ENTERED;
1412 /* XXX see note in pp_entereval() for why we forgo typo
1413 warnings if the symbol must be introduced in an eval.
1415 gv_fetchpvn_flags(s, len,
1416 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1418 kind == '$' ? SVt_PV :
1419 kind == '@' ? SVt_PVAV :
1420 kind == '%' ? SVt_PVHV :
1428 Perl_str_to_version(pTHX_ SV *sv)
1433 const char *start = SvPV_const(sv,len);
1434 const char * const end = start + len;
1435 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1436 while (start < end) {
1440 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1445 retval += ((NV)n)/nshift;
1454 * Forces the next token to be a version number.
1455 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1456 * and if "guessing" is TRUE, then no new token is created (and the caller
1457 * must use an alternative parsing method).
1461 S_force_version(pTHX_ char *s, int guessing)
1467 I32 startoff = s - SvPVX(PL_linestr);
1476 while (isDIGIT(*d) || *d == '_' || *d == '.')
1480 start_force(PL_curforce);
1481 curmad('X', newSVpvn(s,d-s));
1484 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1486 s = scan_num(s, &yylval);
1487 version = yylval.opval;
1488 ver = cSVOPx(version)->op_sv;
1489 if (SvPOK(ver) && !SvNIOK(ver)) {
1490 SvUPGRADE(ver, SVt_PVNV);
1491 SvNV_set(ver, str_to_version(ver));
1492 SvNOK_on(ver); /* hint that it is a version */
1495 else if (guessing) {
1498 sv_free(PL_nextwhite); /* let next token collect whitespace */
1500 s = SvPVX(PL_linestr) + startoff;
1508 if (PL_madskills && !version) {
1509 sv_free(PL_nextwhite); /* let next token collect whitespace */
1511 s = SvPVX(PL_linestr) + startoff;
1514 /* NOTE: The parser sees the package name and the VERSION swapped */
1515 start_force(PL_curforce);
1516 NEXTVAL_NEXTTOKE.opval = version;
1524 * Tokenize a quoted string passed in as an SV. It finds the next
1525 * chunk, up to end of string or a backslash. It may make a new
1526 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1531 S_tokeq(pTHX_ SV *sv)
1535 register char *send;
1543 s = SvPV_force(sv, len);
1544 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1547 while (s < send && *s != '\\')
1552 if ( PL_hints & HINT_NEW_STRING ) {
1553 pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1559 if (s + 1 < send && (s[1] == '\\'))
1560 s++; /* all that, just for this */
1565 SvCUR_set(sv, d - SvPVX_const(sv));
1567 if ( PL_hints & HINT_NEW_STRING )
1568 return new_constant(NULL, 0, "q", sv, pv, "q");
1573 * Now come three functions related to double-quote context,
1574 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1575 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1576 * interact with PL_lex_state, and create fake ( ... ) argument lists
1577 * to handle functions and concatenation.
1578 * They assume that whoever calls them will be setting up a fake
1579 * join call, because each subthing puts a ',' after it. This lets
1582 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1584 * (I'm not sure whether the spurious commas at the end of lcfirst's
1585 * arguments and join's arguments are created or not).
1590 * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1592 * Pattern matching will set PL_lex_op to the pattern-matching op to
1593 * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1595 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1597 * Everything else becomes a FUNC.
1599 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1600 * had an OP_CONST or OP_READLINE). This just sets us up for a
1601 * call to S_sublex_push().
1605 S_sublex_start(pTHX)
1608 register const I32 op_type = yylval.ival;
1610 if (op_type == OP_NULL) {
1611 yylval.opval = PL_lex_op;
1615 if (op_type == OP_CONST || op_type == OP_READLINE) {
1616 SV *sv = tokeq(PL_lex_stuff);
1618 if (SvTYPE(sv) == SVt_PVIV) {
1619 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1621 const char * const p = SvPV_const(sv, len);
1622 SV * const nsv = newSVpvn(p, len);
1628 yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1629 PL_lex_stuff = NULL;
1630 /* Allow <FH> // "foo" */
1631 if (op_type == OP_READLINE)
1632 PL_expect = XTERMORDORDOR;
1635 else if (op_type == OP_BACKTICK && PL_lex_op) {
1636 /* readpipe() vas overriden */
1637 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1638 yylval.opval = PL_lex_op;
1640 PL_lex_stuff = NULL;
1644 PL_sublex_info.super_state = PL_lex_state;
1645 PL_sublex_info.sub_inwhat = (U16)op_type;
1646 PL_sublex_info.sub_op = PL_lex_op;
1647 PL_lex_state = LEX_INTERPPUSH;
1651 yylval.opval = PL_lex_op;
1661 * Create a new scope to save the lexing state. The scope will be
1662 * ended in S_sublex_done. Returns a '(', starting the function arguments
1663 * to the uc, lc, etc. found before.
1664 * Sets PL_lex_state to LEX_INTERPCONCAT.
1673 PL_lex_state = PL_sublex_info.super_state;
1674 SAVEBOOL(PL_lex_dojoin);
1675 SAVEI32(PL_lex_brackets);
1676 SAVEI32(PL_lex_casemods);
1677 SAVEI32(PL_lex_starts);
1678 SAVEI8(PL_lex_state);
1679 SAVEVPTR(PL_lex_inpat);
1680 SAVEI16(PL_lex_inwhat);
1681 SAVECOPLINE(PL_curcop);
1682 SAVEPPTR(PL_bufptr);
1683 SAVEPPTR(PL_bufend);
1684 SAVEPPTR(PL_oldbufptr);
1685 SAVEPPTR(PL_oldoldbufptr);
1686 SAVEPPTR(PL_last_lop);
1687 SAVEPPTR(PL_last_uni);
1688 SAVEPPTR(PL_linestart);
1689 SAVESPTR(PL_linestr);
1690 SAVEGENERICPV(PL_lex_brackstack);
1691 SAVEGENERICPV(PL_lex_casestack);
1693 PL_linestr = PL_lex_stuff;
1694 PL_lex_stuff = NULL;
1696 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1697 = SvPVX(PL_linestr);
1698 PL_bufend += SvCUR(PL_linestr);
1699 PL_last_lop = PL_last_uni = NULL;
1700 SAVEFREESV(PL_linestr);
1702 PL_lex_dojoin = FALSE;
1703 PL_lex_brackets = 0;
1704 Newx(PL_lex_brackstack, 120, char);
1705 Newx(PL_lex_casestack, 12, char);
1706 PL_lex_casemods = 0;
1707 *PL_lex_casestack = '\0';
1709 PL_lex_state = LEX_INTERPCONCAT;
1710 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1712 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1713 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1714 PL_lex_inpat = PL_sublex_info.sub_op;
1716 PL_lex_inpat = NULL;
1723 * Restores lexer state after a S_sublex_push.
1730 if (!PL_lex_starts++) {
1731 SV * const sv = newSVpvs("");
1732 if (SvUTF8(PL_linestr))
1734 PL_expect = XOPERATOR;
1735 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1739 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1740 PL_lex_state = LEX_INTERPCASEMOD;
1744 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1745 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1746 PL_linestr = PL_lex_repl;
1748 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1749 PL_bufend += SvCUR(PL_linestr);
1750 PL_last_lop = PL_last_uni = NULL;
1751 SAVEFREESV(PL_linestr);
1752 PL_lex_dojoin = FALSE;
1753 PL_lex_brackets = 0;
1754 PL_lex_casemods = 0;
1755 *PL_lex_casestack = '\0';
1757 if (SvEVALED(PL_lex_repl)) {
1758 PL_lex_state = LEX_INTERPNORMAL;
1760 /* we don't clear PL_lex_repl here, so that we can check later
1761 whether this is an evalled subst; that means we rely on the
1762 logic to ensure sublex_done() is called again only via the
1763 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1766 PL_lex_state = LEX_INTERPCONCAT;
1776 PL_endwhite = newSVpvs("");
1777 sv_catsv(PL_endwhite, PL_thiswhite);
1781 sv_setpvn(PL_thistoken,"",0);
1783 PL_realtokenstart = -1;
1787 PL_bufend = SvPVX(PL_linestr);
1788 PL_bufend += SvCUR(PL_linestr);
1789 PL_expect = XOPERATOR;
1790 PL_sublex_info.sub_inwhat = 0;
1798 Extracts a pattern, double-quoted string, or transliteration. This
1801 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1802 processing a pattern (PL_lex_inpat is true), a transliteration
1803 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1805 Returns a pointer to the character scanned up to. If this is
1806 advanced from the start pointer supplied (i.e. if anything was
1807 successfully parsed), will leave an OP for the substring scanned
1808 in yylval. Caller must intuit reason for not parsing further
1809 by looking at the next characters herself.
1813 double-quoted style: \r and \n
1814 regexp special ones: \D \s
1817 case and quoting: \U \Q \E
1818 stops on @ and $, but not for $ as tail anchor
1820 In transliterations:
1821 characters are VERY literal, except for - not at the start or end
1822 of the string, which indicates a range. If the range is in bytes,
1823 scan_const expands the range to the full set of intermediate
1824 characters. If the range is in utf8, the hyphen is replaced with
1825 a certain range mark which will be handled by pmtrans() in op.c.
1827 In double-quoted strings:
1829 double-quoted style: \r and \n
1831 deprecated backrefs: \1 (in substitution replacements)
1832 case and quoting: \U \Q \E
1835 scan_const does *not* construct ops to handle interpolated strings.
1836 It stops processing as soon as it finds an embedded $ or @ variable
1837 and leaves it to the caller to work out what's going on.
1839 embedded arrays (whether in pattern or not) could be:
1840 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1842 $ in double-quoted strings must be the symbol of an embedded scalar.
1844 $ in pattern could be $foo or could be tail anchor. Assumption:
1845 it's a tail anchor if $ is the last thing in the string, or if it's
1846 followed by one of "()| \r\n\t"
1848 \1 (backreferences) are turned into $1
1850 The structure of the code is
1851 while (there's a character to process) {
1852 handle transliteration ranges
1853 skip regexp comments /(?#comment)/ and codes /(?{code})/
1854 skip #-initiated comments in //x patterns
1855 check for embedded arrays
1856 check for embedded scalars
1858 leave intact backslashes from leaveit (below)
1859 deprecate \1 in substitution replacements
1860 handle string-changing backslashes \l \U \Q \E, etc.
1861 switch (what was escaped) {
1862 handle \- in a transliteration (becomes a literal -)
1863 handle \132 (octal characters)
1864 handle \x15 and \x{1234} (hex characters)
1865 handle \N{name} (named characters)
1866 handle \cV (control characters)
1867 handle printf-style backslashes (\f, \r, \n, etc)
1869 } (end if backslash)
1870 } (end while character to read)
1875 S_scan_const(pTHX_ char *start)
1878 register char *send = PL_bufend; /* end of the constant */
1879 SV *sv = newSV(send - start); /* sv for the constant */
1880 register char *s = start; /* start of the constant */
1881 register char *d = SvPVX(sv); /* destination for copies */
1882 bool dorange = FALSE; /* are we in a translit range? */
1883 bool didrange = FALSE; /* did we just finish a range? */
1884 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1885 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1888 UV literal_endpoint = 0;
1889 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1892 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1893 /* If we are doing a trans and we know we want UTF8 set expectation */
1894 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1895 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1899 while (s < send || dorange) {
1900 /* get transliterations out of the way (they're most literal) */
1901 if (PL_lex_inwhat == OP_TRANS) {
1902 /* expand a range A-Z to the full set of characters. AIE! */
1904 I32 i; /* current expanded character */
1905 I32 min; /* first character in range */
1906 I32 max; /* last character in range */
1917 char * const c = (char*)utf8_hop((U8*)d, -1);
1921 *c = (char)UTF_TO_NATIVE(0xff);
1922 /* mark the range as done, and continue */
1928 i = d - SvPVX_const(sv); /* remember current offset */
1931 SvLEN(sv) + (has_utf8 ?
1932 (512 - UTF_CONTINUATION_MARK +
1935 /* How many two-byte within 0..255: 128 in UTF-8,
1936 * 96 in UTF-8-mod. */
1938 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1940 d = SvPVX(sv) + i; /* refresh d after realloc */
1944 for (j = 0; j <= 1; j++) {
1945 char * const c = (char*)utf8_hop((U8*)d, -1);
1946 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
1952 max = (U8)0xff; /* only to \xff */
1953 uvmax = uv; /* \x{100} to uvmax */
1955 d = c; /* eat endpoint chars */
1960 d -= 2; /* eat the first char and the - */
1961 min = (U8)*d; /* first char in range */
1962 max = (U8)d[1]; /* last char in range */
1969 "Invalid range \"%c-%c\" in transliteration operator",
1970 (char)min, (char)max);
1974 if (literal_endpoint == 2 &&
1975 ((isLOWER(min) && isLOWER(max)) ||
1976 (isUPPER(min) && isUPPER(max)))) {
1978 for (i = min; i <= max; i++)
1980 *d++ = NATIVE_TO_NEED(has_utf8,i);
1982 for (i = min; i <= max; i++)
1984 *d++ = NATIVE_TO_NEED(has_utf8,i);
1989 for (i = min; i <= max; i++)
1992 const U8 ch = (U8)NATIVE_TO_UTF(i);
1993 if (UNI_IS_INVARIANT(ch))
1996 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
1997 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2006 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2008 *d++ = (char)UTF_TO_NATIVE(0xff);
2010 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2014 /* mark the range as done, and continue */
2018 literal_endpoint = 0;
2023 /* range begins (ignore - as first or last char) */
2024 else if (*s == '-' && s+1 < send && s != start) {
2026 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2033 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2043 literal_endpoint = 0;
2044 native_range = TRUE;
2049 /* if we get here, we're not doing a transliteration */
2051 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2052 except for the last char, which will be done separately. */
2053 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2055 while (s+1 < send && *s != ')')
2056 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2058 else if (s[2] == '{' /* This should match regcomp.c */
2059 || (s[2] == '?' && s[3] == '{'))
2062 char *regparse = s + (s[2] == '{' ? 3 : 4);
2065 while (count && (c = *regparse)) {
2066 if (c == '\\' && regparse[1])
2074 if (*regparse != ')')
2075 regparse--; /* Leave one char for continuation. */
2076 while (s < regparse)
2077 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2081 /* likewise skip #-initiated comments in //x patterns */
2082 else if (*s == '#' && PL_lex_inpat &&
2083 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2084 while (s+1 < send && *s != '\n')
2085 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2088 /* check for embedded arrays
2089 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2091 else if (*s == '@' && s[1]) {
2092 if (isALNUM_lazy_if(s+1,UTF))
2094 if (strchr(":'{$", s[1]))
2096 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2097 break; /* in regexp, neither @+ nor @- are interpolated */
2100 /* check for embedded scalars. only stop if we're sure it's a
2103 else if (*s == '$') {
2104 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2106 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
2107 break; /* in regexp, $ might be tail anchor */
2110 /* End of else if chain - OP_TRANS rejoin rest */
2113 if (*s == '\\' && s+1 < send) {
2116 /* deprecate \1 in strings and substitution replacements */
2117 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2118 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2120 if (ckWARN(WARN_SYNTAX))
2121 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2126 /* string-change backslash escapes */
2127 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2131 /* skip any other backslash escapes in a pattern */
2132 else if (PL_lex_inpat) {
2133 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2134 goto default_action;
2137 /* if we get here, it's either a quoted -, or a digit */
2140 /* quoted - in transliterations */
2142 if (PL_lex_inwhat == OP_TRANS) {
2149 if ((isALPHA(*s) || isDIGIT(*s)) &&
2151 Perl_warner(aTHX_ packWARN(WARN_MISC),
2152 "Unrecognized escape \\%c passed through",
2154 /* default action is to copy the quoted character */
2155 goto default_action;
2158 /* \132 indicates an octal constant */
2159 case '0': case '1': case '2': case '3':
2160 case '4': case '5': case '6': case '7':
2164 uv = grok_oct(s, &len, &flags, NULL);
2167 goto NUM_ESCAPE_INSERT;
2169 /* \x24 indicates a hex constant */
2173 char* const e = strchr(s, '}');
2174 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2175 PERL_SCAN_DISALLOW_PREFIX;
2180 yyerror("Missing right brace on \\x{}");
2184 uv = grok_hex(s, &len, &flags, NULL);
2190 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2191 uv = grok_hex(s, &len, &flags, NULL);
2197 /* Insert oct or hex escaped character.
2198 * There will always enough room in sv since such
2199 * escapes will be longer than any UTF-8 sequence
2200 * they can end up as. */
2202 /* We need to map to chars to ASCII before doing the tests
2205 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2206 if (!has_utf8 && uv > 255) {
2207 /* Might need to recode whatever we have
2208 * accumulated so far if it contains any
2211 * (Can't we keep track of that and avoid
2212 * this rescan? --jhi)
2216 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2217 if (!NATIVE_IS_INVARIANT(*c)) {
2222 const STRLEN offset = d - SvPVX_const(sv);
2224 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2228 while (src >= (const U8 *)SvPVX_const(sv)) {
2229 if (!NATIVE_IS_INVARIANT(*src)) {
2230 const U8 ch = NATIVE_TO_ASCII(*src);
2231 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2232 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2242 if (has_utf8 || uv > 255) {
2243 d = (char*)uvchr_to_utf8((U8*)d, uv);
2245 if (PL_lex_inwhat == OP_TRANS &&
2246 PL_sublex_info.sub_op) {
2247 PL_sublex_info.sub_op->op_private |=
2248 (PL_lex_repl ? OPpTRANS_FROM_UTF
2252 if (uv > 255 && !dorange)
2253 native_range = FALSE;
2265 /* \N{LATIN SMALL LETTER A} is a named character */
2269 char* e = strchr(s, '}');
2276 yyerror("Missing right brace on \\N{}");
2280 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2282 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2283 PERL_SCAN_DISALLOW_PREFIX;
2286 uv = grok_hex(s, &len, &flags, NULL);
2287 if ( e > s && len != (STRLEN)(e - s) ) {
2291 goto NUM_ESCAPE_INSERT;
2293 res = newSVpvn(s + 1, e - s - 1);
2294 type = newSVpvn(s - 2,e - s + 3);
2295 res = new_constant( NULL, 0, "charnames",
2296 res, NULL, SvPVX(type) );
2299 sv_utf8_upgrade(res);
2300 str = SvPV_const(res,len);
2301 #ifdef EBCDIC_NEVER_MIND
2302 /* charnames uses pack U and that has been
2303 * recently changed to do the below uni->native
2304 * mapping, so this would be redundant (and wrong,
2305 * the code point would be doubly converted).
2306 * But leave this in just in case the pack U change
2307 * gets revoked, but the semantics is still
2308 * desireable for charnames. --jhi */
2310 UV uv = utf8_to_uvchr((const U8*)str, 0);
2313 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2315 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2316 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2317 str = SvPV_const(res, len);
2321 if (!has_utf8 && SvUTF8(res)) {
2322 const char * const ostart = SvPVX_const(sv);
2323 SvCUR_set(sv, d - ostart);
2326 sv_utf8_upgrade(sv);
2327 /* this just broke our allocation above... */
2328 SvGROW(sv, (STRLEN)(send - start));
2329 d = SvPVX(sv) + SvCUR(sv);
2332 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2333 const char * const odest = SvPVX_const(sv);
2335 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2336 d = SvPVX(sv) + (d - odest);
2340 native_range = FALSE; /* \N{} is guessed to be Unicode */
2342 Copy(str, d, len, char);
2349 yyerror("Missing braces on \\N{}");
2352 /* \c is a control character */
2361 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2364 yyerror("Missing control char name in \\c");
2368 /* printf-style backslashes, formfeeds, newlines, etc */
2370 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2373 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2376 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2379 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2382 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2385 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2388 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2394 } /* end if (backslash) */
2401 /* If we started with encoded form, or already know we want it
2402 and then encode the next character */
2403 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2405 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2406 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2409 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2410 const STRLEN off = d - SvPVX_const(sv);
2411 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2413 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2416 if (uv > 255 && !dorange)
2417 native_range = FALSE;
2421 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2423 } /* while loop to process each character */
2425 /* terminate the string and set up the sv */
2427 SvCUR_set(sv, d - SvPVX_const(sv));
2428 if (SvCUR(sv) >= SvLEN(sv))
2429 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2432 if (PL_encoding && !has_utf8) {
2433 sv_recode_to_utf8(sv, PL_encoding);
2439 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2440 PL_sublex_info.sub_op->op_private |=
2441 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2445 /* shrink the sv if we allocated more than we used */
2446 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2447 SvPV_shrink_to_cur(sv);
2450 /* return the substring (via yylval) only if we parsed anything */
2451 if (s > PL_bufptr) {
2452 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2453 sv = new_constant(start, s - start,
2454 (const char *)(PL_lex_inpat ? "qr" : "q"),
2457 (( PL_lex_inwhat == OP_TRANS
2459 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2462 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2469 * Returns TRUE if there's more to the expression (e.g., a subscript),
2472 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2474 * ->[ and ->{ return TRUE
2475 * { and [ outside a pattern are always subscripts, so return TRUE
2476 * if we're outside a pattern and it's not { or [, then return FALSE
2477 * if we're in a pattern and the first char is a {
2478 * {4,5} (any digits around the comma) returns FALSE
2479 * if we're in a pattern and the first char is a [
2481 * [SOMETHING] has a funky algorithm to decide whether it's a
2482 * character class or not. It has to deal with things like
2483 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2484 * anything else returns TRUE
2487 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2490 S_intuit_more(pTHX_ register char *s)
2493 if (PL_lex_brackets)
2495 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2497 if (*s != '{' && *s != '[')
2502 /* In a pattern, so maybe we have {n,m}. */
2519 /* On the other hand, maybe we have a character class */
2522 if (*s == ']' || *s == '^')
2525 /* this is terrifying, and it works */
2526 int weight = 2; /* let's weigh the evidence */
2528 unsigned char un_char = 255, last_un_char;
2529 const char * const send = strchr(s,']');
2530 char tmpbuf[sizeof PL_tokenbuf * 4];
2532 if (!send) /* has to be an expression */
2535 Zero(seen,256,char);
2538 else if (isDIGIT(*s)) {
2540 if (isDIGIT(s[1]) && s[2] == ']')
2546 for (; s < send; s++) {
2547 last_un_char = un_char;
2548 un_char = (unsigned char)*s;
2553 weight -= seen[un_char] * 10;
2554 if (isALNUM_lazy_if(s+1,UTF)) {
2556 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2557 len = (int)strlen(tmpbuf);
2558 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2563 else if (*s == '$' && s[1] &&
2564 strchr("[#!%*<>()-=",s[1])) {
2565 if (/*{*/ strchr("])} =",s[2]))
2574 if (strchr("wds]",s[1]))
2576 else if (seen[(U8)'\''] || seen[(U8)'"'])
2578 else if (strchr("rnftbxcav",s[1]))
2580 else if (isDIGIT(s[1])) {
2582 while (s[1] && isDIGIT(s[1]))
2592 if (strchr("aA01! ",last_un_char))
2594 if (strchr("zZ79~",s[1]))
2596 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2597 weight -= 5; /* cope with negative subscript */
2600 if (!isALNUM(last_un_char)
2601 && !(last_un_char == '$' || last_un_char == '@'
2602 || last_un_char == '&')
2603 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2608 if (keyword(tmpbuf, d - tmpbuf, 0))
2611 if (un_char == last_un_char + 1)
2613 weight -= seen[un_char];
2618 if (weight >= 0) /* probably a character class */
2628 * Does all the checking to disambiguate
2630 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2631 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2633 * First argument is the stuff after the first token, e.g. "bar".
2635 * Not a method if bar is a filehandle.
2636 * Not a method if foo is a subroutine prototyped to take a filehandle.
2637 * Not a method if it's really "Foo $bar"
2638 * Method if it's "foo $bar"
2639 * Not a method if it's really "print foo $bar"
2640 * Method if it's really "foo package::" (interpreted as package->foo)
2641 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2642 * Not a method if bar is a filehandle or package, but is quoted with
2647 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2650 char *s = start + (*start == '$');
2651 char tmpbuf[sizeof PL_tokenbuf];
2659 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2663 const char *proto = SvPVX_const(cv);
2674 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2675 /* start is the beginning of the possible filehandle/object,
2676 * and s is the end of it
2677 * tmpbuf is a copy of it
2680 if (*start == '$') {
2681 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2682 isUPPER(*PL_tokenbuf))
2685 len = start - SvPVX(PL_linestr);
2689 start = SvPVX(PL_linestr) + len;
2693 return *s == '(' ? FUNCMETH : METHOD;
2695 if (!keyword(tmpbuf, len, 0)) {
2696 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2700 soff = s - SvPVX(PL_linestr);
2704 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2705 if (indirgv && GvCVu(indirgv))
2707 /* filehandle or package name makes it a method */
2708 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2710 soff = s - SvPVX(PL_linestr);
2713 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2714 return 0; /* no assumptions -- "=>" quotes bearword */
2716 start_force(PL_curforce);
2717 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2718 newSVpvn(tmpbuf,len));
2719 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2721 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2726 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2728 return *s == '(' ? FUNCMETH : METHOD;
2736 * Return a string of Perl code to load the debugger. If PERL5DB
2737 * is set, it will return the contents of that, otherwise a
2738 * compile-time require of perl5db.pl.
2746 const char * const pdb = PerlEnv_getenv("PERL5DB");
2750 SETERRNO(0,SS_NORMAL);
2751 return "BEGIN { require 'perl5db.pl' }";
2757 /* Encoded script support. filter_add() effectively inserts a
2758 * 'pre-processing' function into the current source input stream.
2759 * Note that the filter function only applies to the current source file
2760 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2762 * The datasv parameter (which may be NULL) can be used to pass
2763 * private data to this instance of the filter. The filter function
2764 * can recover the SV using the FILTER_DATA macro and use it to
2765 * store private buffers and state information.
2767 * The supplied datasv parameter is upgraded to a PVIO type
2768 * and the IoDIRP/IoANY field is used to store the function pointer,
2769 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2770 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2771 * private use must be set using malloc'd pointers.
2775 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2784 if (!PL_rsfp_filters)
2785 PL_rsfp_filters = newAV();
2788 SvUPGRADE(datasv, SVt_PVIO);
2789 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2790 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2791 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2792 FPTR2DPTR(void *, IoANY(datasv)),
2793 SvPV_nolen(datasv)));
2794 av_unshift(PL_rsfp_filters, 1);
2795 av_store(PL_rsfp_filters, 0, datasv) ;
2800 /* Delete most recently added instance of this filter function. */
2802 Perl_filter_del(pTHX_ filter_t funcp)
2808 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2809 FPTR2DPTR(void*, funcp)));
2811 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2813 /* if filter is on top of stack (usual case) just pop it off */
2814 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2815 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2816 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2817 IoANY(datasv) = (void *)NULL;
2818 sv_free(av_pop(PL_rsfp_filters));
2822 /* we need to search for the correct entry and clear it */
2823 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2827 /* Invoke the idxth filter function for the current rsfp. */
2828 /* maxlen 0 = read one text line */
2830 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2835 /* This API is bad. It should have been using unsigned int for maxlen.
2836 Not sure if we want to change the API, but if not we should sanity
2837 check the value here. */
2838 const unsigned int correct_length
2847 if (!PL_parser || !PL_rsfp_filters)
2849 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2850 /* Provide a default input filter to make life easy. */
2851 /* Note that we append to the line. This is handy. */
2852 DEBUG_P(PerlIO_printf(Perl_debug_log,
2853 "filter_read %d: from rsfp\n", idx));
2854 if (correct_length) {
2857 const int old_len = SvCUR(buf_sv);
2859 /* ensure buf_sv is large enough */
2860 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2861 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2862 correct_length)) <= 0) {
2863 if (PerlIO_error(PL_rsfp))
2864 return -1; /* error */
2866 return 0 ; /* end of file */
2868 SvCUR_set(buf_sv, old_len + len) ;
2871 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2872 if (PerlIO_error(PL_rsfp))
2873 return -1; /* error */
2875 return 0 ; /* end of file */
2878 return SvCUR(buf_sv);
2880 /* Skip this filter slot if filter has been deleted */
2881 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2882 DEBUG_P(PerlIO_printf(Perl_debug_log,
2883 "filter_read %d: skipped (filter deleted)\n",
2885 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2887 /* Get function pointer hidden within datasv */
2888 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2889 DEBUG_P(PerlIO_printf(Perl_debug_log,
2890 "filter_read %d: via function %p (%s)\n",
2891 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2892 /* Call function. The function is expected to */
2893 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2894 /* Return: <0:error, =0:eof, >0:not eof */
2895 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2899 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2902 #ifdef PERL_CR_FILTER
2903 if (!PL_rsfp_filters) {
2904 filter_add(S_cr_textfilter,NULL);
2907 if (PL_rsfp_filters) {
2909 SvCUR_set(sv, 0); /* start with empty line */
2910 if (FILTER_READ(0, sv, 0) > 0)
2911 return ( SvPVX(sv) ) ;
2916 return (sv_gets(sv, fp, append));
2920 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2925 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2929 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2930 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2932 return GvHV(gv); /* Foo:: */
2935 /* use constant CLASS => 'MyClass' */
2936 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
2937 if (gv && GvCV(gv)) {
2938 SV * const sv = cv_const_sv(GvCV(gv));
2940 pkgname = SvPV_nolen_const(sv);
2943 return gv_stashpv(pkgname, 0);
2947 * S_readpipe_override
2948 * Check whether readpipe() is overriden, and generates the appropriate
2949 * optree, provided sublex_start() is called afterwards.
2952 S_readpipe_override(pTHX)
2955 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
2956 yylval.ival = OP_BACKTICK;
2958 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
2960 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
2961 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
2962 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
2964 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
2965 append_elem(OP_LIST,
2966 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
2967 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
2977 * The intent of this yylex wrapper is to minimize the changes to the
2978 * tokener when we aren't interested in collecting madprops. It remains
2979 * to be seen how successful this strategy will be...
2986 char *s = PL_bufptr;
2988 /* make sure PL_thiswhite is initialized */
2992 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2993 if (PL_pending_ident)
2994 return S_pending_ident(aTHX);
2996 /* previous token ate up our whitespace? */
2997 if (!PL_lasttoke && PL_nextwhite) {
2998 PL_thiswhite = PL_nextwhite;
3002 /* isolate the token, and figure out where it is without whitespace */
3003 PL_realtokenstart = -1;
3007 assert(PL_curforce < 0);
3009 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
3010 if (!PL_thistoken) {
3011 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3012 PL_thistoken = newSVpvs("");
3014 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3015 PL_thistoken = newSVpvn(tstart, s - tstart);
3018 if (PL_thismad) /* install head */
3019 CURMAD('X', PL_thistoken);
3022 /* last whitespace of a sublex? */
3023 if (optype == ')' && PL_endwhite) {
3024 CURMAD('X', PL_endwhite);
3029 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
3030 if (!PL_thiswhite && !PL_endwhite && !optype) {
3031 sv_free(PL_thistoken);
3036 /* put off final whitespace till peg */
3037 if (optype == ';' && !PL_rsfp) {
3038 PL_nextwhite = PL_thiswhite;
3041 else if (PL_thisopen) {
3042 CURMAD('q', PL_thisopen);
3044 sv_free(PL_thistoken);
3048 /* Store actual token text as madprop X */
3049 CURMAD('X', PL_thistoken);
3053 /* add preceding whitespace as madprop _ */
3054 CURMAD('_', PL_thiswhite);
3058 /* add quoted material as madprop = */
3059 CURMAD('=', PL_thisstuff);
3063 /* add terminating quote as madprop Q */
3064 CURMAD('Q', PL_thisclose);
3068 /* special processing based on optype */
3072 /* opval doesn't need a TOKEN since it can already store mp */
3083 append_madprops(PL_thismad, yylval.opval, 0);
3091 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3100 /* remember any fake bracket that lexer is about to discard */
3101 if (PL_lex_brackets == 1 &&
3102 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3105 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3108 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3109 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3112 break; /* don't bother looking for trailing comment */
3121 /* attach a trailing comment to its statement instead of next token */
3125 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3127 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3129 if (*s == '\n' || *s == '#') {
3130 while (s < PL_bufend && *s != '\n')
3134 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3135 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3152 /* Create new token struct. Note: opvals return early above. */
3153 yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
3160 S_tokenize_use(pTHX_ int is_use, char *s) {
3162 if (PL_expect != XSTATE)
3163 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3164 is_use ? "use" : "no"));
3166 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3167 s = force_version(s, TRUE);
3168 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3169 start_force(PL_curforce);
3170 NEXTVAL_NEXTTOKE.opval = NULL;
3173 else if (*s == 'v') {
3174 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3175 s = force_version(s, FALSE);
3179 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3180 s = force_version(s, FALSE);
3182 yylval.ival = is_use;
3186 static const char* const exp_name[] =
3187 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3188 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3195 Works out what to call the token just pulled out of the input
3196 stream. The yacc parser takes care of taking the ops we return and
3197 stitching them into a tree.
3203 if read an identifier
3204 if we're in a my declaration
3205 croak if they tried to say my($foo::bar)
3206 build the ops for a my() declaration
3207 if it's an access to a my() variable
3208 are we in a sort block?
3209 croak if my($a); $a <=> $b
3210 build ops for access to a my() variable
3211 if in a dq string, and they've said @foo and we can't find @foo
3213 build ops for a bareword
3214 if we already built the token before, use it.
3219 #pragma segment Perl_yylex
3225 register char *s = PL_bufptr;
3230 /* orig_keyword, gvp, and gv are initialized here because
3231 * jump to the label just_a_word_zero can bypass their
3232 * initialization later. */
3233 I32 orig_keyword = 0;
3238 SV* tmp = newSVpvs("");
3239 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3240 (IV)CopLINE(PL_curcop),
3241 lex_state_names[PL_lex_state],
3242 exp_name[PL_expect],
3243 pv_display(tmp, s, strlen(s), 0, 60));
3246 /* check if there's an identifier for us to look at */
3247 if (PL_pending_ident)
3248 return REPORT(S_pending_ident(aTHX));
3250 /* no identifier pending identification */
3252 switch (PL_lex_state) {
3254 case LEX_NORMAL: /* Some compilers will produce faster */
3255 case LEX_INTERPNORMAL: /* code if we comment these out. */
3259 /* when we've already built the next token, just pull it out of the queue */
3263 yylval = PL_nexttoke[PL_lasttoke].next_val;
3265 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3266 PL_nexttoke[PL_lasttoke].next_mad = 0;
3267 if (PL_thismad && PL_thismad->mad_key == '_') {
3268 PL_thiswhite = (SV*)PL_thismad->mad_val;
3269 PL_thismad->mad_val = 0;
3270 mad_free(PL_thismad);
3275 PL_lex_state = PL_lex_defer;
3276 PL_expect = PL_lex_expect;
3277 PL_lex_defer = LEX_NORMAL;
3278 if (!PL_nexttoke[PL_lasttoke].next_type)
3283 yylval = PL_nextval[PL_nexttoke];
3285 PL_lex_state = PL_lex_defer;
3286 PL_expect = PL_lex_expect;
3287 PL_lex_defer = LEX_NORMAL;
3291 /* FIXME - can these be merged? */
3292 return(PL_nexttoke[PL_lasttoke].next_type);
3294 return REPORT(PL_nexttype[PL_nexttoke]);
3297 /* interpolated case modifiers like \L \U, including \Q and \E.
3298 when we get here, PL_bufptr is at the \
3300 case LEX_INTERPCASEMOD:
3302 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3303 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3305 /* handle \E or end of string */
3306 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3308 if (PL_lex_casemods) {
3309 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3310 PL_lex_casestack[PL_lex_casemods] = '\0';
3312 if (PL_bufptr != PL_bufend
3313 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3315 PL_lex_state = LEX_INTERPCONCAT;
3318 PL_thistoken = newSVpvs("\\E");
3324 while (PL_bufptr != PL_bufend &&
3325 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3327 PL_thiswhite = newSVpvs("");
3328 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3332 if (PL_bufptr != PL_bufend)
3335 PL_lex_state = LEX_INTERPCONCAT;
3339 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3340 "### Saw case modifier\n"); });
3342 if (s[1] == '\\' && s[2] == 'E') {
3345 PL_thiswhite = newSVpvs("");
3346 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3349 PL_lex_state = LEX_INTERPCONCAT;
3354 if (!PL_madskills) /* when just compiling don't need correct */
3355 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3356 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3357 if ((*s == 'L' || *s == 'U') &&
3358 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3359 PL_lex_casestack[--PL_lex_casemods] = '\0';
3362 if (PL_lex_casemods > 10)
3363 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3364 PL_lex_casestack[PL_lex_casemods++] = *s;
3365 PL_lex_casestack[PL_lex_casemods] = '\0';
3366 PL_lex_state = LEX_INTERPCONCAT;
3367 start_force(PL_curforce);
3368 NEXTVAL_NEXTTOKE.ival = 0;
3370 start_force(PL_curforce);
3372 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3374 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3376 NEXTVAL_NEXTTOKE.ival = OP_LC;
3378 NEXTVAL_NEXTTOKE.ival = OP_UC;
3380 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3382 Perl_croak(aTHX_ "panic: yylex");
3384 SV* const tmpsv = newSVpvs("");
3385 Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3391 if (PL_lex_starts) {
3397 sv_free(PL_thistoken);
3398 PL_thistoken = newSVpvs("");
3401 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3402 if (PL_lex_casemods == 1 && PL_lex_inpat)
3411 case LEX_INTERPPUSH:
3412 return REPORT(sublex_push());
3414 case LEX_INTERPSTART:
3415 if (PL_bufptr == PL_bufend)
3416 return REPORT(sublex_done());
3417 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3418 "### Interpolated variable\n"); });
3420 PL_lex_dojoin = (*PL_bufptr == '@');
3421 PL_lex_state = LEX_INTERPNORMAL;
3422 if (PL_lex_dojoin) {
3423 start_force(PL_curforce);
3424 NEXTVAL_NEXTTOKE.ival = 0;
3426 start_force(PL_curforce);
3427 force_ident("\"", '$');
3428 start_force(PL_curforce);
3429 NEXTVAL_NEXTTOKE.ival = 0;
3431 start_force(PL_curforce);
3432 NEXTVAL_NEXTTOKE.ival = 0;
3434 start_force(PL_curforce);
3435 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3438 if (PL_lex_starts++) {
3443 sv_free(PL_thistoken);
3444 PL_thistoken = newSVpvs("");
3447 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3448 if (!PL_lex_casemods && PL_lex_inpat)
3455 case LEX_INTERPENDMAYBE:
3456 if (intuit_more(PL_bufptr)) {
3457 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3463 if (PL_lex_dojoin) {
3464 PL_lex_dojoin = FALSE;
3465 PL_lex_state = LEX_INTERPCONCAT;
3469 sv_free(PL_thistoken);
3470 PL_thistoken = newSVpvs("");
3475 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3476 && SvEVALED(PL_lex_repl))
3478 if (PL_bufptr != PL_bufend)
3479 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3483 case LEX_INTERPCONCAT:
3485 if (PL_lex_brackets)
3486 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3488 if (PL_bufptr == PL_bufend)
3489 return REPORT(sublex_done());
3491 if (SvIVX(PL_linestr) == '\'') {
3492 SV *sv = newSVsv(PL_linestr);
3495 else if ( PL_hints & HINT_NEW_RE )
3496 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3497 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3501 s = scan_const(PL_bufptr);
3503 PL_lex_state = LEX_INTERPCASEMOD;
3505 PL_lex_state = LEX_INTERPSTART;
3508 if (s != PL_bufptr) {
3509 start_force(PL_curforce);
3511 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3513 NEXTVAL_NEXTTOKE = yylval;
3516 if (PL_lex_starts++) {
3520 sv_free(PL_thistoken);
3521 PL_thistoken = newSVpvs("");
3524 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3525 if (!PL_lex_casemods && PL_lex_inpat)
3538 PL_lex_state = LEX_NORMAL;
3539 s = scan_formline(PL_bufptr);
3540 if (!PL_lex_formbrack)
3546 PL_oldoldbufptr = PL_oldbufptr;
3552 sv_free(PL_thistoken);
3555 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3559 if (isIDFIRST_lazy_if(s,UTF))
3561 Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3564 goto fake_eof; /* emulate EOF on ^D or ^Z */
3573 if (PL_lex_brackets) {
3574 yyerror((const char *)
3576 ? "Format not terminated"
3577 : "Missing right curly or square bracket"));
3579 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3580 "### Tokener got EOF\n");
3584 if (s++ < PL_bufend)
3585 goto retry; /* ignore stray nulls */
3588 if (!PL_in_eval && !PL_preambled) {
3589 PL_preambled = TRUE;
3594 sv_setpv(PL_linestr,incl_perldb());
3595 if (SvCUR(PL_linestr))
3596 sv_catpvs(PL_linestr,";");
3598 while(AvFILLp(PL_preambleav) >= 0) {
3599 SV *tmpsv = av_shift(PL_preambleav);
3600 sv_catsv(PL_linestr, tmpsv);
3601 sv_catpvs(PL_linestr, ";");
3604 sv_free((SV*)PL_preambleav);
3605 PL_preambleav = NULL;
3607 if (PL_minus_n || PL_minus_p) {
3608 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3610 sv_catpvs(PL_linestr,"chomp;");
3613 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3614 || *PL_splitstr == '"')
3615 && strchr(PL_splitstr + 1, *PL_splitstr))
3616 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3618 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3619 bytes can be used as quoting characters. :-) */
3620 const char *splits = PL_splitstr;
3621 sv_catpvs(PL_linestr, "our @F=split(q\0");
3624 if (*splits == '\\')
3625 sv_catpvn(PL_linestr, splits, 1);
3626 sv_catpvn(PL_linestr, splits, 1);
3627 } while (*splits++);
3628 /* This loop will embed the trailing NUL of
3629 PL_linestr as the last thing it does before
3631 sv_catpvs(PL_linestr, ");");
3635 sv_catpvs(PL_linestr,"our @F=split(' ');");
3639 sv_catpvs(PL_linestr,"use feature ':5.10';");
3640 sv_catpvs(PL_linestr, "\n");
3641 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3642 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3643 PL_last_lop = PL_last_uni = NULL;
3644 if (PERLDB_LINE && PL_curstash != PL_debstash)
3645 update_debugger_info(PL_linestr, NULL, 0);
3649 bof = PL_rsfp ? TRUE : FALSE;
3650 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3653 PL_realtokenstart = -1;
3656 if (PL_preprocess && !PL_in_eval)
3657 (void)PerlProc_pclose(PL_rsfp);
3658 else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3659 PerlIO_clearerr(PL_rsfp);
3661 (void)PerlIO_close(PL_rsfp);
3663 PL_doextract = FALSE;
3665 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3670 sv_setpv(PL_linestr,
3673 ? ";}continue{print;}" : ";}"));
3674 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3675 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3676 PL_last_lop = PL_last_uni = NULL;
3677 PL_minus_n = PL_minus_p = 0;
3680 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3681 PL_last_lop = PL_last_uni = NULL;
3682 sv_setpvn(PL_linestr,"",0);
3683 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3685 /* If it looks like the start of a BOM or raw UTF-16,
3686 * check if it in fact is. */
3692 #ifdef PERLIO_IS_STDIO
3693 # ifdef __GNU_LIBRARY__
3694 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3695 # define FTELL_FOR_PIPE_IS_BROKEN
3699 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3700 # define FTELL_FOR_PIPE_IS_BROKEN
3705 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3706 /* This loses the possibility to detect the bof
3707 * situation on perl -P when the libc5 is being used.
3708 * Workaround? Maybe attach some extra state to PL_rsfp?
3711 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3713 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3716 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3717 s = swallow_bom((U8*)s);
3721 /* Incest with pod. */
3724 sv_catsv(PL_thiswhite, PL_linestr);
3726 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3727 sv_setpvn(PL_linestr, "", 0);
3728 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3729 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3730 PL_last_lop = PL_last_uni = NULL;
3731 PL_doextract = FALSE;
3735 } while (PL_doextract);
3736 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3737 if (PERLDB_LINE && PL_curstash != PL_debstash)
3738 update_debugger_info(PL_linestr, NULL, 0);
3739 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3740 PL_last_lop = PL_last_uni = NULL;
3741 if (CopLINE(PL_curcop) == 1) {
3742 while (s < PL_bufend && isSPACE(*s))
3744 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3748 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3752 if (*s == '#' && *(s+1) == '!')
3754 #ifdef ALTERNATE_SHEBANG
3756 static char const as[] = ALTERNATE_SHEBANG;
3757 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3758 d = s + (sizeof(as) - 1);
3760 #endif /* ALTERNATE_SHEBANG */
3769 while (*d && !isSPACE(*d))
3773 #ifdef ARG_ZERO_IS_SCRIPT
3774 if (ipathend > ipath) {
3776 * HP-UX (at least) sets argv[0] to the script name,
3777 * which makes $^X incorrect. And Digital UNIX and Linux,
3778 * at least, set argv[0] to the basename of the Perl
3779 * interpreter. So, having found "#!", we'll set it right.
3781 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3783 assert(SvPOK(x) || SvGMAGICAL(x));
3784 if (sv_eq(x, CopFILESV(PL_curcop))) {
3785 sv_setpvn(x, ipath, ipathend - ipath);
3791 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3792 const char * const lstart = SvPV_const(x,llen);
3794 bstart += blen - llen;
3795 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3796 sv_setpvn(x, ipath, ipathend - ipath);
3801 TAINT_NOT; /* $^X is always tainted, but that's OK */
3803 #endif /* ARG_ZERO_IS_SCRIPT */
3808 d = instr(s,"perl -");
3810 d = instr(s,"perl");
3812 /* avoid getting into infinite loops when shebang
3813 * line contains "Perl" rather than "perl" */
3815 for (d = ipathend-4; d >= ipath; --d) {
3816 if ((*d == 'p' || *d == 'P')
3817 && !ibcmp(d, "perl", 4))
3827 #ifdef ALTERNATE_SHEBANG
3829 * If the ALTERNATE_SHEBANG on this system starts with a
3830 * character that can be part of a Perl expression, then if
3831 * we see it but not "perl", we're probably looking at the
3832 * start of Perl code, not a request to hand off to some
3833 * other interpreter. Similarly, if "perl" is there, but
3834 * not in the first 'word' of the line, we assume the line
3835 * contains the start of the Perl program.
3837 if (d && *s != '#') {
3838 const char *c = ipath;
3839 while (*c && !strchr("; \t\r\n\f\v#", *c))
3842 d = NULL; /* "perl" not in first word; ignore */
3844 *s = '#'; /* Don't try to parse shebang line */
3846 #endif /* ALTERNATE_SHEBANG */
3847 #ifndef MACOS_TRADITIONAL
3852 !instr(s,"indir") &&
3853 instr(PL_origargv[0],"perl"))
3860 while (s < PL_bufend && isSPACE(*s))
3862 if (s < PL_bufend) {
3863 Newxz(newargv,PL_origargc+3,char*);
3865 while (s < PL_bufend && !isSPACE(*s))
3868 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3871 newargv = PL_origargv;
3874 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3876 Perl_croak(aTHX_ "Can't exec %s", ipath);
3880 while (*d && !isSPACE(*d))
3882 while (SPACE_OR_TAB(*d))
3886 const bool switches_done = PL_doswitches;
3887 const U32 oldpdb = PL_perldb;
3888 const bool oldn = PL_minus_n;
3889 const bool oldp = PL_minus_p;
3892 if (*d == 'M' || *d == 'm' || *d == 'C') {
3893 const char * const m = d;
3894 while (*d && !isSPACE(*d))
3896 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3899 d = moreswitches(d);
3901 if (PL_doswitches && !switches_done) {
3902 int argc = PL_origargc;
3903 char **argv = PL_origargv;
3906 } while (argc && argv[0][0] == '-' && argv[0][1]);
3907 init_argv_symbols(argc,argv);
3909 if ((PERLDB_LINE && !oldpdb) ||
3910 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3911 /* if we have already added "LINE: while (<>) {",
3912 we must not do it again */
3914 sv_setpvn(PL_linestr, "", 0);
3915 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3916 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3917 PL_last_lop = PL_last_uni = NULL;
3918 PL_preambled = FALSE;
3920 (void)gv_fetchfile(PL_origfilename);
3927 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3929 PL_lex_state = LEX_FORMLINE;
3934 #ifdef PERL_STRICT_CR
3935 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3937 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3939 case ' ': case '\t': case '\f': case 013:
3940 #ifdef MACOS_TRADITIONAL
3944 PL_realtokenstart = -1;
3946 PL_thiswhite = newSVpvs("");
3947 sv_catpvn(PL_thiswhite, s, 1);
3954 PL_realtokenstart = -1;
3958 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3959 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3960 /* handle eval qq[#line 1 "foo"\n ...] */
3961 CopLINE_dec(PL_curcop);
3964 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3966 if (!PL_in_eval || PL_rsfp)
3971 while (d < PL_bufend && *d != '\n')
3975 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3976 Perl_croak(aTHX_ "panic: input overflow");
3979 PL_thiswhite = newSVpvn(s, d - s);
3984 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3986 PL_lex_state = LEX_FORMLINE;
3992 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3993 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3996 TOKEN(PEG); /* make sure any #! line is accessible */
4001 /* if (PL_madskills && PL_lex_formbrack) { */
4003 while (d < PL_bufend && *d != '\n')
4007 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4008 Perl_croak(aTHX_ "panic: input overflow");
4009 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4011 PL_thiswhite = newSVpvs("");
4012 if (CopLINE(PL_curcop) == 1) {
4013 sv_setpvn(PL_thiswhite, "", 0);
4016 sv_catpvn(PL_thiswhite, s, d - s);
4030 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4038 while (s < PL_bufend && SPACE_OR_TAB(*s))
4041 if (strnEQ(s,"=>",2)) {
4042 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4043 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4044 OPERATOR('-'); /* unary minus */
4046 PL_last_uni = PL_oldbufptr;
4048 case 'r': ftst = OP_FTEREAD; break;
4049 case 'w': ftst = OP_FTEWRITE; break;
4050 case 'x': ftst = OP_FTEEXEC; break;
4051 case 'o': ftst = OP_FTEOWNED; break;
4052 case 'R': ftst = OP_FTRREAD; break;
4053 case 'W': ftst = OP_FTRWRITE; break;
4054 case 'X': ftst = OP_FTREXEC; break;
4055 case 'O': ftst = OP_FTROWNED; break;
4056 case 'e': ftst = OP_FTIS; break;
4057 case 'z': ftst = OP_FTZERO; break;
4058 case 's': ftst = OP_FTSIZE; break;
4059 case 'f': ftst = OP_FTFILE; break;
4060 case 'd': ftst = OP_FTDIR; break;
4061 case 'l': ftst = OP_FTLINK; break;
4062 case 'p': ftst = OP_FTPIPE; break;
4063 case 'S': ftst = OP_FTSOCK; break;
4064 case 'u': ftst = OP_FTSUID; break;
4065 case 'g': ftst = OP_FTSGID; break;
4066 case 'k': ftst = OP_FTSVTX; break;
4067 case 'b': ftst = OP_FTBLK; break;
4068 case 'c': ftst = OP_FTCHR; break;
4069 case 't': ftst = OP_FTTTY; break;
4070 case 'T': ftst = OP_FTTEXT; break;
4071 case 'B': ftst = OP_FTBINARY; break;
4072 case 'M': case 'A': case 'C':
4073 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4075 case 'M': ftst = OP_FTMTIME; break;
4076 case 'A': ftst = OP_FTATIME; break;
4077 case 'C': ftst = OP_FTCTIME; break;
4085 PL_last_lop_op = (OPCODE)ftst;
4086 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4087 "### Saw file test %c\n", (int)tmp);
4092 /* Assume it was a minus followed by a one-letter named
4093 * subroutine call (or a -bareword), then. */
4094 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4095 "### '-%c' looked like a file test but was not\n",
4102 const char tmp = *s++;
4105 if (PL_expect == XOPERATOR)
4110 else if (*s == '>') {
4113 if (isIDFIRST_lazy_if(s,UTF)) {
4114 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4122 if (PL_expect == XOPERATOR)
4125 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4127 OPERATOR('-'); /* unary minus */
4133 const char tmp = *s++;
4136 if (PL_expect == XOPERATOR)
4141 if (PL_expect == XOPERATOR)
4144 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4151 if (PL_expect != XOPERATOR) {
4152 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4153 PL_expect = XOPERATOR;
4154 force_ident(PL_tokenbuf, '*');
4167 if (PL_expect == XOPERATOR) {
4171 PL_tokenbuf[0] = '%';
4172 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4173 sizeof PL_tokenbuf - 1, FALSE);
4174 if (!PL_tokenbuf[1]) {
4177 PL_pending_ident = '%';
4188 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4195 const char tmp = *s++;
4201 goto just_a_word_zero_gv;
4204 switch (PL_expect) {
4210 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4212 PL_bufptr = s; /* update in case we back off */
4218 PL_expect = XTERMBLOCK;
4221 stuffstart = s - SvPVX(PL_linestr) - 1;
4225 while (isIDFIRST_lazy_if(s,UTF)) {
4228 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4229 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4230 if (tmp < 0) tmp = -tmp;
4245 sv = newSVpvn(s, len);
4247 d = scan_str(d,TRUE,TRUE);
4249 /* MUST advance bufptr here to avoid bogus
4250 "at end of line" context messages from yyerror().
4252 PL_bufptr = s + len;
4253 yyerror("Unterminated attribute parameter in attribute list");
4257 return REPORT(0); /* EOF indicator */
4261 sv_catsv(sv, PL_lex_stuff);
4262 attrs = append_elem(OP_LIST, attrs,
4263 newSVOP(OP_CONST, 0, sv));
4264 SvREFCNT_dec(PL_lex_stuff);
4265 PL_lex_stuff = NULL;
4268 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4270 if (PL_in_my == KEY_our) {
4272 GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4274 /* skip to avoid loading attributes.pm */
4276 deprecate(":unique");
4279 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4282 /* NOTE: any CV attrs applied here need to be part of
4283 the CVf_BUILTIN_ATTRS define in cv.h! */
4284 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4286 CvLVALUE_on(PL_compcv);
4288 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4290 CvLOCKED_on(PL_compcv);
4292 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4294 CvMETHOD_on(PL_compcv);
4296 else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4298 CvASSERTION_on(PL_compcv);
4300 /* After we've set the flags, it could be argued that
4301 we don't need to do the attributes.pm-based setting
4302 process, and shouldn't bother appending recognized
4303 flags. To experiment with that, uncomment the
4304 following "else". (Note that's already been
4305 uncommented. That keeps the above-applied built-in
4306 attributes from being intercepted (and possibly
4307 rejected) by a package's attribute routines, but is
4308 justified by the performance win for the common case
4309 of applying only built-in attributes.) */
4311 attrs = append_elem(OP_LIST, attrs,
4312 newSVOP(OP_CONST, 0,
4316 if (*s == ':' && s[1] != ':')
4319 break; /* require real whitespace or :'s */
4320 /* XXX losing whitespace on sequential attributes here */
4324 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4325 if (*s != ';' && *s != '}' && *s != tmp
4326 && (tmp != '=' || *s != ')')) {
4327 const char q = ((*s == '\'') ? '"' : '\'');
4328 /* If here for an expression, and parsed no attrs, back
4330 if (tmp == '=' && !attrs) {
4334 /* MUST advance bufptr here to avoid bogus "at end of line"
4335 context messages from yyerror().
4338 yyerror( (const char *)
4340 ? Perl_form(aTHX_ "Invalid separator character "
4341 "%c%c%c in attribute list", q, *s, q)
4342 : "Unterminated attribute list" ) );
4350 start_force(PL_curforce);
4351 NEXTVAL_NEXTTOKE.opval = attrs;
4352 CURMAD('_', PL_nextwhite);
4357 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4358 (s - SvPVX(PL_linestr)) - stuffstart);
4366 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4367 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4375 const char tmp = *s++;
4380 const char tmp = *s++;
4388 if (PL_lex_brackets <= 0)
4389 yyerror("Unmatched right square bracket");
4392 if (PL_lex_state == LEX_INTERPNORMAL) {
4393 if (PL_lex_brackets == 0) {
4394 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4395 PL_lex_state = LEX_INTERPEND;
4402 if (PL_lex_brackets > 100) {
4403 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4405 switch (PL_expect) {
4407 if (PL_lex_formbrack) {
4411 if (PL_oldoldbufptr == PL_last_lop)
4412 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4414 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4415 OPERATOR(HASHBRACK);
4417 while (s < PL_bufend && SPACE_OR_TAB(*s))
4420 PL_tokenbuf[0] = '\0';
4421 if (d < PL_bufend && *d == '-') {
4422 PL_tokenbuf[0] = '-';
4424 while (d < PL_bufend && SPACE_OR_TAB(*d))
4427 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4428 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4430 while (d < PL_bufend && SPACE_OR_TAB(*d))
4433 const char minus = (PL_tokenbuf[0] == '-');
4434 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4442 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4447 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4452 if (PL_oldoldbufptr == PL_last_lop)
4453 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4455 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4458 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4460 /* This hack is to get the ${} in the message. */
4462 yyerror("syntax error");
4465 OPERATOR(HASHBRACK);
4467 /* This hack serves to disambiguate a pair of curlies
4468 * as being a block or an anon hash. Normally, expectation
4469 * determines that, but in cases where we're not in a
4470 * position to expect anything in particular (like inside
4471 * eval"") we have to resolve the ambiguity. This code
4472 * covers the case where the first term in the curlies is a
4473 * quoted string. Most other cases need to be explicitly
4474 * disambiguated by prepending a "+" before the opening
4475 * curly in order to force resolution as an anon hash.
4477 * XXX should probably propagate the outer expectation
4478 * into eval"" to rely less on this hack, but that could
4479 * potentially break current behavior of eval"".
4483 if (*s == '\'' || *s == '"' || *s == '`') {
4484 /* common case: get past first string, handling escapes */
4485 for (t++; t < PL_bufend && *t != *s;)
4486 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4490 else if (*s == 'q') {
4493 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4496 /* skip q//-like construct */
4498 char open, close, term;
4501 while (t < PL_bufend && isSPACE(*t))
4503 /* check for q => */
4504 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4505 OPERATOR(HASHBRACK);
4509 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4513 for (t++; t < PL_bufend; t++) {
4514 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4516 else if (*t == open)
4520 for (t++; t < PL_bufend; t++) {
4521 if (*t == '\\' && t+1 < PL_bufend)
4523 else if (*t == close && --brackets <= 0)
4525 else if (*t == open)
4532 /* skip plain q word */
4533 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4536 else if (isALNUM_lazy_if(t,UTF)) {
4538 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4541 while (t < PL_bufend && isSPACE(*t))
4543 /* if comma follows first term, call it an anon hash */
4544 /* XXX it could be a comma expression with loop modifiers */
4545 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4546 || (*t == '=' && t[1] == '>')))
4547 OPERATOR(HASHBRACK);
4548 if (PL_expect == XREF)
4551 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4557 yylval.ival = CopLINE(PL_curcop);
4558 if (isSPACE(*s) || *s == '#')
4559 PL_copline = NOLINE; /* invalidate current command line number */
4564 if (PL_lex_brackets <= 0)
4565 yyerror("Unmatched right curly bracket");
4567 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4568 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4569 PL_lex_formbrack = 0;
4570 if (PL_lex_state == LEX_INTERPNORMAL) {
4571 if (PL_lex_brackets == 0) {
4572 if (PL_expect & XFAKEBRACK) {
4573 PL_expect &= XENUMMASK;
4574 PL_lex_state = LEX_INTERPEND;
4579 PL_thiswhite = newSVpvs("");
4580 sv_catpvn(PL_thiswhite,"}",1);
4583 return yylex(); /* ignore fake brackets */
4585 if (*s == '-' && s[1] == '>')
4586 PL_lex_state = LEX_INTERPENDMAYBE;
4587 else if (*s != '[' && *s != '{')
4588 PL_lex_state = LEX_INTERPEND;
4591 if (PL_expect & XFAKEBRACK) {
4592 PL_expect &= XENUMMASK;
4594 return yylex(); /* ignore fake brackets */
4596 start_force(PL_curforce);
4598 curmad('X', newSVpvn(s-1,1));
4599 CURMAD('_', PL_thiswhite);
4604 PL_thistoken = newSVpvs("");
4612 if (PL_expect == XOPERATOR) {
4613 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4614 && isIDFIRST_lazy_if(s,UTF))
4616 CopLINE_dec(PL_curcop);
4617 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4618 CopLINE_inc(PL_curcop);
4623 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4625 PL_expect = XOPERATOR;
4626 force_ident(PL_tokenbuf, '&');
4630 yylval.ival = (OPpENTERSUB_AMPER<<8);
4642 const char tmp = *s++;
4649 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4650 && strchr("+-*/%.^&|<",tmp))
4651 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4652 "Reversed %c= operator",(int)tmp);
4654 if (PL_expect == XSTATE && isALPHA(tmp) &&
4655 (s == PL_linestart+1 || s[-2] == '\n') )
4657 if (PL_in_eval && !PL_rsfp) {
4662 if (strnEQ(s,"=cut",4)) {
4678 PL_thiswhite = newSVpvs("");
4679 sv_catpvn(PL_thiswhite, PL_linestart,
4680 PL_bufend - PL_linestart);
4684 PL_doextract = TRUE;
4688 if (PL_lex_brackets < PL_lex_formbrack) {
4690 #ifdef PERL_STRICT_CR
4691 while (SPACE_OR_TAB(*t))
4693 while (SPACE_OR_TAB(*t) || *t == '\r')
4696 if (*t == '\n' || *t == '#') {
4707 const char tmp = *s++;
4709 /* was this !=~ where !~ was meant?
4710 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4712 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4713 const char *t = s+1;
4715 while (t < PL_bufend && isSPACE(*t))
4718 if (*t == '/' || *t == '?' ||
4719 ((*t == 'm' || *t == 's' || *t == 'y')
4720 && !isALNUM(t[1])) ||
4721 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4722 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4723 "!=~ should be !~");
4733 if (PL_expect != XOPERATOR) {
4734 if (s[1] != '<' && !strchr(s,'>'))
4737 s = scan_heredoc(s);
4739 s = scan_inputsymbol(s);
4740 TERM(sublex_start());
4746 SHop(OP_LEFT_SHIFT);
4760 const char tmp = *s++;
4762 SHop(OP_RIGHT_SHIFT);
4763 else if (tmp == '=')
4772 if (PL_expect == XOPERATOR) {
4773 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4775 deprecate_old(commaless_variable_list);
4776 return REPORT(','); /* grandfather non-comma-format format */
4780 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4781 PL_tokenbuf[0] = '@';
4782 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4783 sizeof PL_tokenbuf - 1, FALSE);
4784 if (PL_expect == XOPERATOR)
4785 no_op("Array length", s);
4786 if (!PL_tokenbuf[1])
4788 PL_expect = XOPERATOR;
4789 PL_pending_ident = '#';
4793 PL_tokenbuf[0] = '$';
4794 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4795 sizeof PL_tokenbuf - 1, FALSE);
4796 if (PL_expect == XOPERATOR)
4798 if (!PL_tokenbuf[1]) {
4800 yyerror("Final $ should be \\$ or $name");
4804 /* This kludge not intended to be bulletproof. */
4805 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4806 yylval.opval = newSVOP(OP_CONST, 0,
4807 newSViv(CopARYBASE_get(&PL_compiling)));
4808 yylval.opval->op_private = OPpCONST_ARYBASE;
4814 const char tmp = *s;
4815 if (PL_lex_state == LEX_NORMAL)
4818 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4819 && intuit_more(s)) {
4821 PL_tokenbuf[0] = '@';
4822 if (ckWARN(WARN_SYNTAX)) {
4825 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4828 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4829 while (t < PL_bufend && *t != ']')
4831 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4832 "Multidimensional syntax %.*s not supported",
4833 (int)((t - PL_bufptr) + 1), PL_bufptr);
4837 else if (*s == '{') {
4839 PL_tokenbuf[0] = '%';
4840 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4841 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4843 char tmpbuf[sizeof PL_tokenbuf];
4846 } while (isSPACE(*t));
4847 if (isIDFIRST_lazy_if(t,UTF)) {
4849 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4853 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4854 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4855 "You need to quote \"%s\"",
4862 PL_expect = XOPERATOR;
4863 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4864 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4865 if (!islop || PL_last_lop_op == OP_GREPSTART)
4866 PL_expect = XOPERATOR;
4867 else if (strchr("$@\"'`q", *s))
4868 PL_expect = XTERM; /* e.g. print $fh "foo" */
4869 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4870 PL_expect = XTERM; /* e.g. print $fh &sub */
4871 else if (isIDFIRST_lazy_if(s,UTF)) {
4872 char tmpbuf[sizeof PL_tokenbuf];
4874 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4875 if ((t2 = keyword(tmpbuf, len, 0))) {
4876 /* binary operators exclude handle interpretations */
4888 PL_expect = XTERM; /* e.g. print $fh length() */
4893 PL_expect = XTERM; /* e.g. print $fh subr() */
4896 else if (isDIGIT(*s))
4897 PL_expect = XTERM; /* e.g. print $fh 3 */
4898 else if (*s == '.' && isDIGIT(s[1]))
4899 PL_expect = XTERM; /* e.g. print $fh .3 */
4900 else if ((*s == '?' || *s == '-' || *s == '+')
4901 && !isSPACE(s[1]) && s[1] != '=')
4902 PL_expect = XTERM; /* e.g. print $fh -1 */
4903 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4905 PL_expect = XTERM; /* e.g. print $fh /.../
4906 XXX except DORDOR operator
4908 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4910 PL_expect = XTERM; /* print $fh <<"EOF" */
4913 PL_pending_ident = '$';
4917 if (PL_expect == XOPERATOR)
4919 PL_tokenbuf[0] = '@';
4920 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4921 if (!PL_tokenbuf[1]) {
4924 if (PL_lex_state == LEX_NORMAL)
4926 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4928 PL_tokenbuf[0] = '%';
4930 /* Warn about @ where they meant $. */
4931 if (*s == '[' || *s == '{') {
4932 if (ckWARN(WARN_SYNTAX)) {
4933 const char *t = s + 1;
4934 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4936 if (*t == '}' || *t == ']') {
4938 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4939 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4940 "Scalar value %.*s better written as $%.*s",
4941 (int)(t-PL_bufptr), PL_bufptr,
4942 (int)(t-PL_bufptr-1), PL_bufptr+1);
4947 PL_pending_ident = '@';
4950 case '/': /* may be division, defined-or, or pattern */
4951 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4955 case '?': /* may either be conditional or pattern */
4956 if(PL_expect == XOPERATOR) {
4964 /* A // operator. */
4974 /* Disable warning on "study /blah/" */
4975 if (PL_oldoldbufptr == PL_last_uni
4976 && (*PL_last_uni != 's' || s - PL_last_uni < 5
4977 || memNE(PL_last_uni, "study", 5)
4978 || isALNUM_lazy_if(PL_last_uni+5,UTF)
4981 s = scan_pat(s,OP_MATCH);
4982 TERM(sublex_start());
4986 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4987 #ifdef PERL_STRICT_CR
4990 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4992 && (s == PL_linestart || s[-1] == '\n') )
4994 PL_lex_formbrack = 0;
4998 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
5004 yylval.ival = OPf_SPECIAL;
5010 if (PL_expect != XOPERATOR)
5015 case '0': case '1': case '2': case '3': case '4':
5016 case '5': case '6': case '7': case '8': case '9':
5017 s = scan_num(s, &yylval);
5018 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
5019 if (PL_expect == XOPERATOR)
5024 s = scan_str(s,!!PL_madskills,FALSE);
5025 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5026 if (PL_expect == XOPERATOR) {
5027 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5029 deprecate_old(commaless_variable_list);
5030 return REPORT(','); /* grandfather non-comma-format format */
5037 yylval.ival = OP_CONST;
5038 TERM(sublex_start());
5041 s = scan_str(s,!!PL_madskills,FALSE);
5042 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5043 if (PL_expect == XOPERATOR) {
5044 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5046 deprecate_old(commaless_variable_list);
5047 return REPORT(','); /* grandfather non-comma-format format */
5054 yylval.ival = OP_CONST;
5055 /* FIXME. I think that this can be const if char *d is replaced by
5056 more localised variables. */
5057 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5058 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5059 yylval.ival = OP_STRINGIFY;
5063 TERM(sublex_start());
5066 s = scan_str(s,!!PL_madskills,FALSE);
5067 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5068 if (PL_expect == XOPERATOR)
5069 no_op("Backticks",s);
5072 readpipe_override();
5073 TERM(sublex_start());
5077 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5078 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5080 if (PL_expect == XOPERATOR)
5081 no_op("Backslash",s);
5085 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5086 char *start = s + 2;
5087 while (isDIGIT(*start) || *start == '_')
5089 if (*start == '.' && isDIGIT(start[1])) {
5090 s = scan_num(s, &yylval);
5093 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5094 else if (!isALPHA(*start) && (PL_expect == XTERM
5095 || PL_expect == XREF || PL_expect == XSTATE
5096 || PL_expect == XTERMORDORDOR)) {
5097 /* XXX Use gv_fetchpvn rather than stomping on a const string */
5098 const char c = *start;
5101 gv = gv_fetchpv(s, 0, SVt_PVCV);
5104 s = scan_num(s, &yylval);
5111 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5153 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5155 /* Some keywords can be followed by any delimiter, including ':' */
5156 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5157 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5158 (PL_tokenbuf[0] == 'q' &&
5159 strchr("qwxr", PL_tokenbuf[1])))));
5161 /* x::* is just a word, unless x is "CORE" */
5162 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5166 while (d < PL_bufend && isSPACE(*d))
5167 d++; /* no comments skipped here, or s### is misparsed */
5169 /* Is this a label? */
5170 if (!tmp && PL_expect == XSTATE
5171 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5173 yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5178 /* Check for keywords */
5179 tmp = keyword(PL_tokenbuf, len, 0);
5181 /* Is this a word before a => operator? */
5182 if (*d == '=' && d[1] == '>') {
5185 = (OP*)newSVOP(OP_CONST, 0,
5186 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5187 yylval.opval->op_private = OPpCONST_BARE;
5191 if (tmp < 0) { /* second-class keyword? */
5192 GV *ogv = NULL; /* override (winner) */
5193 GV *hgv = NULL; /* hidden (loser) */
5194 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5196 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5199 if (GvIMPORTED_CV(gv))
5201 else if (! CvMETHOD(cv))
5205 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5206 (gv = *gvp) && isGV_with_GP(gv) &&
5207 GvCVu(gv) && GvIMPORTED_CV(gv))
5214 tmp = 0; /* overridden by import or by GLOBAL */
5217 && -tmp==KEY_lock /* XXX generalizable kludge */
5220 tmp = 0; /* any sub overrides "weak" keyword */
5222 else { /* no override */
5224 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5225 Perl_warner(aTHX_ packWARN(WARN_MISC),
5226 "dump() better written as CORE::dump()");
5230 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5231 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
5232 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5233 "Ambiguous call resolved as CORE::%s(), %s",
5234 GvENAME(hgv), "qualify as such or use &");
5241 default: /* not a keyword */
5242 /* Trade off - by using this evil construction we can pull the
5243 variable gv into the block labelled keylookup. If not, then
5244 we have to give it function scope so that the goto from the
5245 earlier ':' case doesn't bypass the initialisation. */
5247 just_a_word_zero_gv:
5255 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5258 SV *nextPL_nextwhite = 0;
5262 /* Get the rest if it looks like a package qualifier */
5264 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5266 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5269 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5270 *s == '\'' ? "'" : "::");
5275 if (PL_expect == XOPERATOR) {
5276 if (PL_bufptr == PL_linestart) {
5277 CopLINE_dec(PL_curcop);
5278 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5279 CopLINE_inc(PL_curcop);
5282 no_op("Bareword",s);
5285 /* Look for a subroutine with this name in current package,
5286 unless name is "Foo::", in which case Foo is a bearword
5287 (and a package name). */
5289 if (len > 2 && !PL_madskills &&
5290 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5292 if (ckWARN(WARN_BAREWORD)
5293 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5294 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5295 "Bareword \"%s\" refers to nonexistent package",
5298 PL_tokenbuf[len] = '\0';
5304 /* Mustn't actually add anything to a symbol table.
5305 But also don't want to "initialise" any placeholder
5306 constants that might already be there into full
5307 blown PVGVs with attached PVCV. */
5308 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5309 GV_NOADD_NOINIT, SVt_PVCV);
5314 /* if we saw a global override before, get the right name */
5317 sv = newSVpvs("CORE::GLOBAL::");
5318 sv_catpv(sv,PL_tokenbuf);
5321 /* If len is 0, newSVpv does strlen(), which is correct.
5322 If len is non-zero, then it will be the true length,
5323 and so the scalar will be created correctly. */
5324 sv = newSVpv(PL_tokenbuf,len);
5327 if (PL_madskills && !PL_thistoken) {
5328 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5329 PL_thistoken = newSVpv(start,s - start);
5330 PL_realtokenstart = s - SvPVX(PL_linestr);
5334 /* Presume this is going to be a bareword of some sort. */
5337 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5338 yylval.opval->op_private = OPpCONST_BARE;
5339 /* UTF-8 package name? */
5340 if (UTF && !IN_BYTES &&
5341 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5344 /* And if "Foo::", then that's what it certainly is. */
5349 /* Do the explicit type check so that we don't need to force
5350 the initialisation of the symbol table to have a real GV.
5351 Beware - gv may not really be a PVGV, cv may not really be
5352 a PVCV, (because of the space optimisations that gv_init
5353 understands) But they're true if for this symbol there is
5354 respectively a typeglob and a subroutine.
5356 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5357 /* Real typeglob, so get the real subroutine: */
5359 /* A proxy for a subroutine in this package? */
5360 : SvOK(gv) ? (CV *) gv : NULL)
5363 /* See if it's the indirect object for a list operator. */
5365 if (PL_oldoldbufptr &&
5366 PL_oldoldbufptr < PL_bufptr &&
5367 (PL_oldoldbufptr == PL_last_lop
5368 || PL_oldoldbufptr == PL_last_uni) &&
5369 /* NO SKIPSPACE BEFORE HERE! */
5370 (PL_expect == XREF ||
5371 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5373 bool immediate_paren = *s == '(';
5375 /* (Now we can afford to cross potential line boundary.) */
5376 s = SKIPSPACE2(s,nextPL_nextwhite);
5378 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5381 /* Two barewords in a row may indicate method call. */
5383 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5384 (tmp = intuit_method(s, gv, cv)))
5387 /* If not a declared subroutine, it's an indirect object. */
5388 /* (But it's an indir obj regardless for sort.) */
5389 /* Also, if "_" follows a filetest operator, it's a bareword */
5392 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5394 (PL_last_lop_op != OP_MAPSTART &&
5395 PL_last_lop_op != OP_GREPSTART))))
5396 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5397 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5400 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5405 PL_expect = XOPERATOR;
5408 s = SKIPSPACE2(s,nextPL_nextwhite);
5409 PL_nextwhite = nextPL_nextwhite;
5414 /* Is this a word before a => operator? */
5415 if (*s == '=' && s[1] == '>' && !pkgname) {
5417 sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5418 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5419 SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5423 /* If followed by a paren, it's certainly a subroutine. */
5428 while (SPACE_OR_TAB(*d))
5430 if (*d == ')' && (sv = gv_const_sv(gv))) {
5434 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5435 sv_catpvn(PL_thistoken, par, s - par);
5437 sv_free(PL_nextwhite);
5448 PL_nextwhite = PL_thiswhite;
5451 start_force(PL_curforce);
5453 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5454 PL_expect = XOPERATOR;
5457 PL_nextwhite = nextPL_nextwhite;
5458 curmad('X', PL_thistoken);
5459 PL_thistoken = newSVpvs("");
5467 /* If followed by var or block, call it a method (unless sub) */
5469 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5470 PL_last_lop = PL_oldbufptr;
5471 PL_last_lop_op = OP_METHOD;
5475 /* If followed by a bareword, see if it looks like indir obj. */
5478 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5479 && (tmp = intuit_method(s, gv, cv)))
5482 /* Not a method, so call it a subroutine (if defined) */
5485 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5486 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5487 "Ambiguous use of -%s resolved as -&%s()",
5488 PL_tokenbuf, PL_tokenbuf);
5489 /* Check for a constant sub */
5490 if ((sv = gv_const_sv(gv)) && !PL_madskills) {
5492 SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5493 ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5494 yylval.opval->op_private = 0;
5498 /* Resolve to GV now. */
5499 if (SvTYPE(gv) != SVt_PVGV) {
5500 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5501 assert (SvTYPE(gv) == SVt_PVGV);
5502 /* cv must have been some sort of placeholder, so
5503 now needs replacing with a real code reference. */
5507 op_free(yylval.opval);
5508 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5509 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5510 PL_last_lop = PL_oldbufptr;
5511 PL_last_lop_op = OP_ENTERSUB;
5512 /* Is there a prototype? */
5520 const char *proto = SvPV_const((SV*)cv, protolen);
5523 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5525 while (*proto == ';')
5527 if (*proto == '&' && *s == '{') {
5528 sv_setpv(PL_subname,
5531 "__ANON__" : "__ANON__::__ANON__"));
5538 PL_nextwhite = PL_thiswhite;
5541 start_force(PL_curforce);
5542 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5545 PL_nextwhite = nextPL_nextwhite;
5546 curmad('X', PL_thistoken);
5547 PL_thistoken = newSVpvs("");
5554 /* Guess harder when madskills require "best effort". */
5555 if (PL_madskills && (!gv || !GvCVu(gv))) {
5556 int probable_sub = 0;
5557 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5559 else if (isALPHA(*s)) {
5563 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5564 if (!keyword(tmpbuf, tmplen, 0))
5567 while (d < PL_bufend && isSPACE(*d))
5569 if (*d == '=' && d[1] == '>')
5574 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5575 op_free(yylval.opval);
5576 yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5577 yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5578 PL_last_lop = PL_oldbufptr;
5579 PL_last_lop_op = OP_ENTERSUB;
5580 PL_nextwhite = PL_thiswhite;
5582 start_force(PL_curforce);
5583 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5585 PL_nextwhite = nextPL_nextwhite;
5586 curmad('X', PL_thistoken);
5587 PL_thistoken = newSVpvs("");
5592 NEXTVAL_NEXTTOKE.opval = yylval.opval;
5599 /* Call it a bare word */
5601 if (PL_hints & HINT_STRICT_SUBS)
5602 yylval.opval->op_private |= OPpCONST_STRICT;
5605 if (lastchar != '-') {
5606 if (ckWARN(WARN_RESERVED)) {
5610 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5611 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5618 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5619 && ckWARN_d(WARN_AMBIGUOUS)) {
5620 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5621 "Operator or semicolon missing before %c%s",
5622 lastchar, PL_tokenbuf);
5623 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5624 "Ambiguous use of %c resolved as operator %c",
5625 lastchar, lastchar);
5631 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5632 newSVpv(CopFILE(PL_curcop),0));
5636 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5637 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5640 case KEY___PACKAGE__:
5641 yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5643 ? newSVhek(HvNAME_HEK(PL_curstash))
5650 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5651 const char *pname = "main";
5652 if (PL_tokenbuf[2] == 'D')
5653 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5654 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5658 GvIOp(gv) = newIO();
5659 IoIFP(GvIOp(gv)) = PL_rsfp;
5660 #if defined(HAS_FCNTL) && defined(F_SETFD)
5662 const int fd = PerlIO_fileno(PL_rsfp);
5663 fcntl(fd,F_SETFD,fd >= 3);
5666 /* Mark this internal pseudo-handle as clean */
5667 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5669 IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5670 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5671 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5673 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5674 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5675 /* if the script was opened in binmode, we need to revert
5676 * it to text mode for compatibility; but only iff it has CRs
5677 * XXX this is a questionable hack at best. */
5678 if (PL_bufend-PL_bufptr > 2
5679 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5682 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5683 loc = PerlIO_tell(PL_rsfp);
5684 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5687 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5689 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5690 #endif /* NETWARE */
5691 #ifdef PERLIO_IS_STDIO /* really? */
5692 # if defined(__BORLANDC__)
5693 /* XXX see note in do_binmode() */
5694 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5698 PerlIO_seek(PL_rsfp, loc, 0);
5702 #ifdef PERLIO_LAYERS
5705 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5706 else if (PL_encoding) {
5713 XPUSHs(PL_encoding);
5715 call_method("name", G_SCALAR);
5719 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5720 Perl_form(aTHX_ ":encoding(%"SVf")",
5729 if (PL_realtokenstart >= 0) {
5730 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5732 PL_endwhite = newSVpvs("");
5733 sv_catsv(PL_endwhite, PL_thiswhite);
5735 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5736 PL_realtokenstart = -1;
5738 while ((s = filter_gets(PL_endwhite, PL_rsfp,
5739 SvCUR(PL_endwhite))) != Nullch) ;
5754 if (PL_expect == XSTATE) {
5761 if (*s == ':' && s[1] == ':') {
5764 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5765 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5766 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5769 else if (tmp == KEY_require || tmp == KEY_do)
5770 /* that's a way to remember we saw "CORE::" */
5783 LOP(OP_ACCEPT,XTERM);
5789 LOP(OP_ATAN2,XTERM);
5795 LOP(OP_BINMODE,XTERM);
5798 LOP(OP_BLESS,XTERM);
5807 /* When 'use switch' is in effect, continue has a dual
5808 life as a control operator. */
5810 if (!FEATURE_IS_ENABLED("switch"))
5813 /* We have to disambiguate the two senses of
5814 "continue". If the next token is a '{' then
5815 treat it as the start of a continue block;
5816 otherwise treat it as a control operator.
5828 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5845 if (!PL_cryptseen) {
5846 PL_cryptseen = TRUE;
5850 LOP(OP_CRYPT,XTERM);
5853 LOP(OP_CHMOD,XTERM);
5856 LOP(OP_CHOWN,XTERM);
5859 LOP(OP_CONNECT,XTERM);
5878 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5879 if (orig_keyword == KEY_do) {
5888 PL_hints |= HINT_BLOCK_SCOPE;
5898 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5899 LOP(OP_DBMOPEN,XTERM);
5905 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5912 yylval.ival = CopLINE(PL_curcop);
5928 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5929 UNIBRACK(OP_ENTEREVAL);
5947 case KEY_endhostent:
5953 case KEY_endservent:
5956 case KEY_endprotoent:
5967 yylval.ival = CopLINE(PL_curcop);
5969 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5972 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5975 if ((PL_bufend - p) >= 3 &&
5976 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5978 else if ((PL_bufend - p) >= 4 &&
5979 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5982 if (isIDFIRST_lazy_if(p,UTF)) {
5983 p = scan_ident(p, PL_bufend,
5984 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5988 Perl_croak(aTHX_ "Missing $ on loop variable");
5990 s = SvPVX(PL_linestr) + soff;
5996 LOP(OP_FORMLINE,XTERM);
6002 LOP(OP_FCNTL,XTERM);
6008 LOP(OP_FLOCK,XTERM);
6017 LOP(OP_GREPSTART, XREF);
6020 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6035 case KEY_getpriority:
6036 LOP(OP_GETPRIORITY,XTERM);
6038 case KEY_getprotobyname:
6041 case KEY_getprotobynumber:
6042 LOP(OP_GPBYNUMBER,XTERM);
6044 case KEY_getprotoent:
6056 case KEY_getpeername:
6057 UNI(OP_GETPEERNAME);
6059 case KEY_gethostbyname:
6062 case KEY_gethostbyaddr:
6063 LOP(OP_GHBYADDR,XTERM);
6065 case KEY_gethostent:
6068 case KEY_getnetbyname:
6071 case KEY_getnetbyaddr:
6072 LOP(OP_GNBYADDR,XTERM);
6077 case KEY_getservbyname:
6078 LOP(OP_GSBYNAME,XTERM);
6080 case KEY_getservbyport:
6081 LOP(OP_GSBYPORT,XTERM);
6083 case KEY_getservent:
6086 case KEY_getsockname:
6087 UNI(OP_GETSOCKNAME);
6089 case KEY_getsockopt:
6090 LOP(OP_GSOCKOPT,XTERM);
6105 yylval.ival = CopLINE(PL_curcop);
6116 yylval.ival = CopLINE(PL_curcop);
6120 LOP(OP_INDEX,XTERM);
6126 LOP(OP_IOCTL,XTERM);
6138 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6170 LOP(OP_LISTEN,XTERM);
6179 s = scan_pat(s,OP_MATCH);
6180 TERM(sublex_start());
6183 LOP(OP_MAPSTART, XREF);
6186 LOP(OP_MKDIR,XTERM);
6189 LOP(OP_MSGCTL,XTERM);
6192 LOP(OP_MSGGET,XTERM);
6195 LOP(OP_MSGRCV,XTERM);
6198 LOP(OP_MSGSND,XTERM);
6203 PL_in_my = (U16)tmp;
6205 if (isIDFIRST_lazy_if(s,UTF)) {
6209 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6210 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6212 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6213 if (!PL_in_my_stash) {
6216 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6220 if (PL_madskills) { /* just add type to declarator token */
6221 sv_catsv(PL_thistoken, PL_nextwhite);
6223 sv_catpvn(PL_thistoken, start, s - start);
6231 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6238 s = tokenize_use(0, s);
6242 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6249 if (isIDFIRST_lazy_if(s,UTF)) {
6251 for (d = s; isALNUM_lazy_if(d,UTF);)
6253 for (t=d; isSPACE(*t);)
6255 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6257 && !(t[0] == '=' && t[1] == '>')
6259 int parms_len = (int)(d-s);
6260 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6261 "Precedence problem: open %.*s should be open(%.*s)",
6262 parms_len, s, parms_len, s);
6268 yylval.ival = OP_OR;
6278 LOP(OP_OPEN_DIR,XTERM);
6281 checkcomma(s,PL_tokenbuf,"filehandle");
6285 checkcomma(s,PL_tokenbuf,"filehandle");
6304 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6308 LOP(OP_PIPE_OP,XTERM);
6311 s = scan_str(s,!!PL_madskills,FALSE);
6314 yylval.ival = OP_CONST;
6315 TERM(sublex_start());
6321 s = scan_str(s,!!PL_madskills,FALSE);
6324 PL_expect = XOPERATOR;
6326 if (SvCUR(PL_lex_stuff)) {
6329 d = SvPV_force(PL_lex_stuff, len);
6331 for (; isSPACE(*d) && len; --len, ++d)
6336 if (!warned && ckWARN(WARN_QW)) {
6337 for (; !isSPACE(*d) && len; --len, ++d) {
6339 Perl_warner(aTHX_ packWARN(WARN_QW),
6340 "Possible attempt to separate words with commas");
6343 else if (*d == '#') {
6344 Perl_warner(aTHX_ packWARN(WARN_QW),
6345 "Possible attempt to put comments in qw() list");
6351 for (; !isSPACE(*d) && len; --len, ++d)
6354 sv = newSVpvn(b, d-b);
6355 if (DO_UTF8(PL_lex_stuff))
6357 words = append_elem(OP_LIST, words,
6358 newSVOP(OP_CONST, 0, tokeq(sv)));
6362 start_force(PL_curforce);
6363 NEXTVAL_NEXTTOKE.opval = words;
6368 SvREFCNT_dec(PL_lex_stuff);
6369 PL_lex_stuff = NULL;
6375 s = scan_str(s,!!PL_madskills,FALSE);
6378 yylval.ival = OP_STRINGIFY;
6379 if (SvIVX(PL_lex_stuff) == '\'')
6380 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6381 TERM(sublex_start());
6384 s = scan_pat(s,OP_QR);
6385 TERM(sublex_start());
6388 s = scan_str(s,!!PL_madskills,FALSE);
6391 readpipe_override();
6392 TERM(sublex_start());
6400 s = force_version(s, FALSE);
6402 else if (*s != 'v' || !isDIGIT(s[1])
6403 || (s = force_version(s, TRUE), *s == 'v'))
6405 *PL_tokenbuf = '\0';
6406 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6407 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6408 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6410 yyerror("<> should be quotes");
6412 if (orig_keyword == KEY_require) {
6420 PL_last_uni = PL_oldbufptr;
6421 PL_last_lop_op = OP_REQUIRE;
6423 return REPORT( (int)REQUIRE );
6429 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6433 LOP(OP_RENAME,XTERM);
6442 LOP(OP_RINDEX,XTERM);
6452 UNIDOR(OP_READLINE);
6456 UNIDOR(OP_BACKTICK);
6465 LOP(OP_REVERSE,XTERM);
6468 UNIDOR(OP_READLINK);
6476 TERM(sublex_start());
6478 TOKEN(1); /* force error */
6481 checkcomma(s,PL_tokenbuf,"filehandle");
6491 LOP(OP_SELECT,XTERM);
6497 LOP(OP_SEMCTL,XTERM);
6500 LOP(OP_SEMGET,XTERM);
6503 LOP(OP_SEMOP,XTERM);
6509 LOP(OP_SETPGRP,XTERM);
6511 case KEY_setpriority:
6512 LOP(OP_SETPRIORITY,XTERM);
6514 case KEY_sethostent:
6520 case KEY_setservent:
6523 case KEY_setprotoent:
6533 LOP(OP_SEEKDIR,XTERM);
6535 case KEY_setsockopt:
6536 LOP(OP_SSOCKOPT,XTERM);
6542 LOP(OP_SHMCTL,XTERM);
6545 LOP(OP_SHMGET,XTERM);
6548 LOP(OP_SHMREAD,XTERM);
6551 LOP(OP_SHMWRITE,XTERM);
6554 LOP(OP_SHUTDOWN,XTERM);
6563 LOP(OP_SOCKET,XTERM);
6565 case KEY_socketpair:
6566 LOP(OP_SOCKPAIR,XTERM);
6569 checkcomma(s,PL_tokenbuf,"subroutine name");
6571 if (*s == ';' || *s == ')') /* probably a close */
6572 Perl_croak(aTHX_ "sort is now a reserved word");
6574 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6578 LOP(OP_SPLIT,XTERM);
6581 LOP(OP_SPRINTF,XTERM);
6584 LOP(OP_SPLICE,XTERM);
6599 LOP(OP_SUBSTR,XTERM);
6605 char tmpbuf[sizeof PL_tokenbuf];
6606 SSize_t tboffset = 0;
6607 expectation attrful;
6608 bool have_name, have_proto;
6609 const int key = tmp;
6614 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6615 SV *subtoken = newSVpvn(tstart, s - tstart);
6619 s = SKIPSPACE2(s,tmpwhite);
6624 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6625 (*s == ':' && s[1] == ':'))
6632 attrful = XATTRBLOCK;
6633 /* remember buffer pos'n for later force_word */
6634 tboffset = s - PL_oldbufptr;
6635 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6638 nametoke = newSVpvn(s, d - s);
6640 if (memchr(tmpbuf, ':', len))
6641 sv_setpvn(PL_subname, tmpbuf, len);
6643 sv_setsv(PL_subname,PL_curstname);
6644 sv_catpvs(PL_subname,"::");
6645 sv_catpvn(PL_subname,tmpbuf,len);
6652 CURMAD('X', nametoke);
6653 CURMAD('_', tmpwhite);
6654 (void) force_word(PL_oldbufptr + tboffset, WORD,
6657 s = SKIPSPACE2(d,tmpwhite);
6664 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6665 PL_expect = XTERMBLOCK;
6666 attrful = XATTRTERM;
6667 sv_setpvn(PL_subname,"?",1);
6671 if (key == KEY_format) {
6673 PL_lex_formbrack = PL_lex_brackets + 1;
6675 PL_thistoken = subtoken;
6679 (void) force_word(PL_oldbufptr + tboffset, WORD,
6685 /* Look for a prototype */
6688 bool bad_proto = FALSE;
6689 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6691 s = scan_str(s,!!PL_madskills,FALSE);
6693 Perl_croak(aTHX_ "Prototype not terminated");
6694 /* strip spaces and check for bad characters */
6695 d = SvPVX(PL_lex_stuff);
6697 for (p = d; *p; ++p) {
6700 if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
6706 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6707 "Illegal character in prototype for %"SVf" : %s",
6708 SVfARG(PL_subname), d);
6709 SvCUR_set(PL_lex_stuff, tmp);
6714 CURMAD('q', PL_thisopen);
6715 CURMAD('_', tmpwhite);
6716 CURMAD('=', PL_thisstuff);
6717 CURMAD('Q', PL_thisclose);
6718 NEXTVAL_NEXTTOKE.opval =
6719 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6720 PL_lex_stuff = Nullsv;
6723 s = SKIPSPACE2(s,tmpwhite);
6731 if (*s == ':' && s[1] != ':')
6732 PL_expect = attrful;
6733 else if (*s != '{' && key == KEY_sub) {
6735 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6737 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6744 curmad('^', newSVpvs(""));
6745 CURMAD('_', tmpwhite);
6749 PL_thistoken = subtoken;
6752 NEXTVAL_NEXTTOKE.opval =
6753 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6754 PL_lex_stuff = NULL;
6759 sv_setpv(PL_subname,
6761 (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
6765 (void) force_word(PL_oldbufptr + tboffset, WORD,
6775 LOP(OP_SYSTEM,XREF);
6778 LOP(OP_SYMLINK,XTERM);
6781 LOP(OP_SYSCALL,XTERM);
6784 LOP(OP_SYSOPEN,XTERM);
6787 LOP(OP_SYSSEEK,XTERM);
6790 LOP(OP_SYSREAD,XTERM);
6793 LOP(OP_SYSWRITE,XTERM);
6797 TERM(sublex_start());
6818 LOP(OP_TRUNCATE,XTERM);
6830 yylval.ival = CopLINE(PL_curcop);
6834 yylval.ival = CopLINE(PL_curcop);
6838 LOP(OP_UNLINK,XTERM);
6844 LOP(OP_UNPACK,XTERM);
6847 LOP(OP_UTIME,XTERM);
6853 LOP(OP_UNSHIFT,XTERM);
6856 s = tokenize_use(1, s);
6866 yylval.ival = CopLINE(PL_curcop);
6870 yylval.ival = CopLINE(PL_curcop);
6874 PL_hints |= HINT_BLOCK_SCOPE;
6881 LOP(OP_WAITPID,XTERM);
6890 ctl_l[0] = toCTRL('L');
6892 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6895 /* Make sure $^L is defined */
6896 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6901 if (PL_expect == XOPERATOR)
6907 yylval.ival = OP_XOR;
6912 TERM(sublex_start());
6917 #pragma segment Main
6921 S_pending_ident(pTHX)
6926 /* pit holds the identifier we read and pending_ident is reset */
6927 char pit = PL_pending_ident;
6928 PL_pending_ident = 0;
6930 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6931 DEBUG_T({ PerlIO_printf(Perl_debug_log,
6932 "### Pending identifier '%s'\n", PL_tokenbuf); });
6934 /* if we're in a my(), we can't allow dynamics here.
6935 $foo'bar has already been turned into $foo::bar, so
6936 just check for colons.
6938 if it's a legal name, the OP is a PADANY.
6941 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
6942 if (strchr(PL_tokenbuf,':'))
6943 yyerror(Perl_form(aTHX_ "No package name allowed for "
6944 "variable %s in \"our\"",
6946 tmp = allocmy(PL_tokenbuf);
6949 if (strchr(PL_tokenbuf,':'))
6950 yyerror(Perl_form(aTHX_ PL_no_myglob,
6951 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
6953 yylval.opval = newOP(OP_PADANY, 0);
6954 yylval.opval->op_targ = allocmy(PL_tokenbuf);
6960 build the ops for accesses to a my() variable.
6962 Deny my($a) or my($b) in a sort block, *if* $a or $b is
6963 then used in a comparison. This catches most, but not
6964 all cases. For instance, it catches
6965 sort { my($a); $a <=> $b }
6967 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6968 (although why you'd do that is anyone's guess).
6971 if (!strchr(PL_tokenbuf,':')) {
6973 tmp = pad_findmy(PL_tokenbuf);
6974 if (tmp != NOT_IN_PAD) {
6975 /* might be an "our" variable" */
6976 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6977 /* build ops for a bareword */
6978 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
6979 HEK * const stashname = HvNAME_HEK(stash);
6980 SV * const sym = newSVhek(stashname);
6981 sv_catpvs(sym, "::");
6982 sv_catpv(sym, PL_tokenbuf+1);
6983 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6984 yylval.opval->op_private = OPpCONST_ENTERED;
6987 ? (GV_ADDMULTI | GV_ADDINEVAL)
6990 ((PL_tokenbuf[0] == '$') ? SVt_PV
6991 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6996 /* if it's a sort block and they're naming $a or $b */
6997 if (PL_last_lop_op == OP_SORT &&
6998 PL_tokenbuf[0] == '$' &&
6999 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
7002 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
7003 d < PL_bufend && *d != '\n';
7006 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
7007 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
7013 yylval.opval = newOP(OP_PADANY, 0);
7014 yylval.opval->op_targ = tmp;
7020 Whine if they've said @foo in a doublequoted string,
7021 and @foo isn't a variable we can find in the symbol
7024 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
7025 GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
7026 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
7027 && ckWARN(WARN_AMBIGUOUS)
7028 /* DO NOT warn for @- and @+ */
7029 && !( PL_tokenbuf[2] == '\0' &&
7030 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
7033 /* Downgraded from fatal to warning 20000522 mjd */
7034 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7035 "Possible unintended interpolation of %s in string",
7040 /* build ops for a bareword */
7041 yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
7042 yylval.opval->op_private = OPpCONST_ENTERED;
7045 /* If the identifier refers to a stash, don't autovivify it.
7046 * Change 24660 had the side effect of causing symbol table
7047 * hashes to always be defined, even if they were freshly
7048 * created and the only reference in the entire program was
7049 * the single statement with the defined %foo::bar:: test.
7050 * It appears that all code in the wild doing this actually
7051 * wants to know whether sub-packages have been loaded, so
7052 * by avoiding auto-vivifying symbol tables, we ensure that
7053 * defined %foo::bar:: continues to be false, and the existing
7054 * tests still give the expected answers, even though what
7055 * they're actually testing has now changed subtly.
7057 (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
7059 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7060 ((PL_tokenbuf[0] == '$') ? SVt_PV
7061 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7067 * The following code was generated by perl_keyword.pl.
7071 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7076 case 1: /* 5 tokens of length 1 */
7108 case 2: /* 18 tokens of length 2 */
7254 case 3: /* 29 tokens of length 3 */
7258 if (name[1] == 'N' &&
7321 if (name[1] == 'i' &&
7343 return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7361 if (name[1] == 'o' &&
7370 if (name[1] == 'e' &&
7379 if (name[1] == 'n' &&
7388 if (name[1] == 'o' &&
7397 if (name[1] == 'a' &&
7406 if (name[1] == 'o' &&
7468 if (name[1] == 'e' &&
7482 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7508 if (name[1] == 'i' &&
7517 if (name[1] == 's' &&
7526 if (name[1] == 'e' &&
7535 if (name[1] == 'o' &&
7547 case 4: /* 41 tokens of length 4 */
7551 if (name[1] == 'O' &&
7561 if (name[1] == 'N' &&
7571 if (name[1] == 'i' &&
7581 if (name[1] == 'h' &&
7591 if (name[1] == 'u' &&
7604 if (name[2] == 'c' &&
7613 if (name[2] == 's' &&
7622 if (name[2] == 'a' &&
7658 if (name[1] == 'o' &&
7671 if (name[2] == 't' &&
7680 if (name[2] == 'o' &&
7689 if (name[2] == 't' &&
7698 if (name[2] == 'e' &&
7711 if (name[1] == 'o' &&
7724 if (name[2] == 'y' &&
7733 if (name[2] == 'l' &&
7749 if (name[2] == 's' &&
7758 if (name[2] == 'n' &&
7767 if (name[2] == 'c' &&
7780 if (name[1] == 'e' &&
7790 if (name[1] == 'p' &&
7803 if (name[2] == 'c' &&
7812 if (name[2] == 'p' &&
7821 if (name[2] == 's' &&
7837 if (name[2] == 'n' &&
7907 if (name[2] == 'r' &&
7916 if (name[2] == 'r' &&
7925 if (name[2] == 'a' &&
7941 if (name[2] == 'l' &&
8003 if (name[2] == 'e' &&
8006 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
8019 case 5: /* 39 tokens of length 5 */
8023 if (name[1] == 'E' &&
8034 if (name[1] == 'H' &&
8048 if (name[2] == 'a' &&
8058 if (name[2] == 'a' &&
8075 if (name[2] == 'e' &&
8085 if (name[2] == 'e' &&
8089 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8105 if (name[3] == 'i' &&
8114 if (name[3] == 'o' &&
8150 if (name[2] == 'o' &&
8160 if (name[2] == 'y' &&
8174 if (name[1] == 'l' &&
8188 if (name[2] == 'n' &&
8198 if (name[2] == 'o' &&
8212 if (name[1] == 'i' &&
8217 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8226 if (name[2] == 'd' &&
8236 if (name[2] == 'c' &&
8253 if (name[2] == 'c' &&
8263 if (name[2] == 't' &&
8277 if (name[1] == 'k' &&
8288 if (name[1] == 'r' &&
8302 if (name[2] == 's' &&
8312 if (name[2] == 'd' &&
8329 if (name[2] == 'm' &&
8339 if (name[2] == 'i' &&
8349 if (name[2] == 'e' &&
8359 if (name[2] == 'l' &&
8369 if (name[2] == 'a' &&
8382 if (name[3] == 't' &&
8385 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8391 if (name[3] == 'd' &&
8408 if (name[1] == 'i' &&
8422 if (name[2] == 'a' &&
8435 if (name[3] == 'e' &&
8470 if (name[2] == 'i' &&
8487 if (name[2] == 'i' &&
8497 if (name[2] == 'i' &&
8514 case 6: /* 33 tokens of length 6 */
8518 if (name[1] == 'c' &&
8533 if (name[2] == 'l' &&
8544 if (name[2] == 'r' &&
8559 if (name[1] == 'e' &&
8574 if (name[2] == 's' &&
8579 if(ckWARN_d(WARN_SYNTAX))
8580 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8586 if (name[2] == 'i' &&
8604 if (name[2] == 'l' &&
8615 if (name[2] == 'r' &&
8630 if (name[1] == 'm' &&
8645 if (name[2] == 'n' &&
8656 if (name[2] == 's' &&
8671 if (name[1] == 's' &&
8677 if (name[4] == 't' &&
8686 if (name[4] == 'e' &&
8695 if (name[4] == 'c' &&
8704 if (name[4] == 'n' &&
8720 if (name[1] == 'r' &&
8738 if (name[3] == 'a' &&
8748 if (name[3] == 'u' &&
8762 if (name[2] == 'n' &&
8780 if (name[2] == 'a' &&
8794 if (name[3] == 'e' &&
8807 if (name[4] == 't' &&
8816 if (name[4] == 'e' &&
8838 if (name[4] == 't' &&
8847 if (name[4] == 'e' &&
8863 if (name[2] == 'c' &&
8874 if (name[2] == 'l' &&
8885 if (name[2] == 'b' &&
8896 if (name[2] == 's' &&
8919 if (name[4] == 's' &&
8928 if (name[4] == 'n' &&
8941 if (name[3] == 'a' &&
8958 if (name[1] == 'a' &&
8973 case 7: /* 29 tokens of length 7 */
8977 if (name[1] == 'E' &&
8990 if (name[1] == '_' &&
9003 if (name[1] == 'i' &&
9010 return -KEY_binmode;
9016 if (name[1] == 'o' &&
9023 return -KEY_connect;
9032 if (name[2] == 'm' &&
9038 return -KEY_dbmopen;
9049 if (name[4] == 'u' &&
9053 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9059 if (name[4] == 'n' &&
9080 if (name[1] == 'o' &&
9093 if (name[1] == 'e' &&
9100 if (name[5] == 'r' &&
9103 return -KEY_getpgrp;
9109 if (name[5] == 'i' &&
9112 return -KEY_getppid;
9125 if (name[1] == 'c' &&
9132 return -KEY_lcfirst;
9138 if (name[1] == 'p' &&
9145 return -KEY_opendir;
9151 if (name[1] == 'a' &&
9169 if (name[3] == 'd' &&
9174 return -KEY_readdir;
9180 if (name[3] == 'u' &&
9191 if (name[3] == 'e' &&
9196 return -KEY_reverse;
9215 if (name[3] == 'k' &&
9220 return -KEY_seekdir;
9226 if (name[3] == 'p' &&
9231 return -KEY_setpgrp;
9241 if (name[2] == 'm' &&
9247 return -KEY_shmread;
9253 if (name[2] == 'r' &&
9259 return -KEY_sprintf;
9268 if (name[3] == 'l' &&
9273 return -KEY_symlink;
9282 if (name[4] == 'a' &&
9286 return -KEY_syscall;
9292 if (name[4] == 'p' &&
9296 return -KEY_sysopen;
9302 if (name[4] == 'e' &&
9306 return -KEY_sysread;
9312 if (name[4] == 'e' &&
9316 return -KEY_sysseek;
9334 if (name[1] == 'e' &&
9341 return -KEY_telldir;
9350 if (name[2] == 'f' &&
9356 return -KEY_ucfirst;
9362 if (name[2] == 's' &&
9368 return -KEY_unshift;
9378 if (name[1] == 'a' &&
9385 return -KEY_waitpid;
9394 case 8: /* 26 tokens of length 8 */
9398 if (name[1] == 'U' &&
9406 return KEY_AUTOLOAD;
9417 if (name[3] == 'A' &&
9423 return KEY___DATA__;
9429 if (name[3] == 'I' &&
9435 return -KEY___FILE__;
9441 if (name[3] == 'I' &&
9447 return -KEY___LINE__;
9463 if (name[2] == 'o' &&
9470 return -KEY_closedir;
9476 if (name[2] == 'n' &&
9483 return -KEY_continue;
9493 if (name[1] == 'b' &&
9501 return -KEY_dbmclose;
9507 if (name[1] == 'n' &&
9513 if (name[4] == 'r' &&
9518 return -KEY_endgrent;
9524 if (name[4] == 'w' &&
9529 return -KEY_endpwent;
9542 if (name[1] == 'o' &&
9550 return -KEY_formline;
9556 if (name[1] == 'e' &&
9567 if (name[6] == 'n' &&
9570 return -KEY_getgrent;
9576 if (name[6] == 'i' &&
9579 return -KEY_getgrgid;
9585 if (name[6] == 'a' &&
9588 return -KEY_getgrnam;
9601 if (name[4] == 'o' &&
9606 return -KEY_getlogin;
9617 if (name[6] == 'n' &&
9620 return -KEY_getpwent;
9626 if (name[6] == 'a' &&
9629 return -KEY_getpwnam;
9635 if (name[6] == 'i' &&
9638 return -KEY_getpwuid;
9658 if (name[1] == 'e' &&
9665 if (name[5] == 'i' &&
9672 return -KEY_readline;
9677 return -KEY_readlink;
9688 if (name[5] == 'i' &&
9692 return -KEY_readpipe;
9713 if (name[4] == 'r' &&
9718 return -KEY_setgrent;
9724 if (name[4] == 'w' &&
9729 return -KEY_setpwent;
9745 if (name[3] == 'w' &&
9751 return -KEY_shmwrite;
9757 if (name[3] == 't' &&
9763 return -KEY_shutdown;
9773 if (name[2] == 's' &&
9780 return -KEY_syswrite;
9790 if (name[1] == 'r' &&
9798 return -KEY_truncate;
9807 case 9: /* 9 tokens of length 9 */
9811 if (name[1] == 'N' &&
9820 return KEY_UNITCHECK;
9826 if (name[1] == 'n' &&
9835 return -KEY_endnetent;
9841 if (name[1] == 'e' &&
9850 return -KEY_getnetent;
9856 if (name[1] == 'o' &&
9865 return -KEY_localtime;
9871 if (name[1] == 'r' &&
9880 return KEY_prototype;
9886 if (name[1] == 'u' &&
9895 return -KEY_quotemeta;
9901 if (name[1] == 'e' &&
9910 return -KEY_rewinddir;
9916 if (name[1] == 'e' &&
9925 return -KEY_setnetent;
9931 if (name[1] == 'a' &&
9940 return -KEY_wantarray;
9949 case 10: /* 9 tokens of length 10 */
9953 if (name[1] == 'n' &&
9959 if (name[4] == 'o' &&
9966 return -KEY_endhostent;
9972 if (name[4] == 'e' &&
9979 return -KEY_endservent;
9992 if (name[1] == 'e' &&
9998 if (name[4] == 'o' &&
10005 return -KEY_gethostent;
10014 if (name[5] == 'r' &&
10020 return -KEY_getservent;
10026 if (name[5] == 'c' &&
10032 return -KEY_getsockopt;
10052 if (name[2] == 't')
10057 if (name[4] == 'o' &&
10064 return -KEY_sethostent;
10073 if (name[5] == 'r' &&
10079 return -KEY_setservent;
10085 if (name[5] == 'c' &&
10091 return -KEY_setsockopt;
10108 if (name[2] == 'c' &&
10117 return -KEY_socketpair;
10130 case 11: /* 8 tokens of length 11 */
10134 if (name[1] == '_' &&
10144 { /* __PACKAGE__ */
10145 return -KEY___PACKAGE__;
10151 if (name[1] == 'n' &&
10161 { /* endprotoent */
10162 return -KEY_endprotoent;
10168 if (name[1] == 'e' &&
10177 if (name[5] == 'e' &&
10183 { /* getpeername */
10184 return -KEY_getpeername;
10193 if (name[6] == 'o' &&
10198 { /* getpriority */
10199 return -KEY_getpriority;
10205 if (name[6] == 't' &&
10210 { /* getprotoent */
10211 return -KEY_getprotoent;
10225 if (name[4] == 'o' &&
10232 { /* getsockname */
10233 return -KEY_getsockname;
10246 if (name[1] == 'e' &&
10254 if (name[6] == 'o' &&
10259 { /* setpriority */
10260 return -KEY_setpriority;
10266 if (name[6] == 't' &&
10271 { /* setprotoent */
10272 return -KEY_setprotoent;
10288 case 12: /* 2 tokens of length 12 */
10289 if (name[0] == 'g' &&
10301 if (name[9] == 'd' &&
10304 { /* getnetbyaddr */
10305 return -KEY_getnetbyaddr;
10311 if (name[9] == 'a' &&
10314 { /* getnetbyname */
10315 return -KEY_getnetbyname;
10327 case 13: /* 4 tokens of length 13 */
10328 if (name[0] == 'g' &&
10335 if (name[4] == 'o' &&
10344 if (name[10] == 'd' &&
10347 { /* gethostbyaddr */
10348 return -KEY_gethostbyaddr;
10354 if (name[10] == 'a' &&
10357 { /* gethostbyname */
10358 return -KEY_gethostbyname;
10371 if (name[4] == 'e' &&
10380 if (name[10] == 'a' &&
10383 { /* getservbyname */
10384 return -KEY_getservbyname;
10390 if (name[10] == 'o' &&
10393 { /* getservbyport */
10394 return -KEY_getservbyport;
10413 case 14: /* 1 tokens of length 14 */
10414 if (name[0] == 'g' &&
10428 { /* getprotobyname */
10429 return -KEY_getprotobyname;
10434 case 16: /* 1 tokens of length 16 */
10435 if (name[0] == 'g' &&
10451 { /* getprotobynumber */
10452 return -KEY_getprotobynumber;
10466 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10470 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10471 if (ckWARN(WARN_SYNTAX)) {
10474 for (w = s+2; *w && level; w++) {
10477 else if (*w == ')')
10480 while (isSPACE(*w))
10482 /* the list of chars below is for end of statements or
10483 * block / parens, boolean operators (&&, ||, //) and branch
10484 * constructs (or, and, if, until, unless, while, err, for).
10485 * Not a very solid hack... */
10486 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
10487 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10488 "%s (...) interpreted as function",name);
10491 while (s < PL_bufend && isSPACE(*s))
10495 while (s < PL_bufend && isSPACE(*s))
10497 if (isIDFIRST_lazy_if(s,UTF)) {
10498 const char * const w = s++;
10499 while (isALNUM_lazy_if(s,UTF))
10501 while (s < PL_bufend && isSPACE(*s))
10505 if (keyword(w, s - w, 0))
10508 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10509 if (gv && GvCVu(gv))
10511 Perl_croak(aTHX_ "No comma allowed after %s", what);
10516 /* Either returns sv, or mortalizes sv and returns a new SV*.
10517 Best used as sv=new_constant(..., sv, ...).
10518 If s, pv are NULL, calls subroutine with one argument,
10519 and type is used with error messages only. */
10522 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10526 HV * const table = GvHV(PL_hintgv); /* ^H */
10530 const char *why1 = "", *why2 = "", *why3 = "";
10532 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10535 why2 = (const char *)
10536 (strEQ(key,"charnames")
10537 ? "(possibly a missing \"use charnames ...\")"
10539 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10540 (type ? type: "undef"), why2);
10542 /* This is convoluted and evil ("goto considered harmful")
10543 * but I do not understand the intricacies of all the different
10544 * failure modes of %^H in here. The goal here is to make
10545 * the most probable error message user-friendly. --jhi */
10550 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10551 (type ? type: "undef"), why1, why2, why3);
10553 yyerror(SvPVX_const(msg));
10557 cvp = hv_fetch(table, key, strlen(key), FALSE);
10558 if (!cvp || !SvOK(*cvp)) {
10561 why3 = "} is not defined";
10564 sv_2mortal(sv); /* Parent created it permanently */
10567 pv = sv_2mortal(newSVpvn(s, len));
10569 typesv = sv_2mortal(newSVpv(type, 0));
10571 typesv = &PL_sv_undef;
10573 PUSHSTACKi(PERLSI_OVERLOAD);
10585 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10589 /* Check the eval first */
10590 if (!PL_in_eval && SvTRUE(ERRSV)) {
10591 sv_catpvs(ERRSV, "Propagated");
10592 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10594 res = SvREFCNT_inc_simple(sv);
10598 SvREFCNT_inc_simple_void(res);
10607 why1 = "Call to &{$^H{";
10609 why3 = "}} did not return a defined value";
10617 /* Returns a NUL terminated string, with the length of the string written to
10621 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10624 register char *d = dest;
10625 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10628 Perl_croak(aTHX_ ident_too_long);
10629 if (isALNUM(*s)) /* UTF handled below */
10631 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10636 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10640 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10641 char *t = s + UTF8SKIP(s);
10643 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10647 Perl_croak(aTHX_ ident_too_long);
10648 Copy(s, d, len, char);
10661 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10664 char *bracket = NULL;
10666 register char *d = dest;
10667 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10672 while (isDIGIT(*s)) {
10674 Perl_croak(aTHX_ ident_too_long);
10681 Perl_croak(aTHX_ ident_too_long);
10682 if (isALNUM(*s)) /* UTF handled below */
10684 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10689 else if (*s == ':' && s[1] == ':') {
10693 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10694 char *t = s + UTF8SKIP(s);
10695 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10697 if (d + (t - s) > e)
10698 Perl_croak(aTHX_ ident_too_long);
10699 Copy(s, d, t - s, char);
10710 if (PL_lex_state != LEX_NORMAL)
10711 PL_lex_state = LEX_INTERPENDMAYBE;
10714 if (*s == '$' && s[1] &&
10715 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10728 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10733 if (isSPACE(s[-1])) {
10735 const char ch = *s++;
10736 if (!SPACE_OR_TAB(ch)) {
10742 if (isIDFIRST_lazy_if(d,UTF)) {
10746 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10747 end += UTF8SKIP(end);
10748 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10749 end += UTF8SKIP(end);
10751 Copy(s, d, end - s, char);
10756 while ((isALNUM(*s) || *s == ':') && d < e)
10759 Perl_croak(aTHX_ ident_too_long);
10762 while (s < send && SPACE_OR_TAB(*s))
10764 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10765 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10766 const char * const brack =
10768 ((*s == '[') ? "[...]" : "{...}");
10769 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10770 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10771 funny, dest, brack, funny, dest, brack);
10774 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10778 /* Handle extended ${^Foo} variables
10779 * 1999-02-27 mjd-perl-patch@plover.com */
10780 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10784 while (isALNUM(*s) && d < e) {
10788 Perl_croak(aTHX_ ident_too_long);
10793 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10794 PL_lex_state = LEX_INTERPEND;
10797 if (PL_lex_state == LEX_NORMAL) {
10798 if (ckWARN(WARN_AMBIGUOUS) &&
10799 (keyword(dest, d - dest, 0)
10800 || get_cvn_flags(dest, d - dest, 0)))
10804 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10805 "Ambiguous use of %c{%s} resolved to %c%s",
10806 funny, dest, funny, dest);
10811 s = bracket; /* let the parser handle it */
10815 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10816 PL_lex_state = LEX_INTERPEND;
10821 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10823 PERL_UNUSED_CONTEXT;
10827 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
10828 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
10829 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
10830 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
10831 case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break;
10837 S_scan_pat(pTHX_ char *start, I32 type)
10841 char *s = scan_str(start,!!PL_madskills,FALSE);
10842 const char * const valid_flags =
10843 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10850 const char * const delimiter = skipspace(start);
10854 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10855 : "Search pattern not terminated" ));
10858 pm = (PMOP*)newPMOP(type, 0);
10859 if (PL_multi_open == '?') {
10860 /* This is the only point in the code that sets PMf_ONCE: */
10861 pm->op_pmflags |= PMf_ONCE;
10863 /* Hence it's safe to do this bit of PMOP book-keeping here, which
10864 allows us to restrict the list needed by reset to just the ??
10866 assert(type != OP_TRANS);
10868 MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
10871 mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0,
10874 elements = mg->mg_len / sizeof(PMOP**);
10875 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
10876 ((PMOP**)mg->mg_ptr) [elements++] = pm;
10877 mg->mg_len = elements * sizeof(PMOP**);
10878 PmopSTASH_set(pm,PL_curstash);
10884 while (*s && strchr(valid_flags, *s))
10885 pmflag(&pm->op_pmflags,*s++);
10887 if (PL_madskills && modstart != s) {
10888 SV* tmptoken = newSVpvn(modstart, s - modstart);
10889 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10892 /* issue a warning if /c is specified,but /g is not */
10893 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10894 && ckWARN(WARN_REGEXP))
10896 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
10897 "Use of /c modifier is meaningless without /g" );
10900 PL_lex_op = (OP*)pm;
10901 yylval.ival = OP_MATCH;
10906 S_scan_subst(pTHX_ char *start)
10917 yylval.ival = OP_NULL;
10919 s = scan_str(start,!!PL_madskills,FALSE);
10922 Perl_croak(aTHX_ "Substitution pattern not terminated");
10924 if (s[-1] == PL_multi_open)
10927 if (PL_madskills) {
10928 CURMAD('q', PL_thisopen);
10929 CURMAD('_', PL_thiswhite);
10930 CURMAD('E', PL_thisstuff);
10931 CURMAD('Q', PL_thisclose);
10932 PL_realtokenstart = s - SvPVX(PL_linestr);
10936 first_start = PL_multi_start;
10937 s = scan_str(s,!!PL_madskills,FALSE);
10939 if (PL_lex_stuff) {
10940 SvREFCNT_dec(PL_lex_stuff);
10941 PL_lex_stuff = NULL;
10943 Perl_croak(aTHX_ "Substitution replacement not terminated");
10945 PL_multi_start = first_start; /* so whole substitution is taken together */
10947 pm = (PMOP*)newPMOP(OP_SUBST, 0);
10950 if (PL_madskills) {
10951 CURMAD('z', PL_thisopen);
10952 CURMAD('R', PL_thisstuff);
10953 CURMAD('Z', PL_thisclose);
10959 if (*s == EXEC_PAT_MOD) {
10963 else if (strchr(S_PAT_MODS, *s))
10964 pmflag(&pm->op_pmflags,*s++);
10970 if (PL_madskills) {
10972 curmad('m', newSVpvn(modstart, s - modstart));
10973 append_madprops(PL_thismad, (OP*)pm, 0);
10977 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10978 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10982 SV * const repl = newSVpvs("");
10984 PL_sublex_info.super_bufptr = s;
10985 PL_sublex_info.super_bufend = PL_bufend;
10987 pm->op_pmflags |= PMf_EVAL;
10989 sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10990 sv_catpvs(repl, "{");
10991 sv_catsv(repl, PL_lex_repl);
10992 if (strchr(SvPVX(PL_lex_repl), '#'))
10993 sv_catpvs(repl, "\n");
10994 sv_catpvs(repl, "}");
10996 SvREFCNT_dec(PL_lex_repl);
10997 PL_lex_repl = repl;
11000 PL_lex_op = (OP*)pm;
11001 yylval.ival = OP_SUBST;
11006 S_scan_trans(pTHX_ char *start)
11019 yylval.ival = OP_NULL;
11021 s = scan_str(start,!!PL_madskills,FALSE);
11023 Perl_croak(aTHX_ "Transliteration pattern not terminated");
11025 if (s[-1] == PL_multi_open)
11028 if (PL_madskills) {
11029 CURMAD('q', PL_thisopen);
11030 CURMAD('_', PL_thiswhite);
11031 CURMAD('E', PL_thisstuff);
11032 CURMAD('Q', PL_thisclose);
11033 PL_realtokenstart = s - SvPVX(PL_linestr);
11037 s = scan_str(s,!!PL_madskills,FALSE);
11039 if (PL_lex_stuff) {
11040 SvREFCNT_dec(PL_lex_stuff);
11041 PL_lex_stuff = NULL;
11043 Perl_croak(aTHX_ "Transliteration replacement not terminated");
11045 if (PL_madskills) {
11046 CURMAD('z', PL_thisopen);
11047 CURMAD('R', PL_thisstuff);
11048 CURMAD('Z', PL_thisclose);
11051 complement = del = squash = 0;
11058 complement = OPpTRANS_COMPLEMENT;
11061 del = OPpTRANS_DELETE;
11064 squash = OPpTRANS_SQUASH;
11073 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11074 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11075 o->op_private &= ~OPpTRANS_ALL;
11076 o->op_private |= del|squash|complement|
11077 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11078 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11081 yylval.ival = OP_TRANS;
11084 if (PL_madskills) {
11086 curmad('m', newSVpvn(modstart, s - modstart));
11087 append_madprops(PL_thismad, o, 0);
11096 S_scan_heredoc(pTHX_ register char *s)
11100 I32 op_type = OP_SCALAR;
11104 const char *found_newline;
11108 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11110 I32 stuffstart = s - SvPVX(PL_linestr);
11113 PL_realtokenstart = -1;
11118 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11122 while (SPACE_OR_TAB(*peek))
11124 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11127 s = delimcpy(d, e, s, PL_bufend, term, &len);
11137 if (!isALNUM_lazy_if(s,UTF))
11138 deprecate_old("bare << to mean <<\"\"");
11139 for (; isALNUM_lazy_if(s,UTF); s++) {
11144 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11145 Perl_croak(aTHX_ "Delimiter for here document is too long");
11148 len = d - PL_tokenbuf;
11151 if (PL_madskills) {
11152 tstart = PL_tokenbuf + !outer;
11153 PL_thisclose = newSVpvn(tstart, len - !outer);
11154 tstart = SvPVX(PL_linestr) + stuffstart;
11155 PL_thisopen = newSVpvn(tstart, s - tstart);
11156 stuffstart = s - SvPVX(PL_linestr);
11159 #ifndef PERL_STRICT_CR
11160 d = strchr(s, '\r');
11162 char * const olds = s;
11164 while (s < PL_bufend) {
11170 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11179 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11186 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11187 herewas = newSVpvn(s,PL_bufend-s);
11191 herewas = newSVpvn(s-1,found_newline-s+1);
11194 herewas = newSVpvn(s,found_newline-s);
11198 if (PL_madskills) {
11199 tstart = SvPVX(PL_linestr) + stuffstart;
11201 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11203 PL_thisstuff = newSVpvn(tstart, s - tstart);
11206 s += SvCUR(herewas);
11209 stuffstart = s - SvPVX(PL_linestr);
11215 tmpstr = newSV_type(SVt_PVIV);
11216 SvGROW(tmpstr, 80);
11217 if (term == '\'') {
11218 op_type = OP_CONST;
11219 SvIV_set(tmpstr, -1);
11221 else if (term == '`') {
11222 op_type = OP_BACKTICK;
11223 SvIV_set(tmpstr, '\\');
11227 PL_multi_start = CopLINE(PL_curcop);
11228 PL_multi_open = PL_multi_close = '<';
11229 term = *PL_tokenbuf;
11230 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11231 char * const bufptr = PL_sublex_info.super_bufptr;
11232 char * const bufend = PL_sublex_info.super_bufend;
11233 char * const olds = s - SvCUR(herewas);
11234 s = strchr(bufptr, '\n');
11238 while (s < bufend &&
11239 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11241 CopLINE_inc(PL_curcop);
11244 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11245 missingterm(PL_tokenbuf);
11247 sv_setpvn(herewas,bufptr,d-bufptr+1);
11248 sv_setpvn(tmpstr,d+1,s-d);
11250 sv_catpvn(herewas,s,bufend-s);
11251 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11258 while (s < PL_bufend &&
11259 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11261 CopLINE_inc(PL_curcop);
11263 if (s >= PL_bufend) {
11264 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11265 missingterm(PL_tokenbuf);
11267 sv_setpvn(tmpstr,d+1,s-d);
11269 if (PL_madskills) {
11271 sv_catpvn(PL_thisstuff, d + 1, s - d);
11273 PL_thisstuff = newSVpvn(d + 1, s - d);
11274 stuffstart = s - SvPVX(PL_linestr);
11278 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11280 sv_catpvn(herewas,s,PL_bufend-s);
11281 sv_setsv(PL_linestr,herewas);
11282 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11283 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11284 PL_last_lop = PL_last_uni = NULL;
11287 sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
11288 while (s >= PL_bufend) { /* multiple line string? */
11290 if (PL_madskills) {
11291 tstart = SvPVX(PL_linestr) + stuffstart;
11293 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11295 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11299 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11300 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11301 missingterm(PL_tokenbuf);
11304 stuffstart = s - SvPVX(PL_linestr);
11306 CopLINE_inc(PL_curcop);
11307 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11308 PL_last_lop = PL_last_uni = NULL;
11309 #ifndef PERL_STRICT_CR
11310 if (PL_bufend - PL_linestart >= 2) {
11311 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11312 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11314 PL_bufend[-2] = '\n';
11316 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11318 else if (PL_bufend[-1] == '\r')
11319 PL_bufend[-1] = '\n';
11321 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11322 PL_bufend[-1] = '\n';
11324 if (PERLDB_LINE && PL_curstash != PL_debstash)
11325 update_debugger_info(PL_linestr, NULL, 0);
11326 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11327 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11328 *(SvPVX(PL_linestr) + off ) = ' ';
11329 sv_catsv(PL_linestr,herewas);
11330 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11331 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11335 sv_catsv(tmpstr,PL_linestr);
11340 PL_multi_end = CopLINE(PL_curcop);
11341 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11342 SvPV_shrink_to_cur(tmpstr);
11344 SvREFCNT_dec(herewas);
11346 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11348 else if (PL_encoding)
11349 sv_recode_to_utf8(tmpstr, PL_encoding);
11351 PL_lex_stuff = tmpstr;
11352 yylval.ival = op_type;
11356 /* scan_inputsymbol
11357 takes: current position in input buffer
11358 returns: new position in input buffer
11359 side-effects: yylval and lex_op are set.
11364 <FH> read from filehandle
11365 <pkg::FH> read from package qualified filehandle
11366 <pkg'FH> read from package qualified filehandle
11367 <$fh> read from filehandle in $fh
11368 <*.h> filename glob
11373 S_scan_inputsymbol(pTHX_ char *start)
11376 register char *s = start; /* current position in buffer */
11380 char *d = PL_tokenbuf; /* start of temp holding space */
11381 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11383 end = strchr(s, '\n');
11386 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11388 /* die if we didn't have space for the contents of the <>,
11389 or if it didn't end, or if we see a newline
11392 if (len >= (I32)sizeof PL_tokenbuf)
11393 Perl_croak(aTHX_ "Excessively long <> operator");
11395 Perl_croak(aTHX_ "Unterminated <> operator");
11400 Remember, only scalar variables are interpreted as filehandles by
11401 this code. Anything more complex (e.g., <$fh{$num}>) will be
11402 treated as a glob() call.
11403 This code makes use of the fact that except for the $ at the front,
11404 a scalar variable and a filehandle look the same.
11406 if (*d == '$' && d[1]) d++;
11408 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11409 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11412 /* If we've tried to read what we allow filehandles to look like, and
11413 there's still text left, then it must be a glob() and not a getline.
11414 Use scan_str to pull out the stuff between the <> and treat it
11415 as nothing more than a string.
11418 if (d - PL_tokenbuf != len) {
11419 yylval.ival = OP_GLOB;
11421 s = scan_str(start,!!PL_madskills,FALSE);
11423 Perl_croak(aTHX_ "Glob not terminated");
11427 bool readline_overriden = FALSE;
11430 /* we're in a filehandle read situation */
11433 /* turn <> into <ARGV> */
11435 Copy("ARGV",d,5,char);
11437 /* Check whether readline() is overriden */
11438 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11440 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11442 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11443 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11444 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11445 readline_overriden = TRUE;
11447 /* if <$fh>, create the ops to turn the variable into a
11451 /* try to find it in the pad for this block, otherwise find
11452 add symbol table ops
11454 const PADOFFSET tmp = pad_findmy(d);
11455 if (tmp != NOT_IN_PAD) {
11456 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11457 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11458 HEK * const stashname = HvNAME_HEK(stash);
11459 SV * const sym = sv_2mortal(newSVhek(stashname));
11460 sv_catpvs(sym, "::");
11461 sv_catpv(sym, d+1);
11466 OP * const o = newOP(OP_PADSV, 0);
11468 PL_lex_op = readline_overriden
11469 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11470 append_elem(OP_LIST, o,
11471 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11472 : (OP*)newUNOP(OP_READLINE, 0, o);
11481 ? (GV_ADDMULTI | GV_ADDINEVAL)
11484 PL_lex_op = readline_overriden
11485 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11486 append_elem(OP_LIST,
11487 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11488 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11489 : (OP*)newUNOP(OP_READLINE, 0,
11490 newUNOP(OP_RV2SV, 0,
11491 newGVOP(OP_GV, 0, gv)));
11493 if (!readline_overriden)
11494 PL_lex_op->op_flags |= OPf_SPECIAL;
11495 /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11496 yylval.ival = OP_NULL;
11499 /* If it's none of the above, it must be a literal filehandle
11500 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11502 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11503 PL_lex_op = readline_overriden
11504 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11505 append_elem(OP_LIST,
11506 newGVOP(OP_GV, 0, gv),
11507 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11508 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11509 yylval.ival = OP_NULL;
11518 takes: start position in buffer
11519 keep_quoted preserve \ on the embedded delimiter(s)
11520 keep_delims preserve the delimiters around the string
11521 returns: position to continue reading from buffer
11522 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11523 updates the read buffer.
11525 This subroutine pulls a string out of the input. It is called for:
11526 q single quotes q(literal text)
11527 ' single quotes 'literal text'
11528 qq double quotes qq(interpolate $here please)
11529 " double quotes "interpolate $here please"
11530 qx backticks qx(/bin/ls -l)
11531 ` backticks `/bin/ls -l`
11532 qw quote words @EXPORT_OK = qw( func() $spam )
11533 m// regexp match m/this/
11534 s/// regexp substitute s/this/that/
11535 tr/// string transliterate tr/this/that/
11536 y/// string transliterate y/this/that/
11537 ($*@) sub prototypes sub foo ($)
11538 (stuff) sub attr parameters sub foo : attr(stuff)
11539 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11541 In most of these cases (all but <>, patterns and transliterate)
11542 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11543 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11544 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11547 It skips whitespace before the string starts, and treats the first
11548 character as the delimiter. If the delimiter is one of ([{< then
11549 the corresponding "close" character )]}> is used as the closing
11550 delimiter. It allows quoting of delimiters, and if the string has
11551 balanced delimiters ([{<>}]) it allows nesting.
11553 On success, the SV with the resulting string is put into lex_stuff or,
11554 if that is already non-NULL, into lex_repl. The second case occurs only
11555 when parsing the RHS of the special constructs s/// and tr/// (y///).
11556 For convenience, the terminating delimiter character is stuffed into
11561 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11564 SV *sv; /* scalar value: string */
11565 const char *tmps; /* temp string, used for delimiter matching */
11566 register char *s = start; /* current position in the buffer */
11567 register char term; /* terminating character */
11568 register char *to; /* current position in the sv's data */
11569 I32 brackets = 1; /* bracket nesting level */
11570 bool has_utf8 = FALSE; /* is there any utf8 content? */
11571 I32 termcode; /* terminating char. code */
11572 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11573 STRLEN termlen; /* length of terminating string */
11574 int last_off = 0; /* last position for nesting bracket */
11580 /* skip space before the delimiter */
11586 if (PL_realtokenstart >= 0) {
11587 stuffstart = PL_realtokenstart;
11588 PL_realtokenstart = -1;
11591 stuffstart = start - SvPVX(PL_linestr);
11593 /* mark where we are, in case we need to report errors */
11596 /* after skipping whitespace, the next character is the terminator */
11599 termcode = termstr[0] = term;
11603 termcode = utf8_to_uvchr((U8*)s, &termlen);
11604 Copy(s, termstr, termlen, U8);
11605 if (!UTF8_IS_INVARIANT(term))
11609 /* mark where we are */
11610 PL_multi_start = CopLINE(PL_curcop);
11611 PL_multi_open = term;
11613 /* find corresponding closing delimiter */
11614 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11615 termcode = termstr[0] = term = tmps[5];
11617 PL_multi_close = term;
11619 /* create a new SV to hold the contents. 79 is the SV's initial length.
11620 What a random number. */
11621 sv = newSV_type(SVt_PVIV);
11623 SvIV_set(sv, termcode);
11624 (void)SvPOK_only(sv); /* validate pointer */
11626 /* move past delimiter and try to read a complete string */
11628 sv_catpvn(sv, s, termlen);
11631 tstart = SvPVX(PL_linestr) + stuffstart;
11632 if (!PL_thisopen && !keep_delims) {
11633 PL_thisopen = newSVpvn(tstart, s - tstart);
11634 stuffstart = s - SvPVX(PL_linestr);
11638 if (PL_encoding && !UTF) {
11642 int offset = s - SvPVX_const(PL_linestr);
11643 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11644 &offset, (char*)termstr, termlen);
11645 const char * const ns = SvPVX_const(PL_linestr) + offset;
11646 char * const svlast = SvEND(sv) - 1;
11648 for (; s < ns; s++) {
11649 if (*s == '\n' && !PL_rsfp)
11650 CopLINE_inc(PL_curcop);
11653 goto read_more_line;
11655 /* handle quoted delimiters */
11656 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11658 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11660 if ((svlast-1 - t) % 2) {
11661 if (!keep_quoted) {
11662 *(svlast-1) = term;
11664 SvCUR_set(sv, SvCUR(sv) - 1);
11669 if (PL_multi_open == PL_multi_close) {
11675 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11676 /* At here, all closes are "was quoted" one,
11677 so we don't check PL_multi_close. */
11679 if (!keep_quoted && *(t+1) == PL_multi_open)
11684 else if (*t == PL_multi_open)
11692 SvCUR_set(sv, w - SvPVX_const(sv));
11694 last_off = w - SvPVX(sv);
11695 if (--brackets <= 0)
11700 if (!keep_delims) {
11701 SvCUR_set(sv, SvCUR(sv) - 1);
11707 /* extend sv if need be */
11708 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11709 /* set 'to' to the next character in the sv's string */
11710 to = SvPVX(sv)+SvCUR(sv);
11712 /* if open delimiter is the close delimiter read unbridle */
11713 if (PL_multi_open == PL_multi_close) {
11714 for (; s < PL_bufend; s++,to++) {
11715 /* embedded newlines increment the current line number */
11716 if (*s == '\n' && !PL_rsfp)
11717 CopLINE_inc(PL_curcop);
11718 /* handle quoted delimiters */
11719 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11720 if (!keep_quoted && s[1] == term)
11722 /* any other quotes are simply copied straight through */
11726 /* terminate when run out of buffer (the for() condition), or
11727 have found the terminator */
11728 else if (*s == term) {
11731 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11734 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11740 /* if the terminator isn't the same as the start character (e.g.,
11741 matched brackets), we have to allow more in the quoting, and
11742 be prepared for nested brackets.
11745 /* read until we run out of string, or we find the terminator */
11746 for (; s < PL_bufend; s++,to++) {
11747 /* embedded newlines increment the line count */
11748 if (*s == '\n' && !PL_rsfp)
11749 CopLINE_inc(PL_curcop);
11750 /* backslashes can escape the open or closing characters */
11751 if (*s == '\\' && s+1 < PL_bufend) {
11752 if (!keep_quoted &&
11753 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11758 /* allow nested opens and closes */
11759 else if (*s == PL_multi_close && --brackets <= 0)
11761 else if (*s == PL_multi_open)
11763 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11768 /* terminate the copied string and update the sv's end-of-string */
11770 SvCUR_set(sv, to - SvPVX_const(sv));
11773 * this next chunk reads more into the buffer if we're not done yet
11777 break; /* handle case where we are done yet :-) */
11779 #ifndef PERL_STRICT_CR
11780 if (to - SvPVX_const(sv) >= 2) {
11781 if ((to[-2] == '\r' && to[-1] == '\n') ||
11782 (to[-2] == '\n' && to[-1] == '\r'))
11786 SvCUR_set(sv, to - SvPVX_const(sv));
11788 else if (to[-1] == '\r')
11791 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11796 /* if we're out of file, or a read fails, bail and reset the current
11797 line marker so we can report where the unterminated string began
11800 if (PL_madskills) {
11801 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11803 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11805 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11809 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11811 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11817 /* we read a line, so increment our line counter */
11818 CopLINE_inc(PL_curcop);
11820 /* update debugger info */
11821 if (PERLDB_LINE && PL_curstash != PL_debstash)
11822 update_debugger_info(PL_linestr, NULL, 0);
11824 /* having changed the buffer, we must update PL_bufend */
11825 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11826 PL_last_lop = PL_last_uni = NULL;
11829 /* at this point, we have successfully read the delimited string */
11831 if (!PL_encoding || UTF) {
11833 if (PL_madskills) {
11834 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11835 const int len = s - tstart;
11837 sv_catpvn(PL_thisstuff, tstart, len);
11839 PL_thisstuff = newSVpvn(tstart, len);
11840 if (!PL_thisclose && !keep_delims)
11841 PL_thisclose = newSVpvn(s,termlen);
11846 sv_catpvn(sv, s, termlen);
11851 if (PL_madskills) {
11852 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11853 const int len = s - tstart - termlen;
11855 sv_catpvn(PL_thisstuff, tstart, len);
11857 PL_thisstuff = newSVpvn(tstart, len);
11858 if (!PL_thisclose && !keep_delims)
11859 PL_thisclose = newSVpvn(s - termlen,termlen);
11863 if (has_utf8 || PL_encoding)
11866 PL_multi_end = CopLINE(PL_curcop);
11868 /* if we allocated too much space, give some back */
11869 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11870 SvLEN_set(sv, SvCUR(sv) + 1);
11871 SvPV_renew(sv, SvLEN(sv));
11874 /* decide whether this is the first or second quoted string we've read
11887 takes: pointer to position in buffer
11888 returns: pointer to new position in buffer
11889 side-effects: builds ops for the constant in yylval.op
11891 Read a number in any of the formats that Perl accepts:
11893 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
11894 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
11897 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11899 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11902 If it reads a number without a decimal point or an exponent, it will
11903 try converting the number to an integer and see if it can do so
11904 without loss of precision.
11908 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11911 register const char *s = start; /* current position in buffer */
11912 register char *d; /* destination in temp buffer */
11913 register char *e; /* end of temp buffer */
11914 NV nv; /* number read, as a double */
11915 SV *sv = NULL; /* place to put the converted number */
11916 bool floatit; /* boolean: int or float? */
11917 const char *lastub = NULL; /* position of last underbar */
11918 static char const number_too_long[] = "Number too long";
11920 /* We use the first character to decide what type of number this is */
11924 Perl_croak(aTHX_ "panic: scan_num");
11926 /* if it starts with a 0, it could be an octal number, a decimal in
11927 0.13 disguise, or a hexadecimal number, or a binary number. */
11931 u holds the "number so far"
11932 shift the power of 2 of the base
11933 (hex == 4, octal == 3, binary == 1)
11934 overflowed was the number more than we can hold?
11936 Shift is used when we add a digit. It also serves as an "are
11937 we in octal/hex/binary?" indicator to disallow hex characters
11938 when in octal mode.
11943 bool overflowed = FALSE;
11944 bool just_zero = TRUE; /* just plain 0 or binary number? */
11945 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11946 static const char* const bases[5] =
11947 { "", "binary", "", "octal", "hexadecimal" };
11948 static const char* const Bases[5] =
11949 { "", "Binary", "", "Octal", "Hexadecimal" };
11950 static const char* const maxima[5] =
11952 "0b11111111111111111111111111111111",
11956 const char *base, *Base, *max;
11958 /* check for hex */
11963 } else if (s[1] == 'b') {
11968 /* check for a decimal in disguise */
11969 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11971 /* so it must be octal */
11978 if (ckWARN(WARN_SYNTAX))
11979 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11980 "Misplaced _ in number");
11984 base = bases[shift];
11985 Base = Bases[shift];
11986 max = maxima[shift];
11988 /* read the rest of the number */
11990 /* x is used in the overflow test,
11991 b is the digit we're adding on. */
11996 /* if we don't mention it, we're done */
12000 /* _ are ignored -- but warned about if consecutive */
12002 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12003 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12004 "Misplaced _ in number");
12008 /* 8 and 9 are not octal */
12009 case '8': case '9':
12011 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
12015 case '2': case '3': case '4':
12016 case '5': case '6': case '7':
12018 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
12021 case '0': case '1':
12022 b = *s++ & 15; /* ASCII digit -> value of digit */
12026 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
12027 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
12028 /* make sure they said 0x */
12031 b = (*s++ & 7) + 9;
12033 /* Prepare to put the digit we have onto the end
12034 of the number so far. We check for overflows.
12040 x = u << shift; /* make room for the digit */
12042 if ((x >> shift) != u
12043 && !(PL_hints & HINT_NEW_BINARY)) {
12046 if (ckWARN_d(WARN_OVERFLOW))
12047 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12048 "Integer overflow in %s number",
12051 u = x | b; /* add the digit to the end */
12054 n *= nvshift[shift];
12055 /* If an NV has not enough bits in its
12056 * mantissa to represent an UV this summing of
12057 * small low-order numbers is a waste of time
12058 * (because the NV cannot preserve the
12059 * low-order bits anyway): we could just
12060 * remember when did we overflow and in the
12061 * end just multiply n by the right
12069 /* if we get here, we had success: make a scalar value from
12074 /* final misplaced underbar check */
12075 if (s[-1] == '_') {
12076 if (ckWARN(WARN_SYNTAX))
12077 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12082 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12083 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12084 "%s number > %s non-portable",
12090 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12091 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12092 "%s number > %s non-portable",
12097 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12098 sv = new_constant(start, s - start, "integer",
12100 else if (PL_hints & HINT_NEW_BINARY)
12101 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
12106 handle decimal numbers.
12107 we're also sent here when we read a 0 as the first digit
12109 case '1': case '2': case '3': case '4': case '5':
12110 case '6': case '7': case '8': case '9': case '.':
12113 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12116 /* read next group of digits and _ and copy into d */
12117 while (isDIGIT(*s) || *s == '_') {
12118 /* skip underscores, checking for misplaced ones
12122 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12123 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12124 "Misplaced _ in number");
12128 /* check for end of fixed-length buffer */
12130 Perl_croak(aTHX_ number_too_long);
12131 /* if we're ok, copy the character */
12136 /* final misplaced underbar check */
12137 if (lastub && s == lastub + 1) {
12138 if (ckWARN(WARN_SYNTAX))
12139 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12142 /* read a decimal portion if there is one. avoid
12143 3..5 being interpreted as the number 3. followed
12146 if (*s == '.' && s[1] != '.') {
12151 if (ckWARN(WARN_SYNTAX))
12152 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12153 "Misplaced _ in number");
12157 /* copy, ignoring underbars, until we run out of digits.
12159 for (; isDIGIT(*s) || *s == '_'; s++) {
12160 /* fixed length buffer check */
12162 Perl_croak(aTHX_ number_too_long);
12164 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12165 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12166 "Misplaced _ in number");
12172 /* fractional part ending in underbar? */
12173 if (s[-1] == '_') {
12174 if (ckWARN(WARN_SYNTAX))
12175 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12176 "Misplaced _ in number");
12178 if (*s == '.' && isDIGIT(s[1])) {
12179 /* oops, it's really a v-string, but without the "v" */
12185 /* read exponent part, if present */
12186 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12190 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12191 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12193 /* stray preinitial _ */
12195 if (ckWARN(WARN_SYNTAX))
12196 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12197 "Misplaced _ in number");
12201 /* allow positive or negative exponent */
12202 if (*s == '+' || *s == '-')
12205 /* stray initial _ */
12207 if (ckWARN(WARN_SYNTAX))
12208 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12209 "Misplaced _ in number");
12213 /* read digits of exponent */
12214 while (isDIGIT(*s) || *s == '_') {
12217 Perl_croak(aTHX_ number_too_long);
12221 if (((lastub && s == lastub + 1) ||
12222 (!isDIGIT(s[1]) && s[1] != '_'))
12223 && ckWARN(WARN_SYNTAX))
12224 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12225 "Misplaced _ in number");
12232 /* make an sv from the string */
12236 We try to do an integer conversion first if no characters
12237 indicating "float" have been found.
12242 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12244 if (flags == IS_NUMBER_IN_UV) {
12246 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12249 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12250 if (uv <= (UV) IV_MIN)
12251 sv_setiv(sv, -(IV)uv);
12258 /* terminate the string */
12260 nv = Atof(PL_tokenbuf);
12264 if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12265 (PL_hints & HINT_NEW_INTEGER) )
12266 sv = new_constant(PL_tokenbuf,
12269 (floatit ? "float" : "integer"),
12273 /* if it starts with a v, it could be a v-string */
12276 sv = newSV(5); /* preallocate storage space */
12277 s = scan_vstring(s, PL_bufend, sv);
12281 /* make the op for the constant and return */
12284 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12286 lvalp->opval = NULL;
12292 S_scan_formline(pTHX_ register char *s)
12295 register char *eol;
12297 SV * const stuff = newSVpvs("");
12298 bool needargs = FALSE;
12299 bool eofmt = FALSE;
12301 char *tokenstart = s;
12304 if (PL_madskills) {
12305 savewhite = PL_thiswhite;
12310 while (!needargs) {
12313 #ifdef PERL_STRICT_CR
12314 while (SPACE_OR_TAB(*t))
12317 while (SPACE_OR_TAB(*t) || *t == '\r')
12320 if (*t == '\n' || t == PL_bufend) {
12325 if (PL_in_eval && !PL_rsfp) {
12326 eol = (char *) memchr(s,'\n',PL_bufend-s);
12331 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12333 for (t = s; t < eol; t++) {
12334 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12336 goto enough; /* ~~ must be first line in formline */
12338 if (*t == '@' || *t == '^')
12342 sv_catpvn(stuff, s, eol-s);
12343 #ifndef PERL_STRICT_CR
12344 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12345 char *end = SvPVX(stuff) + SvCUR(stuff);
12348 SvCUR_set(stuff, SvCUR(stuff) - 1);
12358 if (PL_madskills) {
12360 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12362 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12365 s = filter_gets(PL_linestr, PL_rsfp, 0);
12367 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12369 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12371 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12372 PL_last_lop = PL_last_uni = NULL;
12381 if (SvCUR(stuff)) {
12384 PL_lex_state = LEX_NORMAL;
12385 start_force(PL_curforce);
12386 NEXTVAL_NEXTTOKE.ival = 0;
12390 PL_lex_state = LEX_FORMLINE;
12392 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12394 else if (PL_encoding)
12395 sv_recode_to_utf8(stuff, PL_encoding);
12397 start_force(PL_curforce);
12398 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12400 start_force(PL_curforce);
12401 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12405 SvREFCNT_dec(stuff);
12407 PL_lex_formbrack = 0;
12411 if (PL_madskills) {
12413 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12415 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12416 PL_thiswhite = savewhite;
12428 PL_cshlen = strlen(PL_cshname);
12430 #if defined(USE_ITHREADS)
12431 PERL_UNUSED_CONTEXT;
12437 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12440 const I32 oldsavestack_ix = PL_savestack_ix;
12441 CV* const outsidecv = PL_compcv;
12444 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12446 SAVEI32(PL_subline);
12447 save_item(PL_subname);
12448 SAVESPTR(PL_compcv);
12450 PL_compcv = (CV*)newSV_type(is_format ? SVt_PVFM : SVt_PVCV);
12451 CvFLAGS(PL_compcv) |= flags;
12453 PL_subline = CopLINE(PL_curcop);
12454 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12455 CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12456 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12458 return oldsavestack_ix;
12462 #pragma segment Perl_yylex
12465 Perl_yywarn(pTHX_ const char *s)
12468 PL_in_eval |= EVAL_WARNONLY;
12470 PL_in_eval &= ~EVAL_WARNONLY;
12475 Perl_yyerror(pTHX_ const char *s)
12478 const char *where = NULL;
12479 const char *context = NULL;
12482 int yychar = PL_parser->yychar;
12484 if (!yychar || (yychar == ';' && !PL_rsfp))
12486 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12487 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12488 PL_oldbufptr != PL_bufptr) {
12491 The code below is removed for NetWare because it abends/crashes on NetWare
12492 when the script has error such as not having the closing quotes like:
12493 if ($var eq "value)
12494 Checking of white spaces is anyway done in NetWare code.
12497 while (isSPACE(*PL_oldoldbufptr))
12500 context = PL_oldoldbufptr;
12501 contlen = PL_bufptr - PL_oldoldbufptr;
12503 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12504 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12507 The code below is removed for NetWare because it abends/crashes on NetWare
12508 when the script has error such as not having the closing quotes like:
12509 if ($var eq "value)
12510 Checking of white spaces is anyway done in NetWare code.
12513 while (isSPACE(*PL_oldbufptr))
12516 context = PL_oldbufptr;
12517 contlen = PL_bufptr - PL_oldbufptr;
12519 else if (yychar > 255)
12520 where = "next token ???";
12521 else if (yychar == -2) { /* YYEMPTY */
12522 if (PL_lex_state == LEX_NORMAL ||
12523 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12524 where = "at end of line";
12525 else if (PL_lex_inpat)
12526 where = "within pattern";
12528 where = "within string";
12531 SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12533 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12534 else if (isPRINT_LC(yychar))
12535 Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12537 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12538 where = SvPVX_const(where_sv);
12540 msg = sv_2mortal(newSVpv(s, 0));
12541 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12542 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12544 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12546 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12547 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12548 Perl_sv_catpvf(aTHX_ msg,
12549 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12550 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12553 if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12554 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12557 if (PL_error_count >= 10) {
12558 if (PL_in_eval && SvCUR(ERRSV))
12559 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12560 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12562 Perl_croak(aTHX_ "%s has too many errors.\n",
12563 OutCopFILE(PL_curcop));
12566 PL_in_my_stash = NULL;
12570 #pragma segment Main
12574 S_swallow_bom(pTHX_ U8 *s)
12577 const STRLEN slen = SvCUR(PL_linestr);
12580 if (s[1] == 0xFE) {
12581 /* UTF-16 little-endian? (or UTF32-LE?) */
12582 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12583 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12584 #ifndef PERL_NO_UTF16_FILTER
12585 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12588 if (PL_bufend > (char*)s) {
12592 filter_add(utf16rev_textfilter, NULL);
12593 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12594 utf16_to_utf8_reversed(s, news,
12595 PL_bufend - (char*)s - 1,
12597 sv_setpvn(PL_linestr, (const char*)news, newlen);
12599 s = (U8*)SvPVX(PL_linestr);
12600 Copy(news, s, newlen, U8);
12604 SvUTF8_on(PL_linestr);
12605 s = (U8*)SvPVX(PL_linestr);
12607 /* FIXME - is this a general bug fix? */
12610 PL_bufend = SvPVX(PL_linestr) + newlen;
12613 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12618 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12619 #ifndef PERL_NO_UTF16_FILTER
12620 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12623 if (PL_bufend > (char *)s) {
12627 filter_add(utf16_textfilter, NULL);
12628 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12629 utf16_to_utf8(s, news,
12630 PL_bufend - (char*)s,
12632 sv_setpvn(PL_linestr, (const char*)news, newlen);
12634 SvUTF8_on(PL_linestr);
12635 s = (U8*)SvPVX(PL_linestr);
12636 PL_bufend = SvPVX(PL_linestr) + newlen;
12639 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12644 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12645 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12646 s += 3; /* UTF-8 */
12652 if (s[2] == 0xFE && s[3] == 0xFF) {
12653 /* UTF-32 big-endian */
12654 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12657 else if (s[2] == 0 && s[3] != 0) {
12660 * are a good indicator of UTF-16BE. */
12661 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12667 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12668 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12669 s += 4; /* UTF-8 */
12675 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12678 * are a good indicator of UTF-16LE. */
12679 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12687 #ifndef PERL_NO_UTF16_FILTER
12689 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12692 const STRLEN old = SvCUR(sv);
12693 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12694 DEBUG_P(PerlIO_printf(Perl_debug_log,
12695 "utf16_textfilter(%p): %d %d (%d)\n",
12696 FPTR2DPTR(void *, utf16_textfilter),
12697 idx, maxlen, (int) count));
12701 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12702 Copy(SvPVX_const(sv), tmps, old, char);
12703 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12704 SvCUR(sv) - old, &newlen);
12705 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12707 DEBUG_P({sv_dump(sv);});
12712 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12715 const STRLEN old = SvCUR(sv);
12716 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12717 DEBUG_P(PerlIO_printf(Perl_debug_log,
12718 "utf16rev_textfilter(%p): %d %d (%d)\n",
12719 FPTR2DPTR(void *, utf16rev_textfilter),
12720 idx, maxlen, (int) count));
12724 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12725 Copy(SvPVX_const(sv), tmps, old, char);
12726 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12727 SvCUR(sv) - old, &newlen);
12728 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12730 DEBUG_P({ sv_dump(sv); });
12736 Returns a pointer to the next character after the parsed
12737 vstring, as well as updating the passed in sv.
12739 Function must be called like
12742 s = scan_vstring(s,e,sv);
12744 where s and e are the start and end of the string.
12745 The sv should already be large enough to store the vstring
12746 passed in, for performance reasons.
12751 Perl_scan_vstring(pTHX_ const char *s, const char *e, SV *sv)
12754 const char *pos = s;
12755 const char *start = s;
12756 if (*pos == 'v') pos++; /* get past 'v' */
12757 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12759 if ( *pos != '.') {
12760 /* this may not be a v-string if followed by => */
12761 const char *next = pos;
12762 while (next < e && isSPACE(*next))
12764 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12765 /* return string not v-string */
12766 sv_setpvn(sv,(char *)s,pos-s);
12767 return (char *)pos;
12771 if (!isALPHA(*pos)) {
12772 U8 tmpbuf[UTF8_MAXBYTES+1];
12775 s++; /* get past 'v' */
12777 sv_setpvn(sv, "", 0);
12780 /* this is atoi() that tolerates underscores */
12783 const char *end = pos;
12785 while (--end >= s) {
12787 const UV orev = rev;
12788 rev += (*end - '0') * mult;
12790 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12791 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12792 "Integer overflow in decimal number");
12796 if (rev > 0x7FFFFFFF)
12797 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12799 /* Append native character for the rev point */
12800 tmpend = uvchr_to_utf8(tmpbuf, rev);
12801 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12802 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12804 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12810 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12814 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12822 * c-indentation-style: bsd
12823 * c-basic-offset: 4
12824 * indent-tabs-mode: t
12827 * ex: set ts=8 sts=4 sw=4 noet: