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 new_constant(a,b,c,d,e,f,g) \
27 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
29 #define pl_yylval (PL_parser->yylval)
31 /* YYINITDEPTH -- initial size of the parser's stacks. */
32 #define YYINITDEPTH 200
34 /* XXX temporary backwards compatibility */
35 #define PL_lex_brackets (PL_parser->lex_brackets)
36 #define PL_lex_brackstack (PL_parser->lex_brackstack)
37 #define PL_lex_casemods (PL_parser->lex_casemods)
38 #define PL_lex_casestack (PL_parser->lex_casestack)
39 #define PL_lex_defer (PL_parser->lex_defer)
40 #define PL_lex_dojoin (PL_parser->lex_dojoin)
41 #define PL_lex_expect (PL_parser->lex_expect)
42 #define PL_lex_formbrack (PL_parser->lex_formbrack)
43 #define PL_lex_inpat (PL_parser->lex_inpat)
44 #define PL_lex_inwhat (PL_parser->lex_inwhat)
45 #define PL_lex_op (PL_parser->lex_op)
46 #define PL_lex_repl (PL_parser->lex_repl)
47 #define PL_lex_starts (PL_parser->lex_starts)
48 #define PL_lex_stuff (PL_parser->lex_stuff)
49 #define PL_multi_start (PL_parser->multi_start)
50 #define PL_multi_open (PL_parser->multi_open)
51 #define PL_multi_close (PL_parser->multi_close)
52 #define PL_pending_ident (PL_parser->pending_ident)
53 #define PL_preambled (PL_parser->preambled)
54 #define PL_sublex_info (PL_parser->sublex_info)
55 #define PL_linestr (PL_parser->linestr)
56 #define PL_expect (PL_parser->expect)
57 #define PL_copline (PL_parser->copline)
58 #define PL_bufptr (PL_parser->bufptr)
59 #define PL_oldbufptr (PL_parser->oldbufptr)
60 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
61 #define PL_linestart (PL_parser->linestart)
62 #define PL_bufend (PL_parser->bufend)
63 #define PL_last_uni (PL_parser->last_uni)
64 #define PL_last_lop (PL_parser->last_lop)
65 #define PL_last_lop_op (PL_parser->last_lop_op)
66 #define PL_lex_state (PL_parser->lex_state)
67 #define PL_rsfp (PL_parser->rsfp)
68 #define PL_rsfp_filters (PL_parser->rsfp_filters)
69 #define PL_in_my (PL_parser->in_my)
70 #define PL_in_my_stash (PL_parser->in_my_stash)
71 #define PL_tokenbuf (PL_parser->tokenbuf)
72 #define PL_multi_end (PL_parser->multi_end)
73 #define PL_error_count (PL_parser->error_count)
76 # define PL_endwhite (PL_parser->endwhite)
77 # define PL_faketokens (PL_parser->faketokens)
78 # define PL_lasttoke (PL_parser->lasttoke)
79 # define PL_nextwhite (PL_parser->nextwhite)
80 # define PL_realtokenstart (PL_parser->realtokenstart)
81 # define PL_skipwhite (PL_parser->skipwhite)
82 # define PL_thisclose (PL_parser->thisclose)
83 # define PL_thismad (PL_parser->thismad)
84 # define PL_thisopen (PL_parser->thisopen)
85 # define PL_thisstuff (PL_parser->thisstuff)
86 # define PL_thistoken (PL_parser->thistoken)
87 # define PL_thiswhite (PL_parser->thiswhite)
88 # define PL_thiswhite (PL_parser->thiswhite)
89 # define PL_nexttoke (PL_parser->nexttoke)
90 # define PL_curforce (PL_parser->curforce)
92 # define PL_nexttoke (PL_parser->nexttoke)
93 # define PL_nexttype (PL_parser->nexttype)
94 # define PL_nextval (PL_parser->nextval)
98 S_pending_ident(pTHX);
100 static const char ident_too_long[] = "Identifier too long";
101 static const char commaless_variable_list[] = "comma-less variable list";
103 #ifndef PERL_NO_UTF16_FILTER
104 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
105 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
109 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
110 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
112 # define CURMAD(slot,sv)
113 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
116 #define XFAKEBRACK 128
117 #define XENUMMASK 127
119 #ifdef USE_UTF8_SCRIPTS
120 # define UTF (!IN_BYTES)
122 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
125 /* In variables named $^X, these are the legal values for X.
126 * 1999-02-27 mjd-perl-patch@plover.com */
127 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
129 /* On MacOS, respect nonbreaking spaces */
130 #ifdef MACOS_TRADITIONAL
131 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
133 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
136 /* LEX_* are values for PL_lex_state, the state of the lexer.
137 * They are arranged oddly so that the guard on the switch statement
138 * can get by with a single comparison (if the compiler is smart enough).
141 /* #define LEX_NOTPARSING 11 is done in perl.h. */
143 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
144 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
145 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
146 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
147 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
149 /* at end of code, eg "$x" followed by: */
150 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
151 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
153 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
154 string or after \E, $foo, etc */
155 #define LEX_INTERPCONST 2 /* NOT USED */
156 #define LEX_FORMLINE 1 /* expecting a format line */
157 #define LEX_KNOWNEXT 0 /* next token known; just return it */
161 static const char* const lex_state_names[] = {
180 #include "keywords.h"
182 /* CLINE is a macro that ensures PL_copline has a sane value */
187 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
190 # define SKIPSPACE0(s) skipspace0(s)
191 # define SKIPSPACE1(s) skipspace1(s)
192 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
193 # define PEEKSPACE(s) skipspace2(s,0)
195 # define SKIPSPACE0(s) skipspace(s)
196 # define SKIPSPACE1(s) skipspace(s)
197 # define SKIPSPACE2(s,tsv) skipspace(s)
198 # define PEEKSPACE(s) skipspace(s)
202 * Convenience functions to return different tokens and prime the
203 * lexer for the next token. They all take an argument.
205 * TOKEN : generic token (used for '(', DOLSHARP, etc)
206 * OPERATOR : generic operator
207 * AOPERATOR : assignment operator
208 * PREBLOCK : beginning the block after an if, while, foreach, ...
209 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
210 * PREREF : *EXPR where EXPR is not a simple identifier
211 * TERM : expression term
212 * LOOPX : loop exiting command (goto, last, dump, etc)
213 * FTST : file test operator
214 * FUN0 : zero-argument function
215 * FUN1 : not used, except for not, which isn't a UNIOP
216 * BOop : bitwise or or xor
218 * SHop : shift operator
219 * PWop : power operator
220 * PMop : pattern-matching operator
221 * Aop : addition-level operator
222 * Mop : multiplication-level operator
223 * Eop : equality-testing operator
224 * Rop : relational operator <= != gt
226 * Also see LOP and lop() below.
229 #ifdef DEBUGGING /* Serve -DT. */
230 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
232 # define REPORT(retval) (retval)
235 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
236 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
237 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
238 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
239 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
240 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
241 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
242 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
243 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
244 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
245 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
246 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
247 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
248 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
249 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
250 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
251 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
252 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
253 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
254 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
256 /* This bit of chicanery makes a unary function followed by
257 * a parenthesis into a function with one argument, highest precedence.
258 * The UNIDOR macro is for unary functions that can be followed by the //
259 * operator (such as C<shift // 0>).
261 #define UNI2(f,x) { \
262 pl_yylval.ival = f; \
265 PL_last_uni = PL_oldbufptr; \
266 PL_last_lop_op = f; \
268 return REPORT( (int)FUNC1 ); \
270 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
272 #define UNI(f) UNI2(f,XTERM)
273 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
275 #define UNIBRACK(f) { \
276 pl_yylval.ival = f; \
278 PL_last_uni = PL_oldbufptr; \
280 return REPORT( (int)FUNC1 ); \
282 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
285 /* grandfather return to old style */
286 #define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
290 /* how to interpret the pl_yylval associated with the token */
294 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
300 static struct debug_tokens {
302 enum token_type type;
304 } const debug_tokens[] =
306 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
307 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
308 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
309 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
310 { ARROW, TOKENTYPE_NONE, "ARROW" },
311 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
312 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
313 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
314 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
315 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
316 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
317 { DO, TOKENTYPE_NONE, "DO" },
318 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
319 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
320 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
321 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
322 { ELSE, TOKENTYPE_NONE, "ELSE" },
323 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
324 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
325 { FOR, TOKENTYPE_IVAL, "FOR" },
326 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
327 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
328 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
329 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
330 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
331 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
332 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
333 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
334 { IF, TOKENTYPE_IVAL, "IF" },
335 { LABEL, TOKENTYPE_PVAL, "LABEL" },
336 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
337 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
338 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
339 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
340 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
341 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
342 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
343 { MY, TOKENTYPE_IVAL, "MY" },
344 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
345 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
346 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
347 { OROP, TOKENTYPE_IVAL, "OROP" },
348 { OROR, TOKENTYPE_NONE, "OROR" },
349 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
350 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
351 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
352 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
353 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
354 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
355 { PREINC, TOKENTYPE_NONE, "PREINC" },
356 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
357 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
358 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
359 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
360 { SUB, TOKENTYPE_NONE, "SUB" },
361 { THING, TOKENTYPE_OPVAL, "THING" },
362 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
363 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
364 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
365 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
366 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
367 { USE, TOKENTYPE_IVAL, "USE" },
368 { WHEN, TOKENTYPE_IVAL, "WHEN" },
369 { WHILE, TOKENTYPE_IVAL, "WHILE" },
370 { WORD, TOKENTYPE_OPVAL, "WORD" },
371 { 0, TOKENTYPE_NONE, NULL }
374 /* dump the returned token in rv, plus any optional arg in pl_yylval */
377 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
381 const char *name = NULL;
382 enum token_type type = TOKENTYPE_NONE;
383 const struct debug_tokens *p;
384 SV* const report = newSVpvs("<== ");
386 for (p = debug_tokens; p->token; p++) {
387 if (p->token == (int)rv) {
394 Perl_sv_catpv(aTHX_ report, name);
395 else if ((char)rv > ' ' && (char)rv < '~')
396 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
398 sv_catpvs(report, "EOF");
400 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
403 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
406 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
408 case TOKENTYPE_OPNUM:
409 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
410 PL_op_name[lvalp->ival]);
413 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
415 case TOKENTYPE_OPVAL:
417 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
418 PL_op_name[lvalp->opval->op_type]);
419 if (lvalp->opval->op_type == OP_CONST) {
420 Perl_sv_catpvf(aTHX_ report, " %s",
421 SvPEEK(cSVOPx_sv(lvalp->opval)));
426 sv_catpvs(report, "(opval=null)");
429 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
435 /* print the buffer with suitable escapes */
438 S_printbuf(pTHX_ const char *const fmt, const char *const s)
440 SV* const tmp = newSVpvs("");
441 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
450 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
451 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
455 S_ao(pTHX_ int toketype)
458 if (*PL_bufptr == '=') {
460 if (toketype == ANDAND)
461 pl_yylval.ival = OP_ANDASSIGN;
462 else if (toketype == OROR)
463 pl_yylval.ival = OP_ORASSIGN;
464 else if (toketype == DORDOR)
465 pl_yylval.ival = OP_DORASSIGN;
473 * When Perl expects an operator and finds something else, no_op
474 * prints the warning. It always prints "<something> found where
475 * operator expected. It prints "Missing semicolon on previous line?"
476 * if the surprise occurs at the start of the line. "do you need to
477 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
478 * where the compiler doesn't know if foo is a method call or a function.
479 * It prints "Missing operator before end of line" if there's nothing
480 * after the missing operator, or "... before <...>" if there is something
481 * after the missing operator.
485 S_no_op(pTHX_ const char *const what, char *s)
488 char * const oldbp = PL_bufptr;
489 const bool is_first = (PL_oldbufptr == PL_linestart);
495 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
496 if (ckWARN_d(WARN_SYNTAX)) {
498 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
499 "\t(Missing semicolon on previous line?)\n");
500 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
502 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
504 if (t < PL_bufptr && isSPACE(*t))
505 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
506 "\t(Do you need to predeclare %.*s?)\n",
507 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
511 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
512 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
520 * Complain about missing quote/regexp/heredoc terminator.
521 * If it's called with NULL then it cauterizes the line buffer.
522 * If we're in a delimited string and the delimiter is a control
523 * character, it's reformatted into a two-char sequence like ^C.
528 S_missingterm(pTHX_ char *s)
534 char * const nl = strrchr(s,'\n');
540 iscntrl(PL_multi_close)
542 PL_multi_close < 32 || PL_multi_close == 127
546 tmpbuf[1] = (char)toCTRL(PL_multi_close);
551 *tmpbuf = (char)PL_multi_close;
555 q = strchr(s,'"') ? '\'' : '"';
556 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
559 #define FEATURE_IS_ENABLED(name) \
560 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
561 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
562 /* The longest string we pass in. */
563 #define MAX_FEATURE_LEN (sizeof("switch")-1)
566 * S_feature_is_enabled
567 * Check whether the named feature is enabled.
570 S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
573 HV * const hinthv = GvHV(PL_hintgv);
574 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
575 assert(namelen <= MAX_FEATURE_LEN);
576 memcpy(&he_name[8], name, namelen);
578 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
586 Perl_deprecate(pTHX_ const char *const s)
588 if (ckWARN(WARN_DEPRECATED))
589 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
593 Perl_deprecate_old(pTHX_ const char *const s)
595 /* This function should NOT be called for any new deprecated warnings */
596 /* Use Perl_deprecate instead */
598 /* It is here to maintain backward compatibility with the pre-5.8 */
599 /* warnings category hierarchy. The "deprecated" category used to */
600 /* live under the "syntax" category. It is now a top-level category */
601 /* in its own right. */
603 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
604 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
605 "Use of %s is deprecated", s);
609 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
610 * utf16-to-utf8-reversed.
613 #ifdef PERL_CR_FILTER
617 register const char *s = SvPVX_const(sv);
618 register const char * const e = s + SvCUR(sv);
619 /* outer loop optimized to do nothing if there are no CR-LFs */
621 if (*s++ == '\r' && *s == '\n') {
622 /* hit a CR-LF, need to copy the rest */
623 register char *d = s - 1;
626 if (*s == '\r' && s[1] == '\n')
637 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
639 const I32 count = FILTER_READ(idx+1, sv, maxlen);
640 if (count > 0 && !maxlen)
651 * Create a parser object and initialise its parser and lexer fields
653 * rsfp is the opened file handle to read from (if any),
655 * line holds any initial content already read from the file (or in
656 * the case of no file, such as an eval, the whole contents);
658 * new_filter indicates that this is a new file and it shouldn't inherit
659 * the filters from the current parser (ie require).
663 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
666 const char *s = NULL;
668 yy_parser *parser, *oparser;
670 /* create and initialise a parser */
672 Newxz(parser, 1, yy_parser);
673 parser->old_parser = oparser = PL_parser;
676 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
677 parser->ps = parser->stack;
678 parser->stack_size = YYINITDEPTH;
680 parser->stack->state = 0;
681 parser->yyerrstatus = 0;
682 parser->yychar = YYEMPTY; /* Cause a token to be read. */
684 /* on scope exit, free this parser and restore any outer one */
686 parser->saved_curcop = PL_curcop;
688 /* initialise lexer state */
691 parser->curforce = -1;
693 parser->nexttoke = 0;
695 parser->copline = NOLINE;
696 parser->lex_state = LEX_NORMAL;
697 parser->expect = XSTATE;
699 parser->rsfp_filters = (new_filter || !oparser) ? newAV()
700 : (AV*)SvREFCNT_inc(oparser->rsfp_filters);
702 Newx(parser->lex_brackstack, 120, char);
703 Newx(parser->lex_casestack, 12, char);
704 *parser->lex_casestack = '\0';
707 s = SvPV_const(line, len);
713 parser->linestr = newSVpvs("\n;");
714 } else if (SvREADONLY(line) || s[len-1] != ';') {
715 parser->linestr = newSVsv(line);
717 sv_catpvs(parser->linestr, "\n;");
720 SvREFCNT_inc_simple_void_NN(line);
721 parser->linestr = line;
723 parser->oldoldbufptr =
726 parser->linestart = SvPVX(parser->linestr);
727 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
728 parser->last_lop = parser->last_uni = NULL;
732 /* delete a parser object */
735 Perl_parser_free(pTHX_ const yy_parser *parser)
737 PL_curcop = parser->saved_curcop;
738 SvREFCNT_dec(parser->linestr);
740 if (parser->rsfp == PerlIO_stdin())
741 PerlIO_clearerr(parser->rsfp);
742 else if (parser->rsfp && parser->old_parser
743 && parser->rsfp != parser->old_parser->rsfp)
744 PerlIO_close(parser->rsfp);
745 SvREFCNT_dec(parser->rsfp_filters);
747 Safefree(parser->stack);
748 Safefree(parser->lex_brackstack);
749 Safefree(parser->lex_casestack);
750 PL_parser = parser->old_parser;
757 * Finalizer for lexing operations. Must be called when the parser is
758 * done with the lexer.
765 PL_doextract = FALSE;
770 * This subroutine has nothing to do with tilting, whether at windmills
771 * or pinball tables. Its name is short for "increment line". It
772 * increments the current line number in CopLINE(PL_curcop) and checks
773 * to see whether the line starts with a comment of the form
774 * # line 500 "foo.pm"
775 * If so, it sets the current line number and file to the values in the comment.
779 S_incline(pTHX_ const char *s)
786 CopLINE_inc(PL_curcop);
789 while (SPACE_OR_TAB(*s))
791 if (strnEQ(s, "line", 4))
795 if (SPACE_OR_TAB(*s))
799 while (SPACE_OR_TAB(*s))
807 while (SPACE_OR_TAB(*s))
809 if (*s == '"' && (t = strchr(s+1, '"'))) {
819 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
821 if (*e != '\n' && *e != '\0')
822 return; /* false alarm */
825 const STRLEN len = t - s;
827 SV *const temp_sv = CopFILESV(PL_curcop);
833 tmplen = SvCUR(temp_sv);
839 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
840 /* must copy *{"::_<(eval N)[oldfilename:L]"}
841 * to *{"::_<newfilename"} */
842 /* However, the long form of evals is only turned on by the
843 debugger - usually they're "(eval %lu)" */
847 STRLEN tmplen2 = len;
848 if (tmplen + 2 <= sizeof smallbuf)
851 Newx(tmpbuf, tmplen + 2, char);
854 memcpy(tmpbuf + 2, cf, tmplen);
856 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
861 if (tmplen2 + 2 <= sizeof smallbuf)
864 Newx(tmpbuf2, tmplen2 + 2, char);
866 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
867 /* Either they malloc'd it, or we malloc'd it,
868 so no prefix is present in ours. */
873 memcpy(tmpbuf2 + 2, s, tmplen2);
876 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
878 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
879 /* adjust ${"::_<newfilename"} to store the new file name */
880 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
881 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
882 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
885 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
887 if (tmpbuf != smallbuf) Safefree(tmpbuf);
890 CopFILE_free(PL_curcop);
891 CopFILE_setn(PL_curcop, s, len);
893 CopLINE_set(PL_curcop, atoi(n)-1);
897 /* skip space before PL_thistoken */
900 S_skipspace0(pTHX_ register char *s)
907 PL_thiswhite = newSVpvs("");
908 sv_catsv(PL_thiswhite, PL_skipwhite);
909 sv_free(PL_skipwhite);
912 PL_realtokenstart = s - SvPVX(PL_linestr);
916 /* skip space after PL_thistoken */
919 S_skipspace1(pTHX_ register char *s)
921 const char *start = s;
922 I32 startoff = start - SvPVX(PL_linestr);
927 start = SvPVX(PL_linestr) + startoff;
928 if (!PL_thistoken && PL_realtokenstart >= 0) {
929 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
930 PL_thistoken = newSVpvn(tstart, start - tstart);
932 PL_realtokenstart = -1;
935 PL_nextwhite = newSVpvs("");
936 sv_catsv(PL_nextwhite, PL_skipwhite);
937 sv_free(PL_skipwhite);
944 S_skipspace2(pTHX_ register char *s, SV **svp)
947 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
948 const I32 startoff = s - SvPVX(PL_linestr);
951 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
952 if (!PL_madskills || !svp)
954 start = SvPVX(PL_linestr) + startoff;
955 if (!PL_thistoken && PL_realtokenstart >= 0) {
956 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
957 PL_thistoken = newSVpvn(tstart, start - tstart);
958 PL_realtokenstart = -1;
963 sv_setsv(*svp, PL_skipwhite);
964 sv_free(PL_skipwhite);
973 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
975 AV *av = CopFILEAVx(PL_curcop);
977 SV * const sv = newSV_type(SVt_PVMG);
979 sv_setsv(sv, orig_sv);
981 sv_setpvn(sv, buf, len);
984 av_store(av, (I32)CopLINE(PL_curcop), sv);
990 * Called to gobble the appropriate amount and type of whitespace.
991 * Skips comments as well.
995 S_skipspace(pTHX_ register char *s)
1000 int startoff = s - SvPVX(PL_linestr);
1003 sv_free(PL_skipwhite);
1008 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1009 while (s < PL_bufend && SPACE_OR_TAB(*s))
1019 SSize_t oldprevlen, oldoldprevlen;
1020 SSize_t oldloplen = 0, oldunilen = 0;
1021 while (s < PL_bufend && isSPACE(*s)) {
1022 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1027 if (s < PL_bufend && *s == '#') {
1028 while (s < PL_bufend && *s != '\n')
1030 if (s < PL_bufend) {
1032 if (PL_in_eval && !PL_rsfp) {
1039 /* only continue to recharge the buffer if we're at the end
1040 * of the buffer, we're not reading from a source filter, and
1041 * we're in normal lexing mode
1043 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1044 PL_lex_state == LEX_FORMLINE)
1051 /* try to recharge the buffer */
1053 curoff = s - SvPVX(PL_linestr);
1056 if ((s = filter_gets(PL_linestr, PL_rsfp,
1057 (prevlen = SvCUR(PL_linestr)))) == NULL)
1060 if (PL_madskills && curoff != startoff) {
1062 PL_skipwhite = newSVpvs("");
1063 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1067 /* mustn't throw out old stuff yet if madpropping */
1068 SvCUR(PL_linestr) = curoff;
1069 s = SvPVX(PL_linestr) + curoff;
1071 if (curoff && s[-1] == '\n')
1075 /* end of file. Add on the -p or -n magic */
1076 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1079 sv_catpvs(PL_linestr,
1080 ";}continue{print or die qq(-p destination: $!\\n);}");
1082 sv_setpvs(PL_linestr,
1083 ";}continue{print or die qq(-p destination: $!\\n);}");
1085 PL_minus_n = PL_minus_p = 0;
1087 else if (PL_minus_n) {
1089 sv_catpvn(PL_linestr, ";}", 2);
1091 sv_setpvn(PL_linestr, ";}", 2);
1097 sv_catpvn(PL_linestr,";", 1);
1099 sv_setpvn(PL_linestr,";", 1);
1102 /* reset variables for next time we lex */
1103 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1109 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1110 PL_last_lop = PL_last_uni = NULL;
1112 /* Close the filehandle. Could be from
1113 * STDIN, or a regular file. If we were reading code from
1114 * STDIN (because the commandline held no -e or filename)
1115 * then we don't close it, we reset it so the code can
1116 * read from STDIN too.
1119 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1120 PerlIO_clearerr(PL_rsfp);
1122 (void)PerlIO_close(PL_rsfp);
1127 /* not at end of file, so we only read another line */
1128 /* make corresponding updates to old pointers, for yyerror() */
1129 oldprevlen = PL_oldbufptr - PL_bufend;
1130 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1132 oldunilen = PL_last_uni - PL_bufend;
1134 oldloplen = PL_last_lop - PL_bufend;
1135 PL_linestart = PL_bufptr = s + prevlen;
1136 PL_bufend = s + SvCUR(PL_linestr);
1138 PL_oldbufptr = s + oldprevlen;
1139 PL_oldoldbufptr = s + oldoldprevlen;
1141 PL_last_uni = s + oldunilen;
1143 PL_last_lop = s + oldloplen;
1146 /* debugger active and we're not compiling the debugger code,
1147 * so store the line into the debugger's array of lines
1149 if (PERLDB_LINE && PL_curstash != PL_debstash)
1150 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1157 PL_skipwhite = newSVpvs("");
1158 curoff = s - SvPVX(PL_linestr);
1159 if (curoff - startoff)
1160 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1169 * Check the unary operators to ensure there's no ambiguity in how they're
1170 * used. An ambiguous piece of code would be:
1172 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1173 * the +5 is its argument.
1183 if (PL_oldoldbufptr != PL_last_uni)
1185 while (isSPACE(*PL_last_uni))
1188 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1190 if ((t = strchr(s, '(')) && t < PL_bufptr)
1193 if (ckWARN_d(WARN_AMBIGUOUS)){
1194 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1195 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1196 (int)(s - PL_last_uni), PL_last_uni);
1201 * LOP : macro to build a list operator. Its behaviour has been replaced
1202 * with a subroutine, S_lop() for which LOP is just another name.
1205 #define LOP(f,x) return lop(f,x,s)
1209 * Build a list operator (or something that might be one). The rules:
1210 * - if we have a next token, then it's a list operator [why?]
1211 * - if the next thing is an opening paren, then it's a function
1212 * - else it's a list operator
1216 S_lop(pTHX_ I32 f, int x, char *s)
1223 PL_last_lop = PL_oldbufptr;
1224 PL_last_lop_op = (OPCODE)f;
1227 return REPORT(LSTOP);
1230 return REPORT(LSTOP);
1233 return REPORT(FUNC);
1236 return REPORT(FUNC);
1238 return REPORT(LSTOP);
1244 * Sets up for an eventual force_next(). start_force(0) basically does
1245 * an unshift, while start_force(-1) does a push. yylex removes items
1250 S_start_force(pTHX_ int where)
1254 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1255 where = PL_lasttoke;
1256 assert(PL_curforce < 0 || PL_curforce == where);
1257 if (PL_curforce != where) {
1258 for (i = PL_lasttoke; i > where; --i) {
1259 PL_nexttoke[i] = PL_nexttoke[i-1];
1263 if (PL_curforce < 0) /* in case of duplicate start_force() */
1264 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1265 PL_curforce = where;
1268 curmad('^', newSVpvs(""));
1269 CURMAD('_', PL_nextwhite);
1274 S_curmad(pTHX_ char slot, SV *sv)
1280 if (PL_curforce < 0)
1281 where = &PL_thismad;
1283 where = &PL_nexttoke[PL_curforce].next_mad;
1286 sv_setpvn(sv, "", 0);
1289 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1291 else if (PL_encoding) {
1292 sv_recode_to_utf8(sv, PL_encoding);
1297 /* keep a slot open for the head of the list? */
1298 if (slot != '_' && *where && (*where)->mad_key == '^') {
1299 (*where)->mad_key = slot;
1300 sv_free((SV*)((*where)->mad_val));
1301 (*where)->mad_val = (void*)sv;
1304 addmad(newMADsv(slot, sv), where, 0);
1307 # define start_force(where) NOOP
1308 # define curmad(slot, sv) NOOP
1313 * When the lexer realizes it knows the next token (for instance,
1314 * it is reordering tokens for the parser) then it can call S_force_next
1315 * to know what token to return the next time the lexer is called. Caller
1316 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1317 * and possibly PL_expect to ensure the lexer handles the token correctly.
1321 S_force_next(pTHX_ I32 type)
1326 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1327 tokereport(THING, &NEXTVAL_NEXTTOKE);
1331 if (PL_curforce < 0)
1332 start_force(PL_lasttoke);
1333 PL_nexttoke[PL_curforce].next_type = type;
1334 if (PL_lex_state != LEX_KNOWNEXT)
1335 PL_lex_defer = PL_lex_state;
1336 PL_lex_state = LEX_KNOWNEXT;
1337 PL_lex_expect = PL_expect;
1340 PL_nexttype[PL_nexttoke] = type;
1342 if (PL_lex_state != LEX_KNOWNEXT) {
1343 PL_lex_defer = PL_lex_state;
1344 PL_lex_expect = PL_expect;
1345 PL_lex_state = LEX_KNOWNEXT;
1351 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1354 SV * const sv = newSVpvn_utf8(start, len,
1356 && is_utf8_string((const U8*)start, len));
1362 * When the lexer knows the next thing is a word (for instance, it has
1363 * just seen -> and it knows that the next char is a word char, then
1364 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1368 * char *start : buffer position (must be within PL_linestr)
1369 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1370 * int check_keyword : if true, Perl checks to make sure the word isn't
1371 * a keyword (do this if the word is a label, e.g. goto FOO)
1372 * int allow_pack : if true, : characters will also be allowed (require,
1373 * use, etc. do this)
1374 * int allow_initial_tick : used by the "sub" lexer only.
1378 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1384 start = SKIPSPACE1(start);
1386 if (isIDFIRST_lazy_if(s,UTF) ||
1387 (allow_pack && *s == ':') ||
1388 (allow_initial_tick && *s == '\'') )
1390 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1391 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1393 start_force(PL_curforce);
1395 curmad('X', newSVpvn(start,s-start));
1396 if (token == METHOD) {
1401 PL_expect = XOPERATOR;
1405 curmad('g', newSVpvs( "forced" ));
1406 NEXTVAL_NEXTTOKE.opval
1407 = (OP*)newSVOP(OP_CONST,0,
1408 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1409 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1417 * Called when the lexer wants $foo *foo &foo etc, but the program
1418 * text only contains the "foo" portion. The first argument is a pointer
1419 * to the "foo", and the second argument is the type symbol to prefix.
1420 * Forces the next token to be a "WORD".
1421 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1425 S_force_ident(pTHX_ register const char *s, int kind)
1429 const STRLEN len = strlen(s);
1430 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1431 start_force(PL_curforce);
1432 NEXTVAL_NEXTTOKE.opval = o;
1435 o->op_private = OPpCONST_ENTERED;
1436 /* XXX see note in pp_entereval() for why we forgo typo
1437 warnings if the symbol must be introduced in an eval.
1439 gv_fetchpvn_flags(s, len,
1440 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1442 kind == '$' ? SVt_PV :
1443 kind == '@' ? SVt_PVAV :
1444 kind == '%' ? SVt_PVHV :
1452 Perl_str_to_version(pTHX_ SV *sv)
1457 const char *start = SvPV_const(sv,len);
1458 const char * const end = start + len;
1459 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1460 while (start < end) {
1464 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1469 retval += ((NV)n)/nshift;
1478 * Forces the next token to be a version number.
1479 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1480 * and if "guessing" is TRUE, then no new token is created (and the caller
1481 * must use an alternative parsing method).
1485 S_force_version(pTHX_ char *s, int guessing)
1491 I32 startoff = s - SvPVX(PL_linestr);
1500 while (isDIGIT(*d) || *d == '_' || *d == '.')
1504 start_force(PL_curforce);
1505 curmad('X', newSVpvn(s,d-s));
1508 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1510 s = scan_num(s, &pl_yylval);
1511 version = pl_yylval.opval;
1512 ver = cSVOPx(version)->op_sv;
1513 if (SvPOK(ver) && !SvNIOK(ver)) {
1514 SvUPGRADE(ver, SVt_PVNV);
1515 SvNV_set(ver, str_to_version(ver));
1516 SvNOK_on(ver); /* hint that it is a version */
1519 else if (guessing) {
1522 sv_free(PL_nextwhite); /* let next token collect whitespace */
1524 s = SvPVX(PL_linestr) + startoff;
1532 if (PL_madskills && !version) {
1533 sv_free(PL_nextwhite); /* let next token collect whitespace */
1535 s = SvPVX(PL_linestr) + startoff;
1538 /* NOTE: The parser sees the package name and the VERSION swapped */
1539 start_force(PL_curforce);
1540 NEXTVAL_NEXTTOKE.opval = version;
1548 * Tokenize a quoted string passed in as an SV. It finds the next
1549 * chunk, up to end of string or a backslash. It may make a new
1550 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1555 S_tokeq(pTHX_ SV *sv)
1559 register char *send;
1567 s = SvPV_force(sv, len);
1568 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1571 while (s < send && *s != '\\')
1576 if ( PL_hints & HINT_NEW_STRING ) {
1577 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
1581 if (s + 1 < send && (s[1] == '\\'))
1582 s++; /* all that, just for this */
1587 SvCUR_set(sv, d - SvPVX_const(sv));
1589 if ( PL_hints & HINT_NEW_STRING )
1590 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
1595 * Now come three functions related to double-quote context,
1596 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1597 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1598 * interact with PL_lex_state, and create fake ( ... ) argument lists
1599 * to handle functions and concatenation.
1600 * They assume that whoever calls them will be setting up a fake
1601 * join call, because each subthing puts a ',' after it. This lets
1604 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1606 * (I'm not sure whether the spurious commas at the end of lcfirst's
1607 * arguments and join's arguments are created or not).
1612 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1614 * Pattern matching will set PL_lex_op to the pattern-matching op to
1615 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
1617 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1619 * Everything else becomes a FUNC.
1621 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1622 * had an OP_CONST or OP_READLINE). This just sets us up for a
1623 * call to S_sublex_push().
1627 S_sublex_start(pTHX)
1630 register const I32 op_type = pl_yylval.ival;
1632 if (op_type == OP_NULL) {
1633 pl_yylval.opval = PL_lex_op;
1637 if (op_type == OP_CONST || op_type == OP_READLINE) {
1638 SV *sv = tokeq(PL_lex_stuff);
1640 if (SvTYPE(sv) == SVt_PVIV) {
1641 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1643 const char * const p = SvPV_const(sv, len);
1644 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
1648 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1649 PL_lex_stuff = NULL;
1650 /* Allow <FH> // "foo" */
1651 if (op_type == OP_READLINE)
1652 PL_expect = XTERMORDORDOR;
1655 else if (op_type == OP_BACKTICK && PL_lex_op) {
1656 /* readpipe() vas overriden */
1657 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1658 pl_yylval.opval = PL_lex_op;
1660 PL_lex_stuff = NULL;
1664 PL_sublex_info.super_state = PL_lex_state;
1665 PL_sublex_info.sub_inwhat = (U16)op_type;
1666 PL_sublex_info.sub_op = PL_lex_op;
1667 PL_lex_state = LEX_INTERPPUSH;
1671 pl_yylval.opval = PL_lex_op;
1681 * Create a new scope to save the lexing state. The scope will be
1682 * ended in S_sublex_done. Returns a '(', starting the function arguments
1683 * to the uc, lc, etc. found before.
1684 * Sets PL_lex_state to LEX_INTERPCONCAT.
1693 PL_lex_state = PL_sublex_info.super_state;
1694 SAVEBOOL(PL_lex_dojoin);
1695 SAVEI32(PL_lex_brackets);
1696 SAVEI32(PL_lex_casemods);
1697 SAVEI32(PL_lex_starts);
1698 SAVEI8(PL_lex_state);
1699 SAVEVPTR(PL_lex_inpat);
1700 SAVEI16(PL_lex_inwhat);
1701 SAVECOPLINE(PL_curcop);
1702 SAVEPPTR(PL_bufptr);
1703 SAVEPPTR(PL_bufend);
1704 SAVEPPTR(PL_oldbufptr);
1705 SAVEPPTR(PL_oldoldbufptr);
1706 SAVEPPTR(PL_last_lop);
1707 SAVEPPTR(PL_last_uni);
1708 SAVEPPTR(PL_linestart);
1709 SAVESPTR(PL_linestr);
1710 SAVEGENERICPV(PL_lex_brackstack);
1711 SAVEGENERICPV(PL_lex_casestack);
1713 PL_linestr = PL_lex_stuff;
1714 PL_lex_stuff = NULL;
1716 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1717 = SvPVX(PL_linestr);
1718 PL_bufend += SvCUR(PL_linestr);
1719 PL_last_lop = PL_last_uni = NULL;
1720 SAVEFREESV(PL_linestr);
1722 PL_lex_dojoin = FALSE;
1723 PL_lex_brackets = 0;
1724 Newx(PL_lex_brackstack, 120, char);
1725 Newx(PL_lex_casestack, 12, char);
1726 PL_lex_casemods = 0;
1727 *PL_lex_casestack = '\0';
1729 PL_lex_state = LEX_INTERPCONCAT;
1730 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1732 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1733 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1734 PL_lex_inpat = PL_sublex_info.sub_op;
1736 PL_lex_inpat = NULL;
1743 * Restores lexer state after a S_sublex_push.
1750 if (!PL_lex_starts++) {
1751 SV * const sv = newSVpvs("");
1752 if (SvUTF8(PL_linestr))
1754 PL_expect = XOPERATOR;
1755 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1759 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1760 PL_lex_state = LEX_INTERPCASEMOD;
1764 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1765 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1766 PL_linestr = PL_lex_repl;
1768 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1769 PL_bufend += SvCUR(PL_linestr);
1770 PL_last_lop = PL_last_uni = NULL;
1771 SAVEFREESV(PL_linestr);
1772 PL_lex_dojoin = FALSE;
1773 PL_lex_brackets = 0;
1774 PL_lex_casemods = 0;
1775 *PL_lex_casestack = '\0';
1777 if (SvEVALED(PL_lex_repl)) {
1778 PL_lex_state = LEX_INTERPNORMAL;
1780 /* we don't clear PL_lex_repl here, so that we can check later
1781 whether this is an evalled subst; that means we rely on the
1782 logic to ensure sublex_done() is called again only via the
1783 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1786 PL_lex_state = LEX_INTERPCONCAT;
1796 PL_endwhite = newSVpvs("");
1797 sv_catsv(PL_endwhite, PL_thiswhite);
1801 sv_setpvn(PL_thistoken,"",0);
1803 PL_realtokenstart = -1;
1807 PL_bufend = SvPVX(PL_linestr);
1808 PL_bufend += SvCUR(PL_linestr);
1809 PL_expect = XOPERATOR;
1810 PL_sublex_info.sub_inwhat = 0;
1818 Extracts a pattern, double-quoted string, or transliteration. This
1821 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1822 processing a pattern (PL_lex_inpat is true), a transliteration
1823 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1825 Returns a pointer to the character scanned up to. If this is
1826 advanced from the start pointer supplied (i.e. if anything was
1827 successfully parsed), will leave an OP for the substring scanned
1828 in pl_yylval. Caller must intuit reason for not parsing further
1829 by looking at the next characters herself.
1833 double-quoted style: \r and \n
1834 regexp special ones: \D \s
1837 case and quoting: \U \Q \E
1838 stops on @ and $, but not for $ as tail anchor
1840 In transliterations:
1841 characters are VERY literal, except for - not at the start or end
1842 of the string, which indicates a range. If the range is in bytes,
1843 scan_const expands the range to the full set of intermediate
1844 characters. If the range is in utf8, the hyphen is replaced with
1845 a certain range mark which will be handled by pmtrans() in op.c.
1847 In double-quoted strings:
1849 double-quoted style: \r and \n
1851 deprecated backrefs: \1 (in substitution replacements)
1852 case and quoting: \U \Q \E
1855 scan_const does *not* construct ops to handle interpolated strings.
1856 It stops processing as soon as it finds an embedded $ or @ variable
1857 and leaves it to the caller to work out what's going on.
1859 embedded arrays (whether in pattern or not) could be:
1860 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1862 $ in double-quoted strings must be the symbol of an embedded scalar.
1864 $ in pattern could be $foo or could be tail anchor. Assumption:
1865 it's a tail anchor if $ is the last thing in the string, or if it's
1866 followed by one of "()| \r\n\t"
1868 \1 (backreferences) are turned into $1
1870 The structure of the code is
1871 while (there's a character to process) {
1872 handle transliteration ranges
1873 skip regexp comments /(?#comment)/ and codes /(?{code})/
1874 skip #-initiated comments in //x patterns
1875 check for embedded arrays
1876 check for embedded scalars
1878 leave intact backslashes from leaveit (below)
1879 deprecate \1 in substitution replacements
1880 handle string-changing backslashes \l \U \Q \E, etc.
1881 switch (what was escaped) {
1882 handle \- in a transliteration (becomes a literal -)
1883 handle \132 (octal characters)
1884 handle \x15 and \x{1234} (hex characters)
1885 handle \N{name} (named characters)
1886 handle \cV (control characters)
1887 handle printf-style backslashes (\f, \r, \n, etc)
1889 } (end if backslash)
1890 } (end while character to read)
1895 S_scan_const(pTHX_ char *start)
1898 register char *send = PL_bufend; /* end of the constant */
1899 SV *sv = newSV(send - start); /* sv for the constant */
1900 register char *s = start; /* start of the constant */
1901 register char *d = SvPVX(sv); /* destination for copies */
1902 bool dorange = FALSE; /* are we in a translit range? */
1903 bool didrange = FALSE; /* did we just finish a range? */
1904 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1905 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1908 UV literal_endpoint = 0;
1909 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1912 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1913 /* If we are doing a trans and we know we want UTF8 set expectation */
1914 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1915 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1919 while (s < send || dorange) {
1920 /* get transliterations out of the way (they're most literal) */
1921 if (PL_lex_inwhat == OP_TRANS) {
1922 /* expand a range A-Z to the full set of characters. AIE! */
1924 I32 i; /* current expanded character */
1925 I32 min; /* first character in range */
1926 I32 max; /* last character in range */
1937 char * const c = (char*)utf8_hop((U8*)d, -1);
1941 *c = (char)UTF_TO_NATIVE(0xff);
1942 /* mark the range as done, and continue */
1948 i = d - SvPVX_const(sv); /* remember current offset */
1951 SvLEN(sv) + (has_utf8 ?
1952 (512 - UTF_CONTINUATION_MARK +
1955 /* How many two-byte within 0..255: 128 in UTF-8,
1956 * 96 in UTF-8-mod. */
1958 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
1960 d = SvPVX(sv) + i; /* refresh d after realloc */
1964 for (j = 0; j <= 1; j++) {
1965 char * const c = (char*)utf8_hop((U8*)d, -1);
1966 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
1972 max = (U8)0xff; /* only to \xff */
1973 uvmax = uv; /* \x{100} to uvmax */
1975 d = c; /* eat endpoint chars */
1980 d -= 2; /* eat the first char and the - */
1981 min = (U8)*d; /* first char in range */
1982 max = (U8)d[1]; /* last char in range */
1989 "Invalid range \"%c-%c\" in transliteration operator",
1990 (char)min, (char)max);
1994 if (literal_endpoint == 2 &&
1995 ((isLOWER(min) && isLOWER(max)) ||
1996 (isUPPER(min) && isUPPER(max)))) {
1998 for (i = min; i <= max; i++)
2000 *d++ = NATIVE_TO_NEED(has_utf8,i);
2002 for (i = min; i <= max; i++)
2004 *d++ = NATIVE_TO_NEED(has_utf8,i);
2009 for (i = min; i <= max; i++)
2012 const U8 ch = (U8)NATIVE_TO_UTF(i);
2013 if (UNI_IS_INVARIANT(ch))
2016 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2017 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2026 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2028 *d++ = (char)UTF_TO_NATIVE(0xff);
2030 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2034 /* mark the range as done, and continue */
2038 literal_endpoint = 0;
2043 /* range begins (ignore - as first or last char) */
2044 else if (*s == '-' && s+1 < send && s != start) {
2046 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2053 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2063 literal_endpoint = 0;
2064 native_range = TRUE;
2069 /* if we get here, we're not doing a transliteration */
2071 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2072 except for the last char, which will be done separately. */
2073 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2075 while (s+1 < send && *s != ')')
2076 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2078 else if (s[2] == '{' /* This should match regcomp.c */
2079 || (s[2] == '?' && s[3] == '{'))
2082 char *regparse = s + (s[2] == '{' ? 3 : 4);
2085 while (count && (c = *regparse)) {
2086 if (c == '\\' && regparse[1])
2094 if (*regparse != ')')
2095 regparse--; /* Leave one char for continuation. */
2096 while (s < regparse)
2097 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2101 /* likewise skip #-initiated comments in //x patterns */
2102 else if (*s == '#' && PL_lex_inpat &&
2103 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2104 while (s+1 < send && *s != '\n')
2105 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2108 /* check for embedded arrays
2109 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2111 else if (*s == '@' && s[1]) {
2112 if (isALNUM_lazy_if(s+1,UTF))
2114 if (strchr(":'{$", s[1]))
2116 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2117 break; /* in regexp, neither @+ nor @- are interpolated */
2120 /* check for embedded scalars. only stop if we're sure it's a
2123 else if (*s == '$') {
2124 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2126 if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
2127 break; /* in regexp, $ might be tail anchor */
2130 /* End of else if chain - OP_TRANS rejoin rest */
2133 if (*s == '\\' && s+1 < send) {
2136 /* deprecate \1 in strings and substitution replacements */
2137 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2138 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2140 if (ckWARN(WARN_SYNTAX))
2141 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2146 /* string-change backslash escapes */
2147 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2151 /* skip any other backslash escapes in a pattern */
2152 else if (PL_lex_inpat) {
2153 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2154 goto default_action;
2157 /* if we get here, it's either a quoted -, or a digit */
2160 /* quoted - in transliterations */
2162 if (PL_lex_inwhat == OP_TRANS) {
2169 if ((isALPHA(*s) || isDIGIT(*s)) &&
2171 Perl_warner(aTHX_ packWARN(WARN_MISC),
2172 "Unrecognized escape \\%c passed through",
2174 /* default action is to copy the quoted character */
2175 goto default_action;
2178 /* \132 indicates an octal constant */
2179 case '0': case '1': case '2': case '3':
2180 case '4': case '5': case '6': case '7':
2184 uv = grok_oct(s, &len, &flags, NULL);
2187 goto NUM_ESCAPE_INSERT;
2189 /* \x24 indicates a hex constant */
2193 char* const e = strchr(s, '}');
2194 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2195 PERL_SCAN_DISALLOW_PREFIX;
2200 yyerror("Missing right brace on \\x{}");
2204 uv = grok_hex(s, &len, &flags, NULL);
2210 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2211 uv = grok_hex(s, &len, &flags, NULL);
2217 /* Insert oct or hex escaped character.
2218 * There will always enough room in sv since such
2219 * escapes will be longer than any UTF-8 sequence
2220 * they can end up as. */
2222 /* We need to map to chars to ASCII before doing the tests
2225 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2226 if (!has_utf8 && uv > 255) {
2227 /* Might need to recode whatever we have
2228 * accumulated so far if it contains any
2231 * (Can't we keep track of that and avoid
2232 * this rescan? --jhi)
2236 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2237 if (!NATIVE_IS_INVARIANT(*c)) {
2242 const STRLEN offset = d - SvPVX_const(sv);
2244 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2248 while (src >= (const U8 *)SvPVX_const(sv)) {
2249 if (!NATIVE_IS_INVARIANT(*src)) {
2250 const U8 ch = NATIVE_TO_ASCII(*src);
2251 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2252 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2262 if (has_utf8 || uv > 255) {
2263 d = (char*)uvchr_to_utf8((U8*)d, uv);
2265 if (PL_lex_inwhat == OP_TRANS &&
2266 PL_sublex_info.sub_op) {
2267 PL_sublex_info.sub_op->op_private |=
2268 (PL_lex_repl ? OPpTRANS_FROM_UTF
2272 if (uv > 255 && !dorange)
2273 native_range = FALSE;
2285 /* \N{LATIN SMALL LETTER A} is a named character */
2289 char* e = strchr(s, '}');
2295 yyerror("Missing right brace on \\N{}");
2299 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2301 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2302 PERL_SCAN_DISALLOW_PREFIX;
2305 uv = grok_hex(s, &len, &flags, NULL);
2306 if ( e > s && len != (STRLEN)(e - s) ) {
2310 goto NUM_ESCAPE_INSERT;
2312 res = newSVpvn(s + 1, e - s - 1);
2313 res = new_constant( NULL, 0, "charnames",
2314 res, NULL, s - 2, e - s + 3 );
2316 sv_utf8_upgrade(res);
2317 str = SvPV_const(res,len);
2318 #ifdef EBCDIC_NEVER_MIND
2319 /* charnames uses pack U and that has been
2320 * recently changed to do the below uni->native
2321 * mapping, so this would be redundant (and wrong,
2322 * the code point would be doubly converted).
2323 * But leave this in just in case the pack U change
2324 * gets revoked, but the semantics is still
2325 * desireable for charnames. --jhi */
2327 UV uv = utf8_to_uvchr((const U8*)str, 0);
2330 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2332 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2333 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2334 str = SvPV_const(res, len);
2338 if (!has_utf8 && SvUTF8(res)) {
2339 const char * const ostart = SvPVX_const(sv);
2340 SvCUR_set(sv, d - ostart);
2343 sv_utf8_upgrade(sv);
2344 /* this just broke our allocation above... */
2345 SvGROW(sv, (STRLEN)(send - start));
2346 d = SvPVX(sv) + SvCUR(sv);
2349 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2350 const char * const odest = SvPVX_const(sv);
2352 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2353 d = SvPVX(sv) + (d - odest);
2357 native_range = FALSE; /* \N{} is guessed to be Unicode */
2359 Copy(str, d, len, char);
2366 yyerror("Missing braces on \\N{}");
2369 /* \c is a control character */
2378 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2381 yyerror("Missing control char name in \\c");
2385 /* printf-style backslashes, formfeeds, newlines, etc */
2387 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2390 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2393 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2396 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2399 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2402 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2405 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2411 } /* end if (backslash) */
2418 /* If we started with encoded form, or already know we want it
2419 and then encode the next character */
2420 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2422 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2423 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2426 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2427 const STRLEN off = d - SvPVX_const(sv);
2428 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2430 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2433 if (uv > 255 && !dorange)
2434 native_range = FALSE;
2438 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2440 } /* while loop to process each character */
2442 /* terminate the string and set up the sv */
2444 SvCUR_set(sv, d - SvPVX_const(sv));
2445 if (SvCUR(sv) >= SvLEN(sv))
2446 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2449 if (PL_encoding && !has_utf8) {
2450 sv_recode_to_utf8(sv, PL_encoding);
2456 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2457 PL_sublex_info.sub_op->op_private |=
2458 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2462 /* shrink the sv if we allocated more than we used */
2463 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2464 SvPV_shrink_to_cur(sv);
2467 /* return the substring (via pl_yylval) only if we parsed anything */
2468 if (s > PL_bufptr) {
2469 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
2470 const char *const key = PL_lex_inpat ? "qr" : "q";
2471 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
2475 if (PL_lex_inwhat == OP_TRANS) {
2478 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
2486 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
2489 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2496 * Returns TRUE if there's more to the expression (e.g., a subscript),
2499 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2501 * ->[ and ->{ return TRUE
2502 * { and [ outside a pattern are always subscripts, so return TRUE
2503 * if we're outside a pattern and it's not { or [, then return FALSE
2504 * if we're in a pattern and the first char is a {
2505 * {4,5} (any digits around the comma) returns FALSE
2506 * if we're in a pattern and the first char is a [
2508 * [SOMETHING] has a funky algorithm to decide whether it's a
2509 * character class or not. It has to deal with things like
2510 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2511 * anything else returns TRUE
2514 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2517 S_intuit_more(pTHX_ register char *s)
2520 if (PL_lex_brackets)
2522 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2524 if (*s != '{' && *s != '[')
2529 /* In a pattern, so maybe we have {n,m}. */
2546 /* On the other hand, maybe we have a character class */
2549 if (*s == ']' || *s == '^')
2552 /* this is terrifying, and it works */
2553 int weight = 2; /* let's weigh the evidence */
2555 unsigned char un_char = 255, last_un_char;
2556 const char * const send = strchr(s,']');
2557 char tmpbuf[sizeof PL_tokenbuf * 4];
2559 if (!send) /* has to be an expression */
2562 Zero(seen,256,char);
2565 else if (isDIGIT(*s)) {
2567 if (isDIGIT(s[1]) && s[2] == ']')
2573 for (; s < send; s++) {
2574 last_un_char = un_char;
2575 un_char = (unsigned char)*s;
2580 weight -= seen[un_char] * 10;
2581 if (isALNUM_lazy_if(s+1,UTF)) {
2583 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2584 len = (int)strlen(tmpbuf);
2585 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2590 else if (*s == '$' && s[1] &&
2591 strchr("[#!%*<>()-=",s[1])) {
2592 if (/*{*/ strchr("])} =",s[2]))
2601 if (strchr("wds]",s[1]))
2603 else if (seen[(U8)'\''] || seen[(U8)'"'])
2605 else if (strchr("rnftbxcav",s[1]))
2607 else if (isDIGIT(s[1])) {
2609 while (s[1] && isDIGIT(s[1]))
2619 if (strchr("aA01! ",last_un_char))
2621 if (strchr("zZ79~",s[1]))
2623 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2624 weight -= 5; /* cope with negative subscript */
2627 if (!isALNUM(last_un_char)
2628 && !(last_un_char == '$' || last_un_char == '@'
2629 || last_un_char == '&')
2630 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2635 if (keyword(tmpbuf, d - tmpbuf, 0))
2638 if (un_char == last_un_char + 1)
2640 weight -= seen[un_char];
2645 if (weight >= 0) /* probably a character class */
2655 * Does all the checking to disambiguate
2657 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2658 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2660 * First argument is the stuff after the first token, e.g. "bar".
2662 * Not a method if bar is a filehandle.
2663 * Not a method if foo is a subroutine prototyped to take a filehandle.
2664 * Not a method if it's really "Foo $bar"
2665 * Method if it's "foo $bar"
2666 * Not a method if it's really "print foo $bar"
2667 * Method if it's really "foo package::" (interpreted as package->foo)
2668 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2669 * Not a method if bar is a filehandle or package, but is quoted with
2674 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2677 char *s = start + (*start == '$');
2678 char tmpbuf[sizeof PL_tokenbuf];
2686 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2690 const char *proto = SvPVX_const(cv);
2701 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2702 /* start is the beginning of the possible filehandle/object,
2703 * and s is the end of it
2704 * tmpbuf is a copy of it
2707 if (*start == '$') {
2708 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2709 isUPPER(*PL_tokenbuf))
2712 len = start - SvPVX(PL_linestr);
2716 start = SvPVX(PL_linestr) + len;
2720 return *s == '(' ? FUNCMETH : METHOD;
2722 if (!keyword(tmpbuf, len, 0)) {
2723 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2727 soff = s - SvPVX(PL_linestr);
2731 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2732 if (indirgv && GvCVu(indirgv))
2734 /* filehandle or package name makes it a method */
2735 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2737 soff = s - SvPVX(PL_linestr);
2740 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2741 return 0; /* no assumptions -- "=>" quotes bearword */
2743 start_force(PL_curforce);
2744 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2745 newSVpvn(tmpbuf,len));
2746 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2748 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2753 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2755 return *s == '(' ? FUNCMETH : METHOD;
2761 /* Encoded script support. filter_add() effectively inserts a
2762 * 'pre-processing' function into the current source input stream.
2763 * Note that the filter function only applies to the current source file
2764 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2766 * The datasv parameter (which may be NULL) can be used to pass
2767 * private data to this instance of the filter. The filter function
2768 * can recover the SV using the FILTER_DATA macro and use it to
2769 * store private buffers and state information.
2771 * The supplied datasv parameter is upgraded to a PVIO type
2772 * and the IoDIRP/IoANY field is used to store the function pointer,
2773 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2774 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2775 * private use must be set using malloc'd pointers.
2779 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2788 if (!PL_rsfp_filters)
2789 PL_rsfp_filters = newAV();
2792 SvUPGRADE(datasv, SVt_PVIO);
2793 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2794 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2795 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2796 FPTR2DPTR(void *, IoANY(datasv)),
2797 SvPV_nolen(datasv)));
2798 av_unshift(PL_rsfp_filters, 1);
2799 av_store(PL_rsfp_filters, 0, datasv) ;
2804 /* Delete most recently added instance of this filter function. */
2806 Perl_filter_del(pTHX_ filter_t funcp)
2812 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2813 FPTR2DPTR(void*, funcp)));
2815 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2817 /* if filter is on top of stack (usual case) just pop it off */
2818 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2819 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2820 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2821 IoANY(datasv) = (void *)NULL;
2822 sv_free(av_pop(PL_rsfp_filters));
2826 /* we need to search for the correct entry and clear it */
2827 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2831 /* Invoke the idxth filter function for the current rsfp. */
2832 /* maxlen 0 = read one text line */
2834 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2839 /* This API is bad. It should have been using unsigned int for maxlen.
2840 Not sure if we want to change the API, but if not we should sanity
2841 check the value here. */
2842 const unsigned int correct_length
2851 if (!PL_parser || !PL_rsfp_filters)
2853 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2854 /* Provide a default input filter to make life easy. */
2855 /* Note that we append to the line. This is handy. */
2856 DEBUG_P(PerlIO_printf(Perl_debug_log,
2857 "filter_read %d: from rsfp\n", idx));
2858 if (correct_length) {
2861 const int old_len = SvCUR(buf_sv);
2863 /* ensure buf_sv is large enough */
2864 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2865 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2866 correct_length)) <= 0) {
2867 if (PerlIO_error(PL_rsfp))
2868 return -1; /* error */
2870 return 0 ; /* end of file */
2872 SvCUR_set(buf_sv, old_len + len) ;
2875 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2876 if (PerlIO_error(PL_rsfp))
2877 return -1; /* error */
2879 return 0 ; /* end of file */
2882 return SvCUR(buf_sv);
2884 /* Skip this filter slot if filter has been deleted */
2885 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2886 DEBUG_P(PerlIO_printf(Perl_debug_log,
2887 "filter_read %d: skipped (filter deleted)\n",
2889 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2891 /* Get function pointer hidden within datasv */
2892 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2893 DEBUG_P(PerlIO_printf(Perl_debug_log,
2894 "filter_read %d: via function %p (%s)\n",
2895 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2896 /* Call function. The function is expected to */
2897 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2898 /* Return: <0:error, =0:eof, >0:not eof */
2899 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2903 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2906 #ifdef PERL_CR_FILTER
2907 if (!PL_rsfp_filters) {
2908 filter_add(S_cr_textfilter,NULL);
2911 if (PL_rsfp_filters) {
2913 SvCUR_set(sv, 0); /* start with empty line */
2914 if (FILTER_READ(0, sv, 0) > 0)
2915 return ( SvPVX(sv) ) ;
2920 return (sv_gets(sv, fp, append));
2924 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
2929 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2933 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2934 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2936 return GvHV(gv); /* Foo:: */
2939 /* use constant CLASS => 'MyClass' */
2940 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
2941 if (gv && GvCV(gv)) {
2942 SV * const sv = cv_const_sv(GvCV(gv));
2944 pkgname = SvPV_const(sv, len);
2947 return gv_stashpvn(pkgname, len, 0);
2951 * S_readpipe_override
2952 * Check whether readpipe() is overriden, and generates the appropriate
2953 * optree, provided sublex_start() is called afterwards.
2956 S_readpipe_override(pTHX)
2959 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
2960 pl_yylval.ival = OP_BACKTICK;
2962 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
2964 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
2965 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
2966 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
2968 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
2969 append_elem(OP_LIST,
2970 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
2971 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
2978 * The intent of this yylex wrapper is to minimize the changes to the
2979 * tokener when we aren't interested in collecting madprops. It remains
2980 * to be seen how successful this strategy will be...
2987 char *s = PL_bufptr;
2989 /* make sure PL_thiswhite is initialized */
2993 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2994 if (PL_pending_ident)
2995 return S_pending_ident(aTHX);
2997 /* previous token ate up our whitespace? */
2998 if (!PL_lasttoke && PL_nextwhite) {
2999 PL_thiswhite = PL_nextwhite;
3003 /* isolate the token, and figure out where it is without whitespace */
3004 PL_realtokenstart = -1;
3008 assert(PL_curforce < 0);
3010 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
3011 if (!PL_thistoken) {
3012 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3013 PL_thistoken = newSVpvs("");
3015 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3016 PL_thistoken = newSVpvn(tstart, s - tstart);
3019 if (PL_thismad) /* install head */
3020 CURMAD('X', PL_thistoken);
3023 /* last whitespace of a sublex? */
3024 if (optype == ')' && PL_endwhite) {
3025 CURMAD('X', PL_endwhite);
3030 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
3031 if (!PL_thiswhite && !PL_endwhite && !optype) {
3032 sv_free(PL_thistoken);
3037 /* put off final whitespace till peg */
3038 if (optype == ';' && !PL_rsfp) {
3039 PL_nextwhite = PL_thiswhite;
3042 else if (PL_thisopen) {
3043 CURMAD('q', PL_thisopen);
3045 sv_free(PL_thistoken);
3049 /* Store actual token text as madprop X */
3050 CURMAD('X', PL_thistoken);
3054 /* add preceding whitespace as madprop _ */
3055 CURMAD('_', PL_thiswhite);
3059 /* add quoted material as madprop = */
3060 CURMAD('=', PL_thisstuff);
3064 /* add terminating quote as madprop Q */
3065 CURMAD('Q', PL_thisclose);
3069 /* special processing based on optype */
3073 /* opval doesn't need a TOKEN since it can already store mp */
3083 if (pl_yylval.opval)
3084 append_madprops(PL_thismad, pl_yylval.opval, 0);
3092 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3101 /* remember any fake bracket that lexer is about to discard */
3102 if (PL_lex_brackets == 1 &&
3103 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3106 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3109 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3110 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3113 break; /* don't bother looking for trailing comment */
3122 /* attach a trailing comment to its statement instead of next token */
3126 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3128 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3130 if (*s == '\n' || *s == '#') {
3131 while (s < PL_bufend && *s != '\n')
3135 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3136 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3153 /* Create new token struct. Note: opvals return early above. */
3154 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
3161 S_tokenize_use(pTHX_ int is_use, char *s) {
3163 if (PL_expect != XSTATE)
3164 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3165 is_use ? "use" : "no"));
3167 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3168 s = force_version(s, TRUE);
3169 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3170 start_force(PL_curforce);
3171 NEXTVAL_NEXTTOKE.opval = NULL;
3174 else if (*s == 'v') {
3175 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3176 s = force_version(s, FALSE);
3180 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3181 s = force_version(s, FALSE);
3183 pl_yylval.ival = is_use;
3187 static const char* const exp_name[] =
3188 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3189 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3196 Works out what to call the token just pulled out of the input
3197 stream. The yacc parser takes care of taking the ops we return and
3198 stitching them into a tree.
3204 if read an identifier
3205 if we're in a my declaration
3206 croak if they tried to say my($foo::bar)
3207 build the ops for a my() declaration
3208 if it's an access to a my() variable
3209 are we in a sort block?
3210 croak if my($a); $a <=> $b
3211 build ops for access to a my() variable
3212 if in a dq string, and they've said @foo and we can't find @foo
3214 build ops for a bareword
3215 if we already built the token before, use it.
3220 #pragma segment Perl_yylex
3226 register char *s = PL_bufptr;
3231 /* orig_keyword, gvp, and gv are initialized here because
3232 * jump to the label just_a_word_zero can bypass their
3233 * initialization later. */
3234 I32 orig_keyword = 0;
3239 SV* tmp = newSVpvs("");
3240 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3241 (IV)CopLINE(PL_curcop),
3242 lex_state_names[PL_lex_state],
3243 exp_name[PL_expect],
3244 pv_display(tmp, s, strlen(s), 0, 60));
3247 /* check if there's an identifier for us to look at */
3248 if (PL_pending_ident)
3249 return REPORT(S_pending_ident(aTHX));
3251 /* no identifier pending identification */
3253 switch (PL_lex_state) {
3255 case LEX_NORMAL: /* Some compilers will produce faster */
3256 case LEX_INTERPNORMAL: /* code if we comment these out. */
3260 /* when we've already built the next token, just pull it out of the queue */
3264 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
3266 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3267 PL_nexttoke[PL_lasttoke].next_mad = 0;
3268 if (PL_thismad && PL_thismad->mad_key == '_') {
3269 PL_thiswhite = (SV*)PL_thismad->mad_val;
3270 PL_thismad->mad_val = 0;
3271 mad_free(PL_thismad);
3276 PL_lex_state = PL_lex_defer;
3277 PL_expect = PL_lex_expect;
3278 PL_lex_defer = LEX_NORMAL;
3279 if (!PL_nexttoke[PL_lasttoke].next_type)
3284 pl_yylval = PL_nextval[PL_nexttoke];
3286 PL_lex_state = PL_lex_defer;
3287 PL_expect = PL_lex_expect;
3288 PL_lex_defer = LEX_NORMAL;
3292 /* FIXME - can these be merged? */
3293 return(PL_nexttoke[PL_lasttoke].next_type);
3295 return REPORT(PL_nexttype[PL_nexttoke]);
3298 /* interpolated case modifiers like \L \U, including \Q and \E.
3299 when we get here, PL_bufptr is at the \
3301 case LEX_INTERPCASEMOD:
3303 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3304 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3306 /* handle \E or end of string */
3307 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3309 if (PL_lex_casemods) {
3310 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3311 PL_lex_casestack[PL_lex_casemods] = '\0';
3313 if (PL_bufptr != PL_bufend
3314 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3316 PL_lex_state = LEX_INTERPCONCAT;
3319 PL_thistoken = newSVpvs("\\E");
3325 while (PL_bufptr != PL_bufend &&
3326 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3328 PL_thiswhite = newSVpvs("");
3329 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3333 if (PL_bufptr != PL_bufend)
3336 PL_lex_state = LEX_INTERPCONCAT;
3340 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3341 "### Saw case modifier\n"); });
3343 if (s[1] == '\\' && s[2] == 'E') {
3346 PL_thiswhite = newSVpvs("");
3347 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3350 PL_lex_state = LEX_INTERPCONCAT;
3355 if (!PL_madskills) /* when just compiling don't need correct */
3356 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3357 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3358 if ((*s == 'L' || *s == 'U') &&
3359 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3360 PL_lex_casestack[--PL_lex_casemods] = '\0';
3363 if (PL_lex_casemods > 10)
3364 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3365 PL_lex_casestack[PL_lex_casemods++] = *s;
3366 PL_lex_casestack[PL_lex_casemods] = '\0';
3367 PL_lex_state = LEX_INTERPCONCAT;
3368 start_force(PL_curforce);
3369 NEXTVAL_NEXTTOKE.ival = 0;
3371 start_force(PL_curforce);
3373 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3375 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3377 NEXTVAL_NEXTTOKE.ival = OP_LC;
3379 NEXTVAL_NEXTTOKE.ival = OP_UC;
3381 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3383 Perl_croak(aTHX_ "panic: yylex");
3385 SV* const tmpsv = newSVpvs("\\ ");
3386 /* replace the space with the character we want to escape
3388 SvPVX(tmpsv)[1] = *s;
3394 if (PL_lex_starts) {
3400 sv_free(PL_thistoken);
3401 PL_thistoken = newSVpvs("");
3404 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3405 if (PL_lex_casemods == 1 && PL_lex_inpat)
3414 case LEX_INTERPPUSH:
3415 return REPORT(sublex_push());
3417 case LEX_INTERPSTART:
3418 if (PL_bufptr == PL_bufend)
3419 return REPORT(sublex_done());
3420 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3421 "### Interpolated variable\n"); });
3423 PL_lex_dojoin = (*PL_bufptr == '@');
3424 PL_lex_state = LEX_INTERPNORMAL;
3425 if (PL_lex_dojoin) {
3426 start_force(PL_curforce);
3427 NEXTVAL_NEXTTOKE.ival = 0;
3429 start_force(PL_curforce);
3430 force_ident("\"", '$');
3431 start_force(PL_curforce);
3432 NEXTVAL_NEXTTOKE.ival = 0;
3434 start_force(PL_curforce);
3435 NEXTVAL_NEXTTOKE.ival = 0;
3437 start_force(PL_curforce);
3438 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3441 if (PL_lex_starts++) {
3446 sv_free(PL_thistoken);
3447 PL_thistoken = newSVpvs("");
3450 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3451 if (!PL_lex_casemods && PL_lex_inpat)
3458 case LEX_INTERPENDMAYBE:
3459 if (intuit_more(PL_bufptr)) {
3460 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3466 if (PL_lex_dojoin) {
3467 PL_lex_dojoin = FALSE;
3468 PL_lex_state = LEX_INTERPCONCAT;
3472 sv_free(PL_thistoken);
3473 PL_thistoken = newSVpvs("");
3478 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3479 && SvEVALED(PL_lex_repl))
3481 if (PL_bufptr != PL_bufend)
3482 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3486 case LEX_INTERPCONCAT:
3488 if (PL_lex_brackets)
3489 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3491 if (PL_bufptr == PL_bufend)
3492 return REPORT(sublex_done());
3494 if (SvIVX(PL_linestr) == '\'') {
3495 SV *sv = newSVsv(PL_linestr);
3498 else if ( PL_hints & HINT_NEW_RE )
3499 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
3500 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3504 s = scan_const(PL_bufptr);
3506 PL_lex_state = LEX_INTERPCASEMOD;
3508 PL_lex_state = LEX_INTERPSTART;
3511 if (s != PL_bufptr) {
3512 start_force(PL_curforce);
3514 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3516 NEXTVAL_NEXTTOKE = pl_yylval;
3519 if (PL_lex_starts++) {
3523 sv_free(PL_thistoken);
3524 PL_thistoken = newSVpvs("");
3527 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3528 if (!PL_lex_casemods && PL_lex_inpat)
3541 PL_lex_state = LEX_NORMAL;
3542 s = scan_formline(PL_bufptr);
3543 if (!PL_lex_formbrack)
3549 PL_oldoldbufptr = PL_oldbufptr;
3555 sv_free(PL_thistoken);
3558 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3562 if (isIDFIRST_lazy_if(s,UTF))
3564 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
3565 Perl_croak(aTHX_ "Unrecognized character \\x%02X in column %d", *s & 255, (int) len + 1);
3568 goto fake_eof; /* emulate EOF on ^D or ^Z */
3577 if (PL_lex_brackets) {
3578 yyerror((const char *)
3580 ? "Format not terminated"
3581 : "Missing right curly or square bracket"));
3583 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3584 "### Tokener got EOF\n");
3588 if (s++ < PL_bufend)
3589 goto retry; /* ignore stray nulls */
3592 if (!PL_in_eval && !PL_preambled) {
3593 PL_preambled = TRUE;
3599 /* Generate a string of Perl code to load the debugger.
3600 * If PERL5DB is set, it will return the contents of that,
3601 * otherwise a compile-time require of perl5db.pl. */
3603 const char * const pdb = PerlEnv_getenv("PERL5DB");
3606 sv_setpv(PL_linestr, pdb);
3607 sv_catpvs(PL_linestr,";");
3609 SETERRNO(0,SS_NORMAL);
3610 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
3613 sv_setpvs(PL_linestr,"");
3614 if (PL_preambleav) {
3615 SV **svp = AvARRAY(PL_preambleav);
3616 SV **const end = svp + AvFILLp(PL_preambleav);
3618 sv_catsv(PL_linestr, *svp);
3620 sv_catpvs(PL_linestr, ";");
3622 sv_free((SV*)PL_preambleav);
3623 PL_preambleav = NULL;
3625 if (PL_minus_n || PL_minus_p) {
3626 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3628 sv_catpvs(PL_linestr,"chomp;");
3631 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3632 || *PL_splitstr == '"')
3633 && strchr(PL_splitstr + 1, *PL_splitstr))
3634 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3636 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3637 bytes can be used as quoting characters. :-) */
3638 const char *splits = PL_splitstr;
3639 sv_catpvs(PL_linestr, "our @F=split(q\0");
3642 if (*splits == '\\')
3643 sv_catpvn(PL_linestr, splits, 1);
3644 sv_catpvn(PL_linestr, splits, 1);
3645 } while (*splits++);
3646 /* This loop will embed the trailing NUL of
3647 PL_linestr as the last thing it does before
3649 sv_catpvs(PL_linestr, ");");
3653 sv_catpvs(PL_linestr,"our @F=split(' ');");
3657 sv_catpvs(PL_linestr,
3658 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
3659 sv_catpvs(PL_linestr, "\n");
3660 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3661 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3662 PL_last_lop = PL_last_uni = NULL;
3663 if (PERLDB_LINE && PL_curstash != PL_debstash)
3664 update_debugger_info(PL_linestr, NULL, 0);
3668 bof = PL_rsfp ? TRUE : FALSE;
3669 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3672 PL_realtokenstart = -1;
3675 if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3676 PerlIO_clearerr(PL_rsfp);
3678 (void)PerlIO_close(PL_rsfp);
3680 PL_doextract = FALSE;
3682 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3688 sv_setpvs(PL_linestr, ";}continue{print;}");
3690 sv_setpvs(PL_linestr, ";}");
3691 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3692 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3693 PL_last_lop = PL_last_uni = NULL;
3694 PL_minus_n = PL_minus_p = 0;
3697 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3698 PL_last_lop = PL_last_uni = NULL;
3699 sv_setpvn(PL_linestr,"",0);
3700 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3702 /* If it looks like the start of a BOM or raw UTF-16,
3703 * check if it in fact is. */
3709 #ifdef PERLIO_IS_STDIO
3710 # ifdef __GNU_LIBRARY__
3711 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3712 # define FTELL_FOR_PIPE_IS_BROKEN
3716 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3717 # define FTELL_FOR_PIPE_IS_BROKEN
3722 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3724 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3725 s = swallow_bom((U8*)s);
3729 /* Incest with pod. */
3732 sv_catsv(PL_thiswhite, PL_linestr);
3734 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3735 sv_setpvn(PL_linestr, "", 0);
3736 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3737 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3738 PL_last_lop = PL_last_uni = NULL;
3739 PL_doextract = FALSE;
3743 } while (PL_doextract);
3744 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3745 if (PERLDB_LINE && PL_curstash != PL_debstash)
3746 update_debugger_info(PL_linestr, NULL, 0);
3747 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3748 PL_last_lop = PL_last_uni = NULL;
3749 if (CopLINE(PL_curcop) == 1) {
3750 while (s < PL_bufend && isSPACE(*s))
3752 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3756 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3760 if (*s == '#' && *(s+1) == '!')
3762 #ifdef ALTERNATE_SHEBANG
3764 static char const as[] = ALTERNATE_SHEBANG;
3765 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3766 d = s + (sizeof(as) - 1);
3768 #endif /* ALTERNATE_SHEBANG */
3777 while (*d && !isSPACE(*d))
3781 #ifdef ARG_ZERO_IS_SCRIPT
3782 if (ipathend > ipath) {
3784 * HP-UX (at least) sets argv[0] to the script name,
3785 * which makes $^X incorrect. And Digital UNIX and Linux,
3786 * at least, set argv[0] to the basename of the Perl
3787 * interpreter. So, having found "#!", we'll set it right.
3789 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3791 assert(SvPOK(x) || SvGMAGICAL(x));
3792 if (sv_eq(x, CopFILESV(PL_curcop))) {
3793 sv_setpvn(x, ipath, ipathend - ipath);
3799 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3800 const char * const lstart = SvPV_const(x,llen);
3802 bstart += blen - llen;
3803 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3804 sv_setpvn(x, ipath, ipathend - ipath);
3809 TAINT_NOT; /* $^X is always tainted, but that's OK */
3811 #endif /* ARG_ZERO_IS_SCRIPT */
3816 d = instr(s,"perl -");
3818 d = instr(s,"perl");
3820 /* avoid getting into infinite loops when shebang
3821 * line contains "Perl" rather than "perl" */
3823 for (d = ipathend-4; d >= ipath; --d) {
3824 if ((*d == 'p' || *d == 'P')
3825 && !ibcmp(d, "perl", 4))
3835 #ifdef ALTERNATE_SHEBANG
3837 * If the ALTERNATE_SHEBANG on this system starts with a
3838 * character that can be part of a Perl expression, then if
3839 * we see it but not "perl", we're probably looking at the
3840 * start of Perl code, not a request to hand off to some
3841 * other interpreter. Similarly, if "perl" is there, but
3842 * not in the first 'word' of the line, we assume the line
3843 * contains the start of the Perl program.
3845 if (d && *s != '#') {
3846 const char *c = ipath;
3847 while (*c && !strchr("; \t\r\n\f\v#", *c))
3850 d = NULL; /* "perl" not in first word; ignore */
3852 *s = '#'; /* Don't try to parse shebang line */
3854 #endif /* ALTERNATE_SHEBANG */
3855 #ifndef MACOS_TRADITIONAL
3860 !instr(s,"indir") &&
3861 instr(PL_origargv[0],"perl"))
3868 while (s < PL_bufend && isSPACE(*s))
3870 if (s < PL_bufend) {
3871 Newxz(newargv,PL_origargc+3,char*);
3873 while (s < PL_bufend && !isSPACE(*s))
3876 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3879 newargv = PL_origargv;
3882 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3884 Perl_croak(aTHX_ "Can't exec %s", ipath);
3888 while (*d && !isSPACE(*d))
3890 while (SPACE_OR_TAB(*d))
3894 const bool switches_done = PL_doswitches;
3895 const U32 oldpdb = PL_perldb;
3896 const bool oldn = PL_minus_n;
3897 const bool oldp = PL_minus_p;
3901 if (*d1 == 'M' || *d1 == 'm' || *d1 == 'C') {
3902 const char * const m = d1;
3903 while (*d1 && !isSPACE(*d1))
3905 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3908 d1 = moreswitches(d1);
3910 if (PL_doswitches && !switches_done) {
3911 int argc = PL_origargc;
3912 char **argv = PL_origargv;
3915 } while (argc && argv[0][0] == '-' && argv[0][1]);
3916 init_argv_symbols(argc,argv);
3918 if ((PERLDB_LINE && !oldpdb) ||
3919 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3920 /* if we have already added "LINE: while (<>) {",
3921 we must not do it again */
3923 sv_setpvn(PL_linestr, "", 0);
3924 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3925 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3926 PL_last_lop = PL_last_uni = NULL;
3927 PL_preambled = FALSE;
3929 (void)gv_fetchfile(PL_origfilename);
3936 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3938 PL_lex_state = LEX_FORMLINE;
3943 #ifdef PERL_STRICT_CR
3944 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3946 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3948 case ' ': case '\t': case '\f': case 013:
3949 #ifdef MACOS_TRADITIONAL
3953 PL_realtokenstart = -1;
3955 PL_thiswhite = newSVpvs("");
3956 sv_catpvn(PL_thiswhite, s, 1);
3963 PL_realtokenstart = -1;
3967 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3968 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3969 /* handle eval qq[#line 1 "foo"\n ...] */
3970 CopLINE_dec(PL_curcop);
3973 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3975 if (!PL_in_eval || PL_rsfp)
3980 while (d < PL_bufend && *d != '\n')
3984 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3985 Perl_croak(aTHX_ "panic: input overflow");
3988 PL_thiswhite = newSVpvn(s, d - s);
3993 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3995 PL_lex_state = LEX_FORMLINE;
4001 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
4002 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
4005 TOKEN(PEG); /* make sure any #! line is accessible */
4010 /* if (PL_madskills && PL_lex_formbrack) { */
4012 while (d < PL_bufend && *d != '\n')
4016 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4017 Perl_croak(aTHX_ "panic: input overflow");
4018 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4020 PL_thiswhite = newSVpvs("");
4021 if (CopLINE(PL_curcop) == 1) {
4022 sv_setpvn(PL_thiswhite, "", 0);
4025 sv_catpvn(PL_thiswhite, s, d - s);
4039 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4047 while (s < PL_bufend && SPACE_OR_TAB(*s))
4050 if (strnEQ(s,"=>",2)) {
4051 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4052 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4053 OPERATOR('-'); /* unary minus */
4055 PL_last_uni = PL_oldbufptr;
4057 case 'r': ftst = OP_FTEREAD; break;
4058 case 'w': ftst = OP_FTEWRITE; break;
4059 case 'x': ftst = OP_FTEEXEC; break;
4060 case 'o': ftst = OP_FTEOWNED; break;
4061 case 'R': ftst = OP_FTRREAD; break;
4062 case 'W': ftst = OP_FTRWRITE; break;
4063 case 'X': ftst = OP_FTREXEC; break;
4064 case 'O': ftst = OP_FTROWNED; break;
4065 case 'e': ftst = OP_FTIS; break;
4066 case 'z': ftst = OP_FTZERO; break;
4067 case 's': ftst = OP_FTSIZE; break;
4068 case 'f': ftst = OP_FTFILE; break;
4069 case 'd': ftst = OP_FTDIR; break;
4070 case 'l': ftst = OP_FTLINK; break;
4071 case 'p': ftst = OP_FTPIPE; break;
4072 case 'S': ftst = OP_FTSOCK; break;
4073 case 'u': ftst = OP_FTSUID; break;
4074 case 'g': ftst = OP_FTSGID; break;
4075 case 'k': ftst = OP_FTSVTX; break;
4076 case 'b': ftst = OP_FTBLK; break;
4077 case 'c': ftst = OP_FTCHR; break;
4078 case 't': ftst = OP_FTTTY; break;
4079 case 'T': ftst = OP_FTTEXT; break;
4080 case 'B': ftst = OP_FTBINARY; break;
4081 case 'M': case 'A': case 'C':
4082 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4084 case 'M': ftst = OP_FTMTIME; break;
4085 case 'A': ftst = OP_FTATIME; break;
4086 case 'C': ftst = OP_FTCTIME; break;
4094 PL_last_lop_op = (OPCODE)ftst;
4095 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4096 "### Saw file test %c\n", (int)tmp);
4101 /* Assume it was a minus followed by a one-letter named
4102 * subroutine call (or a -bareword), then. */
4103 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4104 "### '-%c' looked like a file test but was not\n",
4111 const char tmp = *s++;
4114 if (PL_expect == XOPERATOR)
4119 else if (*s == '>') {
4122 if (isIDFIRST_lazy_if(s,UTF)) {
4123 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4131 if (PL_expect == XOPERATOR)
4134 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4136 OPERATOR('-'); /* unary minus */
4142 const char tmp = *s++;
4145 if (PL_expect == XOPERATOR)
4150 if (PL_expect == XOPERATOR)
4153 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4160 if (PL_expect != XOPERATOR) {
4161 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4162 PL_expect = XOPERATOR;
4163 force_ident(PL_tokenbuf, '*');
4176 if (PL_expect == XOPERATOR) {
4180 PL_tokenbuf[0] = '%';
4181 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4182 sizeof PL_tokenbuf - 1, FALSE);
4183 if (!PL_tokenbuf[1]) {
4186 PL_pending_ident = '%';
4197 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4204 const char tmp = *s++;
4210 goto just_a_word_zero_gv;
4213 switch (PL_expect) {
4219 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4221 PL_bufptr = s; /* update in case we back off */
4227 PL_expect = XTERMBLOCK;
4230 stuffstart = s - SvPVX(PL_linestr) - 1;
4234 while (isIDFIRST_lazy_if(s,UTF)) {
4237 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4238 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4239 if (tmp < 0) tmp = -tmp;
4253 sv = newSVpvn(s, len);
4255 d = scan_str(d,TRUE,TRUE);
4257 /* MUST advance bufptr here to avoid bogus
4258 "at end of line" context messages from yyerror().
4260 PL_bufptr = s + len;
4261 yyerror("Unterminated attribute parameter in attribute list");
4265 return REPORT(0); /* EOF indicator */
4269 sv_catsv(sv, PL_lex_stuff);
4270 attrs = append_elem(OP_LIST, attrs,
4271 newSVOP(OP_CONST, 0, sv));
4272 SvREFCNT_dec(PL_lex_stuff);
4273 PL_lex_stuff = NULL;
4276 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4278 if (PL_in_my == KEY_our) {
4280 GvUNIQUE_on(cGVOPx_gv(pl_yylval.opval));
4282 /* skip to avoid loading attributes.pm */
4284 deprecate(":unique");
4287 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4290 /* NOTE: any CV attrs applied here need to be part of
4291 the CVf_BUILTIN_ATTRS define in cv.h! */
4292 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4294 CvLVALUE_on(PL_compcv);
4296 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4298 CvLOCKED_on(PL_compcv);
4300 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4302 CvMETHOD_on(PL_compcv);
4304 /* After we've set the flags, it could be argued that
4305 we don't need to do the attributes.pm-based setting
4306 process, and shouldn't bother appending recognized
4307 flags. To experiment with that, uncomment the
4308 following "else". (Note that's already been
4309 uncommented. That keeps the above-applied built-in
4310 attributes from being intercepted (and possibly
4311 rejected) by a package's attribute routines, but is
4312 justified by the performance win for the common case
4313 of applying only built-in attributes.) */
4315 attrs = append_elem(OP_LIST, attrs,
4316 newSVOP(OP_CONST, 0,
4320 if (*s == ':' && s[1] != ':')
4323 break; /* require real whitespace or :'s */
4324 /* XXX losing whitespace on sequential attributes here */
4328 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4329 if (*s != ';' && *s != '}' && *s != tmp
4330 && (tmp != '=' || *s != ')')) {
4331 const char q = ((*s == '\'') ? '"' : '\'');
4332 /* If here for an expression, and parsed no attrs, back
4334 if (tmp == '=' && !attrs) {
4338 /* MUST advance bufptr here to avoid bogus "at end of line"
4339 context messages from yyerror().
4342 yyerror( (const char *)
4344 ? Perl_form(aTHX_ "Invalid separator character "
4345 "%c%c%c in attribute list", q, *s, q)
4346 : "Unterminated attribute list" ) );
4354 start_force(PL_curforce);
4355 NEXTVAL_NEXTTOKE.opval = attrs;
4356 CURMAD('_', PL_nextwhite);
4361 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4362 (s - SvPVX(PL_linestr)) - stuffstart);
4370 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4371 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4379 const char tmp = *s++;
4384 const char tmp = *s++;
4392 if (PL_lex_brackets <= 0)
4393 yyerror("Unmatched right square bracket");
4396 if (PL_lex_state == LEX_INTERPNORMAL) {
4397 if (PL_lex_brackets == 0) {
4398 if (*s == '-' && s[1] == '>')
4399 PL_lex_state = LEX_INTERPENDMAYBE;
4400 else if (*s != '[' && *s != '{')
4401 PL_lex_state = LEX_INTERPEND;
4408 if (PL_lex_brackets > 100) {
4409 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4411 switch (PL_expect) {
4413 if (PL_lex_formbrack) {
4417 if (PL_oldoldbufptr == PL_last_lop)
4418 PL_lex_brackstack[PL_lex_brackets++] = XTERM;