3 * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4 * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 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 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
372 { 0, TOKENTYPE_NONE, NULL }
375 /* dump the returned token in rv, plus any optional arg in pl_yylval */
378 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
382 PERL_ARGS_ASSERT_TOKEREPORT;
385 const char *name = NULL;
386 enum token_type type = TOKENTYPE_NONE;
387 const struct debug_tokens *p;
388 SV* const report = newSVpvs("<== ");
390 for (p = debug_tokens; p->token; p++) {
391 if (p->token == (int)rv) {
398 Perl_sv_catpv(aTHX_ report, name);
399 else if ((char)rv > ' ' && (char)rv < '~')
400 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
402 sv_catpvs(report, "EOF");
404 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
407 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
410 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
412 case TOKENTYPE_OPNUM:
413 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
414 PL_op_name[lvalp->ival]);
417 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
419 case TOKENTYPE_OPVAL:
421 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
422 PL_op_name[lvalp->opval->op_type]);
423 if (lvalp->opval->op_type == OP_CONST) {
424 Perl_sv_catpvf(aTHX_ report, " %s",
425 SvPEEK(cSVOPx_sv(lvalp->opval)));
430 sv_catpvs(report, "(opval=null)");
433 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
439 /* print the buffer with suitable escapes */
442 S_printbuf(pTHX_ const char *const fmt, const char *const s)
444 SV* const tmp = newSVpvs("");
446 PERL_ARGS_ASSERT_PRINTBUF;
448 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
457 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
458 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
462 S_ao(pTHX_ int toketype)
465 if (*PL_bufptr == '=') {
467 if (toketype == ANDAND)
468 pl_yylval.ival = OP_ANDASSIGN;
469 else if (toketype == OROR)
470 pl_yylval.ival = OP_ORASSIGN;
471 else if (toketype == DORDOR)
472 pl_yylval.ival = OP_DORASSIGN;
480 * When Perl expects an operator and finds something else, no_op
481 * prints the warning. It always prints "<something> found where
482 * operator expected. It prints "Missing semicolon on previous line?"
483 * if the surprise occurs at the start of the line. "do you need to
484 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
485 * where the compiler doesn't know if foo is a method call or a function.
486 * It prints "Missing operator before end of line" if there's nothing
487 * after the missing operator, or "... before <...>" if there is something
488 * after the missing operator.
492 S_no_op(pTHX_ const char *const what, char *s)
495 char * const oldbp = PL_bufptr;
496 const bool is_first = (PL_oldbufptr == PL_linestart);
498 PERL_ARGS_ASSERT_NO_OP;
504 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
505 if (ckWARN_d(WARN_SYNTAX)) {
507 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
508 "\t(Missing semicolon on previous line?)\n");
509 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
511 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
513 if (t < PL_bufptr && isSPACE(*t))
514 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
515 "\t(Do you need to predeclare %.*s?)\n",
516 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
520 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
521 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
529 * Complain about missing quote/regexp/heredoc terminator.
530 * If it's called with NULL then it cauterizes the line buffer.
531 * If we're in a delimited string and the delimiter is a control
532 * character, it's reformatted into a two-char sequence like ^C.
537 S_missingterm(pTHX_ char *s)
543 char * const nl = strrchr(s,'\n');
549 iscntrl(PL_multi_close)
551 PL_multi_close < 32 || PL_multi_close == 127
555 tmpbuf[1] = (char)toCTRL(PL_multi_close);
560 *tmpbuf = (char)PL_multi_close;
564 q = strchr(s,'"') ? '\'' : '"';
565 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
568 #define FEATURE_IS_ENABLED(name) \
569 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
570 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
571 /* The longest string we pass in. */
572 #define MAX_FEATURE_LEN (sizeof("switch")-1)
575 * S_feature_is_enabled
576 * Check whether the named feature is enabled.
579 S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
582 HV * const hinthv = GvHV(PL_hintgv);
583 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
585 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
587 assert(namelen <= MAX_FEATURE_LEN);
588 memcpy(&he_name[8], name, namelen);
590 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
598 Perl_deprecate(pTHX_ const char *const s)
600 PERL_ARGS_ASSERT_DEPRECATE;
602 if (ckWARN(WARN_DEPRECATED))
603 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
607 Perl_deprecate_old(pTHX_ const char *const s)
609 /* This function should NOT be called for any new deprecated warnings */
610 /* Use Perl_deprecate instead */
612 /* It is here to maintain backward compatibility with the pre-5.8 */
613 /* warnings category hierarchy. The "deprecated" category used to */
614 /* live under the "syntax" category. It is now a top-level category */
615 /* in its own right. */
617 PERL_ARGS_ASSERT_DEPRECATE_OLD;
619 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
620 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
621 "Use of %s is deprecated", s);
625 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
626 * utf16-to-utf8-reversed.
629 #ifdef PERL_CR_FILTER
633 register const char *s = SvPVX_const(sv);
634 register const char * const e = s + SvCUR(sv);
636 PERL_ARGS_ASSERT_STRIP_RETURN;
638 /* outer loop optimized to do nothing if there are no CR-LFs */
640 if (*s++ == '\r' && *s == '\n') {
641 /* hit a CR-LF, need to copy the rest */
642 register char *d = s - 1;
645 if (*s == '\r' && s[1] == '\n')
656 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
658 const I32 count = FILTER_READ(idx+1, sv, maxlen);
659 if (count > 0 && !maxlen)
670 * Create a parser object and initialise its parser and lexer fields
672 * rsfp is the opened file handle to read from (if any),
674 * line holds any initial content already read from the file (or in
675 * the case of no file, such as an eval, the whole contents);
677 * new_filter indicates that this is a new file and it shouldn't inherit
678 * the filters from the current parser (ie require).
682 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
685 const char *s = NULL;
687 yy_parser *parser, *oparser;
689 /* create and initialise a parser */
691 Newxz(parser, 1, yy_parser);
692 parser->old_parser = oparser = PL_parser;
695 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
696 parser->ps = parser->stack;
697 parser->stack_size = YYINITDEPTH;
699 parser->stack->state = 0;
700 parser->yyerrstatus = 0;
701 parser->yychar = YYEMPTY; /* Cause a token to be read. */
703 /* on scope exit, free this parser and restore any outer one */
705 parser->saved_curcop = PL_curcop;
707 /* initialise lexer state */
710 parser->curforce = -1;
712 parser->nexttoke = 0;
714 parser->error_count = oparser ? oparser->error_count : 0;
715 parser->copline = NOLINE;
716 parser->lex_state = LEX_NORMAL;
717 parser->expect = XSTATE;
719 parser->rsfp_filters = (new_filter || !oparser) ? newAV()
720 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
722 Newx(parser->lex_brackstack, 120, char);
723 Newx(parser->lex_casestack, 12, char);
724 *parser->lex_casestack = '\0';
727 s = SvPV_const(line, len);
733 parser->linestr = newSVpvs("\n;");
734 } else if (SvREADONLY(line) || s[len-1] != ';') {
735 parser->linestr = newSVsv(line);
737 sv_catpvs(parser->linestr, "\n;");
740 SvREFCNT_inc_simple_void_NN(line);
741 parser->linestr = line;
743 parser->oldoldbufptr =
746 parser->linestart = SvPVX(parser->linestr);
747 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
748 parser->last_lop = parser->last_uni = NULL;
752 /* delete a parser object */
755 Perl_parser_free(pTHX_ const yy_parser *parser)
757 PERL_ARGS_ASSERT_PARSER_FREE;
759 PL_curcop = parser->saved_curcop;
760 SvREFCNT_dec(parser->linestr);
762 if (parser->rsfp == PerlIO_stdin())
763 PerlIO_clearerr(parser->rsfp);
764 else if (parser->rsfp && (!parser->old_parser ||
765 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
766 PerlIO_close(parser->rsfp);
767 SvREFCNT_dec(parser->rsfp_filters);
769 Safefree(parser->stack);
770 Safefree(parser->lex_brackstack);
771 Safefree(parser->lex_casestack);
772 PL_parser = parser->old_parser;
779 * Finalizer for lexing operations. Must be called when the parser is
780 * done with the lexer.
787 PL_doextract = FALSE;
792 * This subroutine has nothing to do with tilting, whether at windmills
793 * or pinball tables. Its name is short for "increment line". It
794 * increments the current line number in CopLINE(PL_curcop) and checks
795 * to see whether the line starts with a comment of the form
796 * # line 500 "foo.pm"
797 * If so, it sets the current line number and file to the values in the comment.
801 S_incline(pTHX_ const char *s)
808 PERL_ARGS_ASSERT_INCLINE;
810 CopLINE_inc(PL_curcop);
813 while (SPACE_OR_TAB(*s))
815 if (strnEQ(s, "line", 4))
819 if (SPACE_OR_TAB(*s))
823 while (SPACE_OR_TAB(*s))
831 while (SPACE_OR_TAB(*s))
833 if (*s == '"' && (t = strchr(s+1, '"'))) {
843 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
845 if (*e != '\n' && *e != '\0')
846 return; /* false alarm */
849 const STRLEN len = t - s;
851 SV *const temp_sv = CopFILESV(PL_curcop);
857 tmplen = SvCUR(temp_sv);
863 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
864 /* must copy *{"::_<(eval N)[oldfilename:L]"}
865 * to *{"::_<newfilename"} */
866 /* However, the long form of evals is only turned on by the
867 debugger - usually they're "(eval %lu)" */
871 STRLEN tmplen2 = len;
872 if (tmplen + 2 <= sizeof smallbuf)
875 Newx(tmpbuf, tmplen + 2, char);
878 memcpy(tmpbuf + 2, cf, tmplen);
880 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
885 if (tmplen2 + 2 <= sizeof smallbuf)
888 Newx(tmpbuf2, tmplen2 + 2, char);
890 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
891 /* Either they malloc'd it, or we malloc'd it,
892 so no prefix is present in ours. */
897 memcpy(tmpbuf2 + 2, s, tmplen2);
900 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
902 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
903 /* adjust ${"::_<newfilename"} to store the new file name */
904 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
905 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
906 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
909 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
911 if (tmpbuf != smallbuf) Safefree(tmpbuf);
914 CopFILE_free(PL_curcop);
915 CopFILE_setn(PL_curcop, s, len);
917 CopLINE_set(PL_curcop, atoi(n)-1);
921 /* skip space before PL_thistoken */
924 S_skipspace0(pTHX_ register char *s)
926 PERL_ARGS_ASSERT_SKIPSPACE0;
933 PL_thiswhite = newSVpvs("");
934 sv_catsv(PL_thiswhite, PL_skipwhite);
935 sv_free(PL_skipwhite);
938 PL_realtokenstart = s - SvPVX(PL_linestr);
942 /* skip space after PL_thistoken */
945 S_skipspace1(pTHX_ register char *s)
947 const char *start = s;
948 I32 startoff = start - SvPVX(PL_linestr);
950 PERL_ARGS_ASSERT_SKIPSPACE1;
955 start = SvPVX(PL_linestr) + startoff;
956 if (!PL_thistoken && PL_realtokenstart >= 0) {
957 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
958 PL_thistoken = newSVpvn(tstart, start - tstart);
960 PL_realtokenstart = -1;
963 PL_nextwhite = newSVpvs("");
964 sv_catsv(PL_nextwhite, PL_skipwhite);
965 sv_free(PL_skipwhite);
972 S_skipspace2(pTHX_ register char *s, SV **svp)
975 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
976 const I32 startoff = s - SvPVX(PL_linestr);
978 PERL_ARGS_ASSERT_SKIPSPACE2;
981 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
982 if (!PL_madskills || !svp)
984 start = SvPVX(PL_linestr) + startoff;
985 if (!PL_thistoken && PL_realtokenstart >= 0) {
986 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
987 PL_thistoken = newSVpvn(tstart, start - tstart);
988 PL_realtokenstart = -1;
993 sv_setsv(*svp, PL_skipwhite);
994 sv_free(PL_skipwhite);
1003 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1005 AV *av = CopFILEAVx(PL_curcop);
1007 SV * const sv = newSV_type(SVt_PVMG);
1009 sv_setsv(sv, orig_sv);
1011 sv_setpvn(sv, buf, len);
1014 av_store(av, (I32)CopLINE(PL_curcop), sv);
1020 * Called to gobble the appropriate amount and type of whitespace.
1021 * Skips comments as well.
1025 S_skipspace(pTHX_ register char *s)
1030 int startoff = s - SvPVX(PL_linestr);
1032 PERL_ARGS_ASSERT_SKIPSPACE;
1035 sv_free(PL_skipwhite);
1039 PERL_ARGS_ASSERT_SKIPSPACE;
1041 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1042 while (s < PL_bufend && SPACE_OR_TAB(*s))
1052 SSize_t oldprevlen, oldoldprevlen;
1053 SSize_t oldloplen = 0, oldunilen = 0;
1054 while (s < PL_bufend && isSPACE(*s)) {
1055 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1060 if (s < PL_bufend && *s == '#') {
1061 while (s < PL_bufend && *s != '\n')
1063 if (s < PL_bufend) {
1065 if (PL_in_eval && !PL_rsfp) {
1072 /* only continue to recharge the buffer if we're at the end
1073 * of the buffer, we're not reading from a source filter, and
1074 * we're in normal lexing mode
1076 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1077 PL_lex_state == LEX_FORMLINE)
1084 /* try to recharge the buffer */
1086 curoff = s - SvPVX(PL_linestr);
1089 if ((s = filter_gets(PL_linestr, PL_rsfp,
1090 (prevlen = SvCUR(PL_linestr)))) == NULL)
1093 if (PL_madskills && curoff != startoff) {
1095 PL_skipwhite = newSVpvs("");
1096 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1100 /* mustn't throw out old stuff yet if madpropping */
1101 SvCUR(PL_linestr) = curoff;
1102 s = SvPVX(PL_linestr) + curoff;
1104 if (curoff && s[-1] == '\n')
1108 /* end of file. Add on the -p or -n magic */
1109 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1112 sv_catpvs(PL_linestr,
1113 ";}continue{print or die qq(-p destination: $!\\n);}");
1115 sv_setpvs(PL_linestr,
1116 ";}continue{print or die qq(-p destination: $!\\n);}");
1118 PL_minus_n = PL_minus_p = 0;
1120 else if (PL_minus_n) {
1122 sv_catpvn(PL_linestr, ";}", 2);
1124 sv_setpvn(PL_linestr, ";}", 2);
1130 sv_catpvn(PL_linestr,";", 1);
1132 sv_setpvn(PL_linestr,";", 1);
1135 /* reset variables for next time we lex */
1136 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1142 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1143 PL_last_lop = PL_last_uni = NULL;
1145 /* Close the filehandle. Could be from
1146 * STDIN, or a regular file. If we were reading code from
1147 * STDIN (because the commandline held no -e or filename)
1148 * then we don't close it, we reset it so the code can
1149 * read from STDIN too.
1152 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1153 PerlIO_clearerr(PL_rsfp);
1155 (void)PerlIO_close(PL_rsfp);
1160 /* not at end of file, so we only read another line */
1161 /* make corresponding updates to old pointers, for yyerror() */
1162 oldprevlen = PL_oldbufptr - PL_bufend;
1163 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1165 oldunilen = PL_last_uni - PL_bufend;
1167 oldloplen = PL_last_lop - PL_bufend;
1168 PL_linestart = PL_bufptr = s + prevlen;
1169 PL_bufend = s + SvCUR(PL_linestr);
1171 PL_oldbufptr = s + oldprevlen;
1172 PL_oldoldbufptr = s + oldoldprevlen;
1174 PL_last_uni = s + oldunilen;
1176 PL_last_lop = s + oldloplen;
1179 /* debugger active and we're not compiling the debugger code,
1180 * so store the line into the debugger's array of lines
1182 if (PERLDB_LINE && PL_curstash != PL_debstash)
1183 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1190 PL_skipwhite = newSVpvs("");
1191 curoff = s - SvPVX(PL_linestr);
1192 if (curoff - startoff)
1193 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1202 * Check the unary operators to ensure there's no ambiguity in how they're
1203 * used. An ambiguous piece of code would be:
1205 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1206 * the +5 is its argument.
1216 if (PL_oldoldbufptr != PL_last_uni)
1218 while (isSPACE(*PL_last_uni))
1221 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1223 if ((t = strchr(s, '(')) && t < PL_bufptr)
1226 if (ckWARN_d(WARN_AMBIGUOUS)){
1227 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1228 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1229 (int)(s - PL_last_uni), PL_last_uni);
1234 * LOP : macro to build a list operator. Its behaviour has been replaced
1235 * with a subroutine, S_lop() for which LOP is just another name.
1238 #define LOP(f,x) return lop(f,x,s)
1242 * Build a list operator (or something that might be one). The rules:
1243 * - if we have a next token, then it's a list operator [why?]
1244 * - if the next thing is an opening paren, then it's a function
1245 * - else it's a list operator
1249 S_lop(pTHX_ I32 f, int x, char *s)
1253 PERL_ARGS_ASSERT_LOP;
1259 PL_last_lop = PL_oldbufptr;
1260 PL_last_lop_op = (OPCODE)f;
1263 return REPORT(LSTOP);
1266 return REPORT(LSTOP);
1269 return REPORT(FUNC);
1272 return REPORT(FUNC);
1274 return REPORT(LSTOP);
1280 * Sets up for an eventual force_next(). start_force(0) basically does
1281 * an unshift, while start_force(-1) does a push. yylex removes items
1286 S_start_force(pTHX_ int where)
1290 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1291 where = PL_lasttoke;
1292 assert(PL_curforce < 0 || PL_curforce == where);
1293 if (PL_curforce != where) {
1294 for (i = PL_lasttoke; i > where; --i) {
1295 PL_nexttoke[i] = PL_nexttoke[i-1];
1299 if (PL_curforce < 0) /* in case of duplicate start_force() */
1300 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1301 PL_curforce = where;
1304 curmad('^', newSVpvs(""));
1305 CURMAD('_', PL_nextwhite);
1310 S_curmad(pTHX_ char slot, SV *sv)
1316 if (PL_curforce < 0)
1317 where = &PL_thismad;
1319 where = &PL_nexttoke[PL_curforce].next_mad;
1322 sv_setpvn(sv, "", 0);
1325 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1327 else if (PL_encoding) {
1328 sv_recode_to_utf8(sv, PL_encoding);
1333 /* keep a slot open for the head of the list? */
1334 if (slot != '_' && *where && (*where)->mad_key == '^') {
1335 (*where)->mad_key = slot;
1336 sv_free((SV*)((*where)->mad_val));
1337 (*where)->mad_val = (void*)sv;
1340 addmad(newMADsv(slot, sv), where, 0);
1343 # define start_force(where) NOOP
1344 # define curmad(slot, sv) NOOP
1349 * When the lexer realizes it knows the next token (for instance,
1350 * it is reordering tokens for the parser) then it can call S_force_next
1351 * to know what token to return the next time the lexer is called. Caller
1352 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1353 * and possibly PL_expect to ensure the lexer handles the token correctly.
1357 S_force_next(pTHX_ I32 type)
1362 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1363 tokereport(type, &NEXTVAL_NEXTTOKE);
1367 if (PL_curforce < 0)
1368 start_force(PL_lasttoke);
1369 PL_nexttoke[PL_curforce].next_type = type;
1370 if (PL_lex_state != LEX_KNOWNEXT)
1371 PL_lex_defer = PL_lex_state;
1372 PL_lex_state = LEX_KNOWNEXT;
1373 PL_lex_expect = PL_expect;
1376 PL_nexttype[PL_nexttoke] = type;
1378 if (PL_lex_state != LEX_KNOWNEXT) {
1379 PL_lex_defer = PL_lex_state;
1380 PL_lex_expect = PL_expect;
1381 PL_lex_state = LEX_KNOWNEXT;
1387 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1390 SV * const sv = newSVpvn_utf8(start, len,
1392 && is_utf8_string((const U8*)start, len));
1398 * When the lexer knows the next thing is a word (for instance, it has
1399 * just seen -> and it knows that the next char is a word char, then
1400 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1404 * char *start : buffer position (must be within PL_linestr)
1405 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1406 * int check_keyword : if true, Perl checks to make sure the word isn't
1407 * a keyword (do this if the word is a label, e.g. goto FOO)
1408 * int allow_pack : if true, : characters will also be allowed (require,
1409 * use, etc. do this)
1410 * int allow_initial_tick : used by the "sub" lexer only.
1414 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1420 PERL_ARGS_ASSERT_FORCE_WORD;
1422 start = SKIPSPACE1(start);
1424 if (isIDFIRST_lazy_if(s,UTF) ||
1425 (allow_pack && *s == ':') ||
1426 (allow_initial_tick && *s == '\'') )
1428 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1429 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1431 start_force(PL_curforce);
1433 curmad('X', newSVpvn(start,s-start));
1434 if (token == METHOD) {
1439 PL_expect = XOPERATOR;
1443 curmad('g', newSVpvs( "forced" ));
1444 NEXTVAL_NEXTTOKE.opval
1445 = (OP*)newSVOP(OP_CONST,0,
1446 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1447 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1455 * Called when the lexer wants $foo *foo &foo etc, but the program
1456 * text only contains the "foo" portion. The first argument is a pointer
1457 * to the "foo", and the second argument is the type symbol to prefix.
1458 * Forces the next token to be a "WORD".
1459 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1463 S_force_ident(pTHX_ register const char *s, int kind)
1467 PERL_ARGS_ASSERT_FORCE_IDENT;
1470 const STRLEN len = strlen(s);
1471 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1472 start_force(PL_curforce);
1473 NEXTVAL_NEXTTOKE.opval = o;
1476 o->op_private = OPpCONST_ENTERED;
1477 /* XXX see note in pp_entereval() for why we forgo typo
1478 warnings if the symbol must be introduced in an eval.
1480 gv_fetchpvn_flags(s, len,
1481 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1483 kind == '$' ? SVt_PV :
1484 kind == '@' ? SVt_PVAV :
1485 kind == '%' ? SVt_PVHV :
1493 Perl_str_to_version(pTHX_ SV *sv)
1498 const char *start = SvPV_const(sv,len);
1499 const char * const end = start + len;
1500 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1502 PERL_ARGS_ASSERT_STR_TO_VERSION;
1504 while (start < end) {
1508 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1513 retval += ((NV)n)/nshift;
1522 * Forces the next token to be a version number.
1523 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1524 * and if "guessing" is TRUE, then no new token is created (and the caller
1525 * must use an alternative parsing method).
1529 S_force_version(pTHX_ char *s, int guessing)
1535 I32 startoff = s - SvPVX(PL_linestr);
1538 PERL_ARGS_ASSERT_FORCE_VERSION;
1546 while (isDIGIT(*d) || *d == '_' || *d == '.')
1550 start_force(PL_curforce);
1551 curmad('X', newSVpvn(s,d-s));
1554 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1556 s = scan_num(s, &pl_yylval);
1557 version = pl_yylval.opval;
1558 ver = cSVOPx(version)->op_sv;
1559 if (SvPOK(ver) && !SvNIOK(ver)) {
1560 SvUPGRADE(ver, SVt_PVNV);
1561 SvNV_set(ver, str_to_version(ver));
1562 SvNOK_on(ver); /* hint that it is a version */
1565 else if (guessing) {
1568 sv_free(PL_nextwhite); /* let next token collect whitespace */
1570 s = SvPVX(PL_linestr) + startoff;
1578 if (PL_madskills && !version) {
1579 sv_free(PL_nextwhite); /* let next token collect whitespace */
1581 s = SvPVX(PL_linestr) + startoff;
1584 /* NOTE: The parser sees the package name and the VERSION swapped */
1585 start_force(PL_curforce);
1586 NEXTVAL_NEXTTOKE.opval = version;
1594 * Tokenize a quoted string passed in as an SV. It finds the next
1595 * chunk, up to end of string or a backslash. It may make a new
1596 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1601 S_tokeq(pTHX_ SV *sv)
1605 register char *send;
1610 PERL_ARGS_ASSERT_TOKEQ;
1615 s = SvPV_force(sv, len);
1616 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1619 while (s < send && *s != '\\')
1624 if ( PL_hints & HINT_NEW_STRING ) {
1625 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
1629 if (s + 1 < send && (s[1] == '\\'))
1630 s++; /* all that, just for this */
1635 SvCUR_set(sv, d - SvPVX_const(sv));
1637 if ( PL_hints & HINT_NEW_STRING )
1638 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
1643 * Now come three functions related to double-quote context,
1644 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1645 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1646 * interact with PL_lex_state, and create fake ( ... ) argument lists
1647 * to handle functions and concatenation.
1648 * They assume that whoever calls them will be setting up a fake
1649 * join call, because each subthing puts a ',' after it. This lets
1652 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1654 * (I'm not sure whether the spurious commas at the end of lcfirst's
1655 * arguments and join's arguments are created or not).
1660 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1662 * Pattern matching will set PL_lex_op to the pattern-matching op to
1663 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
1665 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1667 * Everything else becomes a FUNC.
1669 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1670 * had an OP_CONST or OP_READLINE). This just sets us up for a
1671 * call to S_sublex_push().
1675 S_sublex_start(pTHX)
1678 register const I32 op_type = pl_yylval.ival;
1680 if (op_type == OP_NULL) {
1681 pl_yylval.opval = PL_lex_op;
1685 if (op_type == OP_CONST || op_type == OP_READLINE) {
1686 SV *sv = tokeq(PL_lex_stuff);
1688 if (SvTYPE(sv) == SVt_PVIV) {
1689 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1691 const char * const p = SvPV_const(sv, len);
1692 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
1696 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1697 PL_lex_stuff = NULL;
1698 /* Allow <FH> // "foo" */
1699 if (op_type == OP_READLINE)
1700 PL_expect = XTERMORDORDOR;
1703 else if (op_type == OP_BACKTICK && PL_lex_op) {
1704 /* readpipe() vas overriden */
1705 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1706 pl_yylval.opval = PL_lex_op;
1708 PL_lex_stuff = NULL;
1712 PL_sublex_info.super_state = PL_lex_state;
1713 PL_sublex_info.sub_inwhat = (U16)op_type;
1714 PL_sublex_info.sub_op = PL_lex_op;
1715 PL_lex_state = LEX_INTERPPUSH;
1719 pl_yylval.opval = PL_lex_op;
1729 * Create a new scope to save the lexing state. The scope will be
1730 * ended in S_sublex_done. Returns a '(', starting the function arguments
1731 * to the uc, lc, etc. found before.
1732 * Sets PL_lex_state to LEX_INTERPCONCAT.
1741 PL_lex_state = PL_sublex_info.super_state;
1742 SAVEBOOL(PL_lex_dojoin);
1743 SAVEI32(PL_lex_brackets);
1744 SAVEI32(PL_lex_casemods);
1745 SAVEI32(PL_lex_starts);
1746 SAVEI8(PL_lex_state);
1747 SAVEVPTR(PL_lex_inpat);
1748 SAVEI16(PL_lex_inwhat);
1749 SAVECOPLINE(PL_curcop);
1750 SAVEPPTR(PL_bufptr);
1751 SAVEPPTR(PL_bufend);
1752 SAVEPPTR(PL_oldbufptr);
1753 SAVEPPTR(PL_oldoldbufptr);
1754 SAVEPPTR(PL_last_lop);
1755 SAVEPPTR(PL_last_uni);
1756 SAVEPPTR(PL_linestart);
1757 SAVESPTR(PL_linestr);
1758 SAVEGENERICPV(PL_lex_brackstack);
1759 SAVEGENERICPV(PL_lex_casestack);
1761 PL_linestr = PL_lex_stuff;
1762 PL_lex_stuff = NULL;
1764 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1765 = SvPVX(PL_linestr);
1766 PL_bufend += SvCUR(PL_linestr);
1767 PL_last_lop = PL_last_uni = NULL;
1768 SAVEFREESV(PL_linestr);
1770 PL_lex_dojoin = FALSE;
1771 PL_lex_brackets = 0;
1772 Newx(PL_lex_brackstack, 120, char);
1773 Newx(PL_lex_casestack, 12, char);
1774 PL_lex_casemods = 0;
1775 *PL_lex_casestack = '\0';
1777 PL_lex_state = LEX_INTERPCONCAT;
1778 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1780 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1781 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1782 PL_lex_inpat = PL_sublex_info.sub_op;
1784 PL_lex_inpat = NULL;
1791 * Restores lexer state after a S_sublex_push.
1798 if (!PL_lex_starts++) {
1799 SV * const sv = newSVpvs("");
1800 if (SvUTF8(PL_linestr))
1802 PL_expect = XOPERATOR;
1803 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1807 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1808 PL_lex_state = LEX_INTERPCASEMOD;
1812 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1813 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1814 PL_linestr = PL_lex_repl;
1816 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1817 PL_bufend += SvCUR(PL_linestr);
1818 PL_last_lop = PL_last_uni = NULL;
1819 SAVEFREESV(PL_linestr);
1820 PL_lex_dojoin = FALSE;
1821 PL_lex_brackets = 0;
1822 PL_lex_casemods = 0;
1823 *PL_lex_casestack = '\0';
1825 if (SvEVALED(PL_lex_repl)) {
1826 PL_lex_state = LEX_INTERPNORMAL;
1828 /* we don't clear PL_lex_repl here, so that we can check later
1829 whether this is an evalled subst; that means we rely on the
1830 logic to ensure sublex_done() is called again only via the
1831 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1834 PL_lex_state = LEX_INTERPCONCAT;
1844 PL_endwhite = newSVpvs("");
1845 sv_catsv(PL_endwhite, PL_thiswhite);
1849 sv_setpvn(PL_thistoken,"",0);
1851 PL_realtokenstart = -1;
1855 PL_bufend = SvPVX(PL_linestr);
1856 PL_bufend += SvCUR(PL_linestr);
1857 PL_expect = XOPERATOR;
1858 PL_sublex_info.sub_inwhat = 0;
1866 Extracts a pattern, double-quoted string, or transliteration. This
1869 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1870 processing a pattern (PL_lex_inpat is true), a transliteration
1871 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1873 Returns a pointer to the character scanned up to. If this is
1874 advanced from the start pointer supplied (i.e. if anything was
1875 successfully parsed), will leave an OP for the substring scanned
1876 in pl_yylval. Caller must intuit reason for not parsing further
1877 by looking at the next characters herself.
1881 double-quoted style: \r and \n
1882 regexp special ones: \D \s
1885 case and quoting: \U \Q \E
1886 stops on @ and $, but not for $ as tail anchor
1888 In transliterations:
1889 characters are VERY literal, except for - not at the start or end
1890 of the string, which indicates a range. If the range is in bytes,
1891 scan_const expands the range to the full set of intermediate
1892 characters. If the range is in utf8, the hyphen is replaced with
1893 a certain range mark which will be handled by pmtrans() in op.c.
1895 In double-quoted strings:
1897 double-quoted style: \r and \n
1899 deprecated backrefs: \1 (in substitution replacements)
1900 case and quoting: \U \Q \E
1903 scan_const does *not* construct ops to handle interpolated strings.
1904 It stops processing as soon as it finds an embedded $ or @ variable
1905 and leaves it to the caller to work out what's going on.
1907 embedded arrays (whether in pattern or not) could be:
1908 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1910 $ in double-quoted strings must be the symbol of an embedded scalar.
1912 $ in pattern could be $foo or could be tail anchor. Assumption:
1913 it's a tail anchor if $ is the last thing in the string, or if it's
1914 followed by one of "()| \r\n\t"
1916 \1 (backreferences) are turned into $1
1918 The structure of the code is
1919 while (there's a character to process) {
1920 handle transliteration ranges
1921 skip regexp comments /(?#comment)/ and codes /(?{code})/
1922 skip #-initiated comments in //x patterns
1923 check for embedded arrays
1924 check for embedded scalars
1926 leave intact backslashes from leaveit (below)
1927 deprecate \1 in substitution replacements
1928 handle string-changing backslashes \l \U \Q \E, etc.
1929 switch (what was escaped) {
1930 handle \- in a transliteration (becomes a literal -)
1931 handle \132 (octal characters)
1932 handle \x15 and \x{1234} (hex characters)
1933 handle \N{name} (named characters)
1934 handle \cV (control characters)
1935 handle printf-style backslashes (\f, \r, \n, etc)
1937 } (end if backslash)
1938 } (end while character to read)
1943 S_scan_const(pTHX_ char *start)
1946 register char *send = PL_bufend; /* end of the constant */
1947 SV *sv = newSV(send - start); /* sv for the constant */
1948 register char *s = start; /* start of the constant */
1949 register char *d = SvPVX(sv); /* destination for copies */
1950 bool dorange = FALSE; /* are we in a translit range? */
1951 bool didrange = FALSE; /* did we just finish a range? */
1952 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1953 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1956 UV literal_endpoint = 0;
1957 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1960 PERL_ARGS_ASSERT_SCAN_CONST;
1962 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1963 /* If we are doing a trans and we know we want UTF8 set expectation */
1964 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1965 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1969 while (s < send || dorange) {
1970 /* get transliterations out of the way (they're most literal) */
1971 if (PL_lex_inwhat == OP_TRANS) {
1972 /* expand a range A-Z to the full set of characters. AIE! */
1974 I32 i; /* current expanded character */
1975 I32 min; /* first character in range */
1976 I32 max; /* last character in range */
1987 char * const c = (char*)utf8_hop((U8*)d, -1);
1991 *c = (char)UTF_TO_NATIVE(0xff);
1992 /* mark the range as done, and continue */
1998 i = d - SvPVX_const(sv); /* remember current offset */
2001 SvLEN(sv) + (has_utf8 ?
2002 (512 - UTF_CONTINUATION_MARK +
2005 /* How many two-byte within 0..255: 128 in UTF-8,
2006 * 96 in UTF-8-mod. */
2008 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2010 d = SvPVX(sv) + i; /* refresh d after realloc */
2014 for (j = 0; j <= 1; j++) {
2015 char * const c = (char*)utf8_hop((U8*)d, -1);
2016 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2022 max = (U8)0xff; /* only to \xff */
2023 uvmax = uv; /* \x{100} to uvmax */
2025 d = c; /* eat endpoint chars */
2030 d -= 2; /* eat the first char and the - */
2031 min = (U8)*d; /* first char in range */
2032 max = (U8)d[1]; /* last char in range */
2039 "Invalid range \"%c-%c\" in transliteration operator",
2040 (char)min, (char)max);
2044 if (literal_endpoint == 2 &&
2045 ((isLOWER(min) && isLOWER(max)) ||
2046 (isUPPER(min) && isUPPER(max)))) {
2048 for (i = min; i <= max; i++)
2050 *d++ = NATIVE_TO_NEED(has_utf8,i);
2052 for (i = min; i <= max; i++)
2054 *d++ = NATIVE_TO_NEED(has_utf8,i);
2059 for (i = min; i <= max; i++)
2062 const U8 ch = (U8)NATIVE_TO_UTF(i);
2063 if (UNI_IS_INVARIANT(ch))
2066 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2067 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2076 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2078 *d++ = (char)UTF_TO_NATIVE(0xff);
2080 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2084 /* mark the range as done, and continue */
2088 literal_endpoint = 0;
2093 /* range begins (ignore - as first or last char) */
2094 else if (*s == '-' && s+1 < send && s != start) {
2096 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2103 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2113 literal_endpoint = 0;
2114 native_range = TRUE;
2119 /* if we get here, we're not doing a transliteration */
2121 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2122 except for the last char, which will be done separately. */
2123 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2125 while (s+1 < send && *s != ')')
2126 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2128 else if (s[2] == '{' /* This should match regcomp.c */
2129 || (s[2] == '?' && s[3] == '{'))
2132 char *regparse = s + (s[2] == '{' ? 3 : 4);
2135 while (count && (c = *regparse)) {
2136 if (c == '\\' && regparse[1])
2144 if (*regparse != ')')
2145 regparse--; /* Leave one char for continuation. */
2146 while (s < regparse)
2147 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2151 /* likewise skip #-initiated comments in //x patterns */
2152 else if (*s == '#' && PL_lex_inpat &&
2153 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2154 while (s+1 < send && *s != '\n')
2155 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2158 /* check for embedded arrays
2159 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2161 else if (*s == '@' && s[1]) {
2162 if (isALNUM_lazy_if(s+1,UTF))
2164 if (strchr(":'{$", s[1]))
2166 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2167 break; /* in regexp, neither @+ nor @- are interpolated */
2170 /* check for embedded scalars. only stop if we're sure it's a
2173 else if (*s == '$') {
2174 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2176 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2177 if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) {
2178 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2179 "Possible unintended interpolation of $\\ in regex");
2181 break; /* in regexp, $ might be tail anchor */
2185 /* End of else if chain - OP_TRANS rejoin rest */
2188 if (*s == '\\' && s+1 < send) {
2191 /* deprecate \1 in strings and substitution replacements */
2192 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2193 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2195 if (ckWARN(WARN_SYNTAX))
2196 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2201 /* string-change backslash escapes */
2202 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2206 /* skip any other backslash escapes in a pattern */
2207 else if (PL_lex_inpat) {
2208 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2209 goto default_action;
2212 /* if we get here, it's either a quoted -, or a digit */
2215 /* quoted - in transliterations */
2217 if (PL_lex_inwhat == OP_TRANS) {
2224 if ((isALPHA(*s) || isDIGIT(*s)) &&
2226 Perl_warner(aTHX_ packWARN(WARN_MISC),
2227 "Unrecognized escape \\%c passed through",
2229 /* default action is to copy the quoted character */
2230 goto default_action;
2233 /* \132 indicates an octal constant */
2234 case '0': case '1': case '2': case '3':
2235 case '4': case '5': case '6': case '7':
2239 uv = grok_oct(s, &len, &flags, NULL);
2242 goto NUM_ESCAPE_INSERT;
2244 /* \x24 indicates a hex constant */
2248 char* const e = strchr(s, '}');
2249 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2250 PERL_SCAN_DISALLOW_PREFIX;
2255 yyerror("Missing right brace on \\x{}");
2259 uv = grok_hex(s, &len, &flags, NULL);
2265 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2266 uv = grok_hex(s, &len, &flags, NULL);
2272 /* Insert oct or hex escaped character.
2273 * There will always enough room in sv since such
2274 * escapes will be longer than any UTF-8 sequence
2275 * they can end up as. */
2277 /* We need to map to chars to ASCII before doing the tests
2280 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2281 if (!has_utf8 && uv > 255) {
2282 /* Might need to recode whatever we have
2283 * accumulated so far if it contains any
2286 * (Can't we keep track of that and avoid
2287 * this rescan? --jhi)
2291 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2292 if (!NATIVE_IS_INVARIANT(*c)) {
2297 const STRLEN offset = d - SvPVX_const(sv);
2299 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2303 while (src >= (const U8 *)SvPVX_const(sv)) {
2304 if (!NATIVE_IS_INVARIANT(*src)) {
2305 const U8 ch = NATIVE_TO_ASCII(*src);
2306 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2307 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2317 if (has_utf8 || uv > 255) {
2318 d = (char*)uvchr_to_utf8((U8*)d, uv);
2320 if (PL_lex_inwhat == OP_TRANS &&
2321 PL_sublex_info.sub_op) {
2322 PL_sublex_info.sub_op->op_private |=
2323 (PL_lex_repl ? OPpTRANS_FROM_UTF
2327 if (uv > 255 && !dorange)
2328 native_range = FALSE;
2340 /* \N{LATIN SMALL LETTER A} is a named character */
2344 char* e = strchr(s, '}');
2350 yyerror("Missing right brace on \\N{}");
2354 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2356 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2357 PERL_SCAN_DISALLOW_PREFIX;
2360 uv = grok_hex(s, &len, &flags, NULL);
2361 if ( e > s && len != (STRLEN)(e - s) ) {
2365 goto NUM_ESCAPE_INSERT;
2367 res = newSVpvn(s + 1, e - s - 1);
2368 res = new_constant( NULL, 0, "charnames",
2369 res, NULL, s - 2, e - s + 3 );
2371 sv_utf8_upgrade(res);
2372 str = SvPV_const(res,len);
2373 #ifdef EBCDIC_NEVER_MIND
2374 /* charnames uses pack U and that has been
2375 * recently changed to do the below uni->native
2376 * mapping, so this would be redundant (and wrong,
2377 * the code point would be doubly converted).
2378 * But leave this in just in case the pack U change
2379 * gets revoked, but the semantics is still
2380 * desireable for charnames. --jhi */
2382 UV uv = utf8_to_uvchr((const U8*)str, 0);
2385 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2387 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2388 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2389 str = SvPV_const(res, len);
2393 if (!has_utf8 && SvUTF8(res)) {
2394 const char * const ostart = SvPVX_const(sv);
2395 SvCUR_set(sv, d - ostart);
2398 sv_utf8_upgrade(sv);
2399 /* this just broke our allocation above... */
2400 SvGROW(sv, (STRLEN)(send - start));
2401 d = SvPVX(sv) + SvCUR(sv);
2404 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2405 const char * const odest = SvPVX_const(sv);
2407 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2408 d = SvPVX(sv) + (d - odest);
2412 native_range = FALSE; /* \N{} is guessed to be Unicode */
2414 Copy(str, d, len, char);
2421 yyerror("Missing braces on \\N{}");
2424 /* \c is a control character */
2433 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2436 yyerror("Missing control char name in \\c");
2440 /* printf-style backslashes, formfeeds, newlines, etc */
2442 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2445 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2448 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2451 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2454 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2457 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2460 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2466 } /* end if (backslash) */
2473 /* If we started with encoded form, or already know we want it
2474 and then encode the next character */
2475 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2477 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2478 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2481 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2482 const STRLEN off = d - SvPVX_const(sv);
2483 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2485 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2488 if (uv > 255 && !dorange)
2489 native_range = FALSE;
2493 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2495 } /* while loop to process each character */
2497 /* terminate the string and set up the sv */
2499 SvCUR_set(sv, d - SvPVX_const(sv));
2500 if (SvCUR(sv) >= SvLEN(sv))
2501 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2504 if (PL_encoding && !has_utf8) {
2505 sv_recode_to_utf8(sv, PL_encoding);
2511 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2512 PL_sublex_info.sub_op->op_private |=
2513 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2517 /* shrink the sv if we allocated more than we used */
2518 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2519 SvPV_shrink_to_cur(sv);
2522 /* return the substring (via pl_yylval) only if we parsed anything */
2523 if (s > PL_bufptr) {
2524 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
2525 const char *const key = PL_lex_inpat ? "qr" : "q";
2526 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
2530 if (PL_lex_inwhat == OP_TRANS) {
2533 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
2541 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
2544 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2551 * Returns TRUE if there's more to the expression (e.g., a subscript),
2554 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2556 * ->[ and ->{ return TRUE
2557 * { and [ outside a pattern are always subscripts, so return TRUE
2558 * if we're outside a pattern and it's not { or [, then return FALSE
2559 * if we're in a pattern and the first char is a {
2560 * {4,5} (any digits around the comma) returns FALSE
2561 * if we're in a pattern and the first char is a [
2563 * [SOMETHING] has a funky algorithm to decide whether it's a
2564 * character class or not. It has to deal with things like
2565 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2566 * anything else returns TRUE
2569 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2572 S_intuit_more(pTHX_ register char *s)
2576 PERL_ARGS_ASSERT_INTUIT_MORE;
2578 if (PL_lex_brackets)
2580 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2582 if (*s != '{' && *s != '[')
2587 /* In a pattern, so maybe we have {n,m}. */
2604 /* On the other hand, maybe we have a character class */
2607 if (*s == ']' || *s == '^')
2610 /* this is terrifying, and it works */
2611 int weight = 2; /* let's weigh the evidence */
2613 unsigned char un_char = 255, last_un_char;
2614 const char * const send = strchr(s,']');
2615 char tmpbuf[sizeof PL_tokenbuf * 4];
2617 if (!send) /* has to be an expression */
2620 Zero(seen,256,char);
2623 else if (isDIGIT(*s)) {
2625 if (isDIGIT(s[1]) && s[2] == ']')
2631 for (; s < send; s++) {
2632 last_un_char = un_char;
2633 un_char = (unsigned char)*s;
2638 weight -= seen[un_char] * 10;
2639 if (isALNUM_lazy_if(s+1,UTF)) {
2641 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2642 len = (int)strlen(tmpbuf);
2643 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2648 else if (*s == '$' && s[1] &&
2649 strchr("[#!%*<>()-=",s[1])) {
2650 if (/*{*/ strchr("])} =",s[2]))
2659 if (strchr("wds]",s[1]))
2661 else if (seen[(U8)'\''] || seen[(U8)'"'])
2663 else if (strchr("rnftbxcav",s[1]))
2665 else if (isDIGIT(s[1])) {
2667 while (s[1] && isDIGIT(s[1]))
2677 if (strchr("aA01! ",last_un_char))
2679 if (strchr("zZ79~",s[1]))
2681 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2682 weight -= 5; /* cope with negative subscript */
2685 if (!isALNUM(last_un_char)
2686 && !(last_un_char == '$' || last_un_char == '@'
2687 || last_un_char == '&')
2688 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2693 if (keyword(tmpbuf, d - tmpbuf, 0))
2696 if (un_char == last_un_char + 1)
2698 weight -= seen[un_char];
2703 if (weight >= 0) /* probably a character class */
2713 * Does all the checking to disambiguate
2715 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2716 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2718 * First argument is the stuff after the first token, e.g. "bar".
2720 * Not a method if bar is a filehandle.
2721 * Not a method if foo is a subroutine prototyped to take a filehandle.
2722 * Not a method if it's really "Foo $bar"
2723 * Method if it's "foo $bar"
2724 * Not a method if it's really "print foo $bar"
2725 * Method if it's really "foo package::" (interpreted as package->foo)
2726 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2727 * Not a method if bar is a filehandle or package, but is quoted with
2732 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2735 char *s = start + (*start == '$');
2736 char tmpbuf[sizeof PL_tokenbuf];
2743 PERL_ARGS_ASSERT_INTUIT_METHOD;
2746 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2750 const char *proto = SvPVX_const(cv);
2761 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2762 /* start is the beginning of the possible filehandle/object,
2763 * and s is the end of it
2764 * tmpbuf is a copy of it
2767 if (*start == '$') {
2768 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2769 isUPPER(*PL_tokenbuf))
2772 len = start - SvPVX(PL_linestr);
2776 start = SvPVX(PL_linestr) + len;
2780 return *s == '(' ? FUNCMETH : METHOD;
2782 if (!keyword(tmpbuf, len, 0)) {
2783 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2787 soff = s - SvPVX(PL_linestr);
2791 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2792 if (indirgv && GvCVu(indirgv))
2794 /* filehandle or package name makes it a method */
2795 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2797 soff = s - SvPVX(PL_linestr);
2800 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2801 return 0; /* no assumptions -- "=>" quotes bearword */
2803 start_force(PL_curforce);
2804 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2805 newSVpvn(tmpbuf,len));
2806 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2808 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2813 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2815 return *s == '(' ? FUNCMETH : METHOD;
2821 /* Encoded script support. filter_add() effectively inserts a
2822 * 'pre-processing' function into the current source input stream.
2823 * Note that the filter function only applies to the current source file
2824 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2826 * The datasv parameter (which may be NULL) can be used to pass
2827 * private data to this instance of the filter. The filter function
2828 * can recover the SV using the FILTER_DATA macro and use it to
2829 * store private buffers and state information.
2831 * The supplied datasv parameter is upgraded to a PVIO type
2832 * and the IoDIRP/IoANY field is used to store the function pointer,
2833 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2834 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2835 * private use must be set using malloc'd pointers.
2839 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2848 if (!PL_rsfp_filters)
2849 PL_rsfp_filters = newAV();
2852 SvUPGRADE(datasv, SVt_PVIO);
2853 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2854 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2855 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2856 FPTR2DPTR(void *, IoANY(datasv)),
2857 SvPV_nolen(datasv)));
2858 av_unshift(PL_rsfp_filters, 1);
2859 av_store(PL_rsfp_filters, 0, datasv) ;
2864 /* Delete most recently added instance of this filter function. */
2866 Perl_filter_del(pTHX_ filter_t funcp)
2871 PERL_ARGS_ASSERT_FILTER_DEL;
2874 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2875 FPTR2DPTR(void*, funcp)));
2877 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2879 /* if filter is on top of stack (usual case) just pop it off */
2880 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2881 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2882 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2883 IoANY(datasv) = (void *)NULL;
2884 sv_free(av_pop(PL_rsfp_filters));
2888 /* we need to search for the correct entry and clear it */
2889 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2893 /* Invoke the idxth filter function for the current rsfp. */
2894 /* maxlen 0 = read one text line */
2896 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2901 /* This API is bad. It should have been using unsigned int for maxlen.
2902 Not sure if we want to change the API, but if not we should sanity
2903 check the value here. */
2904 const unsigned int correct_length
2913 PERL_ARGS_ASSERT_FILTER_READ;
2915 if (!PL_parser || !PL_rsfp_filters)
2917 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2918 /* Provide a default input filter to make life easy. */
2919 /* Note that we append to the line. This is handy. */
2920 DEBUG_P(PerlIO_printf(Perl_debug_log,
2921 "filter_read %d: from rsfp\n", idx));
2922 if (correct_length) {
2925 const int old_len = SvCUR(buf_sv);
2927 /* ensure buf_sv is large enough */
2928 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2929 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2930 correct_length)) <= 0) {
2931 if (PerlIO_error(PL_rsfp))
2932 return -1; /* error */
2934 return 0 ; /* end of file */
2936 SvCUR_set(buf_sv, old_len + len) ;
2939 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2940 if (PerlIO_error(PL_rsfp))
2941 return -1; /* error */
2943 return 0 ; /* end of file */
2946 return SvCUR(buf_sv);
2948 /* Skip this filter slot if filter has been deleted */
2949 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2950 DEBUG_P(PerlIO_printf(Perl_debug_log,
2951 "filter_read %d: skipped (filter deleted)\n",
2953 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2955 /* Get function pointer hidden within datasv */
2956 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2957 DEBUG_P(PerlIO_printf(Perl_debug_log,
2958 "filter_read %d: via function %p (%s)\n",
2959 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2960 /* Call function. The function is expected to */
2961 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2962 /* Return: <0:error, =0:eof, >0:not eof */
2963 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2967 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2971 PERL_ARGS_ASSERT_FILTER_GETS;
2973 #ifdef PERL_CR_FILTER
2974 if (!PL_rsfp_filters) {
2975 filter_add(S_cr_textfilter,NULL);
2978 if (PL_rsfp_filters) {
2980 SvCUR_set(sv, 0); /* start with empty line */
2981 if (FILTER_READ(0, sv, 0) > 0)
2982 return ( SvPVX(sv) ) ;
2987 return (sv_gets(sv, fp, append));
2991 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
2996 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
2998 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3002 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3003 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3005 return GvHV(gv); /* Foo:: */
3008 /* use constant CLASS => 'MyClass' */
3009 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3010 if (gv && GvCV(gv)) {
3011 SV * const sv = cv_const_sv(GvCV(gv));
3013 pkgname = SvPV_const(sv, len);
3016 return gv_stashpvn(pkgname, len, 0);
3020 * S_readpipe_override
3021 * Check whether readpipe() is overriden, and generates the appropriate
3022 * optree, provided sublex_start() is called afterwards.
3025 S_readpipe_override(pTHX)
3028 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
3029 pl_yylval.ival = OP_BACKTICK;
3031 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
3033 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
3034 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
3035 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
3037 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
3038 append_elem(OP_LIST,
3039 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
3040 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
3047 * The intent of this yylex wrapper is to minimize the changes to the
3048 * tokener when we aren't interested in collecting madprops. It remains
3049 * to be seen how successful this strategy will be...
3056 char *s = PL_bufptr;
3058 /* make sure PL_thiswhite is initialized */
3062 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
3063 if (PL_pending_ident)
3064 return S_pending_ident(aTHX);
3066 /* previous token ate up our whitespace? */
3067 if (!PL_lasttoke && PL_nextwhite) {
3068 PL_thiswhite = PL_nextwhite;
3072 /* isolate the token, and figure out where it is without whitespace */
3073 PL_realtokenstart = -1;
3077 assert(PL_curforce < 0);
3079 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
3080 if (!PL_thistoken) {
3081 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3082 PL_thistoken = newSVpvs("");
3084 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3085 PL_thistoken = newSVpvn(tstart, s - tstart);
3088 if (PL_thismad) /* install head */
3089 CURMAD('X', PL_thistoken);
3092 /* last whitespace of a sublex? */
3093 if (optype == ')' && PL_endwhite) {
3094 CURMAD('X', PL_endwhite);
3099 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
3100 if (!PL_thiswhite && !PL_endwhite && !optype) {
3101 sv_free(PL_thistoken);
3106 /* put off final whitespace till peg */
3107 if (optype == ';' && !PL_rsfp) {
3108 PL_nextwhite = PL_thiswhite;
3111 else if (PL_thisopen) {
3112 CURMAD('q', PL_thisopen);
3114 sv_free(PL_thistoken);
3118 /* Store actual token text as madprop X */
3119 CURMAD('X', PL_thistoken);
3123 /* add preceding whitespace as madprop _ */
3124 CURMAD('_', PL_thiswhite);
3128 /* add quoted material as madprop = */
3129 CURMAD('=', PL_thisstuff);
3133 /* add terminating quote as madprop Q */
3134 CURMAD('Q', PL_thisclose);
3138 /* special processing based on optype */
3142 /* opval doesn't need a TOKEN since it can already store mp */
3152 if (pl_yylval.opval)
3153 append_madprops(PL_thismad, pl_yylval.opval, 0);
3161 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3170 /* remember any fake bracket that lexer is about to discard */
3171 if (PL_lex_brackets == 1 &&
3172 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3175 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3178 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3179 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3182 break; /* don't bother looking for trailing comment */
3191 /* attach a trailing comment to its statement instead of next token */
3195 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3197 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3199 if (*s == '\n' || *s == '#') {
3200 while (s < PL_bufend && *s != '\n')
3204 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3205 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3222 /* Create new token struct. Note: opvals return early above. */
3223 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
3230 S_tokenize_use(pTHX_ int is_use, char *s) {
3233 PERL_ARGS_ASSERT_TOKENIZE_USE;
3235 if (PL_expect != XSTATE)
3236 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3237 is_use ? "use" : "no"));
3239 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3240 s = force_version(s, TRUE);
3241 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3242 start_force(PL_curforce);
3243 NEXTVAL_NEXTTOKE.opval = NULL;
3246 else if (*s == 'v') {
3247 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3248 s = force_version(s, FALSE);
3252 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3253 s = force_version(s, FALSE);
3255 pl_yylval.ival = is_use;
3259 static const char* const exp_name[] =
3260 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3261 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3268 Works out what to call the token just pulled out of the input
3269 stream. The yacc parser takes care of taking the ops we return and
3270 stitching them into a tree.
3276 if read an identifier
3277 if we're in a my declaration
3278 croak if they tried to say my($foo::bar)
3279 build the ops for a my() declaration
3280 if it's an access to a my() variable
3281 are we in a sort block?
3282 croak if my($a); $a <=> $b
3283 build ops for access to a my() variable
3284 if in a dq string, and they've said @foo and we can't find @foo
3286 build ops for a bareword
3287 if we already built the token before, use it.
3292 #pragma segment Perl_yylex
3298 register char *s = PL_bufptr;
3303 /* orig_keyword, gvp, and gv are initialized here because
3304 * jump to the label just_a_word_zero can bypass their
3305 * initialization later. */
3306 I32 orig_keyword = 0;
3311 SV* tmp = newSVpvs("");
3312 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3313 (IV)CopLINE(PL_curcop),
3314 lex_state_names[PL_lex_state],
3315 exp_name[PL_expect],
3316 pv_display(tmp, s, strlen(s), 0, 60));
3319 /* check if there's an identifier for us to look at */
3320 if (PL_pending_ident)
3321 return REPORT(S_pending_ident(aTHX));
3323 /* no identifier pending identification */
3325 switch (PL_lex_state) {
3327 case LEX_NORMAL: /* Some compilers will produce faster */
3328 case LEX_INTERPNORMAL: /* code if we comment these out. */
3332 /* when we've already built the next token, just pull it out of the queue */
3336 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
3338 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3339 PL_nexttoke[PL_lasttoke].next_mad = 0;
3340 if (PL_thismad && PL_thismad->mad_key == '_') {
3341 PL_thiswhite = (SV*)PL_thismad->mad_val;
3342 PL_thismad->mad_val = 0;
3343 mad_free(PL_thismad);
3348 PL_lex_state = PL_lex_defer;
3349 PL_expect = PL_lex_expect;
3350 PL_lex_defer = LEX_NORMAL;
3351 if (!PL_nexttoke[PL_lasttoke].next_type)
3356 pl_yylval = PL_nextval[PL_nexttoke];
3358 PL_lex_state = PL_lex_defer;
3359 PL_expect = PL_lex_expect;
3360 PL_lex_defer = LEX_NORMAL;
3364 /* FIXME - can these be merged? */
3365 return(PL_nexttoke[PL_lasttoke].next_type);
3367 return REPORT(PL_nexttype[PL_nexttoke]);
3370 /* interpolated case modifiers like \L \U, including \Q and \E.
3371 when we get here, PL_bufptr is at the \
3373 case LEX_INTERPCASEMOD:
3375 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3376 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3378 /* handle \E or end of string */
3379 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3381 if (PL_lex_casemods) {
3382 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3383 PL_lex_casestack[PL_lex_casemods] = '\0';
3385 if (PL_bufptr != PL_bufend
3386 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3388 PL_lex_state = LEX_INTERPCONCAT;
3391 PL_thistoken = newSVpvs("\\E");
3397 while (PL_bufptr != PL_bufend &&
3398 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3400 PL_thiswhite = newSVpvs("");
3401 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3405 if (PL_bufptr != PL_bufend)
3408 PL_lex_state = LEX_INTERPCONCAT;
3412 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3413 "### Saw case modifier\n"); });
3415 if (s[1] == '\\' && s[2] == 'E') {
3418 PL_thiswhite = newSVpvs("");
3419 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3422 PL_lex_state = LEX_INTERPCONCAT;
3427 if (!PL_madskills) /* when just compiling don't need correct */
3428 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3429 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3430 if ((*s == 'L' || *s == 'U') &&
3431 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3432 PL_lex_casestack[--PL_lex_casemods] = '\0';
3435 if (PL_lex_casemods > 10)
3436 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3437 PL_lex_casestack[PL_lex_casemods++] = *s;
3438 PL_lex_casestack[PL_lex_casemods] = '\0';
3439 PL_lex_state = LEX_INTERPCONCAT;
3440 start_force(PL_curforce);
3441 NEXTVAL_NEXTTOKE.ival = 0;
3443 start_force(PL_curforce);
3445 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3447 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3449 NEXTVAL_NEXTTOKE.ival = OP_LC;
3451 NEXTVAL_NEXTTOKE.ival = OP_UC;
3453 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3455 Perl_croak(aTHX_ "panic: yylex");
3457 SV* const tmpsv = newSVpvs("\\ ");
3458 /* replace the space with the character we want to escape
3460 SvPVX(tmpsv)[1] = *s;
3466 if (PL_lex_starts) {
3472 sv_free(PL_thistoken);
3473 PL_thistoken = newSVpvs("");
3476 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3477 if (PL_lex_casemods == 1 && PL_lex_inpat)
3486 case LEX_INTERPPUSH:
3487 return REPORT(sublex_push());
3489 case LEX_INTERPSTART:
3490 if (PL_bufptr == PL_bufend)
3491 return REPORT(sublex_done());
3492 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3493 "### Interpolated variable\n"); });
3495 PL_lex_dojoin = (*PL_bufptr == '@');
3496 PL_lex_state = LEX_INTERPNORMAL;
3497 if (PL_lex_dojoin) {
3498 start_force(PL_curforce);
3499 NEXTVAL_NEXTTOKE.ival = 0;
3501 start_force(PL_curforce);
3502 force_ident("\"", '$');
3503 start_force(PL_curforce);
3504 NEXTVAL_NEXTTOKE.ival = 0;
3506 start_force(PL_curforce);
3507 NEXTVAL_NEXTTOKE.ival = 0;
3509 start_force(PL_curforce);
3510 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3513 if (PL_lex_starts++) {
3518 sv_free(PL_thistoken);
3519 PL_thistoken = newSVpvs("");
3522 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3523 if (!PL_lex_casemods && PL_lex_inpat)
3530 case LEX_INTERPENDMAYBE:
3531 if (intuit_more(PL_bufptr)) {
3532 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3538 if (PL_lex_dojoin) {
3539 PL_lex_dojoin = FALSE;
3540 PL_lex_state = LEX_INTERPCONCAT;
3544 sv_free(PL_thistoken);
3545 PL_thistoken = newSVpvs("");
3550 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3551 && SvEVALED(PL_lex_repl))
3553 if (PL_bufptr != PL_bufend)
3554 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3558 case LEX_INTERPCONCAT:
3560 if (PL_lex_brackets)
3561 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3563 if (PL_bufptr == PL_bufend)
3564 return REPORT(sublex_done());
3566 if (SvIVX(PL_linestr) == '\'') {
3567 SV *sv = newSVsv(PL_linestr);
3570 else if ( PL_hints & HINT_NEW_RE )
3571 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
3572 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3576 s = scan_const(PL_bufptr);
3578 PL_lex_state = LEX_INTERPCASEMOD;
3580 PL_lex_state = LEX_INTERPSTART;
3583 if (s != PL_bufptr) {
3584 start_force(PL_curforce);
3586 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3588 NEXTVAL_NEXTTOKE = pl_yylval;
3591 if (PL_lex_starts++) {
3595 sv_free(PL_thistoken);
3596 PL_thistoken = newSVpvs("");
3599 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3600 if (!PL_lex_casemods && PL_lex_inpat)
3613 PL_lex_state = LEX_NORMAL;
3614 s = scan_formline(PL_bufptr);
3615 if (!PL_lex_formbrack)
3621 PL_oldoldbufptr = PL_oldbufptr;
3627 sv_free(PL_thistoken);
3630 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3634 if (isIDFIRST_lazy_if(s,UTF))
3636 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
3637 Perl_croak(aTHX_ "Unrecognized character \\x%02X in column %d", *s & 255, (int) len + 1);
3640 goto fake_eof; /* emulate EOF on ^D or ^Z */
3649 if (PL_lex_brackets) {
3650 yyerror((const char *)
3652 ? "Format not terminated"
3653 : "Missing right curly or square bracket"));
3655 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3656 "### Tokener got EOF\n");
3660 if (s++ < PL_bufend)
3661 goto retry; /* ignore stray nulls */
3664 if (!PL_in_eval && !PL_preambled) {
3665 PL_preambled = TRUE;
3671 /* Generate a string of Perl code to load the debugger.
3672 * If PERL5DB is set, it will return the contents of that,
3673 * otherwise a compile-time require of perl5db.pl. */
3675 const char * const pdb = PerlEnv_getenv("PERL5DB");
3678 sv_setpv(PL_linestr, pdb);
3679 sv_catpvs(PL_linestr,";");
3681 SETERRNO(0,SS_NORMAL);
3682 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
3685 sv_setpvs(PL_linestr,"");
3686 if (PL_preambleav) {
3687 SV **svp = AvARRAY(PL_preambleav);
3688 SV **const end = svp + AvFILLp(PL_preambleav);
3690 sv_catsv(PL_linestr, *svp);
3692 sv_catpvs(PL_linestr, ";");
3694 sv_free((SV*)PL_preambleav);
3695 PL_preambleav = NULL;
3698 sv_catpvs(PL_linestr,
3699 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
3700 if (PL_minus_n || PL_minus_p) {
3701 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3703 sv_catpvs(PL_linestr,"chomp;");
3706 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3707 || *PL_splitstr == '"')
3708 && strchr(PL_splitstr + 1, *PL_splitstr))
3709 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3711 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3712 bytes can be used as quoting characters. :-) */
3713 const char *splits = PL_splitstr;
3714 sv_catpvs(PL_linestr, "our @F=split(q\0");
3717 if (*splits == '\\')
3718 sv_catpvn(PL_linestr, splits, 1);
3719 sv_catpvn(PL_linestr, splits, 1);
3720 } while (*splits++);
3721 /* This loop will embed the trailing NUL of
3722 PL_linestr as the last thing it does before
3724 sv_catpvs(PL_linestr, ");");
3728 sv_catpvs(PL_linestr,"our @F=split(' ');");
3731 sv_catpvs(PL_linestr, "\n");
3732 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3733 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3734 PL_last_lop = PL_last_uni = NULL;
3735 if (PERLDB_LINE && PL_curstash != PL_debstash)
3736 update_debugger_info(PL_linestr, NULL, 0);
3740 bof = PL_rsfp ? TRUE : FALSE;
3741 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3744 PL_realtokenstart = -1;
3747 if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3748 PerlIO_clearerr(PL_rsfp);
3750 (void)PerlIO_close(PL_rsfp);
3752 PL_doextract = FALSE;
3754 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3760 sv_setpvs(PL_linestr, ";}continue{print;}");
3762 sv_setpvs(PL_linestr, ";}");
3763 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3764 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3765 PL_last_lop = PL_last_uni = NULL;
3766 PL_minus_n = PL_minus_p = 0;
3769 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3770 PL_last_lop = PL_last_uni = NULL;
3771 sv_setpvn(PL_linestr,"",0);
3772 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3774 /* If it looks like the start of a BOM or raw UTF-16,
3775 * check if it in fact is. */
3781 #ifdef PERLIO_IS_STDIO
3782 # ifdef __GNU_LIBRARY__
3783 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3784 # define FTELL_FOR_PIPE_IS_BROKEN
3788 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3789 # define FTELL_FOR_PIPE_IS_BROKEN
3794 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3796 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3797 s = swallow_bom((U8*)s);
3801 /* Incest with pod. */
3804 sv_catsv(PL_thiswhite, PL_linestr);
3806 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3807 sv_setpvn(PL_linestr, "", 0);
3808 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3809 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3810 PL_last_lop = PL_last_uni = NULL;
3811 PL_doextract = FALSE;
3815 } while (PL_doextract);
3816 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3817 if (PERLDB_LINE && PL_curstash != PL_debstash)
3818 update_debugger_info(PL_linestr, NULL, 0);
3819 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3820 PL_last_lop = PL_last_uni = NULL;
3821 if (CopLINE(PL_curcop) == 1) {
3822 while (s < PL_bufend && isSPACE(*s))
3824 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3828 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3832 if (*s == '#' && *(s+1) == '!')
3834 #ifdef ALTERNATE_SHEBANG
3836 static char const as[] = ALTERNATE_SHEBANG;
3837 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3838 d = s + (sizeof(as) - 1);
3840 #endif /* ALTERNATE_SHEBANG */
3849 while (*d && !isSPACE(*d))
3853 #ifdef ARG_ZERO_IS_SCRIPT
3854 if (ipathend > ipath) {
3856 * HP-UX (at least) sets argv[0] to the script name,
3857 * which makes $^X incorrect. And Digital UNIX and Linux,
3858 * at least, set argv[0] to the basename of the Perl
3859 * interpreter. So, having found "#!", we'll set it right.
3861 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3863 assert(SvPOK(x) || SvGMAGICAL(x));
3864 if (sv_eq(x, CopFILESV(PL_curcop))) {
3865 sv_setpvn(x, ipath, ipathend - ipath);
3871 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3872 const char * const lstart = SvPV_const(x,llen);
3874 bstart += blen - llen;
3875 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3876 sv_setpvn(x, ipath, ipathend - ipath);
3881 TAINT_NOT; /* $^X is always tainted, but that's OK */
3883 #endif /* ARG_ZERO_IS_SCRIPT */
3888 d = instr(s,"perl -");
3890 d = instr(s,"perl");
3892 /* avoid getting into infinite loops when shebang
3893 * line contains "Perl" rather than "perl" */
3895 for (d = ipathend-4; d >= ipath; --d) {
3896 if ((*d == 'p' || *d == 'P')
3897 && !ibcmp(d, "perl", 4))
3907 #ifdef ALTERNATE_SHEBANG
3909 * If the ALTERNATE_SHEBANG on this system starts with a
3910 * character that can be part of a Perl expression, then if
3911 * we see it but not "perl", we're probably looking at the
3912 * start of Perl code, not a request to hand off to some
3913 * other interpreter. Similarly, if "perl" is there, but
3914 * not in the first 'word' of the line, we assume the line
3915 * contains the start of the Perl program.
3917 if (d && *s != '#') {
3918 const char *c = ipath;
3919 while (*c && !strchr("; \t\r\n\f\v#", *c))
3922 d = NULL; /* "perl" not in first word; ignore */
3924 *s = '#'; /* Don't try to parse shebang line */
3926 #endif /* ALTERNATE_SHEBANG */
3927 #ifndef MACOS_TRADITIONAL
3932 !instr(s,"indir") &&
3933 instr(PL_origargv[0],"perl"))
3940 while (s < PL_bufend && isSPACE(*s))
3942 if (s < PL_bufend) {
3943 Newxz(newargv,PL_origargc+3,char*);
3945 while (s < PL_bufend && !isSPACE(*s))
3948 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3951 newargv = PL_origargv;
3954 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3956 Perl_croak(aTHX_ "Can't exec %s", ipath);
3960 while (*d && !isSPACE(*d))
3962 while (SPACE_OR_TAB(*d))
3966 const bool switches_done = PL_doswitches;
3967 const U32 oldpdb = PL_perldb;
3968 const bool oldn = PL_minus_n;
3969 const bool oldp = PL_minus_p;
3973 if (*d1 == 'M' || *d1 == 'm' || *d1 == 'C') {
3974 const char * const m = d1;
3975 while (*d1 && !isSPACE(*d1))
3977 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3980 d1 = moreswitches(d1);
3982 if (PL_doswitches && !switches_done) {
3983 int argc = PL_origargc;
3984 char **argv = PL_origargv;
3987 } while (argc && argv[0][0] == '-' && argv[0][1]);
3988 init_argv_symbols(argc,argv);
3990 if ((PERLDB_LINE && !oldpdb) ||
3991 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3992 /* if we have already added "LINE: while (<>) {",
3993 we must not do it again */
3995 sv_setpvn(PL_linestr, "", 0);
3996 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3997 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3998 PL_last_lop = PL_last_uni = NULL;
3999 PL_preambled = FALSE;
4001 (void)gv_fetchfile(PL_origfilename);
4008 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4010 PL_lex_state = LEX_FORMLINE;
4015 #ifdef PERL_STRICT_CR
4016 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4018 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4020 case ' ': case '\t': case '\f': case 013:
4021 #ifdef MACOS_TRADITIONAL
4025 PL_realtokenstart = -1;
4027 PL_thiswhite = newSVpvs("");
4028 sv_catpvn(PL_thiswhite, s, 1);
4035 PL_realtokenstart = -1;
4039 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
4040 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
4041 /* handle eval qq[#line 1 "foo"\n ...] */
4042 CopLINE_dec(PL_curcop);
4045 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
4047 if (!PL_in_eval || PL_rsfp)
4052 while (d < PL_bufend && *d != '\n')
4056 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4057 Perl_croak(aTHX_ "panic: input overflow");
4060 PL_thiswhite = newSVpvn(s, d - s);
4065 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4067 PL_lex_state = LEX_FORMLINE;
4073 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
4074 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
4077 TOKEN(PEG); /* make sure any #! line is accessible */
4082 /* if (PL_madskills && PL_lex_formbrack) { */
4084 while (d < PL_bufend && *d != '\n')
4088 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4089 Perl_croak(aTHX_ "panic: input overflow");
4090 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4092 PL_thiswhite = newSVpvs("");
4093 if (CopLINE(PL_curcop) == 1) {
4094 sv_setpvn(PL_thiswhite, "", 0);
4097 sv_catpvn(PL_thiswhite, s, d - s);
4111 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4119 while (s < PL_bufend && SPACE_OR_TAB(*s))
4122 if (strnEQ(s,"=>",2)) {
4123 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4124 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4125 OPERATOR('-'); /* unary minus */
4127 PL_last_uni = PL_oldbufptr;
4129 case 'r': ftst = OP_FTEREAD; break;
4130 case 'w': ftst = OP_FTEWRITE; break;
4131 case 'x': ftst = OP_FTEEXEC; break;
4132 case 'o': ftst = OP_FTEOWNED; break;
4133 case 'R': ftst = OP_FTRREAD; break;
4134 case 'W': ftst = OP_FTRWRITE; break;
4135 case 'X': ftst = OP_FTREXEC; break;
4136 case 'O': ftst = OP_FTROWNED; break;
4137 case 'e': ftst = OP_FTIS; break;
4138 case 'z': ftst = OP_FTZERO; break;
4139 case 's': ftst = OP_FTSIZE; break;
4140 case 'f': ftst = OP_FTFILE; break;
4141 case 'd': ftst = OP_FTDIR; break;
4142 case 'l': ftst = OP_FTLINK; break;
4143 case 'p': ftst = OP_FTPIPE; break;
4144 case 'S': ftst = OP_FTSOCK; break;
4145 case 'u': ftst = OP_FTSUID; break;
4146 case 'g': ftst = OP_FTSGID; break;
4147 case 'k': ftst = OP_FTSVTX; break;
4148 case 'b': ftst = OP_FTBLK; break;
4149 case 'c': ftst = OP_FTCHR; break;
4150 case 't': ftst = OP_FTTTY; break;
4151 case 'T': ftst = OP_FTTEXT; break;
4152 case 'B': ftst = OP_FTBINARY; break;
4153 case 'M': case 'A': case 'C':
4154 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4156 case 'M': ftst = OP_FTMTIME; break;
4157 case 'A': ftst = OP_FTATIME; break;
4158 case 'C': ftst = OP_FTCTIME; break;
4166 PL_last_lop_op = (OPCODE)ftst;
4167 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4168 "### Saw file test %c\n", (int)tmp);
4173 /* Assume it was a minus followed by a one-letter named
4174 * subroutine call (or a -bareword), then. */
4175 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4176 "### '-%c' looked like a file test but was not\n",
4183 const char tmp = *s++;
4186 if (PL_expect == XOPERATOR)
4191 else if (*s == '>') {
4194 if (isIDFIRST_lazy_if(s,UTF)) {
4195 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4203 if (PL_expect == XOPERATOR)
4206 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4208 OPERATOR('-'); /* unary minus */
4214 const char tmp = *s++;
4217 if (PL_expect == XOPERATOR)
4222 if (PL_expect == XOPERATOR)
4225 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4232 if (PL_expect != XOPERATOR) {
4233 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4234 PL_expect = XOPERATOR;
4235 force_ident(PL_tokenbuf, '*');
4248 if (PL_expect == XOPERATOR) {
4252 PL_tokenbuf[0] = '%';
4253 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4254 sizeof PL_tokenbuf - 1, FALSE);
4255 if (!PL_tokenbuf[1]) {
4258 PL_pending_ident = '%';
4269 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4276 const char tmp = *s++;
4282 goto just_a_word_zero_gv;
4285 switch (PL_expect) {
4291 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4293 PL_bufptr = s; /* update in case we back off */
4299 PL_expect = XTERMBLOCK;
4302 stuffstart = s - SvPVX(PL_linestr) - 1;
4306 while (isIDFIRST_lazy_if(s,UTF)) {
4309 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4310 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4311 if (tmp < 0) tmp = -tmp;
4325 sv = newSVpvn(s, len);
4327 d = scan_str(d,TRUE,TRUE);
4329 /* MUST advance bufptr here to avoid bogus
4330 "at end of line" context messages from yyerror().
4332 PL_bufptr = s + len;
4333 yyerror("Unterminated attribute parameter in attribute list");
4337 return REPORT(0); /* EOF indicator */
4341 sv_catsv(sv, PL_lex_stuff);
4342 attrs = append_elem(OP_LIST, attrs,
4343 newSVOP(OP_CONST, 0, sv));
4344 SvREFCNT_dec(PL_lex_stuff);
4345 PL_lex_stuff = NULL;
4348 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4350 if (PL_in_my == KEY_our) {
4352 GvUNIQUE_on(cGVOPx_gv(pl_yylval.opval));
4354 /* skip to avoid loading attributes.pm */
4356 deprecate(":unique");
4359 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4362 /* NOTE: any CV attrs applied here need to be part of
4363 the CVf_BUILTIN_ATTRS define in cv.h! */
4364 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4366 CvLVALUE_on(PL_compcv);
4368 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4370 CvLOCKED_on(PL_compcv);
4372 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4374 CvMETHOD_on(PL_compcv);
4376 /* After we've set the flags, it could be argued that
4377 we don't need to do the attributes.pm-based setting
4378 process, and shouldn't bother appending recognized
4379 flags. To experiment with that, uncomment the
4380 following "else". (Note that's already been
4381 uncommented. That keeps the above-applied built-in
4382 attributes from being intercepted (and possibly
4383 rejected) by a package's attribute routines, but is
4384 justified by the performance win for the common case
4385 of applying only built-in attributes.) */
4387 attrs = append_elem(OP_LIST, attrs,
4388 newSVOP(OP_CONST, 0,
4392 if (*s == ':' && s[1] != ':')
4395 break; /* require real whitespace or :'s */
4396 /* XXX losing whitespace on sequential attributes here */
4400 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4401 if (*s != ';' && *s != '}' && *s != tmp
4402 && (tmp != '=' || *s != ')')) {
4403 const char q = ((*s == '\'') ? '"' : '\'');
4404 /* If here for an expression, and parsed no attrs, back
4406 if (tmp == '=' && !attrs) {
4410 /* MUST advance bufptr here to avoid bogus "at end of line"
4411 context messages from yyerror().
4414 yyerror( (const char *)
4416 ? Perl_form(aTHX_ "Invalid separator character "
4417 "%c%c%c in attribute list", q, *s, q)
4418 : "Unterminated attribute list" ) );