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
14 * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
18 * This file is the lexer for Perl. It's closely linked to the
21 * The main routine is yylex(), which returns the next token.
25 #define PERL_IN_TOKE_C
28 #define new_constant(a,b,c,d,e,f,g) \
29 S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
31 #define pl_yylval (PL_parser->yylval)
33 /* YYINITDEPTH -- initial size of the parser's stacks. */
34 #define YYINITDEPTH 200
36 /* XXX temporary backwards compatibility */
37 #define PL_lex_brackets (PL_parser->lex_brackets)
38 #define PL_lex_brackstack (PL_parser->lex_brackstack)
39 #define PL_lex_casemods (PL_parser->lex_casemods)
40 #define PL_lex_casestack (PL_parser->lex_casestack)
41 #define PL_lex_defer (PL_parser->lex_defer)
42 #define PL_lex_dojoin (PL_parser->lex_dojoin)
43 #define PL_lex_expect (PL_parser->lex_expect)
44 #define PL_lex_formbrack (PL_parser->lex_formbrack)
45 #define PL_lex_inpat (PL_parser->lex_inpat)
46 #define PL_lex_inwhat (PL_parser->lex_inwhat)
47 #define PL_lex_op (PL_parser->lex_op)
48 #define PL_lex_repl (PL_parser->lex_repl)
49 #define PL_lex_starts (PL_parser->lex_starts)
50 #define PL_lex_stuff (PL_parser->lex_stuff)
51 #define PL_multi_start (PL_parser->multi_start)
52 #define PL_multi_open (PL_parser->multi_open)
53 #define PL_multi_close (PL_parser->multi_close)
54 #define PL_pending_ident (PL_parser->pending_ident)
55 #define PL_preambled (PL_parser->preambled)
56 #define PL_sublex_info (PL_parser->sublex_info)
57 #define PL_linestr (PL_parser->linestr)
58 #define PL_expect (PL_parser->expect)
59 #define PL_copline (PL_parser->copline)
60 #define PL_bufptr (PL_parser->bufptr)
61 #define PL_oldbufptr (PL_parser->oldbufptr)
62 #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
63 #define PL_linestart (PL_parser->linestart)
64 #define PL_bufend (PL_parser->bufend)
65 #define PL_last_uni (PL_parser->last_uni)
66 #define PL_last_lop (PL_parser->last_lop)
67 #define PL_last_lop_op (PL_parser->last_lop_op)
68 #define PL_lex_state (PL_parser->lex_state)
69 #define PL_rsfp (PL_parser->rsfp)
70 #define PL_rsfp_filters (PL_parser->rsfp_filters)
71 #define PL_in_my (PL_parser->in_my)
72 #define PL_in_my_stash (PL_parser->in_my_stash)
73 #define PL_tokenbuf (PL_parser->tokenbuf)
74 #define PL_multi_end (PL_parser->multi_end)
75 #define PL_error_count (PL_parser->error_count)
78 # define PL_endwhite (PL_parser->endwhite)
79 # define PL_faketokens (PL_parser->faketokens)
80 # define PL_lasttoke (PL_parser->lasttoke)
81 # define PL_nextwhite (PL_parser->nextwhite)
82 # define PL_realtokenstart (PL_parser->realtokenstart)
83 # define PL_skipwhite (PL_parser->skipwhite)
84 # define PL_thisclose (PL_parser->thisclose)
85 # define PL_thismad (PL_parser->thismad)
86 # define PL_thisopen (PL_parser->thisopen)
87 # define PL_thisstuff (PL_parser->thisstuff)
88 # define PL_thistoken (PL_parser->thistoken)
89 # define PL_thiswhite (PL_parser->thiswhite)
90 # define PL_thiswhite (PL_parser->thiswhite)
91 # define PL_nexttoke (PL_parser->nexttoke)
92 # define PL_curforce (PL_parser->curforce)
94 # define PL_nexttoke (PL_parser->nexttoke)
95 # define PL_nexttype (PL_parser->nexttype)
96 # define PL_nextval (PL_parser->nextval)
99 /* This can't be done with embed.fnc, because struct yy_parser contains a
100 member named pending_ident, which clashes with the generated #define */
102 S_pending_ident(pTHX);
104 static const char ident_too_long[] = "Identifier too long";
107 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
108 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
110 # define CURMAD(slot,sv)
111 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
114 #define XFAKEBRACK 128
115 #define XENUMMASK 127
117 #ifdef USE_UTF8_SCRIPTS
118 # define UTF (!IN_BYTES)
120 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
123 /* The maximum number of characters preceding the unrecognized one to display */
124 #define UNRECOGNIZED_PRECEDE_COUNT 10
126 /* In variables named $^X, these are the legal values for X.
127 * 1999-02-27 mjd-perl-patch@plover.com */
128 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
130 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
132 /* LEX_* are values for PL_lex_state, the state of the lexer.
133 * They are arranged oddly so that the guard on the switch statement
134 * can get by with a single comparison (if the compiler is smart enough).
137 /* #define LEX_NOTPARSING 11 is done in perl.h. */
139 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
140 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
141 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
142 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
143 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
145 /* at end of code, eg "$x" followed by: */
146 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
147 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
149 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
150 string or after \E, $foo, etc */
151 #define LEX_INTERPCONST 2 /* NOT USED */
152 #define LEX_FORMLINE 1 /* expecting a format line */
153 #define LEX_KNOWNEXT 0 /* next token known; just return it */
157 static const char* const lex_state_names[] = {
176 #include "keywords.h"
178 /* CLINE is a macro that ensures PL_copline has a sane value */
183 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
186 # define SKIPSPACE0(s) skipspace0(s)
187 # define SKIPSPACE1(s) skipspace1(s)
188 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
189 # define PEEKSPACE(s) skipspace2(s,0)
191 # define SKIPSPACE0(s) skipspace(s)
192 # define SKIPSPACE1(s) skipspace(s)
193 # define SKIPSPACE2(s,tsv) skipspace(s)
194 # define PEEKSPACE(s) skipspace(s)
198 * Convenience functions to return different tokens and prime the
199 * lexer for the next token. They all take an argument.
201 * TOKEN : generic token (used for '(', DOLSHARP, etc)
202 * OPERATOR : generic operator
203 * AOPERATOR : assignment operator
204 * PREBLOCK : beginning the block after an if, while, foreach, ...
205 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
206 * PREREF : *EXPR where EXPR is not a simple identifier
207 * TERM : expression term
208 * LOOPX : loop exiting command (goto, last, dump, etc)
209 * FTST : file test operator
210 * FUN0 : zero-argument function
211 * FUN1 : not used, except for not, which isn't a UNIOP
212 * BOop : bitwise or or xor
214 * SHop : shift operator
215 * PWop : power operator
216 * PMop : pattern-matching operator
217 * Aop : addition-level operator
218 * Mop : multiplication-level operator
219 * Eop : equality-testing operator
220 * Rop : relational operator <= != gt
222 * Also see LOP and lop() below.
225 #ifdef DEBUGGING /* Serve -DT. */
226 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
228 # define REPORT(retval) (retval)
231 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
232 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
233 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
234 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
235 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
236 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
237 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
238 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
239 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
240 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
241 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
242 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
243 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
244 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
245 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
246 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
247 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
248 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
249 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
250 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
252 /* This bit of chicanery makes a unary function followed by
253 * a parenthesis into a function with one argument, highest precedence.
254 * The UNIDOR macro is for unary functions that can be followed by the //
255 * operator (such as C<shift // 0>).
257 #define UNI2(f,x) { \
258 pl_yylval.ival = f; \
261 PL_last_uni = PL_oldbufptr; \
262 PL_last_lop_op = f; \
264 return REPORT( (int)FUNC1 ); \
266 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
268 #define UNI(f) UNI2(f,XTERM)
269 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
271 #define UNIBRACK(f) { \
272 pl_yylval.ival = f; \
274 PL_last_uni = PL_oldbufptr; \
276 return REPORT( (int)FUNC1 ); \
278 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
281 /* grandfather return to old style */
282 #define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
286 /* how to interpret the pl_yylval associated with the token */
290 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
296 static struct debug_tokens {
298 enum token_type type;
300 } const debug_tokens[] =
302 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
303 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
304 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
305 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
306 { ARROW, TOKENTYPE_NONE, "ARROW" },
307 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
308 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
309 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
310 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
311 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
312 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
313 { DO, TOKENTYPE_NONE, "DO" },
314 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
315 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
316 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
317 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
318 { ELSE, TOKENTYPE_NONE, "ELSE" },
319 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
320 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
321 { FOR, TOKENTYPE_IVAL, "FOR" },
322 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
323 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
324 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
325 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
326 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
327 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
328 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
329 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
330 { IF, TOKENTYPE_IVAL, "IF" },
331 { LABEL, TOKENTYPE_PVAL, "LABEL" },
332 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
333 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
334 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
335 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
336 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
337 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
338 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
339 { MY, TOKENTYPE_IVAL, "MY" },
340 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
341 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
342 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
343 { OROP, TOKENTYPE_IVAL, "OROP" },
344 { OROR, TOKENTYPE_NONE, "OROR" },
345 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
346 { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
347 { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
348 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
349 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
350 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
351 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
352 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
353 { PREINC, TOKENTYPE_NONE, "PREINC" },
354 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
355 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
356 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
357 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
358 { SUB, TOKENTYPE_NONE, "SUB" },
359 { THING, TOKENTYPE_OPVAL, "THING" },
360 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
361 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
362 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
363 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
364 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
365 { USE, TOKENTYPE_IVAL, "USE" },
366 { WHEN, TOKENTYPE_IVAL, "WHEN" },
367 { WHILE, TOKENTYPE_IVAL, "WHILE" },
368 { WORD, TOKENTYPE_OPVAL, "WORD" },
369 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
370 { 0, TOKENTYPE_NONE, NULL }
373 /* dump the returned token in rv, plus any optional arg in pl_yylval */
376 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
380 PERL_ARGS_ASSERT_TOKEREPORT;
383 const char *name = NULL;
384 enum token_type type = TOKENTYPE_NONE;
385 const struct debug_tokens *p;
386 SV* const report = newSVpvs("<== ");
388 for (p = debug_tokens; p->token; p++) {
389 if (p->token == (int)rv) {
396 Perl_sv_catpv(aTHX_ report, name);
397 else if ((char)rv > ' ' && (char)rv < '~')
398 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
400 sv_catpvs(report, "EOF");
402 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
405 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
408 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
410 case TOKENTYPE_OPNUM:
411 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
412 PL_op_name[lvalp->ival]);
415 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
417 case TOKENTYPE_OPVAL:
419 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
420 PL_op_name[lvalp->opval->op_type]);
421 if (lvalp->opval->op_type == OP_CONST) {
422 Perl_sv_catpvf(aTHX_ report, " %s",
423 SvPEEK(cSVOPx_sv(lvalp->opval)));
428 sv_catpvs(report, "(opval=null)");
431 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
437 /* print the buffer with suitable escapes */
440 S_printbuf(pTHX_ const char *const fmt, const char *const s)
442 SV* const tmp = newSVpvs("");
444 PERL_ARGS_ASSERT_PRINTBUF;
446 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
453 S_deprecate_commaless_var_list(pTHX) {
455 deprecate("comma-less variable list");
456 return REPORT(','); /* grandfather non-comma-format format */
462 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
463 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
467 S_ao(pTHX_ int toketype)
470 if (*PL_bufptr == '=') {
472 if (toketype == ANDAND)
473 pl_yylval.ival = OP_ANDASSIGN;
474 else if (toketype == OROR)
475 pl_yylval.ival = OP_ORASSIGN;
476 else if (toketype == DORDOR)
477 pl_yylval.ival = OP_DORASSIGN;
485 * When Perl expects an operator and finds something else, no_op
486 * prints the warning. It always prints "<something> found where
487 * operator expected. It prints "Missing semicolon on previous line?"
488 * if the surprise occurs at the start of the line. "do you need to
489 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
490 * where the compiler doesn't know if foo is a method call or a function.
491 * It prints "Missing operator before end of line" if there's nothing
492 * after the missing operator, or "... before <...>" if there is something
493 * after the missing operator.
497 S_no_op(pTHX_ const char *const what, char *s)
500 char * const oldbp = PL_bufptr;
501 const bool is_first = (PL_oldbufptr == PL_linestart);
503 PERL_ARGS_ASSERT_NO_OP;
509 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
510 if (ckWARN_d(WARN_SYNTAX)) {
512 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
513 "\t(Missing semicolon on previous line?)\n");
514 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
516 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
518 if (t < PL_bufptr && isSPACE(*t))
519 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
520 "\t(Do you need to predeclare %.*s?)\n",
521 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
525 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
526 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
534 * Complain about missing quote/regexp/heredoc terminator.
535 * If it's called with NULL then it cauterizes the line buffer.
536 * If we're in a delimited string and the delimiter is a control
537 * character, it's reformatted into a two-char sequence like ^C.
542 S_missingterm(pTHX_ char *s)
548 char * const nl = strrchr(s,'\n');
552 else if (isCNTRL(PL_multi_close)) {
554 tmpbuf[1] = (char)toCTRL(PL_multi_close);
559 *tmpbuf = (char)PL_multi_close;
563 q = strchr(s,'"') ? '\'' : '"';
564 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
567 #define FEATURE_IS_ENABLED(name) \
568 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
569 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
570 /* The longest string we pass in. */
571 #define MAX_FEATURE_LEN (sizeof("switch")-1)
574 * S_feature_is_enabled
575 * Check whether the named feature is enabled.
578 S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
581 HV * const hinthv = GvHV(PL_hintgv);
582 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
584 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
586 assert(namelen <= MAX_FEATURE_LEN);
587 memcpy(&he_name[8], name, namelen);
589 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
593 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
594 * utf16-to-utf8-reversed.
597 #ifdef PERL_CR_FILTER
601 register const char *s = SvPVX_const(sv);
602 register const char * const e = s + SvCUR(sv);
604 PERL_ARGS_ASSERT_STRIP_RETURN;
606 /* outer loop optimized to do nothing if there are no CR-LFs */
608 if (*s++ == '\r' && *s == '\n') {
609 /* hit a CR-LF, need to copy the rest */
610 register char *d = s - 1;
613 if (*s == '\r' && s[1] == '\n')
624 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
626 const I32 count = FILTER_READ(idx+1, sv, maxlen);
627 if (count > 0 && !maxlen)
638 * Create a parser object and initialise its parser and lexer fields
640 * rsfp is the opened file handle to read from (if any),
642 * line holds any initial content already read from the file (or in
643 * the case of no file, such as an eval, the whole contents);
645 * new_filter indicates that this is a new file and it shouldn't inherit
646 * the filters from the current parser (ie require).
650 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
653 const char *s = NULL;
655 yy_parser *parser, *oparser;
657 /* create and initialise a parser */
659 Newxz(parser, 1, yy_parser);
660 parser->old_parser = oparser = PL_parser;
663 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
664 parser->ps = parser->stack;
665 parser->stack_size = YYINITDEPTH;
667 parser->stack->state = 0;
668 parser->yyerrstatus = 0;
669 parser->yychar = YYEMPTY; /* Cause a token to be read. */
671 /* on scope exit, free this parser and restore any outer one */
673 parser->saved_curcop = PL_curcop;
675 /* initialise lexer state */
678 parser->curforce = -1;
680 parser->nexttoke = 0;
682 parser->error_count = oparser ? oparser->error_count : 0;
683 parser->copline = NOLINE;
684 parser->lex_state = LEX_NORMAL;
685 parser->expect = XSTATE;
687 parser->rsfp_filters = (new_filter || !oparser) ? newAV()
688 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
690 Newx(parser->lex_brackstack, 120, char);
691 Newx(parser->lex_casestack, 12, char);
692 *parser->lex_casestack = '\0';
695 s = SvPV_const(line, len);
701 parser->linestr = newSVpvs("\n;");
702 } else if (SvREADONLY(line) || s[len-1] != ';') {
703 parser->linestr = newSVsv(line);
705 sv_catpvs(parser->linestr, "\n;");
708 SvREFCNT_inc_simple_void_NN(line);
709 parser->linestr = line;
711 parser->oldoldbufptr =
714 parser->linestart = SvPVX(parser->linestr);
715 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
716 parser->last_lop = parser->last_uni = NULL;
720 /* delete a parser object */
723 Perl_parser_free(pTHX_ const yy_parser *parser)
725 PERL_ARGS_ASSERT_PARSER_FREE;
727 PL_curcop = parser->saved_curcop;
728 SvREFCNT_dec(parser->linestr);
730 if (parser->rsfp == PerlIO_stdin())
731 PerlIO_clearerr(parser->rsfp);
732 else if (parser->rsfp && (!parser->old_parser ||
733 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
734 PerlIO_close(parser->rsfp);
735 SvREFCNT_dec(parser->rsfp_filters);
737 Safefree(parser->stack);
738 Safefree(parser->lex_brackstack);
739 Safefree(parser->lex_casestack);
740 PL_parser = parser->old_parser;
747 * Finalizer for lexing operations. Must be called when the parser is
748 * done with the lexer.
755 PL_doextract = FALSE;
760 * This subroutine has nothing to do with tilting, whether at windmills
761 * or pinball tables. Its name is short for "increment line". It
762 * increments the current line number in CopLINE(PL_curcop) and checks
763 * to see whether the line starts with a comment of the form
764 * # line 500 "foo.pm"
765 * If so, it sets the current line number and file to the values in the comment.
769 S_incline(pTHX_ const char *s)
776 PERL_ARGS_ASSERT_INCLINE;
778 CopLINE_inc(PL_curcop);
781 while (SPACE_OR_TAB(*s))
783 if (strnEQ(s, "line", 4))
787 if (SPACE_OR_TAB(*s))
791 while (SPACE_OR_TAB(*s))
799 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
801 while (SPACE_OR_TAB(*s))
803 if (*s == '"' && (t = strchr(s+1, '"'))) {
813 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
815 if (*e != '\n' && *e != '\0')
816 return; /* false alarm */
819 const STRLEN len = t - s;
821 SV *const temp_sv = CopFILESV(PL_curcop);
827 tmplen = SvCUR(temp_sv);
833 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
834 /* must copy *{"::_<(eval N)[oldfilename:L]"}
835 * to *{"::_<newfilename"} */
836 /* However, the long form of evals is only turned on by the
837 debugger - usually they're "(eval %lu)" */
841 STRLEN tmplen2 = len;
842 if (tmplen + 2 <= sizeof smallbuf)
845 Newx(tmpbuf, tmplen + 2, char);
848 memcpy(tmpbuf + 2, cf, tmplen);
850 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
855 if (tmplen2 + 2 <= sizeof smallbuf)
858 Newx(tmpbuf2, tmplen2 + 2, char);
860 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
861 /* Either they malloc'd it, or we malloc'd it,
862 so no prefix is present in ours. */
867 memcpy(tmpbuf2 + 2, s, tmplen2);
870 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
872 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
873 /* adjust ${"::_<newfilename"} to store the new file name */
874 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
875 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
876 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
879 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
881 if (tmpbuf != smallbuf) Safefree(tmpbuf);
884 CopFILE_free(PL_curcop);
885 CopFILE_setn(PL_curcop, s, len);
887 CopLINE_set(PL_curcop, atoi(n)-1);
891 /* skip space before PL_thistoken */
894 S_skipspace0(pTHX_ register char *s)
896 PERL_ARGS_ASSERT_SKIPSPACE0;
903 PL_thiswhite = newSVpvs("");
904 sv_catsv(PL_thiswhite, PL_skipwhite);
905 sv_free(PL_skipwhite);
908 PL_realtokenstart = s - SvPVX(PL_linestr);
912 /* skip space after PL_thistoken */
915 S_skipspace1(pTHX_ register char *s)
917 const char *start = s;
918 I32 startoff = start - SvPVX(PL_linestr);
920 PERL_ARGS_ASSERT_SKIPSPACE1;
925 start = SvPVX(PL_linestr) + startoff;
926 if (!PL_thistoken && PL_realtokenstart >= 0) {
927 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
928 PL_thistoken = newSVpvn(tstart, start - tstart);
930 PL_realtokenstart = -1;
933 PL_nextwhite = newSVpvs("");
934 sv_catsv(PL_nextwhite, PL_skipwhite);
935 sv_free(PL_skipwhite);
942 S_skipspace2(pTHX_ register char *s, SV **svp)
945 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
946 const I32 startoff = s - SvPVX(PL_linestr);
948 PERL_ARGS_ASSERT_SKIPSPACE2;
951 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
952 if (!PL_madskills || !svp)
954 start = SvPVX(PL_linestr) + startoff;
955 if (!PL_thistoken && PL_realtokenstart >= 0) {
956 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
957 PL_thistoken = newSVpvn(tstart, start - tstart);
958 PL_realtokenstart = -1;
963 sv_setsv(*svp, PL_skipwhite);
964 sv_free(PL_skipwhite);
973 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
975 AV *av = CopFILEAVx(PL_curcop);
977 SV * const sv = newSV_type(SVt_PVMG);
979 sv_setsv(sv, orig_sv);
981 sv_setpvn(sv, buf, len);
984 av_store(av, (I32)CopLINE(PL_curcop), sv);
990 * Called to gobble the appropriate amount and type of whitespace.
991 * Skips comments as well.
995 S_skipspace(pTHX_ register char *s)
1000 int startoff = s - SvPVX(PL_linestr);
1002 PERL_ARGS_ASSERT_SKIPSPACE;
1005 sv_free(PL_skipwhite);
1009 PERL_ARGS_ASSERT_SKIPSPACE;
1011 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1012 while (s < PL_bufend && SPACE_OR_TAB(*s))
1022 SSize_t oldprevlen, oldoldprevlen;
1023 SSize_t oldloplen = 0, oldunilen = 0;
1024 while (s < PL_bufend && isSPACE(*s)) {
1025 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1030 if (s < PL_bufend && *s == '#') {
1031 while (s < PL_bufend && *s != '\n')
1033 if (s < PL_bufend) {
1035 if (PL_in_eval && !PL_rsfp) {
1042 /* only continue to recharge the buffer if we're at the end
1043 * of the buffer, we're not reading from a source filter, and
1044 * we're in normal lexing mode
1046 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1047 PL_lex_state == LEX_FORMLINE)
1054 /* try to recharge the buffer */
1056 curoff = s - SvPVX(PL_linestr);
1059 if ((s = filter_gets(PL_linestr, (prevlen = SvCUR(PL_linestr))))
1063 if (PL_madskills && curoff != startoff) {
1065 PL_skipwhite = newSVpvs("");
1066 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1070 /* mustn't throw out old stuff yet if madpropping */
1071 SvCUR(PL_linestr) = curoff;
1072 s = SvPVX(PL_linestr) + curoff;
1074 if (curoff && s[-1] == '\n')
1078 /* end of file. Add on the -p or -n magic */
1079 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1082 sv_catpvs(PL_linestr,
1083 ";}continue{print or die qq(-p destination: $!\\n);}");
1085 sv_setpvs(PL_linestr,
1086 ";}continue{print or die qq(-p destination: $!\\n);}");
1088 PL_minus_n = PL_minus_p = 0;
1090 else if (PL_minus_n) {
1092 sv_catpvs(PL_linestr, ";}");
1094 sv_setpvs(PL_linestr, ";}");
1100 sv_catpvs(PL_linestr,";");
1102 sv_setpvs(PL_linestr,";");
1105 /* reset variables for next time we lex */
1106 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1112 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1113 PL_last_lop = PL_last_uni = NULL;
1115 /* Close the filehandle. Could be from
1116 * STDIN, or a regular file. If we were reading code from
1117 * STDIN (because the commandline held no -e or filename)
1118 * then we don't close it, we reset it so the code can
1119 * read from STDIN too.
1122 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1123 PerlIO_clearerr(PL_rsfp);
1125 (void)PerlIO_close(PL_rsfp);
1130 /* not at end of file, so we only read another line */
1131 /* make corresponding updates to old pointers, for yyerror() */
1132 oldprevlen = PL_oldbufptr - PL_bufend;
1133 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1135 oldunilen = PL_last_uni - PL_bufend;
1137 oldloplen = PL_last_lop - PL_bufend;
1138 PL_linestart = PL_bufptr = s + prevlen;
1139 PL_bufend = s + SvCUR(PL_linestr);
1141 PL_oldbufptr = s + oldprevlen;
1142 PL_oldoldbufptr = s + oldoldprevlen;
1144 PL_last_uni = s + oldunilen;
1146 PL_last_lop = s + oldloplen;
1149 /* debugger active and we're not compiling the debugger code,
1150 * so store the line into the debugger's array of lines
1152 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
1153 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1160 PL_skipwhite = newSVpvs("");
1161 curoff = s - SvPVX(PL_linestr);
1162 if (curoff - startoff)
1163 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1172 * Check the unary operators to ensure there's no ambiguity in how they're
1173 * used. An ambiguous piece of code would be:
1175 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1176 * the +5 is its argument.
1186 if (PL_oldoldbufptr != PL_last_uni)
1188 while (isSPACE(*PL_last_uni))
1191 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1193 if ((t = strchr(s, '(')) && t < PL_bufptr)
1196 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1197 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1198 (int)(s - PL_last_uni), PL_last_uni);
1202 * LOP : macro to build a list operator. Its behaviour has been replaced
1203 * with a subroutine, S_lop() for which LOP is just another name.
1206 #define LOP(f,x) return lop(f,x,s)
1210 * Build a list operator (or something that might be one). The rules:
1211 * - if we have a next token, then it's a list operator [why?]
1212 * - if the next thing is an opening paren, then it's a function
1213 * - else it's a list operator
1217 S_lop(pTHX_ I32 f, int x, char *s)
1221 PERL_ARGS_ASSERT_LOP;
1227 PL_last_lop = PL_oldbufptr;
1228 PL_last_lop_op = (OPCODE)f;
1231 return REPORT(LSTOP);
1234 return REPORT(LSTOP);
1237 return REPORT(FUNC);
1240 return REPORT(FUNC);
1242 return REPORT(LSTOP);
1248 * Sets up for an eventual force_next(). start_force(0) basically does
1249 * an unshift, while start_force(-1) does a push. yylex removes items
1254 S_start_force(pTHX_ int where)
1258 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1259 where = PL_lasttoke;
1260 assert(PL_curforce < 0 || PL_curforce == where);
1261 if (PL_curforce != where) {
1262 for (i = PL_lasttoke; i > where; --i) {
1263 PL_nexttoke[i] = PL_nexttoke[i-1];
1267 if (PL_curforce < 0) /* in case of duplicate start_force() */
1268 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1269 PL_curforce = where;
1272 curmad('^', newSVpvs(""));
1273 CURMAD('_', PL_nextwhite);
1278 S_curmad(pTHX_ char slot, SV *sv)
1284 if (PL_curforce < 0)
1285 where = &PL_thismad;
1287 where = &PL_nexttoke[PL_curforce].next_mad;
1293 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1295 else if (PL_encoding) {
1296 sv_recode_to_utf8(sv, PL_encoding);
1301 /* keep a slot open for the head of the list? */
1302 if (slot != '_' && *where && (*where)->mad_key == '^') {
1303 (*where)->mad_key = slot;
1304 sv_free(MUTABLE_SV(((*where)->mad_val)));
1305 (*where)->mad_val = (void*)sv;
1308 addmad(newMADsv(slot, sv), where, 0);
1311 # define start_force(where) NOOP
1312 # define curmad(slot, sv) NOOP
1317 * When the lexer realizes it knows the next token (for instance,
1318 * it is reordering tokens for the parser) then it can call S_force_next
1319 * to know what token to return the next time the lexer is called. Caller
1320 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1321 * and possibly PL_expect to ensure the lexer handles the token correctly.
1325 S_force_next(pTHX_ I32 type)
1330 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1331 tokereport(type, &NEXTVAL_NEXTTOKE);
1335 if (PL_curforce < 0)
1336 start_force(PL_lasttoke);
1337 PL_nexttoke[PL_curforce].next_type = type;
1338 if (PL_lex_state != LEX_KNOWNEXT)
1339 PL_lex_defer = PL_lex_state;
1340 PL_lex_state = LEX_KNOWNEXT;
1341 PL_lex_expect = PL_expect;
1344 PL_nexttype[PL_nexttoke] = type;
1346 if (PL_lex_state != LEX_KNOWNEXT) {
1347 PL_lex_defer = PL_lex_state;
1348 PL_lex_expect = PL_expect;
1349 PL_lex_state = LEX_KNOWNEXT;
1355 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1358 SV * const sv = newSVpvn_utf8(start, len,
1361 && !is_ascii_string((const U8*)start, len)
1362 && is_utf8_string((const U8*)start, len));
1368 * When the lexer knows the next thing is a word (for instance, it has
1369 * just seen -> and it knows that the next char is a word char, then
1370 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1374 * char *start : buffer position (must be within PL_linestr)
1375 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1376 * int check_keyword : if true, Perl checks to make sure the word isn't
1377 * a keyword (do this if the word is a label, e.g. goto FOO)
1378 * int allow_pack : if true, : characters will also be allowed (require,
1379 * use, etc. do this)
1380 * int allow_initial_tick : used by the "sub" lexer only.
1384 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1390 PERL_ARGS_ASSERT_FORCE_WORD;
1392 start = SKIPSPACE1(start);
1394 if (isIDFIRST_lazy_if(s,UTF) ||
1395 (allow_pack && *s == ':') ||
1396 (allow_initial_tick && *s == '\'') )
1398 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1399 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1401 start_force(PL_curforce);
1403 curmad('X', newSVpvn(start,s-start));
1404 if (token == METHOD) {
1409 PL_expect = XOPERATOR;
1413 curmad('g', newSVpvs( "forced" ));
1414 NEXTVAL_NEXTTOKE.opval
1415 = (OP*)newSVOP(OP_CONST,0,
1416 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1417 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1425 * Called when the lexer wants $foo *foo &foo etc, but the program
1426 * text only contains the "foo" portion. The first argument is a pointer
1427 * to the "foo", and the second argument is the type symbol to prefix.
1428 * Forces the next token to be a "WORD".
1429 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1433 S_force_ident(pTHX_ register const char *s, int kind)
1437 PERL_ARGS_ASSERT_FORCE_IDENT;
1440 const STRLEN len = strlen(s);
1441 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1442 start_force(PL_curforce);
1443 NEXTVAL_NEXTTOKE.opval = o;
1446 o->op_private = OPpCONST_ENTERED;
1447 /* XXX see note in pp_entereval() for why we forgo typo
1448 warnings if the symbol must be introduced in an eval.
1450 gv_fetchpvn_flags(s, len,
1451 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1453 kind == '$' ? SVt_PV :
1454 kind == '@' ? SVt_PVAV :
1455 kind == '%' ? SVt_PVHV :
1463 Perl_str_to_version(pTHX_ SV *sv)
1468 const char *start = SvPV_const(sv,len);
1469 const char * const end = start + len;
1470 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1472 PERL_ARGS_ASSERT_STR_TO_VERSION;
1474 while (start < end) {
1478 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1483 retval += ((NV)n)/nshift;
1492 * Forces the next token to be a version number.
1493 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1494 * and if "guessing" is TRUE, then no new token is created (and the caller
1495 * must use an alternative parsing method).
1499 S_force_version(pTHX_ char *s, int guessing)
1505 I32 startoff = s - SvPVX(PL_linestr);
1508 PERL_ARGS_ASSERT_FORCE_VERSION;
1516 while (isDIGIT(*d) || *d == '_' || *d == '.')
1520 start_force(PL_curforce);
1521 curmad('X', newSVpvn(s,d-s));
1524 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1526 s = scan_num(s, &pl_yylval);
1527 version = pl_yylval.opval;
1528 ver = cSVOPx(version)->op_sv;
1529 if (SvPOK(ver) && !SvNIOK(ver)) {
1530 SvUPGRADE(ver, SVt_PVNV);
1531 SvNV_set(ver, str_to_version(ver));
1532 SvNOK_on(ver); /* hint that it is a version */
1535 else if (guessing) {
1538 sv_free(PL_nextwhite); /* let next token collect whitespace */
1540 s = SvPVX(PL_linestr) + startoff;
1548 if (PL_madskills && !version) {
1549 sv_free(PL_nextwhite); /* let next token collect whitespace */
1551 s = SvPVX(PL_linestr) + startoff;
1554 /* NOTE: The parser sees the package name and the VERSION swapped */
1555 start_force(PL_curforce);
1556 NEXTVAL_NEXTTOKE.opval = version;
1564 * Tokenize a quoted string passed in as an SV. It finds the next
1565 * chunk, up to end of string or a backslash. It may make a new
1566 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1571 S_tokeq(pTHX_ SV *sv)
1575 register char *send;
1580 PERL_ARGS_ASSERT_TOKEQ;
1585 s = SvPV_force(sv, len);
1586 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1589 while (s < send && *s != '\\')
1594 if ( PL_hints & HINT_NEW_STRING ) {
1595 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
1599 if (s + 1 < send && (s[1] == '\\'))
1600 s++; /* all that, just for this */
1605 SvCUR_set(sv, d - SvPVX_const(sv));
1607 if ( PL_hints & HINT_NEW_STRING )
1608 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
1613 * Now come three functions related to double-quote context,
1614 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1615 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1616 * interact with PL_lex_state, and create fake ( ... ) argument lists
1617 * to handle functions and concatenation.
1618 * They assume that whoever calls them will be setting up a fake
1619 * join call, because each subthing puts a ',' after it. This lets
1622 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1624 * (I'm not sure whether the spurious commas at the end of lcfirst's
1625 * arguments and join's arguments are created or not).
1630 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1632 * Pattern matching will set PL_lex_op to the pattern-matching op to
1633 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
1635 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1637 * Everything else becomes a FUNC.
1639 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1640 * had an OP_CONST or OP_READLINE). This just sets us up for a
1641 * call to S_sublex_push().
1645 S_sublex_start(pTHX)
1648 register const I32 op_type = pl_yylval.ival;
1650 if (op_type == OP_NULL) {
1651 pl_yylval.opval = PL_lex_op;
1655 if (op_type == OP_CONST || op_type == OP_READLINE) {
1656 SV *sv = tokeq(PL_lex_stuff);
1658 if (SvTYPE(sv) == SVt_PVIV) {
1659 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1661 const char * const p = SvPV_const(sv, len);
1662 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
1666 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1667 PL_lex_stuff = NULL;
1668 /* Allow <FH> // "foo" */
1669 if (op_type == OP_READLINE)
1670 PL_expect = XTERMORDORDOR;
1673 else if (op_type == OP_BACKTICK && PL_lex_op) {
1674 /* readpipe() vas overriden */
1675 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1676 pl_yylval.opval = PL_lex_op;
1678 PL_lex_stuff = NULL;
1682 PL_sublex_info.super_state = PL_lex_state;
1683 PL_sublex_info.sub_inwhat = (U16)op_type;
1684 PL_sublex_info.sub_op = PL_lex_op;
1685 PL_lex_state = LEX_INTERPPUSH;
1689 pl_yylval.opval = PL_lex_op;
1699 * Create a new scope to save the lexing state. The scope will be
1700 * ended in S_sublex_done. Returns a '(', starting the function arguments
1701 * to the uc, lc, etc. found before.
1702 * Sets PL_lex_state to LEX_INTERPCONCAT.
1711 PL_lex_state = PL_sublex_info.super_state;
1712 SAVEBOOL(PL_lex_dojoin);
1713 SAVEI32(PL_lex_brackets);
1714 SAVEI32(PL_lex_casemods);
1715 SAVEI32(PL_lex_starts);
1716 SAVEI8(PL_lex_state);
1717 SAVEVPTR(PL_lex_inpat);
1718 SAVEI16(PL_lex_inwhat);
1719 SAVECOPLINE(PL_curcop);
1720 SAVEPPTR(PL_bufptr);
1721 SAVEPPTR(PL_bufend);
1722 SAVEPPTR(PL_oldbufptr);
1723 SAVEPPTR(PL_oldoldbufptr);
1724 SAVEPPTR(PL_last_lop);
1725 SAVEPPTR(PL_last_uni);
1726 SAVEPPTR(PL_linestart);
1727 SAVESPTR(PL_linestr);
1728 SAVEGENERICPV(PL_lex_brackstack);
1729 SAVEGENERICPV(PL_lex_casestack);
1731 PL_linestr = PL_lex_stuff;
1732 PL_lex_stuff = NULL;
1734 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1735 = SvPVX(PL_linestr);
1736 PL_bufend += SvCUR(PL_linestr);
1737 PL_last_lop = PL_last_uni = NULL;
1738 SAVEFREESV(PL_linestr);
1740 PL_lex_dojoin = FALSE;
1741 PL_lex_brackets = 0;
1742 Newx(PL_lex_brackstack, 120, char);
1743 Newx(PL_lex_casestack, 12, char);
1744 PL_lex_casemods = 0;
1745 *PL_lex_casestack = '\0';
1747 PL_lex_state = LEX_INTERPCONCAT;
1748 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1750 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1751 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1752 PL_lex_inpat = PL_sublex_info.sub_op;
1754 PL_lex_inpat = NULL;
1761 * Restores lexer state after a S_sublex_push.
1768 if (!PL_lex_starts++) {
1769 SV * const sv = newSVpvs("");
1770 if (SvUTF8(PL_linestr))
1772 PL_expect = XOPERATOR;
1773 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1777 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1778 PL_lex_state = LEX_INTERPCASEMOD;
1782 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1783 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1784 PL_linestr = PL_lex_repl;
1786 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1787 PL_bufend += SvCUR(PL_linestr);
1788 PL_last_lop = PL_last_uni = NULL;
1789 SAVEFREESV(PL_linestr);
1790 PL_lex_dojoin = FALSE;
1791 PL_lex_brackets = 0;
1792 PL_lex_casemods = 0;
1793 *PL_lex_casestack = '\0';
1795 if (SvEVALED(PL_lex_repl)) {
1796 PL_lex_state = LEX_INTERPNORMAL;
1798 /* we don't clear PL_lex_repl here, so that we can check later
1799 whether this is an evalled subst; that means we rely on the
1800 logic to ensure sublex_done() is called again only via the
1801 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1804 PL_lex_state = LEX_INTERPCONCAT;
1814 PL_endwhite = newSVpvs("");
1815 sv_catsv(PL_endwhite, PL_thiswhite);
1819 sv_setpvs(PL_thistoken,"");
1821 PL_realtokenstart = -1;
1825 PL_bufend = SvPVX(PL_linestr);
1826 PL_bufend += SvCUR(PL_linestr);
1827 PL_expect = XOPERATOR;
1828 PL_sublex_info.sub_inwhat = 0;
1836 Extracts a pattern, double-quoted string, or transliteration. This
1839 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1840 processing a pattern (PL_lex_inpat is true), a transliteration
1841 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1843 Returns a pointer to the character scanned up to. If this is
1844 advanced from the start pointer supplied (i.e. if anything was
1845 successfully parsed), will leave an OP for the substring scanned
1846 in pl_yylval. Caller must intuit reason for not parsing further
1847 by looking at the next characters herself.
1851 double-quoted style: \r and \n
1852 regexp special ones: \D \s
1855 case and quoting: \U \Q \E
1856 stops on @ and $, but not for $ as tail anchor
1858 In transliterations:
1859 characters are VERY literal, except for - not at the start or end
1860 of the string, which indicates a range. If the range is in bytes,
1861 scan_const expands the range to the full set of intermediate
1862 characters. If the range is in utf8, the hyphen is replaced with
1863 a certain range mark which will be handled by pmtrans() in op.c.
1865 In double-quoted strings:
1867 double-quoted style: \r and \n
1869 deprecated backrefs: \1 (in substitution replacements)
1870 case and quoting: \U \Q \E
1873 scan_const does *not* construct ops to handle interpolated strings.
1874 It stops processing as soon as it finds an embedded $ or @ variable
1875 and leaves it to the caller to work out what's going on.
1877 embedded arrays (whether in pattern or not) could be:
1878 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1880 $ in double-quoted strings must be the symbol of an embedded scalar.
1882 $ in pattern could be $foo or could be tail anchor. Assumption:
1883 it's a tail anchor if $ is the last thing in the string, or if it's
1884 followed by one of "()| \r\n\t"
1886 \1 (backreferences) are turned into $1
1888 The structure of the code is
1889 while (there's a character to process) {
1890 handle transliteration ranges
1891 skip regexp comments /(?#comment)/ and codes /(?{code})/
1892 skip #-initiated comments in //x patterns
1893 check for embedded arrays
1894 check for embedded scalars
1896 leave intact backslashes from leaveit (below)
1897 deprecate \1 in substitution replacements
1898 handle string-changing backslashes \l \U \Q \E, etc.
1899 switch (what was escaped) {
1900 handle \- in a transliteration (becomes a literal -)
1901 handle \132 (octal characters)
1902 handle \x15 and \x{1234} (hex characters)
1903 handle \N{name} (named characters)
1904 handle \cV (control characters)
1905 handle printf-style backslashes (\f, \r, \n, etc)
1908 } (end if backslash)
1909 handle regular character
1910 } (end while character to read)
1915 S_scan_const(pTHX_ char *start)
1918 register char *send = PL_bufend; /* end of the constant */
1919 SV *sv = newSV(send - start); /* sv for the constant. See
1920 note below on sizing. */
1921 register char *s = start; /* start of the constant */
1922 register char *d = SvPVX(sv); /* destination for copies */
1923 bool dorange = FALSE; /* are we in a translit range? */
1924 bool didrange = FALSE; /* did we just finish a range? */
1925 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1926 I32 this_utf8 = UTF; /* Is the source string assumed
1927 to be UTF8? But, this can
1928 show as true when the source
1929 isn't utf8, as for example
1930 when it is entirely composed
1933 /* Note on sizing: The scanned constant is placed into sv, which is
1934 * initialized by newSV() assuming one byte of output for every byte of
1935 * input. This routine expects newSV() to allocate an extra byte for a
1936 * trailing NUL, which this routine will append if it gets to the end of
1937 * the input. There may be more bytes of input than output (eg., \N{LATIN
1938 * CAPITAL LETTER A}), or more output than input if the constant ends up
1939 * recoded to utf8, but each time a construct is found that might increase
1940 * the needed size, SvGROW() is called. Its size parameter each time is
1941 * based on the best guess estimate at the time, namely the length used so
1942 * far, plus the length the current construct will occupy, plus room for
1943 * the trailing NUL, plus one byte for every input byte still unscanned */
1947 UV literal_endpoint = 0;
1948 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1951 PERL_ARGS_ASSERT_SCAN_CONST;
1953 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1954 /* If we are doing a trans and we know we want UTF8 set expectation */
1955 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1956 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1960 while (s < send || dorange) {
1961 /* get transliterations out of the way (they're most literal) */
1962 if (PL_lex_inwhat == OP_TRANS) {
1963 /* expand a range A-Z to the full set of characters. AIE! */
1965 I32 i; /* current expanded character */
1966 I32 min; /* first character in range */
1967 I32 max; /* last character in range */
1978 char * const c = (char*)utf8_hop((U8*)d, -1);
1982 *c = (char)UTF_TO_NATIVE(0xff);
1983 /* mark the range as done, and continue */
1989 i = d - SvPVX_const(sv); /* remember current offset */
1992 SvLEN(sv) + (has_utf8 ?
1993 (512 - UTF_CONTINUATION_MARK +
1996 /* How many two-byte within 0..255: 128 in UTF-8,
1997 * 96 in UTF-8-mod. */
1999 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2001 d = SvPVX(sv) + i; /* refresh d after realloc */
2005 for (j = 0; j <= 1; j++) {
2006 char * const c = (char*)utf8_hop((U8*)d, -1);
2007 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2013 max = (U8)0xff; /* only to \xff */
2014 uvmax = uv; /* \x{100} to uvmax */
2016 d = c; /* eat endpoint chars */
2021 d -= 2; /* eat the first char and the - */
2022 min = (U8)*d; /* first char in range */
2023 max = (U8)d[1]; /* last char in range */
2030 "Invalid range \"%c-%c\" in transliteration operator",
2031 (char)min, (char)max);
2035 if (literal_endpoint == 2 &&
2036 ((isLOWER(min) && isLOWER(max)) ||
2037 (isUPPER(min) && isUPPER(max)))) {
2039 for (i = min; i <= max; i++)
2041 *d++ = NATIVE_TO_NEED(has_utf8,i);
2043 for (i = min; i <= max; i++)
2045 *d++ = NATIVE_TO_NEED(has_utf8,i);
2050 for (i = min; i <= max; i++)
2053 const U8 ch = (U8)NATIVE_TO_UTF(i);
2054 if (UNI_IS_INVARIANT(ch))
2057 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2058 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2067 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2069 *d++ = (char)UTF_TO_NATIVE(0xff);
2071 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2075 /* mark the range as done, and continue */
2079 literal_endpoint = 0;
2084 /* range begins (ignore - as first or last char) */
2085 else if (*s == '-' && s+1 < send && s != start) {
2087 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2094 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2104 literal_endpoint = 0;
2105 native_range = TRUE;
2110 /* if we get here, we're not doing a transliteration */
2112 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2113 except for the last char, which will be done separately. */
2114 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2116 while (s+1 < send && *s != ')')
2117 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2119 else if (s[2] == '{' /* This should match regcomp.c */
2120 || (s[2] == '?' && s[3] == '{'))
2123 char *regparse = s + (s[2] == '{' ? 3 : 4);
2126 while (count && (c = *regparse)) {
2127 if (c == '\\' && regparse[1])
2135 if (*regparse != ')')
2136 regparse--; /* Leave one char for continuation. */
2137 while (s < regparse)
2138 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2142 /* likewise skip #-initiated comments in //x patterns */
2143 else if (*s == '#' && PL_lex_inpat &&
2144 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2145 while (s+1 < send && *s != '\n')
2146 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2149 /* check for embedded arrays
2150 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2152 else if (*s == '@' && s[1]) {
2153 if (isALNUM_lazy_if(s+1,UTF))
2155 if (strchr(":'{$", s[1]))
2157 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2158 break; /* in regexp, neither @+ nor @- are interpolated */
2161 /* check for embedded scalars. only stop if we're sure it's a
2164 else if (*s == '$') {
2165 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2167 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2169 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2170 "Possible unintended interpolation of $\\ in regex");
2172 break; /* in regexp, $ might be tail anchor */
2176 /* End of else if chain - OP_TRANS rejoin rest */
2179 if (*s == '\\' && s+1 < send) {
2182 /* deprecate \1 in strings and substitution replacements */
2183 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2184 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2186 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2191 /* string-change backslash escapes */
2192 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2196 /* skip any other backslash escapes in a pattern */
2197 else if (PL_lex_inpat) {
2198 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2199 goto default_action;
2202 /* if we get here, it's either a quoted -, or a digit */
2205 /* quoted - in transliterations */
2207 if (PL_lex_inwhat == OP_TRANS) {
2214 if ((isALPHA(*s) || isDIGIT(*s)))
2215 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
2216 "Unrecognized escape \\%c passed through",
2218 /* default action is to copy the quoted character */
2219 goto default_action;
2222 /* eg. \132 indicates the octal constant 0x132 */
2223 case '0': case '1': case '2': case '3':
2224 case '4': case '5': case '6': case '7':
2228 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2231 goto NUM_ESCAPE_INSERT;
2233 /* eg. \x24 indicates the hex constant 0x24 */
2237 char* const e = strchr(s, '}');
2238 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2239 PERL_SCAN_DISALLOW_PREFIX;
2244 yyerror("Missing right brace on \\x{}");
2248 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2254 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2255 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2261 /* Insert oct, hex, or \N{U+...} escaped character. There will
2262 * always be enough room in sv since such escapes will be
2263 * longer than any UTF-8 sequence they can end up as, except if
2264 * they force us to recode the rest of the string into utf8 */
2266 /* Here uv is the ordinal of the next character being added in
2267 * unicode (converted from native). (It has to be done before
2268 * here because \N is interpreted as unicode, and oct and hex
2270 if (!UNI_IS_INVARIANT(uv)) {
2271 if (!has_utf8 && uv > 255) {
2272 /* Might need to recode whatever we have accumulated so
2273 * far if it contains any chars variant in utf8 or
2276 SvCUR_set(sv, d - SvPVX_const(sv));
2279 /* See Note on sizing above. */
2280 sv_utf8_upgrade_flags_grow(sv,
2281 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2282 UNISKIP(uv) + (STRLEN)(send - s) + 1);
2283 d = SvPVX(sv) + SvCUR(sv);
2288 d = (char*)uvuni_to_utf8((U8*)d, uv);
2289 if (PL_lex_inwhat == OP_TRANS &&
2290 PL_sublex_info.sub_op) {
2291 PL_sublex_info.sub_op->op_private |=
2292 (PL_lex_repl ? OPpTRANS_FROM_UTF
2296 if (uv > 255 && !dorange)
2297 native_range = FALSE;
2309 /* \N{LATIN SMALL LETTER A} is a named character, and so is
2314 char* e = strchr(s, '}');
2320 yyerror("Missing right brace on \\N{}");
2324 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2325 /* \N{U+...} The ... is a unicode value even on EBCDIC
2327 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2328 PERL_SCAN_DISALLOW_PREFIX;
2331 uv = grok_hex(s, &len, &flags, NULL);
2332 if ( e > s && len != (STRLEN)(e - s) ) {
2336 goto NUM_ESCAPE_INSERT;
2338 res = newSVpvn(s + 1, e - s - 1);
2339 res = new_constant( NULL, 0, "charnames",
2340 res, NULL, s - 2, e - s + 3 );
2342 sv_utf8_upgrade(res);
2343 str = SvPV_const(res,len);
2344 #ifdef EBCDIC_NEVER_MIND
2345 /* charnames uses pack U and that has been
2346 * recently changed to do the below uni->native
2347 * mapping, so this would be redundant (and wrong,
2348 * the code point would be doubly converted).
2349 * But leave this in just in case the pack U change
2350 * gets revoked, but the semantics is still
2351 * desireable for charnames. --jhi */
2353 UV uv = utf8_to_uvchr((const U8*)str, 0);
2356 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2358 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2359 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2360 str = SvPV_const(res, len);
2364 /* If destination is not in utf8 but this new character is,
2365 * recode the dest to utf8 */
2366 if (!has_utf8 && SvUTF8(res)) {
2367 SvCUR_set(sv, d - SvPVX_const(sv));
2370 /* See Note on sizing above. */
2371 sv_utf8_upgrade_flags_grow(sv,
2372 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2373 len + (STRLEN)(send - s) + 1);
2374 d = SvPVX(sv) + SvCUR(sv);
2376 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2378 /* See Note on sizing above. (NOTE: SvCUR() is not set
2379 * correctly here). */
2380 const STRLEN off = d - SvPVX_const(sv);
2381 d = SvGROW(sv, off + len + (STRLEN)(send - s) + 1) + off;
2385 native_range = FALSE; /* \N{} is guessed to be Unicode */
2387 Copy(str, d, len, char);
2394 yyerror("Missing braces on \\N{}");
2397 /* \c is a control character */
2406 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2409 yyerror("Missing control char name in \\c");
2413 /* printf-style backslashes, formfeeds, newlines, etc */
2415 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2418 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2421 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2424 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2427 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2430 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2433 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2439 } /* end if (backslash) */
2446 /* If we started with encoded form, or already know we want it,
2447 then encode the next character */
2448 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
2452 /* One might think that it is wasted effort in the case of the
2453 * source being utf8 (this_utf8 == TRUE) to take the next character
2454 * in the source, convert it to an unsigned value, and then convert
2455 * it back again. But the source has not been validated here. The
2456 * routine that does the conversion checks for errors like
2459 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2460 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2462 SvCUR_set(sv, d - SvPVX_const(sv));
2465 /* See Note on sizing above. */
2466 sv_utf8_upgrade_flags_grow(sv,
2467 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2468 need + (STRLEN)(send - s) + 1);
2469 d = SvPVX(sv) + SvCUR(sv);
2471 } else if (need > len) {
2472 /* encoded value larger than old, may need extra space (NOTE:
2473 * SvCUR() is not set correctly here). See Note on sizing
2475 const STRLEN off = d - SvPVX_const(sv);
2476 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
2480 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2482 if (uv > 255 && !dorange)
2483 native_range = FALSE;
2487 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2489 } /* while loop to process each character */
2491 /* terminate the string and set up the sv */
2493 SvCUR_set(sv, d - SvPVX_const(sv));
2494 if (SvCUR(sv) >= SvLEN(sv))
2495 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2498 if (PL_encoding && !has_utf8) {
2499 sv_recode_to_utf8(sv, PL_encoding);
2505 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2506 PL_sublex_info.sub_op->op_private |=
2507 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2511 /* shrink the sv if we allocated more than we used */
2512 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2513 SvPV_shrink_to_cur(sv);
2516 /* return the substring (via pl_yylval) only if we parsed anything */
2517 if (s > PL_bufptr) {
2518 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
2519 const char *const key = PL_lex_inpat ? "qr" : "q";
2520 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
2524 if (PL_lex_inwhat == OP_TRANS) {
2527 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
2535 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
2538 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2545 * Returns TRUE if there's more to the expression (e.g., a subscript),
2548 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2550 * ->[ and ->{ return TRUE
2551 * { and [ outside a pattern are always subscripts, so return TRUE
2552 * if we're outside a pattern and it's not { or [, then return FALSE
2553 * if we're in a pattern and the first char is a {
2554 * {4,5} (any digits around the comma) returns FALSE
2555 * if we're in a pattern and the first char is a [
2557 * [SOMETHING] has a funky algorithm to decide whether it's a
2558 * character class or not. It has to deal with things like
2559 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2560 * anything else returns TRUE
2563 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2566 S_intuit_more(pTHX_ register char *s)
2570 PERL_ARGS_ASSERT_INTUIT_MORE;
2572 if (PL_lex_brackets)
2574 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2576 if (*s != '{' && *s != '[')
2581 /* In a pattern, so maybe we have {n,m}. */
2598 /* On the other hand, maybe we have a character class */
2601 if (*s == ']' || *s == '^')
2604 /* this is terrifying, and it works */
2605 int weight = 2; /* let's weigh the evidence */
2607 unsigned char un_char = 255, last_un_char;
2608 const char * const send = strchr(s,']');
2609 char tmpbuf[sizeof PL_tokenbuf * 4];
2611 if (!send) /* has to be an expression */
2614 Zero(seen,256,char);
2617 else if (isDIGIT(*s)) {
2619 if (isDIGIT(s[1]) && s[2] == ']')
2625 for (; s < send; s++) {
2626 last_un_char = un_char;
2627 un_char = (unsigned char)*s;
2632 weight -= seen[un_char] * 10;
2633 if (isALNUM_lazy_if(s+1,UTF)) {
2635 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2636 len = (int)strlen(tmpbuf);
2637 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2642 else if (*s == '$' && s[1] &&
2643 strchr("[#!%*<>()-=",s[1])) {
2644 if (/*{*/ strchr("])} =",s[2]))
2653 if (strchr("wds]",s[1]))
2655 else if (seen[(U8)'\''] || seen[(U8)'"'])
2657 else if (strchr("rnftbxcav",s[1]))
2659 else if (isDIGIT(s[1])) {
2661 while (s[1] && isDIGIT(s[1]))
2671 if (strchr("aA01! ",last_un_char))
2673 if (strchr("zZ79~",s[1]))
2675 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2676 weight -= 5; /* cope with negative subscript */
2679 if (!isALNUM(last_un_char)
2680 && !(last_un_char == '$' || last_un_char == '@'
2681 || last_un_char == '&')
2682 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2687 if (keyword(tmpbuf, d - tmpbuf, 0))
2690 if (un_char == last_un_char + 1)
2692 weight -= seen[un_char];
2697 if (weight >= 0) /* probably a character class */
2707 * Does all the checking to disambiguate
2709 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2710 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2712 * First argument is the stuff after the first token, e.g. "bar".
2714 * Not a method if bar is a filehandle.
2715 * Not a method if foo is a subroutine prototyped to take a filehandle.
2716 * Not a method if it's really "Foo $bar"
2717 * Method if it's "foo $bar"
2718 * Not a method if it's really "print foo $bar"
2719 * Method if it's really "foo package::" (interpreted as package->foo)
2720 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2721 * Not a method if bar is a filehandle or package, but is quoted with
2726 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2729 char *s = start + (*start == '$');
2730 char tmpbuf[sizeof PL_tokenbuf];
2737 PERL_ARGS_ASSERT_INTUIT_METHOD;
2740 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2744 const char *proto = SvPVX_const(cv);
2755 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2756 /* start is the beginning of the possible filehandle/object,
2757 * and s is the end of it
2758 * tmpbuf is a copy of it
2761 if (*start == '$') {
2762 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2763 isUPPER(*PL_tokenbuf))
2766 len = start - SvPVX(PL_linestr);
2770 start = SvPVX(PL_linestr) + len;
2774 return *s == '(' ? FUNCMETH : METHOD;
2776 if (!keyword(tmpbuf, len, 0)) {
2777 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2781 soff = s - SvPVX(PL_linestr);
2785 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2786 if (indirgv && GvCVu(indirgv))
2788 /* filehandle or package name makes it a method */
2789 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2791 soff = s - SvPVX(PL_linestr);
2794 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2795 return 0; /* no assumptions -- "=>" quotes bearword */
2797 start_force(PL_curforce);
2798 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2799 S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
2800 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2802 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2807 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2809 return *s == '(' ? FUNCMETH : METHOD;
2815 /* Encoded script support. filter_add() effectively inserts a
2816 * 'pre-processing' function into the current source input stream.
2817 * Note that the filter function only applies to the current source file
2818 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2820 * The datasv parameter (which may be NULL) can be used to pass
2821 * private data to this instance of the filter. The filter function
2822 * can recover the SV using the FILTER_DATA macro and use it to
2823 * store private buffers and state information.
2825 * The supplied datasv parameter is upgraded to a PVIO type
2826 * and the IoDIRP/IoANY field is used to store the function pointer,
2827 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2828 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2829 * private use must be set using malloc'd pointers.
2833 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2842 if (!PL_rsfp_filters)
2843 PL_rsfp_filters = newAV();
2846 SvUPGRADE(datasv, SVt_PVIO);
2847 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2848 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2849 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2850 FPTR2DPTR(void *, IoANY(datasv)),
2851 SvPV_nolen(datasv)));
2852 av_unshift(PL_rsfp_filters, 1);
2853 av_store(PL_rsfp_filters, 0, datasv) ;
2858 /* Delete most recently added instance of this filter function. */
2860 Perl_filter_del(pTHX_ filter_t funcp)
2865 PERL_ARGS_ASSERT_FILTER_DEL;
2868 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2869 FPTR2DPTR(void*, funcp)));
2871 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2873 /* if filter is on top of stack (usual case) just pop it off */
2874 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2875 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2876 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2877 IoANY(datasv) = (void *)NULL;
2878 sv_free(av_pop(PL_rsfp_filters));
2882 /* we need to search for the correct entry and clear it */
2883 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2887 /* Invoke the idxth filter function for the current rsfp. */
2888 /* maxlen 0 = read one text line */
2890 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2895 /* This API is bad. It should have been using unsigned int for maxlen.
2896 Not sure if we want to change the API, but if not we should sanity
2897 check the value here. */
2898 const unsigned int correct_length
2907 PERL_ARGS_ASSERT_FILTER_READ;
2909 if (!PL_parser || !PL_rsfp_filters)
2911 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2912 /* Provide a default input filter to make life easy. */
2913 /* Note that we append to the line. This is handy. */
2914 DEBUG_P(PerlIO_printf(Perl_debug_log,
2915 "filter_read %d: from rsfp\n", idx));
2916 if (correct_length) {
2919 const int old_len = SvCUR(buf_sv);
2921 /* ensure buf_sv is large enough */
2922 SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
2923 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2924 correct_length)) <= 0) {
2925 if (PerlIO_error(PL_rsfp))
2926 return -1; /* error */
2928 return 0 ; /* end of file */
2930 SvCUR_set(buf_sv, old_len + len) ;
2931 SvPVX(buf_sv)[old_len + len] = '\0';
2934 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2935 if (PerlIO_error(PL_rsfp))
2936 return -1; /* error */
2938 return 0 ; /* end of file */
2941 return SvCUR(buf_sv);
2943 /* Skip this filter slot if filter has been deleted */
2944 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2945 DEBUG_P(PerlIO_printf(Perl_debug_log,
2946 "filter_read %d: skipped (filter deleted)\n",
2948 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2950 /* Get function pointer hidden within datasv */
2951 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2952 DEBUG_P(PerlIO_printf(Perl_debug_log,
2953 "filter_read %d: via function %p (%s)\n",
2954 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2955 /* Call function. The function is expected to */
2956 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2957 /* Return: <0:error, =0:eof, >0:not eof */
2958 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2962 S_filter_gets(pTHX_ register SV *sv, STRLEN append)
2966 PERL_ARGS_ASSERT_FILTER_GETS;
2968 #ifdef PERL_CR_FILTER
2969 if (!PL_rsfp_filters) {
2970 filter_add(S_cr_textfilter,NULL);
2973 if (PL_rsfp_filters) {
2975 SvCUR_set(sv, 0); /* start with empty line */
2976 if (FILTER_READ(0, sv, 0) > 0)
2977 return ( SvPVX(sv) ) ;
2982 return (sv_gets(sv, PL_rsfp, append));
2986 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
2991 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
2993 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2997 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2998 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3000 return GvHV(gv); /* Foo:: */
3003 /* use constant CLASS => 'MyClass' */
3004 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3005 if (gv && GvCV(gv)) {
3006 SV * const sv = cv_const_sv(GvCV(gv));
3008 pkgname = SvPV_const(sv, len);
3011 return gv_stashpvn(pkgname, len, 0);
3015 * S_readpipe_override
3016 * Check whether readpipe() is overriden, and generates the appropriate
3017 * optree, provided sublex_start() is called afterwards.
3020 S_readpipe_override(pTHX)
3023 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
3024 pl_yylval.ival = OP_BACKTICK;
3026 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
3028 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
3029 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
3030 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
3032 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
3033 append_elem(OP_LIST,
3034 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
3035 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
3042 * The intent of this yylex wrapper is to minimize the changes to the
3043 * tokener when we aren't interested in collecting madprops. It remains
3044 * to be seen how successful this strategy will be...
3051 char *s = PL_bufptr;
3053 /* make sure PL_thiswhite is initialized */
3057 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
3058 if (PL_pending_ident)
3059 return S_pending_ident(aTHX);
3061 /* previous token ate up our whitespace? */
3062 if (!PL_lasttoke && PL_nextwhite) {
3063 PL_thiswhite = PL_nextwhite;
3067 /* isolate the token, and figure out where it is without whitespace */
3068 PL_realtokenstart = -1;
3072 assert(PL_curforce < 0);
3074 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
3075 if (!PL_thistoken) {
3076 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3077 PL_thistoken = newSVpvs("");
3079 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3080 PL_thistoken = newSVpvn(tstart, s - tstart);
3083 if (PL_thismad) /* install head */
3084 CURMAD('X', PL_thistoken);
3087 /* last whitespace of a sublex? */
3088 if (optype == ')' && PL_endwhite) {
3089 CURMAD('X', PL_endwhite);
3094 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
3095 if (!PL_thiswhite && !PL_endwhite && !optype) {
3096 sv_free(PL_thistoken);
3101 /* put off final whitespace till peg */
3102 if (optype == ';' && !PL_rsfp) {
3103 PL_nextwhite = PL_thiswhite;
3106 else if (PL_thisopen) {
3107 CURMAD('q', PL_thisopen);
3109 sv_free(PL_thistoken);
3113 /* Store actual token text as madprop X */
3114 CURMAD('X', PL_thistoken);
3118 /* add preceding whitespace as madprop _ */
3119 CURMAD('_', PL_thiswhite);
3123 /* add quoted material as madprop = */
3124 CURMAD('=', PL_thisstuff);
3128 /* add terminating quote as madprop Q */
3129 CURMAD('Q', PL_thisclose);
3133 /* special processing based on optype */
3137 /* opval doesn't need a TOKEN since it can already store mp */
3147 if (pl_yylval.opval)
3148 append_madprops(PL_thismad, pl_yylval.opval, 0);
3156 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3165 /* remember any fake bracket that lexer is about to discard */
3166 if (PL_lex_brackets == 1 &&
3167 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3170 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3173 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3174 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3177 break; /* don't bother looking for trailing comment */
3186 /* attach a trailing comment to its statement instead of next token */
3190 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3192 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3194 if (*s == '\n' || *s == '#') {
3195 while (s < PL_bufend && *s != '\n')
3199 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3200 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3217 /* Create new token struct. Note: opvals return early above. */
3218 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
3225 S_tokenize_use(pTHX_ int is_use, char *s) {
3228 PERL_ARGS_ASSERT_TOKENIZE_USE;
3230 if (PL_expect != XSTATE)
3231 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3232 is_use ? "use" : "no"));
3234 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3235 s = force_version(s, TRUE);
3236 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3237 start_force(PL_curforce);
3238 NEXTVAL_NEXTTOKE.opval = NULL;
3241 else if (*s == 'v') {
3242 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3243 s = force_version(s, FALSE);
3247 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3248 s = force_version(s, FALSE);
3250 pl_yylval.ival = is_use;
3254 static const char* const exp_name[] =
3255 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3256 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3263 Works out what to call the token just pulled out of the input
3264 stream. The yacc parser takes care of taking the ops we return and
3265 stitching them into a tree.
3271 if read an identifier
3272 if we're in a my declaration
3273 croak if they tried to say my($foo::bar)
3274 build the ops for a my() declaration
3275 if it's an access to a my() variable
3276 are we in a sort block?
3277 croak if my($a); $a <=> $b
3278 build ops for access to a my() variable
3279 if in a dq string, and they've said @foo and we can't find @foo
3281 build ops for a bareword
3282 if we already built the token before, use it.
3287 #pragma segment Perl_yylex
3293 register char *s = PL_bufptr;
3298 /* orig_keyword, gvp, and gv are initialized here because
3299 * jump to the label just_a_word_zero can bypass their
3300 * initialization later. */
3301 I32 orig_keyword = 0;
3306 SV* tmp = newSVpvs("");
3307 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3308 (IV)CopLINE(PL_curcop),
3309 lex_state_names[PL_lex_state],
3310 exp_name[PL_expect],
3311 pv_display(tmp, s, strlen(s), 0, 60));
3314 /* check if there's an identifier for us to look at */
3315 if (PL_pending_ident)
3316 return REPORT(S_pending_ident(aTHX));
3318 /* no identifier pending identification */
3320 switch (PL_lex_state) {
3322 case LEX_NORMAL: /* Some compilers will produce faster */
3323 case LEX_INTERPNORMAL: /* code if we comment these out. */
3327 /* when we've already built the next token, just pull it out of the queue */
3331 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
3333 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3334 PL_nexttoke[PL_lasttoke].next_mad = 0;
3335 if (PL_thismad && PL_thismad->mad_key == '_') {
3336 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
3337 PL_thismad->mad_val = 0;
3338 mad_free(PL_thismad);
3343 PL_lex_state = PL_lex_defer;
3344 PL_expect = PL_lex_expect;
3345 PL_lex_defer = LEX_NORMAL;
3346 if (!PL_nexttoke[PL_lasttoke].next_type)
3351 pl_yylval = PL_nextval[PL_nexttoke];
3353 PL_lex_state = PL_lex_defer;
3354 PL_expect = PL_lex_expect;
3355 PL_lex_defer = LEX_NORMAL;
3359 /* FIXME - can these be merged? */
3360 return(PL_nexttoke[PL_lasttoke].next_type);
3362 return REPORT(PL_nexttype[PL_nexttoke]);
3365 /* interpolated case modifiers like \L \U, including \Q and \E.
3366 when we get here, PL_bufptr is at the \
3368 case LEX_INTERPCASEMOD:
3370 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3371 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3373 /* handle \E or end of string */
3374 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3376 if (PL_lex_casemods) {
3377 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3378 PL_lex_casestack[PL_lex_casemods] = '\0';
3380 if (PL_bufptr != PL_bufend
3381 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3383 PL_lex_state = LEX_INTERPCONCAT;
3386 PL_thistoken = newSVpvs("\\E");
3392 while (PL_bufptr != PL_bufend &&
3393 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3395 PL_thiswhite = newSVpvs("");
3396 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3400 if (PL_bufptr != PL_bufend)
3403 PL_lex_state = LEX_INTERPCONCAT;
3407 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3408 "### Saw case modifier\n"); });
3410 if (s[1] == '\\' && s[2] == 'E') {
3413 PL_thiswhite = newSVpvs("");
3414 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3417 PL_lex_state = LEX_INTERPCONCAT;
3422 if (!PL_madskills) /* when just compiling don't need correct */
3423 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3424 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3425 if ((*s == 'L' || *s == 'U') &&
3426 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3427 PL_lex_casestack[--PL_lex_casemods] = '\0';
3430 if (PL_lex_casemods > 10)
3431 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3432 PL_lex_casestack[PL_lex_casemods++] = *s;
3433 PL_lex_casestack[PL_lex_casemods] = '\0';
3434 PL_lex_state = LEX_INTERPCONCAT;
3435 start_force(PL_curforce);
3436 NEXTVAL_NEXTTOKE.ival = 0;
3438 start_force(PL_curforce);
3440 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3442 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3444 NEXTVAL_NEXTTOKE.ival = OP_LC;
3446 NEXTVAL_NEXTTOKE.ival = OP_UC;
3448 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3450 Perl_croak(aTHX_ "panic: yylex");
3452 SV* const tmpsv = newSVpvs("\\ ");
3453 /* replace the space with the character we want to escape
3455 SvPVX(tmpsv)[1] = *s;
3461 if (PL_lex_starts) {
3467 sv_free(PL_thistoken);
3468 PL_thistoken = newSVpvs("");
3471 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3472 if (PL_lex_casemods == 1 && PL_lex_inpat)
3481 case LEX_INTERPPUSH:
3482 return REPORT(sublex_push());
3484 case LEX_INTERPSTART:
3485 if (PL_bufptr == PL_bufend)
3486 return REPORT(sublex_done());
3487 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3488 "### Interpolated variable\n"); });
3490 PL_lex_dojoin = (*PL_bufptr == '@');
3491 PL_lex_state = LEX_INTERPNORMAL;
3492 if (PL_lex_dojoin) {
3493 start_force(PL_curforce);
3494 NEXTVAL_NEXTTOKE.ival = 0;
3496 start_force(PL_curforce);
3497 force_ident("\"", '$');
3498 start_force(PL_curforce);
3499 NEXTVAL_NEXTTOKE.ival = 0;
3501 start_force(PL_curforce);
3502 NEXTVAL_NEXTTOKE.ival = 0;
3504 start_force(PL_curforce);
3505 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3508 if (PL_lex_starts++) {
3513 sv_free(PL_thistoken);
3514 PL_thistoken = newSVpvs("");
3517 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3518 if (!PL_lex_casemods && PL_lex_inpat)
3525 case LEX_INTERPENDMAYBE:
3526 if (intuit_more(PL_bufptr)) {
3527 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3533 if (PL_lex_dojoin) {
3534 PL_lex_dojoin = FALSE;
3535 PL_lex_state = LEX_INTERPCONCAT;
3539 sv_free(PL_thistoken);
3540 PL_thistoken = newSVpvs("");
3545 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3546 && SvEVALED(PL_lex_repl))
3548 if (PL_bufptr != PL_bufend)
3549 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3553 case LEX_INTERPCONCAT:
3555 if (PL_lex_brackets)
3556 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3558 if (PL_bufptr == PL_bufend)
3559 return REPORT(sublex_done());
3561 if (SvIVX(PL_linestr) == '\'') {
3562 SV *sv = newSVsv(PL_linestr);
3565 else if ( PL_hints & HINT_NEW_RE )
3566 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
3567 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3571 s = scan_const(PL_bufptr);
3573 PL_lex_state = LEX_INTERPCASEMOD;
3575 PL_lex_state = LEX_INTERPSTART;
3578 if (s != PL_bufptr) {
3579 start_force(PL_curforce);
3581 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3583 NEXTVAL_NEXTTOKE = pl_yylval;
3586 if (PL_lex_starts++) {
3590 sv_free(PL_thistoken);
3591 PL_thistoken = newSVpvs("");
3594 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3595 if (!PL_lex_casemods && PL_lex_inpat)
3608 PL_lex_state = LEX_NORMAL;
3609 s = scan_formline(PL_bufptr);
3610 if (!PL_lex_formbrack)
3616 PL_oldoldbufptr = PL_oldbufptr;
3622 sv_free(PL_thistoken);
3625 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3629 if (isIDFIRST_lazy_if(s,UTF))
3632 unsigned char c = *s;
3633 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
3634 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
3635 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
3640 Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
3644 goto fake_eof; /* emulate EOF on ^D or ^Z */
3653 if (PL_lex_brackets) {
3654 yyerror((const char *)
3656 ? "Format not terminated"
3657 : "Missing right curly or square bracket"));
3659 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3660 "### Tokener got EOF\n");
3664 if (s++ < PL_bufend)
3665 goto retry; /* ignore stray nulls */
3668 if (!PL_in_eval && !PL_preambled) {
3669 PL_preambled = TRUE;
3675 /* Generate a string of Perl code to load the debugger.
3676 * If PERL5DB is set, it will return the contents of that,
3677 * otherwise a compile-time require of perl5db.pl. */
3679 const char * const pdb = PerlEnv_getenv("PERL5DB");
3682 sv_setpv(PL_linestr, pdb);
3683 sv_catpvs(PL_linestr,";");
3685 SETERRNO(0,SS_NORMAL);
3686 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
3689 sv_setpvs(PL_linestr,"");
3690 if (PL_preambleav) {
3691 SV **svp = AvARRAY(PL_preambleav);
3692 SV **const end = svp + AvFILLp(PL_preambleav);
3694 sv_catsv(PL_linestr, *svp);
3696 sv_catpvs(PL_linestr, ";");
3698 sv_free(MUTABLE_SV(PL_preambleav));
3699 PL_preambleav = NULL;
3702 sv_catpvs(PL_linestr,
3703 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
3704 if (PL_minus_n || PL_minus_p) {
3705 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3707 sv_catpvs(PL_linestr,"chomp;");
3710 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3711 || *PL_splitstr == '"')
3712 && strchr(PL_splitstr + 1, *PL_splitstr))
3713 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3715 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3716 bytes can be used as quoting characters. :-) */
3717 const char *splits = PL_splitstr;
3718 sv_catpvs(PL_linestr, "our @F=split(q\0");
3721 if (*splits == '\\')
3722 sv_catpvn(PL_linestr, splits, 1);
3723 sv_catpvn(PL_linestr, splits, 1);
3724 } while (*splits++);
3725 /* This loop will embed the trailing NUL of
3726 PL_linestr as the last thing it does before
3728 sv_catpvs(PL_linestr, ");");
3732 sv_catpvs(PL_linestr,"our @F=split(' ');");
3735 sv_catpvs(PL_linestr, "\n");
3736 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3737 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3738 PL_last_lop = PL_last_uni = NULL;
3739 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3740 update_debugger_info(PL_linestr, NULL, 0);
3744 bof = PL_rsfp ? TRUE : FALSE;
3745 if ((s = filter_gets(PL_linestr, 0)) == NULL) {
3748 PL_realtokenstart = -1;
3751 if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3752 PerlIO_clearerr(PL_rsfp);
3754 (void)PerlIO_close(PL_rsfp);
3756 PL_doextract = FALSE;
3758 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3764 sv_setpvs(PL_linestr, ";}continue{print;}");
3766 sv_setpvs(PL_linestr, ";}");
3767 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3768 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3769 PL_last_lop = PL_last_uni = NULL;
3770 PL_minus_n = PL_minus_p = 0;
3773 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3774 PL_last_lop = PL_last_uni = NULL;
3775 sv_setpvs(PL_linestr,"");
3776 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3778 /* If it looks like the start of a BOM or raw UTF-16,
3779 * check if it in fact is. */
3785 #ifdef PERLIO_IS_STDIO
3786 # ifdef __GNU_LIBRARY__
3787 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3788 # define FTELL_FOR_PIPE_IS_BROKEN
3792 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3793 # define FTELL_FOR_PIPE_IS_BROKEN
3798 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3800 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3801 s = swallow_bom((U8*)s);
3805 /* Incest with pod. */
3808 sv_catsv(PL_thiswhite, PL_linestr);
3810 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3811 sv_setpvs(PL_linestr, "");
3812 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3813 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3814 PL_last_lop = PL_last_uni = NULL;
3815 PL_doextract = FALSE;
3819 } while (PL_doextract);
3820 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3821 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3822 update_debugger_info(PL_linestr, NULL, 0);
3823 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3824 PL_last_lop = PL_last_uni = NULL;
3825 if (CopLINE(PL_curcop) == 1) {
3826 while (s < PL_bufend && isSPACE(*s))
3828 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3832 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3836 if (*s == '#' && *(s+1) == '!')
3838 #ifdef ALTERNATE_SHEBANG
3840 static char const as[] = ALTERNATE_SHEBANG;
3841 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3842 d = s + (sizeof(as) - 1);
3844 #endif /* ALTERNATE_SHEBANG */
3853 while (*d && !isSPACE(*d))
3857 #ifdef ARG_ZERO_IS_SCRIPT
3858 if (ipathend > ipath) {
3860 * HP-UX (at least) sets argv[0] to the script name,
3861 * which makes $^X incorrect. And Digital UNIX and Linux,
3862 * at least, set argv[0] to the basename of the Perl
3863 * interpreter. So, having found "#!", we'll set it right.
3865 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3867 assert(SvPOK(x) || SvGMAGICAL(x));
3868 if (sv_eq(x, CopFILESV(PL_curcop))) {
3869 sv_setpvn(x, ipath, ipathend - ipath);
3875 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3876 const char * const lstart = SvPV_const(x,llen);
3878 bstart += blen - llen;
3879 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3880 sv_setpvn(x, ipath, ipathend - ipath);
3885 TAINT_NOT; /* $^X is always tainted, but that's OK */
3887 #endif /* ARG_ZERO_IS_SCRIPT */
3892 d = instr(s,"perl -");
3894 d = instr(s,"perl");
3896 /* avoid getting into infinite loops when shebang
3897 * line contains "Perl" rather than "perl" */
3899 for (d = ipathend-4; d >= ipath; --d) {
3900 if ((*d == 'p' || *d == 'P')
3901 && !ibcmp(d, "perl", 4))
3911 #ifdef ALTERNATE_SHEBANG
3913 * If the ALTERNATE_SHEBANG on this system starts with a
3914 * character that can be part of a Perl expression, then if
3915 * we see it but not "perl", we're probably looking at the
3916 * start of Perl code, not a request to hand off to some
3917 * other interpreter. Similarly, if "perl" is there, but
3918 * not in the first 'word' of the line, we assume the line
3919 * contains the start of the Perl program.
3921 if (d && *s != '#') {
3922 const char *c = ipath;
3923 while (*c && !strchr("; \t\r\n\f\v#", *c))
3926 d = NULL; /* "perl" not in first word; ignore */
3928 *s = '#'; /* Don't try to parse shebang line */
3930 #endif /* ALTERNATE_SHEBANG */
3935 !instr(s,"indir") &&
3936 instr(PL_origargv[0],"perl"))
3943 while (s < PL_bufend && isSPACE(*s))
3945 if (s < PL_bufend) {
3946 Newx(newargv,PL_origargc+3,char*);
3948 while (s < PL_bufend && !isSPACE(*s))
3951 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3954 newargv = PL_origargv;
3957 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3959 Perl_croak(aTHX_ "Can't exec %s", ipath);
3962 while (*d && !isSPACE(*d))
3964 while (SPACE_OR_TAB(*d))
3968 const bool switches_done = PL_doswitches;
3969 const U32 oldpdb = PL_perldb;
3970 const bool oldn = PL_minus_n;
3971 const bool oldp = PL_minus_p;
3975 bool baduni = FALSE;
3977 const char *d2 = d1 + 1;
3978 if (parse_unicode_opts((const char **)&d2)
3982 if (baduni || *d1 == 'M' || *d1 == 'm') {
3983 const char * const m = d1;
3984 while (*d1 && !isSPACE(*d1))
3986 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3989 d1 = moreswitches(d1);
3991 if (PL_doswitches && !switches_done) {
3992 int argc = PL_origargc;
3993 char **argv = PL_origargv;
3996 } while (argc && argv[0][0] == '-' && argv[0][1]);
3997 init_argv_symbols(argc,argv);
3999 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4000 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4001 /* if we have already added "LINE: while (<>) {",
4002 we must not do it again */
4004 sv_setpvs(PL_linestr, "");
4005 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4006 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4007 PL_last_lop = PL_last_uni = NULL;
4008 PL_preambled = FALSE;
4009 if (PERLDB_LINE || PERLDB_SAVESRC)
4010 (void)gv_fetchfile(PL_origfilename);
4017 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4019 PL_lex_state = LEX_FORMLINE;
4024 #ifdef PERL_STRICT_CR
4025 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4027 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4029 case ' ': case '\t': case '\f': case 013:
4031 PL_realtokenstart = -1;
4033 PL_thiswhite = newSVpvs("");
4034 sv_catpvn(PL_thiswhite, s, 1);
4041 PL_realtokenstart = -1;
4045 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
4046 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
4047 /* handle eval qq[#line 1 "foo"\n ...] */
4048 CopLINE_dec(PL_curcop);
4051 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
4053 if (!PL_in_eval || PL_rsfp)
4058 while (d < PL_bufend && *d != '\n')
4062 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4063 Perl_croak(aTHX_ "panic: input overflow");
4066 PL_thiswhite = newSVpvn(s, d - s);
4071 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4073 PL_lex_state = LEX_FORMLINE;
4079 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
4080 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
4083 TOKEN(PEG); /* make sure any #! line is accessible */
4088 /* if (PL_madskills && PL_lex_formbrack) { */
4090 while (d < PL_bufend && *d != '\n')
4094 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4095 Perl_croak(aTHX_ "panic: input overflow");
4096 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4098 PL_thiswhite = newSVpvs("");
4099 if (CopLINE(PL_curcop) == 1) {
4100 sv_setpvs(PL_thiswhite, "");
4103 sv_catpvn(PL_thiswhite, s, d - s);
4117 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4125 while (s < PL_bufend && SPACE_OR_TAB(*s))
4128 if (strnEQ(s,"=>",2)) {
4129 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4130 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4131 OPERATOR('-'); /* unary minus */
4133 PL_last_uni = PL_oldbufptr;
4135 case 'r': ftst = OP_FTEREAD; break;
4136 case 'w': ftst = OP_FTEWRITE; break;
4137 case 'x': ftst = OP_FTEEXEC; break;
4138 case 'o': ftst = OP_FTEOWNED; break;
4139 case 'R': ftst = OP_FTRREAD; break;
4140 case 'W': ftst = OP_FTRWRITE; break;
4141 case 'X': ftst = OP_FTREXEC; break;
4142 case 'O': ftst = OP_FTROWNED; break;
4143 case 'e': ftst = OP_FTIS; break;
4144 case 'z': ftst = OP_FTZERO; break;
4145 case 's': ftst = OP_FTSIZE; break;
4146 case 'f': ftst = OP_FTFILE; break;
4147 case 'd': ftst = OP_FTDIR; break;
4148 case 'l': ftst = OP_FTLINK; break;
4149 case 'p': ftst = OP_FTPIPE; break;
4150 case 'S': ftst = OP_FTSOCK; break;
4151 case 'u': ftst = OP_FTSUID; break;
4152 case 'g': ftst = OP_FTSGID; break;
4153 case 'k': ftst = OP_FTSVTX; break;
4154 case 'b': ftst = OP_FTBLK; break;
4155 case 'c': ftst = OP_FTCHR; break;
4156 case 't': ftst = OP_FTTTY; break;
4157 case 'T': ftst = OP_FTTEXT; break;
4158 case 'B': ftst = OP_FTBINARY; break;
4159 case 'M': case 'A': case 'C':
4160 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4162 case 'M': ftst = OP_FTMTIME; break;
4163 case 'A': ftst = OP_FTATIME; break;
4164 case 'C': ftst = OP_FTCTIME; break;
4172 PL_last_lop_op = (OPCODE)ftst;
4173 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4174 "### Saw file test %c\n", (int)tmp);
4179 /* Assume it was a minus followed by a one-letter named
4180 * subroutine call (or a -bareword), then. */
4181 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4182 "### '-%c' looked like a file test but was not\n",
4189 const char tmp = *s++;
4192 if (PL_expect == XOPERATOR)
4197 else if (*s == '>') {
4200 if (isIDFIRST_lazy_if(s,UTF)) {
4201 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4209 if (PL_expect == XOPERATOR)
4212 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4214 OPERATOR('-'); /* unary minus */
4220 const char tmp = *s++;
4223 if (PL_expect == XOPERATOR)
4228 if (PL_expect == XOPERATOR)
4231 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4238 if (PL_expect != XOPERATOR) {
4239 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4240 PL_expect = XOPERATOR;
4241 force_ident(PL_tokenbuf, '*');
4254 if (PL_expect == XOPERATOR) {
4258 PL_tokenbuf[0] = '%';
4259 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4260 sizeof PL_tokenbuf - 1, FALSE);
4261 if (!PL_tokenbuf[1]) {
4264 PL_pending_ident = '%';
4273 const char tmp = *s++;
4278 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4285 const char tmp = *s++;
4291 goto just_a_word_zero_gv;
4294 switch (PL_expect) {
4300 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4302 PL_bufptr = s; /* update in case we back off */
4304 deprecate(":= for an empty attribute list");
4311 PL_expect = XTERMBLOCK;
4314 stuffstart = s - SvPVX(PL_linestr) - 1;
4318 while (isIDFIRST_lazy_if(s,UTF)) {
4321 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4322 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4323 if (tmp < 0) tmp = -tmp;
4338 sv = newSVpvn(s, len);
4340 d = scan_str(d,TRUE,TRUE);
4342 /* MUST advance bufptr here to avoid bogus
4343 "at end of line" context messages from yyerror().
4345 PL_bufptr = s + len;
4346 yyerror("Unterminated attribute parameter in attribute list");
4350 return REPORT(0); /* EOF indicator */
4354 sv_catsv(sv, PL_lex_stuff);
4355 attrs = append_elem(OP_LIST, attrs,
4356 newSVOP(OP_CONST, 0, sv));
4357 SvREFCNT_dec(PL_lex_stuff);
4358 PL_lex_stuff = NULL;
4361 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4363 if (PL_in_my == KEY_our) {
4364 deprecate(":unique");
4367 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4370 /* NOTE: any CV attrs applied here need to be part of
4371 the CVf_BUILTIN_ATTRS define in cv.h! */
4372 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4374 CvLVALUE_on(PL_compcv);
4376 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4378 deprecate(":locked");
4380 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4382 CvMETHOD_on(PL_compcv);
4384 /* After we've set the flags, it could be argued that
4385 we don't need to do the attributes.pm-based setting
4386 process, and shouldn't bother appending recognized
4387 flags. To experiment with that, uncomment the
4388 following "else". (Note that's already been
4389 uncommented. That keeps the above-applied built-in
4390 attributes from being intercepted (and possibly
4391 rejected) by a package's attribute routines, but is
4392 justified by the performance win for the common case
4393 of applying only built-in attributes.) */
4395 attrs = append_elem(OP_LIST, attrs,
4396 newSVOP(OP_CONST, 0,
4400 if (*s == ':' && s[1] != ':')
4403 break; /* require real whitespace or :'s */
4404 /* XXX losing whitespace on sequential attributes here */
4408 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4409 if (*s != ';' && *s != '}' && *s != tmp
4410 && (tmp != '=' || *s != ')')) {
4411 const char q = ((*s == '\'') ? '"' : '\'');
4412 /* If here for an expression, and parsed no attrs, back
4414 if (tmp == '=' && !attrs) {
4418 /* MUST advance bufptr here to avoid bogus "at end of line"
4419 context messages from yyerror().
4422 yyerror( (const char *)
4424 ? Perl_form(aTHX_ "Invalid separator character "
4425 "%c%c%c in attribute list", q, *s, q)
4426 : "Unterminated attribute list" ) );
4434 start_force(PL_curforce);
4435 NEXTVAL_NEXTTOKE.opval = attrs;
4436 CURMAD('_', PL_nextwhite);
4441 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4442 (s - SvPVX(PL_linestr)) - stuffstart);
4450 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4451 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4459 const char tmp = *s++;
4464 const char tmp = *s++;
4472 if (PL_lex_brackets <= 0)
4473 yyerror("Unmatched right square bracket");
4476 if (PL_lex_state == LEX_INTERPNORMAL) {
4477 if (PL_lex_brackets == 0) {
4478 if (*s == '-' && s[1] == '>')
4479 PL_lex_state = LEX_INTERPENDMAYBE;
4480 else if (*s != '[' && *s != '{')
4481 PL_lex_state = LEX_INTERPEND;
4488 if (PL_lex_brackets > 100) {
4489 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4491 switch (PL_expect) {
4493 if (PL_lex_formbrack) {
4497 if (PL_oldoldbufptr == PL_last_lop)
4498 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4500 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4501 OPERATOR(HASHBRACK);
4503 while (s < PL_bufend && SPACE_OR_TAB(*s))
4506 PL_tokenbuf[0] = '\0';
4507 if (d < PL_bufend && *d == '-') {
4508 PL_tokenbuf[0] = '-';
4510 while (d < PL_bufend && SPACE_OR_TAB(*d))
4513 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4514 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4516 while (d < PL_bufend && SPACE_OR_TAB(*d))
4519 const char minus = (PL_tokenbuf[0] == '-');
4520 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4528 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4533 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4538 if (PL_oldoldbufptr == PL_last_lop)
4539 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4541 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4544 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4546 /* This hack is to get the ${} in the message. */
4548 yyerror("syntax error");
4551 OPERATOR(HASHBRACK);
4553 /* This hack serves to disambiguate a pair of curlies
4554 * as being a block or an anon hash. Normally, expectation
4555 * determines that, but in cases where we're not in a
4556 * position to expect anything in particular (like inside
4557 * eval"") we have to resolve the ambiguity. This code
4558 * covers the case where the first term in the curlies is a
4559 * quoted string. Most other cases need to be explicitly
4560 * disambiguated by prepending a "+" before the opening
4561 * curly in order to force resolution as an anon hash.
4563 * XXX should probably propagate the outer expectation
4564 * into eval"" to rely less on this hack, but that could
4565 * potentially break current behavior of eval"".
4569 if (*s == '\'' || *s == '"' || *s == '`') {
4570 /* common case: get past first string, handling escapes */
4571 for (t++; t < PL_bufend && *t != *s;)
4572 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4576 else if (*s == 'q') {
4579 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4582 /* skip q//-like construct */
4584 char open, close, term;
4587 while (t < PL_bufend && isSPACE(*t))
4589 /* check for q => */
4590 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4591 OPERATOR(HASHBRACK);
4595 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4599 for (t++; t < PL_bufend; t++) {
4600 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4602 else if (*t == open)
4606 for (t++; t < PL_bufend; t++) {
4607 if (*t == '\\' && t+1 < PL_bufend)
4609 else if (*t == close && --brackets <= 0)
4611 else if (*t == open)
4618 /* skip plain q word */
4619 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4622 else if (isALNUM_lazy_if(t,UTF)) {
4624 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4627 while (t < PL_bufend && isSPACE(*t))
4629 /* if comma follows first term, call it an anon hash */
4630 /* XXX it could be a comma expression with loop modifiers */
4631 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4632 || (*t == '=' && t[1] == '>')))
4633 OPERATOR(HASHBRACK);
4634 if (PL_expect == XREF)
4637 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4643 pl_yylval.ival = CopLINE(PL_curcop);
4644 if (isSPACE(*s) || *s == '#')
4645 PL_copline = NOLINE; /* invalidate current command line number */
4650 if (PL_lex_brackets <= 0)
4651 yyerror("Unmatched right curly bracket");
4653 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4654 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4655 PL_lex_formbrack = 0;
4656 if (PL_lex_state == LEX_INTERPNORMAL) {
4657 if (PL_lex_brackets == 0) {
4658 if (PL_expect & XFAKEBRACK) {
4659 PL_expect &= XENUMMASK;
4660 PL_lex_state = LEX_INTERPEND;
4665 PL_thiswhite = newSVpvs("");
4666 sv_catpvs(PL_thiswhite,"}");
4669 return yylex(); /* ignore fake brackets */
4671 if (*s == '-' && s[1] == '>')
4672 PL_lex_state = LEX_INTERPENDMAYBE;
4673 else if (*s != '[' && *s != '{')
4674 PL_lex_state = LEX_INTERPEND;
4677 if (PL_expect & XFAKEBRACK) {
4678 PL_expect &= XENUMMASK;
4680 return yylex(); /* ignore fake brackets */
4682 start_force(PL_curforce);
4684 curmad('X', newSVpvn(s-1,1));
4685 CURMAD('_', PL_thiswhite);
4690 PL_thistoken = newSVpvs("");
4698 if (PL_expect == XOPERATOR) {
4699 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4700 && isIDFIRST_lazy_if(s,UTF))
4702 CopLINE_dec(PL_curcop);
4703 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
4704 CopLINE_inc(PL_curcop);
4709 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4711 PL_expect = XOPERATOR;
4712 force_ident(PL_tokenbuf, '&');
4716 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
4728 const char tmp = *s++;
4735 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4736 && strchr("+-*/%.^&|<",tmp))
4737 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4738 "Reversed %c= operator",(int)tmp);
4740 if (PL_expect == XSTATE && isALPHA(tmp) &&
4741 (s == PL_linestart+1 || s[-2] == '\n') )
4743 if (PL_in_eval && !PL_rsfp) {
4748 if (strnEQ(s,"=cut",4)) {
4764 PL_thiswhite = newSVpvs("");
4765 sv_catpvn(PL_thiswhite, PL_linestart,
4766 PL_bufend - PL_linestart);
4770 PL_doextract = TRUE;
4774 if (PL_lex_brackets < PL_lex_formbrack) {
4776 #ifdef PERL_STRICT_CR
4777 while (SPACE_OR_TAB(*t))
4779 while (SPACE_OR_TAB(*t) || *t == '\r')
4782 if (*t == '\n' || *t == '#') {
4793 const char tmp = *s++;
4795 /* was this !=~ where !~ was meant?
4796 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4798 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4799 const char *t = s+1;
4801 while (t < PL_bufend && isSPACE(*t))
4804 if (*t == '/' || *t == '?' ||
4805 ((*t == 'm' || *t == 's' || *t == 'y')
4806 && !isALNUM(t[1])) ||
4807 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4808 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4809 "!=~ should be !~");
4819 if (PL_expect != XOPERATOR) {
4820 if (s[1] != '<' && !strchr(s,'>'))
4823 s = scan_heredoc(s);
4825 s = scan_inputsymbol(s);
4826 TERM(sublex_start());
4832 SHop(OP_LEFT_SHIFT);
4846 const char tmp = *s++;
4848 SHop(OP_RIGHT_SHIFT);
4849 else if (tmp == '=')
4858 if (PL_expect == XOPERATOR) {
4859 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4860 return deprecate_commaless_var_list();
4864 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4865 PL_tokenbuf[0] = '@';
4866 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4867 sizeof PL_tokenbuf - 1, FALSE);
4868 if (PL_expect == XOPERATOR)
4869 no_op("Array length", s);
4870 if (!PL_tokenbuf[1])
4872 PL_expect = XOPERATOR;
4873 PL_pending_ident = '#';
4877 PL_tokenbuf[0] = '$';
4878 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4879 sizeof PL_tokenbuf - 1, FALSE);
4880 if (PL_expect == XOPERATOR)
4882 if (!PL_tokenbuf[1]) {
4884 yyerror("Final $ should be \\$ or $name");
4888 /* This kludge not intended to be bulletproof. */
4889 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4890 pl_yylval.opval = newSVOP(OP_CONST, 0,
4891 newSViv(CopARYBASE_get(&PL_compiling)));
4892 pl_yylval.opval->op_private = OPpCONST_ARYBASE;
4898 const char tmp = *s;
4899 if (PL_lex_state == LEX_NORMAL)
4902 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4903 && intuit_more(s)) {
4905 PL_tokenbuf[0] = '@';
4906 if (ckWARN(WARN_SYNTAX)) {
4909 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4912 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4913 while (t < PL_bufend && *t != ']')
4915 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4916 "Multidimensional syntax %.*s not supported",
4917 (int)((t - PL_bufptr) + 1), PL_bufptr);
4921 else if (*s == '{') {
4923 PL_tokenbuf[0] = '%';
4924 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4925 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4927 char tmpbuf[sizeof PL_tokenbuf];
4930 } while (isSPACE(*t));
4931 if (isIDFIRST_lazy_if(t,UTF)) {
4933 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4937 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4938 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4939 "You need to quote \"%s\"",
4946 PL_expect = XOPERATOR;
4947 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4948 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4949 if (!islop || PL_last_lop_op == OP_GREPSTART)
4950 PL_expect = XOPERATOR;
4951 else if (strchr("$@\"'`q", *s))
4952 PL_expect = XTERM; /* e.g. print $fh "foo" */
4953 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4954 PL_expect = XTERM; /* e.g. print $fh &sub */
4955 else if (isIDFIRST_lazy_if(s,UTF)) {
4956 char tmpbuf[sizeof PL_tokenbuf];
4958 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4959 if ((t2 = keyword(tmpbuf, len, 0))) {
4960 /* binary operators exclude handle interpretations */
4972 PL_expect = XTERM; /* e.g. print $fh length() */
4977 PL_expect = XTERM; /* e.g. print $fh subr() */
4980 else if (isDIGIT(*s))
4981 PL_expect = XTERM; /* e.g. print $fh 3 */
4982 else if (*s == '.' && isDIGIT(s[1]))
4983 PL_expect = XTERM; /* e.g. print $fh .3 */
4984 else if ((*s == '?' || *s == '-' || *s == '+')
4985 && !isSPACE(s[1]) && s[1] != '=')
4986 PL_expect = XTERM; /* e.g. print $fh -1 */
4987 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4989 PL_expect = XTERM; /* e.g. print $fh /.../
4990 XXX except DORDOR operator
4992 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4994 PL_expect = XTERM; /* print $fh <<"EOF" */
4997 PL_pending_ident = '$';
5001 if (PL_expect == XOPERATOR)
5003 PL_tokenbuf[0] = '@';
5004 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5005 if (!PL_tokenbuf[1]) {
5008 if (PL_lex_state == LEX_NORMAL)
5010 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5012 PL_tokenbuf[0] = '%';
5014 /* Warn about @ where they meant $. */
5015 if (*s == '[' || *s == '{') {
5016 if (ckWARN(WARN_SYNTAX)) {
5017 const char *t = s + 1;
5018 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
5020 if (*t == '}' || *t == ']') {
5022 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
5023 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5024 "Scalar value %.*s better written as $%.*s",
5025 (int)(t-PL_bufptr), PL_bufptr,
5026 (int)(t-PL_bufptr-1), PL_bufptr+1);
5031 PL_pending_ident = '@';
5034 case '/': /* may be division, defined-or, or pattern */
5035 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
5039 case '?': /* may either be conditional or pattern */
5040 if (PL_expect == XOPERATOR) {
5048 /* A // operator. */
5058 /* Disable warning on "study /blah/" */
5059 if (PL_oldoldbufptr == PL_last_uni
5060 && (*PL_last_uni != 's' || s - PL_last_uni < 5
5061 || memNE(PL_last_uni, "study", 5)
5062 || isALNUM_lazy_if(PL_last_uni+5,UTF)
5065 s = scan_pat(s,OP_MATCH);
5066 TERM(sublex_start());
5070 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
5071 #ifdef PERL_STRICT_CR
5074 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
5076 && (s == PL_linestart || s[-1] == '\n') )
5078 PL_lex_formbrack = 0;
5082 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
5086 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
5092 pl_yylval.ival = OPf_SPECIAL;
5098 if (PL_expect != XOPERATOR)
5103 case '0': case '1': case '2': case '3': case '4':
5104 case '5': case '6': case '7': case '8': case '9':
5105 s = scan_num(s, &pl_yylval);
5106 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
5107 if (PL_expect == XOPERATOR)
5112 s = scan_str(s,!!PL_madskills,FALSE);
5113 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5114 if (PL_expect == XOPERATOR) {
5115 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5116 return deprecate_commaless_var_list();
5123 pl_yylval.ival = OP_CONST;
5124 TERM(sublex_start());
5127 s = scan_str(s,!!PL_madskills,FALSE);
5128 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5129 if (PL_expect == XOPERATOR) {
5130 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5131 return deprecate_commaless_var_list();
5138 pl_yylval.ival = OP_CONST;
5139 /* FIXME. I think that this can be const if char *d is replaced by
5140 more localised variables. */
5141 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5142 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5143 pl_yylval.ival = OP_STRINGIFY;
5147 TERM(sublex_start());
5150 s = scan_str(s,!!PL_madskills,FALSE);
5151 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5152 if (PL_expect == XOPERATOR)
5153 no_op("Backticks",s);
5156 readpipe_override();
5157 TERM(sublex_start());
5161 if (PL_lex_inwhat && isDIGIT(*s))
5162 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5164 if (PL_expect == XOPERATOR)
5165 no_op("Backslash",s);
5169 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5170 char *start = s + 2;
5171 while (isDIGIT(*start) || *start == '_')
5173 if (*start == '.' && isDIGIT(start[1])) {
5174 s = scan_num(s, &pl_yylval);
5177 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5178 else if (!isALPHA(*start) && (PL_expect == XTERM
5179 || PL_expect == XREF || PL_expect == XSTATE
5180 || PL_expect == XTERMORDORDOR)) {
5181 GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
5183 s = scan_num(s, &pl_yylval);
5190 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5233 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5235 /* Some keywords can be followed by any delimiter, including ':' */
5236 anydelim = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5237 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5238 (PL_tokenbuf[0] == 'q' &&
5239 strchr("qwxr", PL_tokenbuf[1])))));
5241 /* x::* is just a word, unless x is "CORE" */
5242 if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5246 while (d < PL_bufend && isSPACE(*d))
5247 d++; /* no comments skipped here, or s### is misparsed */
5249 /* Is this a word before a => operator? */
5250 if (*d == '=' && d[1] == '>') {
5253 = (OP*)newSVOP(OP_CONST, 0,
5254 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5255 pl_yylval.opval->op_private = OPpCONST_BARE;
5259 /* Check for plugged-in keyword */
5263 char *saved_bufptr = PL_bufptr;
5265 result = CALL_FPTR(PL_keyword_plugin)(aTHX_ PL_tokenbuf, len, &o);
5267 if (result == KEYWORD_PLUGIN_DECLINE) {
5268 /* not a plugged-in keyword */
5269 PL_bufptr = saved_bufptr;
5270 } else if (result == KEYWORD_PLUGIN_STMT) {
5271 pl_yylval.opval = o;
5274 return REPORT(PLUGSTMT);
5275 } else if (result == KEYWORD_PLUGIN_EXPR) {
5276 pl_yylval.opval = o;
5278 PL_expect = XOPERATOR;
5279 return REPORT(PLUGEXPR);
5281 Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
5286 /* Check for built-in keyword */
5287 tmp = keyword(PL_tokenbuf, len, 0);
5289 /* Is this a label? */
5290 if (!anydelim && PL_expect == XSTATE
5291 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5293 Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
5295 pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5300 if (tmp < 0) { /* second-class keyword? */
5301 GV *ogv = NULL; /* override (winner) */
5302 GV *hgv = NULL; /* hidden (loser) */
5303 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5305 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5308 if (GvIMPORTED_CV(gv))
5310 else if (! CvMETHOD(cv))
5314 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5315 (gv = *gvp) && isGV_with_GP(gv) &&
5316 GvCVu(gv) && GvIMPORTED_CV(gv))
5323 tmp = 0; /* overridden by import or by GLOBAL */
5326 && -tmp==KEY_lock /* XXX generalizable kludge */
5329 tmp = 0; /* any sub overrides "weak" keyword */
5331 else { /* no override */
5333 if (tmp == KEY_dump) {
5334 Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
5335 "dump() better written as CORE::dump()");
5339 if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
5340 Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5341 "Ambiguous call resolved as CORE::%s(), %s",
5342 GvENAME(hgv), "qualify as such or use &");
5349 default: /* not a keyword */
5350 /* Trade off - by using this evil construction we can pull the
5351 variable gv into the block labelled keylookup. If not, then
5352 we have to give it function scope so that the goto from the
5353 earlier ':' case doesn't bypass the initialisation. */
5355 just_a_word_zero_gv:
5363 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5366 SV *nextPL_nextwhite = 0;
5370 /* Get the rest if it looks like a package qualifier */
5372 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5374 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5377 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5378 *s == '\'' ? "'" : "::");
5383 if (PL_expect == XOPERATOR) {
5384 if (PL_bufptr == PL_linestart) {
5385 CopLINE_dec(PL_curcop);
5386 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5387 CopLINE_inc(PL_curcop);
5390 no_op("Bareword",s);
5393 /* Look for a subroutine with this name in current package,
5394 unless name is "Foo::", in which case Foo is a bearword
5395 (and a package name). */
5397 if (len > 2 && !PL_madskills &&
5398 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5400 if (ckWARN(WARN_BAREWORD)
5401 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5402 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5403 "Bareword \"%s\" refers to nonexistent package",
5406 PL_tokenbuf[len] = '\0';
5412 /* Mustn't actually add anything to a symbol table.
5413 But also don't want to "initialise" any placeholder
5414 constants that might already be there into full
5415 blown PVGVs with attached PVCV. */
5416 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5417 GV_NOADD_NOINIT, SVt_PVCV);
5422 /* if we saw a global override before, get the right name */
5425 sv = newSVpvs("CORE::GLOBAL::");
5426 sv_catpv(sv,PL_tokenbuf);
5429 /* If len is 0, newSVpv does strlen(), which is correct.
5430 If len is non-zero, then it will be the true length,
5431 and so the scalar will be created correctly. */
5432 sv = newSVpv(PL_tokenbuf,len);
5435 if (PL_madskills && !PL_thistoken) {
5436 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5437 PL_thistoken = newSVpvn(start,s - start);
5438 PL_realtokenstart = s - SvPVX(PL_linestr);
5442 /* Presume this is going to be a bareword of some sort. */
5445 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5446 pl_yylval.opval->op_private = OPpCONST_BARE;
5447 /* UTF-8 package name? */
5448 if (UTF && !IN_BYTES &&
5449 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5452 /* And if "Foo::", then that's what it certainly is. */
5457 /* Do the explicit type check so that we don't need to force
5458 the initialisation of the symbol table to have a real GV.
5459 Beware - gv may not really be a PVGV, cv may not really be
5460 a PVCV, (because of the space optimisations that gv_init
5461 understands) But they're true if for this symbol there is
5462 respectively a typeglob and a subroutine.
5464 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5465 /* Real typeglob, so get the real subroutine: */
5467 /* A proxy for a subroutine in this package? */
5468 : SvOK(gv) ? MUTABLE_CV(gv) : NULL)
5471 /* See if it's the indirect object for a list operator. */
5473 if (PL_oldoldbufptr &&
5474 PL_oldoldbufptr < PL_bufptr &&
5475 (PL_oldoldbufptr == PL_last_lop
5476 || PL_oldoldbufptr == PL_last_uni) &&
5477 /* NO SKIPSPACE BEFORE HERE! */
5478 (PL_expect == XREF ||
5479 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5481 bool immediate_paren = *s == '(';
5483 /* (Now we can afford to cross potential line boundary.) */
5484 s = SKIPSPACE2(s,nextPL_nextwhite);
5486 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5489 /* Two barewords in a row may indicate method call. */
5491 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5492 (tmp = intuit_method(s, gv, cv)))
5495 /* If not a declared subroutine, it's an indirect object. */
5496 /* (But it's an indir obj regardless for sort.) */
5497 /* Also, if "_" follows a filetest operator, it's a bareword */
5500 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5502 (PL_last_lop_op != OP_MAPSTART &&
5503 PL_last_lop_op != OP_GREPSTART))))
5504 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5505 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5508 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5513 PL_expect = XOPERATOR;
5516 s = SKIPSPACE2(s,nextPL_nextwhite);
5517 PL_nextwhite = nextPL_nextwhite;
5522 /* Is this a word before a => operator? */
5523 if (*s == '=' && s[1] == '>' && !pkgname) {
5525 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
5526 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5527 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
5531 /* If followed by a paren, it's certainly a subroutine. */
5536 while (SPACE_OR_TAB(*d))
5538 if (*d == ')' && (sv = gv_const_sv(gv))) {
5545 PL_nextwhite = PL_thiswhite;
5548 start_force(PL_curforce);
5550 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5551 PL_expect = XOPERATOR;
5554 PL_nextwhite = nextPL_nextwhite;
5555 curmad('X', PL_thistoken);
5556 PL_thistoken = newSVpvs("");
5564 /* If followed by var or block, call it a method (unless sub) */
5566 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5567 PL_last_lop = PL_oldbufptr;
5568 PL_last_lop_op = OP_METHOD;
5572 /* If followed by a bareword, see if it looks like indir obj. */
5575 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5576 && (tmp = intuit_method(s, gv, cv)))
5579 /* Not a method, so call it a subroutine (if defined) */
5582 if (lastchar == '-')
5583 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
5584 "Ambiguous use of -%s resolved as -&%s()",
5585 PL_tokenbuf, PL_tokenbuf);
5586 /* Check for a constant sub */
5587 if ((sv = gv_const_sv(gv))) {
5589 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
5590 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5591 pl_yylval.opval->op_private = 0;
5595 /* Resolve to GV now. */
5596 if (SvTYPE(gv) != SVt_PVGV) {
5597 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5598 assert (SvTYPE(gv) == SVt_PVGV);
5599 /* cv must have been some sort of placeholder, so
5600 now needs replacing with a real code reference. */
5604 op_free(pl_yylval.opval);
5605 pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5606 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5607 PL_last_lop = PL_oldbufptr;
5608 PL_last_lop_op = OP_ENTERSUB;
5609 /* Is there a prototype? */
5617 const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
5620 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5622 while (*proto == ';')
5624 if (*proto == '&' && *s == '{') {
5626 sv_setpvs(PL_subname, "__ANON__");
5628 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5635 PL_nextwhite = PL_thiswhite;
5638 start_force(PL_curforce);
5639 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5642 PL_nextwhite = nextPL_nextwhite;
5643 curmad('X', PL_thistoken);
5644 PL_thistoken = newSVpvs("");
5651 /* Guess harder when madskills require "best effort". */
5652 if (PL_madskills && (!gv || !GvCVu(gv))) {
5653 int probable_sub = 0;
5654 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5656 else if (isALPHA(*s)) {
5660 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5661 if (!keyword(tmpbuf, tmplen, 0))
5664 while (d < PL_bufend && isSPACE(*d))
5666 if (*d == '=' && d[1] == '>')
5671 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5672 op_free(pl_yylval.opval);
5673 pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5674 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5675 PL_last_lop = PL_oldbufptr;
5676 PL_last_lop_op = OP_ENTERSUB;
5677 PL_nextwhite = PL_thiswhite;
5679 start_force(PL_curforce);
5680 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5682 PL_nextwhite = nextPL_nextwhite;
5683 curmad('X', PL_thistoken);
5684 PL_thistoken = newSVpvs("");
5689 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5696 /* Call it a bare word */
5698 if (PL_hints & HINT_STRICT_SUBS)
5699 pl_yylval.opval->op_private |= OPpCONST_STRICT;
5702 /* after "print" and similar functions (corresponding to
5703 * "F? L" in opcode.pl), whatever wasn't already parsed as
5704 * a filehandle should be subject to "strict subs".
5705 * Likewise for the optional indirect-object argument to system
5706 * or exec, which can't be a bareword */
5707 if ((PL_last_lop_op == OP_PRINT
5708 || PL_last_lop_op == OP_PRTF
5709 || PL_last_lop_op == OP_SAY
5710 || PL_last_lop_op == OP_SYSTEM
5711 || PL_last_lop_op == OP_EXEC)
5712 && (PL_hints & HINT_STRICT_SUBS))
5713 pl_yylval.opval->op_private |= OPpCONST_STRICT;
5714 if (lastchar != '-') {
5715 if (ckWARN(WARN_RESERVED)) {
5719 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5720 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5727 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
5728 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
5729 "Operator or semicolon missing before %c%s",
5730 lastchar, PL_tokenbuf);
5731 Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
5732 "Ambiguous use of %c resolved as operator %c",
5733 lastchar, lastchar);
5739 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5740 newSVpv(CopFILE(PL_curcop),0));
5744 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5745 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5748 case KEY___PACKAGE__:
5749 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5751 ? newSVhek(HvNAME_HEK(PL_curstash))
5758 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5759 const char *pname = "main";
5760 if (PL_tokenbuf[2] == 'D')
5761 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5762 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5766 GvIOp(gv) = newIO();
5767 IoIFP(GvIOp(gv)) = PL_rsfp;
5768 #if defined(HAS_FCNTL) && defined(F_SETFD)
5770 const int fd = PerlIO_fileno(PL_rsfp);
5771 fcntl(fd,F_SETFD,fd >= 3);
5774 /* Mark this internal pseudo-handle as clean */
5775 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5776 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5777 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5779 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5780 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5781 /* if the script was opened in binmode, we need to revert
5782 * it to text mode for compatibility; but only iff it has CRs
5783 * XXX this is a questionable hack at best. */
5784 if (PL_bufend-PL_bufptr > 2
5785 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5788 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5789 loc = PerlIO_tell(PL_rsfp);
5790 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5793 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5795 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5796 #endif /* NETWARE */
5797 #ifdef PERLIO_IS_STDIO /* really? */
5798 # if defined(__BORLANDC__)
5799 /* XXX see note in do_binmode() */
5800 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5804 PerlIO_seek(PL_rsfp, loc, 0);
5808 #ifdef PERLIO_LAYERS
5811 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5812 else if (PL_encoding) {
5819 XPUSHs(PL_encoding);
5821 call_method("name", G_SCALAR);
5825 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5826 Perl_form(aTHX_ ":encoding(%"SVf")",
5835 if (PL_realtokenstart >= 0) {
5836 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5838 PL_endwhite = newSVpvs("");
5839 sv_catsv(PL_endwhite, PL_thiswhite);
5841 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5842 PL_realtokenstart = -1;
5844 while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
5860 if (PL_expect == XSTATE) {
5867 if (*s == ':' && s[1] == ':') {
5870 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5871 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5872 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5875 else if (tmp == KEY_require || tmp == KEY_do)
5876 /* that's a way to remember we saw "CORE::" */
5889 LOP(OP_ACCEPT,XTERM);
5895 LOP(OP_ATAN2,XTERM);
5901 LOP(OP_BINMODE,XTERM);
5904 LOP(OP_BLESS,XTERM);
5913 /* When 'use switch' is in effect, continue has a dual
5914 life as a control operator. */
5916 if (!FEATURE_IS_ENABLED("switch"))
5919 /* We have to disambiguate the two senses of
5920 "continue". If the next token is a '{' then
5921 treat it as the start of a continue block;
5922 otherwise treat it as a control operator.
5934 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5951 if (!PL_cryptseen) {
5952 PL_cryptseen = TRUE;
5956 LOP(OP_CRYPT,XTERM);
5959 LOP(OP_CHMOD,XTERM);
5962 LOP(OP_CHOWN,XTERM);
5965 LOP(OP_CONNECT,XTERM);
5984 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5985 if (orig_keyword == KEY_do) {
5994 PL_hints |= HINT_BLOCK_SCOPE;
6004 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
6005 LOP(OP_DBMOPEN,XTERM);
6011 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6018 pl_yylval.ival = CopLINE(PL_curcop);
6034 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
6035 UNIBRACK(OP_ENTEREVAL);
6049 case KEY_endhostent:
6055 case KEY_endservent:
6058 case KEY_endprotoent:
6069 pl_yylval.ival = CopLINE(PL_curcop);
6071 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
6074 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
6077 if ((PL_bufend - p) >= 3 &&
6078 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
6080 else if ((PL_bufend - p) >= 4 &&
6081 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
6084 if (isIDFIRST_lazy_if(p,UTF)) {
6085 p = scan_ident(p, PL_bufend,
6086 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
6090 Perl_croak(aTHX_ "Missing $ on loop variable");
6092 s = SvPVX(PL_linestr) + soff;
6098 LOP(OP_FORMLINE,XTERM);
6104 LOP(OP_FCNTL,XTERM);
6110 LOP(OP_FLOCK,XTERM);
6119 LOP(OP_GREPSTART, XREF);
6122 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6137 case KEY_getpriority:
6138 LOP(OP_GETPRIORITY,XTERM);
6140 case KEY_getprotobyname:
6143 case KEY_getprotobynumber:
6144 LOP(OP_GPBYNUMBER,XTERM);
6146 case KEY_getprotoent:
6158 case KEY_getpeername:
6159 UNI(OP_GETPEERNAME);
6161 case KEY_gethostbyname:
6164 case KEY_gethostbyaddr:
6165 LOP(OP_GHBYADDR,XTERM);
6167 case KEY_gethostent:
6170 case KEY_getnetbyname:
6173 case KEY_getnetbyaddr:
6174 LOP(OP_GNBYADDR,XTERM);
6179 case KEY_getservbyname:
6180 LOP(OP_GSBYNAME,XTERM);
6182 case KEY_getservbyport:
6183 LOP(OP_GSBYPORT,XTERM);
6185 case KEY_getservent:
6188 case KEY_getsockname:
6189 UNI(OP_GETSOCKNAME);
6191 case KEY_getsockopt:
6192 LOP(OP_GSOCKOPT,XTERM);
6207 pl_yylval.ival = CopLINE(PL_curcop);
6217 pl_yylval.ival = CopLINE(PL_curcop);
6221 LOP(OP_INDEX,XTERM);
6227 LOP(OP_IOCTL,XTERM);
6239 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6271 LOP(OP_LISTEN,XTERM);
6280 s = scan_pat(s,OP_MATCH);
6281 TERM(sublex_start());
6284 LOP(OP_MAPSTART, XREF);
6287 LOP(OP_MKDIR,XTERM);
6290 LOP(OP_MSGCTL,XTERM);
6293 LOP(OP_MSGGET,XTERM);
6296 LOP(OP_MSGRCV,XTERM);
6299 LOP(OP_MSGSND,XTERM);
6304 PL_in_my = (U16)tmp;
6306 if (isIDFIRST_lazy_if(s,UTF)) {
6310 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6311 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6313 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6314 if (!PL_in_my_stash) {
6317 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6321 if (PL_madskills) { /* just add type to declarator token */
6322 sv_catsv(PL_thistoken, PL_nextwhite);
6324 sv_catpvn(PL_thistoken, start, s - start);
6332 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6339 s = tokenize_use(0, s);
6343 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6350 if (isIDFIRST_lazy_if(s,UTF)) {
6352 for (d = s; isALNUM_lazy_if(d,UTF);)
6354 for (t=d; isSPACE(*t);)
6356 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6358 && !(t[0] == '=' && t[1] == '>')
6360 int parms_len = (int)(d-s);
6361 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6362 "Precedence problem: open %.*s should be open(%.*s)",
6363 parms_len, s, parms_len, s);
6369 pl_yylval.ival = OP_OR;
6379 LOP(OP_OPEN_DIR,XTERM);
6382 checkcomma(s,PL_tokenbuf,"filehandle");
6386 checkcomma(s,PL_tokenbuf,"filehandle");
6405 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6406 s = force_version(s, FALSE);
6410 LOP(OP_PIPE_OP,XTERM);
6413 s = scan_str(s,!!PL_madskills,FALSE);
6416 pl_yylval.ival = OP_CONST;
6417 TERM(sublex_start());
6423 s = scan_str(s,!!PL_madskills,FALSE);
6426 PL_expect = XOPERATOR;
6428 if (SvCUR(PL_lex_stuff)) {
6431 d = SvPV_force(PL_lex_stuff, len);
6433 for (; isSPACE(*d) && len; --len, ++d)
6438 if (!warned && ckWARN(WARN_QW)) {
6439 for (; !isSPACE(*d) && len; --len, ++d) {
6441 Perl_warner(aTHX_ packWARN(WARN_QW),
6442 "Possible attempt to separate words with commas");
6445 else if (*d == '#') {
6446 Perl_warner(aTHX_ packWARN(WARN_QW),
6447 "Possible attempt to put comments in qw() list");
6453 for (; !isSPACE(*d) && len; --len, ++d)
6456 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
6457 words = append_elem(OP_LIST, words,
6458 newSVOP(OP_CONST, 0, tokeq(sv)));
6462 start_force(PL_curforce);
6463 NEXTVAL_NEXTTOKE.opval = words;
6468 SvREFCNT_dec(PL_lex_stuff);
6469 PL_lex_stuff = NULL;
6475 s = scan_str(s,!!PL_madskills,FALSE);
6478 pl_yylval.ival = OP_STRINGIFY;
6479 if (SvIVX(PL_lex_stuff) == '\'')
6480 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6481 TERM(sublex_start());
6484 s = scan_pat(s,OP_QR);
6485 TERM(sublex_start());
6488 s = scan_str(s,!!PL_madskills,FALSE);
6491 readpipe_override();
6492 TERM(sublex_start());
6500 s = force_version(s, FALSE);
6502 else if (*s != 'v' || !isDIGIT(s[1])
6503 || (s = force_version(s, TRUE), *s == 'v'))
6505 *PL_tokenbuf = '\0';
6506 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6507 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6508 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6510 yyerror("<> should be quotes");
6512 if (orig_keyword == KEY_require) {
6520 PL_last_uni = PL_oldbufptr;
6521 PL_last_lop_op = OP_REQUIRE;
6523 return REPORT( (int)REQUIRE );
6529 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6533 LOP(OP_RENAME,XTERM);
6542 LOP(OP_RINDEX,XTERM);
6551 UNIDOR(OP_READLINE);
6554 UNIDOR(OP_BACKTICK);
6563 LOP(OP_REVERSE,XTERM);
6566 UNIDOR(OP_READLINK);
6573 if (pl_yylval.opval)
6574 TERM(sublex_start());
6576 TOKEN(1); /* force error */
6579 checkcomma(s,PL_tokenbuf,"filehandle");
6589 LOP(OP_SELECT,XTERM);
6595 LOP(OP_SEMCTL,XTERM);
6598 LOP(OP_SEMGET,XTERM);
6601 LOP(OP_SEMOP,XTERM);
6607 LOP(OP_SETPGRP,XTERM);
6609 case KEY_setpriority:
6610 LOP(OP_SETPRIORITY,XTERM);
6612 case KEY_sethostent:
6618 case KEY_setservent:
6621 case KEY_setprotoent:
6631 LOP(OP_SEEKDIR,XTERM);
6633 case KEY_setsockopt:
6634 LOP(OP_SSOCKOPT,XTERM);
6640 LOP(OP_SHMCTL,XTERM);
6643 LOP(OP_SHMGET,XTERM);
6646 LOP(OP_SHMREAD,XTERM);
6649 LOP(OP_SHMWRITE,XTERM);
6652 LOP(OP_SHUTDOWN,XTERM);
6661 LOP(OP_SOCKET,XTERM);
6663 case KEY_socketpair:
6664 LOP(OP_SOCKPAIR,XTERM);
6667 checkcomma(s,PL_tokenbuf,"subroutine name");
6669 if (*s == ';' || *s == ')') /* probably a close */
6670 Perl_croak(aTHX_ "sort is now a reserved word");
6672 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6676 LOP(OP_SPLIT,XTERM);
6679 LOP(OP_SPRINTF,XTERM);
6682 LOP(OP_SPLICE,XTERM);
6697 LOP(OP_SUBSTR,XTERM);
6703 char tmpbuf[sizeof PL_tokenbuf];
6704 SSize_t tboffset = 0;
6705 expectation attrful;
6706 bool have_name, have_proto;
6707 const int key = tmp;
6712 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6713 SV *subtoken = newSVpvn(tstart, s - tstart);
6717 s = SKIPSPACE2(s,tmpwhite);
6722 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6723 (*s == ':' && s[1] == ':'))
6726 SV *nametoke = NULL;
6730 attrful = XATTRBLOCK;
6731 /* remember buffer pos'n for later force_word */
6732 tboffset = s - PL_oldbufptr;
6733 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6736 nametoke = newSVpvn(s, d - s);
6738 if (memchr(tmpbuf, ':', len))
6739 sv_setpvn(PL_subname, tmpbuf, len);
6741 sv_setsv(PL_subname,PL_curstname);
6742 sv_catpvs(PL_subname,"::");
6743 sv_catpvn(PL_subname,tmpbuf,len);
6750 CURMAD('X', nametoke);
6751 CURMAD('_', tmpwhite);
6752 (void) force_word(PL_oldbufptr + tboffset, WORD,
6755 s = SKIPSPACE2(d,tmpwhite);
6762 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6763 PL_expect = XTERMBLOCK;
6764 attrful = XATTRTERM;
6765 sv_setpvs(PL_subname,"?");
6769 if (key == KEY_format) {
6771 PL_lex_formbrack = PL_lex_brackets + 1;
6773 PL_thistoken = subtoken;
6777 (void) force_word(PL_oldbufptr + tboffset, WORD,
6783 /* Look for a prototype */
6786 bool bad_proto = FALSE;
6787 bool in_brackets = FALSE;
6788 char greedy_proto = ' ';
6789 bool proto_after_greedy_proto = FALSE;
6790 bool must_be_last = FALSE;
6791 bool underscore = FALSE;
6792 bool seen_underscore = FALSE;
6793 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6795 s = scan_str(s,!!PL_madskills,FALSE);
6797 Perl_croak(aTHX_ "Prototype not terminated");
6798 /* strip spaces and check for bad characters */
6799 d = SvPVX(PL_lex_stuff);
6801 for (p = d; *p; ++p) {
6807 proto_after_greedy_proto = TRUE;
6808 if (!strchr("$@%*;[]&\\_", *p)) {
6820 else if ( *p == ']' ) {
6821 in_brackets = FALSE;
6823 else if ( (*p == '@' || *p == '%') &&
6824 ( tmp < 2 || d[tmp-2] != '\\' ) &&
6826 must_be_last = TRUE;
6829 else if ( *p == '_' ) {
6830 underscore = seen_underscore = TRUE;
6837 if (proto_after_greedy_proto)
6838 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6839 "Prototype after '%c' for %"SVf" : %s",
6840 greedy_proto, SVfARG(PL_subname), d);
6842 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6843 "Illegal character %sin prototype for %"SVf" : %s",
6844 seen_underscore ? "after '_' " : "",
6845 SVfARG(PL_subname), d);
6846 SvCUR_set(PL_lex_stuff, tmp);
6851 CURMAD('q', PL_thisopen);
6852 CURMAD('_', tmpwhite);
6853 CURMAD('=', PL_thisstuff);
6854 CURMAD('Q', PL_thisclose);
6855 NEXTVAL_NEXTTOKE.opval =
6856 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6857 PL_lex_stuff = NULL;
6860 s = SKIPSPACE2(s,tmpwhite);
6868 if (*s == ':' && s[1] != ':')
6869 PL_expect = attrful;
6870 else if (*s != '{' && key == KEY_sub) {
6872 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6874 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6881 curmad('^', newSVpvs(""));
6882 CURMAD('_', tmpwhite);
6886 PL_thistoken = subtoken;
6889 NEXTVAL_NEXTTOKE.opval =
6890 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6891 PL_lex_stuff = NULL;
6897 sv_setpvs(PL_subname, "__ANON__");
6899 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6903 (void) force_word(PL_oldbufptr + tboffset, WORD,
6912 LOP(OP_SYSTEM,XREF);
6915 LOP(OP_SYMLINK,XTERM);
6918 LOP(OP_SYSCALL,XTERM);
6921 LOP(OP_SYSOPEN,XTERM);
6924 LOP(OP_SYSSEEK,XTERM);
6927 LOP(OP_SYSREAD,XTERM);
6930 LOP(OP_SYSWRITE,XTERM);
6934 TERM(sublex_start());
6955 LOP(OP_TRUNCATE,XTERM);
6967 pl_yylval.ival = CopLINE(PL_curcop);
6971 pl_yylval.ival = CopLINE(PL_curcop);
6975 LOP(OP_UNLINK,XTERM);
6981 LOP(OP_UNPACK,XTERM);
6984 LOP(OP_UTIME,XTERM);
6990 LOP(OP_UNSHIFT,XTERM);
6993 s = tokenize_use(1, s);
7003 pl_yylval.ival = CopLINE(PL_curcop);
7007 pl_yylval.ival = CopLINE(PL_curcop);
7011 PL_hints |= HINT_BLOCK_SCOPE;
7018 LOP(OP_WAITPID,XTERM);
7027 ctl_l[0] = toCTRL('L');
7029 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
7032 /* Make sure $^L is defined */
7033 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
7038 if (PL_expect == XOPERATOR)
7044 pl_yylval.ival = OP_XOR;
7049 TERM(sublex_start());
7054 #pragma segment Main
7058 S_pending_ident(pTHX)
7063 /* pit holds the identifier we read and pending_ident is reset */
7064 char pit = PL_pending_ident;
7065 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
7066 /* All routes through this function want to know if there is a colon. */
7067 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
7068 PL_pending_ident = 0;
7070 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
7071 DEBUG_T({ PerlIO_printf(Perl_debug_log,
7072 "### Pending identifier '%s'\n", PL_tokenbuf); });
7074 /* if we're in a my(), we can't allow dynamics here.
7075 $foo'bar has already been turned into $foo::bar, so
7076 just check for colons.
7078 if it's a legal name, the OP is a PADANY.
7081 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
7083 yyerror(Perl_form(aTHX_ "No package name allowed for "
7084 "variable %s in \"our\"",
7086 tmp = allocmy(PL_tokenbuf);
7090 yyerror(Perl_form(aTHX_ PL_no_myglob,
7091 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
7093 pl_yylval.opval = newOP(OP_PADANY, 0);
7094 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf);
7100 build the ops for accesses to a my() variable.
7102 Deny my($a) or my($b) in a sort block, *if* $a or $b is
7103 then used in a comparison. This catches most, but not
7104 all cases. For instance, it catches
7105 sort { my($a); $a <=> $b }
7107 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
7108 (although why you'd do that is anyone's guess).
7113 tmp = pad_findmy(PL_tokenbuf, tokenbuf_len, 0);
7114 if (tmp != NOT_IN_PAD) {
7115 /* might be an "our" variable" */
7116 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
7117 /* build ops for a bareword */
7118 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
7119 HEK * const stashname = HvNAME_HEK(stash);
7120 SV * const sym = newSVhek(stashname);
7121 sv_catpvs(sym, "::");
7122 sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
7123 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
7124 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7127 ? (GV_ADDMULTI | GV_ADDINEVAL)
7130 ((PL_tokenbuf[0] == '$') ? SVt_PV
7131 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7136 /* if it's a sort block and they're naming $a or $b */
7137 if (PL_last_lop_op == OP_SORT &&
7138 PL_tokenbuf[0] == '$' &&
7139 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
7142 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
7143 d < PL_bufend && *d != '\n';
7146 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
7147 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
7153 pl_yylval.opval = newOP(OP_PADANY, 0);
7154 pl_yylval.opval->op_targ = tmp;
7160 Whine if they've said @foo in a doublequoted string,
7161 and @foo isn't a variable we can find in the symbol
7164 if (ckWARN(WARN_AMBIGUOUS) &&
7165 pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
7166 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
7168 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
7169 /* DO NOT warn for @- and @+ */
7170 && !( PL_tokenbuf[2] == '\0' &&
7171 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
7174 /* Downgraded from fatal to warning 20000522 mjd */
7175 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7176 "Possible unintended interpolation of %s in string",
7181 /* build ops for a bareword */
7182 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
7184 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7186 PL_tokenbuf + 1, tokenbuf_len - 1,
7187 /* If the identifier refers to a stash, don't autovivify it.
7188 * Change 24660 had the side effect of causing symbol table
7189 * hashes to always be defined, even if they were freshly
7190 * created and the only reference in the entire program was
7191 * the single statement with the defined %foo::bar:: test.
7192 * It appears that all code in the wild doing this actually
7193 * wants to know whether sub-packages have been loaded, so
7194 * by avoiding auto-vivifying symbol tables, we ensure that
7195 * defined %foo::bar:: continues to be false, and the existing
7196 * tests still give the expected answers, even though what
7197 * they're actually testing has now changed subtly.
7199 (*PL_tokenbuf == '%'
7200 && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
7203 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7204 ((PL_tokenbuf[0] == '$') ? SVt_PV
7205 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7211 * The following code was generated by perl_keyword.pl.
7215 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7219 PERL_ARGS_ASSERT_KEYWORD;
7223 case 1: /* 5 tokens of length 1 */
7255 case 2: /* 18 tokens of length 2 */
7401 case 3: /* 29 tokens of length 3 */
7405 if (name[1] == 'N' &&
7468 if (name[1] == 'i' &&
7500 if (name[1] == 'o' &&
7509 if (name[1] == 'e' &&
7518 if (name[1] == 'n' &&
7527 if (name[1] == 'o' &&
7536 if (name[1] == 'a' &&
7545 if (name[1] == 'o' &&
7607 if (name[1] == 'e' &&
7621 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7647 if (name[1] == 'i' &&
7656 if (name[1] == 's' &&
7665 if (name[1] == 'e' &&
7674 if (name[1] == 'o' &&
7686 case 4: /* 41 tokens of length 4 */
7690 if (name[1] == 'O' &&
7700 if (name[1] == 'N' &&
7710 if (name[1] == 'i' &&
7720 if (name[1] == 'h' &&
7730 if (name[1] == 'u' &&
7743 if (name[2] == 'c' &&
7752 if (name[2] == 's' &&
7761 if (name[2] == 'a' &&
7797 if (name[1] == 'o' &&
7810 if (name[2] == 't' &&
7819 if (name[2] == 'o' &&
7828 if (name[2] == 't' &&
7837 if (name[2] == 'e' &&
7850 if (name[1] == 'o' &&
7863 if (name[2] == 'y' &&
7872 if (name[2] == 'l' &&
7888 if (name[2] == 's' &&
7897 if (name[2] == 'n' &&
7906 if (name[2] == 'c' &&
7919 if (name[1] == 'e' &&
7929 if (name[1] == 'p' &&
7942 if (name[2] == 'c' &&
7951 if (name[2] == 'p' &&
7960 if (name[2] == 's' &&
7976 if (name[2] == 'n' &&
8046 if (name[2] == 'r' &&
8055 if (name[2] == 'r' &&
8064 if (name[2] == 'a' &&
8080 if (name[2] == 'l' &&
8142 if (name[2] == 'e' &&
8145 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
8158 case 5: /* 39 tokens of length 5 */
8162 if (name[1] == 'E' &&
8173 if (name[1] == 'H' &&
8187 if (name[2] == 'a' &&
8197 if (name[2] == 'a' &&
8214 if (name[2] == 'e' &&
8224 if (name[2] == 'e' &&
8228 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8244 if (name[3] == 'i' &&
8253 if (name[3] == 'o' &&
8289 if (name[2] == 'o' &&
8299 if (name[2] == 'y' &&
8313 if (name[1] == 'l' &&
8327 if (name[2] == 'n' &&
8337 if (name[2] == 'o' &&
8351 if (name[1] == 'i' &&
8356 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8365 if (name[2] == 'd' &&
8375 if (name[2] == 'c' &&
8392 if (name[2] == 'c' &&
8402 if (name[2] == 't' &&
8416 if (name[1] == 'k' &&
8427 if (name[1] == 'r' &&
8441 if (name[2] == 's' &&
8451 if (name[2] == 'd' &&
8468 if (name[2] == 'm' &&
8478 if (name[2] == 'i' &&
8488 if (name[2] == 'e' &&
8498 if (name[2] == 'l' &&
8508 if (name[2] == 'a' &&
8521 if (name[3] == 't' &&
8524 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8530 if (name[3] == 'd' &&
8547 if (name[1] == 'i' &&
8561 if (name[2] == 'a' &&
8574 if (name[3] == 'e' &&
8609 if (name[2] == 'i' &&
8626 if (name[2] == 'i' &&
8636 if (name[2] == 'i' &&
8653 case 6: /* 33 tokens of length 6 */
8657 if (name[1] == 'c' &&
8672 if (name[2] == 'l' &&
8683 if (name[2] == 'r' &&
8698 if (name[1] == 'e' &&
8713 if (name[2] == 's' &&
8718 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8724 if (name[2] == 'i' &&
8742 if (name[2] == 'l' &&
8753 if (name[2] == 'r' &&
8768 if (name[1] == 'm' &&
8783 if (name[2] == 'n' &&
8794 if (name[2] == 's' &&
8809 if (name[1] == 's' &&
8815 if (name[4] == 't' &&
8824 if (name[4] == 'e' &&
8833 if (name[4] == 'c' &&
8842 if (name[4] == 'n' &&
8858 if (name[1] == 'r' &&
8876 if (name[3] == 'a' &&
8886 if (name[3] == 'u' &&
8900 if (name[2] == 'n' &&
8918 if (name[2] == 'a' &&
8932 if (name[3] == 'e' &&
8945 if (name[4] == 't' &&
8954 if (name[4] == 'e' &&
8976 if (name[4] == 't' &&
8985 if (name[4] == 'e' &&
9001 if (name[2] == 'c' &&
9012 if (name[2] == 'l' &&
9023 if (name[2] == 'b' &&
9034 if (name[2] == 's' &&
9057 if (name[4] == 's' &&
9066 if (name[4] == 'n' &&
9079 if (name[3] == 'a' &&
9096 if (name[1] == 'a' &&
9111 case 7: /* 29 tokens of length 7 */
9115 if (name[1] == 'E' &&
9128 if (name[1] == '_' &&
9141 if (name[1] == 'i' &&
9148 return -KEY_binmode;
9154 if (name[1] == 'o' &&
9161 return -KEY_connect;
9170 if (name[2] == 'm' &&
9176 return -KEY_dbmopen;
9187 if (name[4] == 'u' &&
9191 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9197 if (name[4] == 'n' &&
9218 if (name[1] == 'o' &&
9231 if (name[1] == 'e' &&
9238 if (name[5] == 'r' &&
9241 return -KEY_getpgrp;
9247 if (name[5] == 'i' &&
9250 return -KEY_getppid;
9263 if (name[1] == 'c' &&
9270 return -KEY_lcfirst;
9276 if (name[1] == 'p' &&
9283 return -KEY_opendir;
9289 if (name[1] == 'a' &&
9307 if (name[3] == 'd' &&
9312 return -KEY_readdir;
9318 if (name[3] == 'u' &&
9329 if (name[3] == 'e' &&
9334 return -KEY_reverse;
9353 if (name[3] == 'k' &&
9358 return -KEY_seekdir;
9364 if (name[3] == 'p' &&
9369 return -KEY_setpgrp;
9379 if (name[2] == 'm' &&
9385 return -KEY_shmread;
9391 if (name[2] == 'r' &&
9397 return -KEY_sprintf;
9406 if (name[3] == 'l' &&
9411 return -KEY_symlink;
9420 if (name[4] == 'a' &&
9424 return -KEY_syscall;
9430 if (name[4] == 'p' &&
9434 return -KEY_sysopen;
9440 if (name[4] == 'e' &&
9444 return -KEY_sysread;
9450 if (name[4] == 'e' &&
9454 return -KEY_sysseek;
9472 if (name[1] == 'e' &&
9479 return -KEY_telldir;
9488 if (name[2] == 'f' &&
9494 return -KEY_ucfirst;
9500 if (name[2] == 's' &&
9506 return -KEY_unshift;
9516 if (name[1] == 'a' &&
9523 return -KEY_waitpid;
9532 case 8: /* 26 tokens of length 8 */
9536 if (name[1] == 'U' &&
9544 return KEY_AUTOLOAD;
9555 if (name[3] == 'A' &&
9561 return KEY___DATA__;
9567 if (name[3] == 'I' &&
9573 return -KEY___FILE__;
9579 if (name[3] == 'I' &&
9585 return -KEY___LINE__;
9601 if (name[2] == 'o' &&
9608 return -KEY_closedir;
9614 if (name[2] == 'n' &&
9621 return -KEY_continue;
9631 if (name[1] == 'b' &&
9639 return -KEY_dbmclose;
9645 if (name[1] == 'n' &&
9651 if (name[4] == 'r' &&
9656 return -KEY_endgrent;
9662 if (name[4] == 'w' &&
9667 return -KEY_endpwent;
9680 if (name[1] == 'o' &&
9688 return -KEY_formline;
9694 if (name[1] == 'e' &&
9705 if (name[6] == 'n' &&
9708 return -KEY_getgrent;
9714 if (name[6] == 'i' &&
9717 return -KEY_getgrgid;
9723 if (name[6] == 'a' &&
9726 return -KEY_getgrnam;
9739 if (name[4] == 'o' &&
9744 return -KEY_getlogin;
9755 if (name[6] == 'n' &&
9758 return -KEY_getpwent;
9764 if (name[6] == 'a' &&
9767 return -KEY_getpwnam;
9773 if (name[6] == 'i' &&
9776 return -KEY_getpwuid;
9796 if (name[1] == 'e' &&
9803 if (name[5] == 'i' &&
9810 return -KEY_readline;
9815 return -KEY_readlink;
9826 if (name[5] == 'i' &&
9830 return -KEY_readpipe;
9851 if (name[4] == 'r' &&
9856 return -KEY_setgrent;
9862 if (name[4] == 'w' &&
9867 return -KEY_setpwent;
9883 if (name[3] == 'w' &&
9889 return -KEY_shmwrite;
9895 if (name[3] == 't' &&
9901 return -KEY_shutdown;
9911 if (name[2] == 's' &&
9918 return -KEY_syswrite;
9928 if (name[1] == 'r' &&
9936 return -KEY_truncate;
9945 case 9: /* 9 tokens of length 9 */
9949 if (name[1] == 'N' &&
9958 return KEY_UNITCHECK;
9964 if (name[1] == 'n' &&
9973 return -KEY_endnetent;
9979 if (name[1] == 'e' &&
9988 return -KEY_getnetent;
9994 if (name[1] == 'o' &&
10003 return -KEY_localtime;
10009 if (name[1] == 'r' &&
10018 return KEY_prototype;
10024 if (name[1] == 'u' &&
10033 return -KEY_quotemeta;
10039 if (name[1] == 'e' &&
10048 return -KEY_rewinddir;
10054 if (name[1] == 'e' &&
10063 return -KEY_setnetent;
10069 if (name[1] == 'a' &&
10078 return -KEY_wantarray;
10087 case 10: /* 9 tokens of length 10 */
10091 if (name[1] == 'n' &&
10097 if (name[4] == 'o' &&
10104 return -KEY_endhostent;
10110 if (name[4] == 'e' &&
10117 return -KEY_endservent;
10130 if (name[1] == 'e' &&
10136 if (name[4] == 'o' &&
10143 return -KEY_gethostent;
10152 if (name[5] == 'r' &&
10158 return -KEY_getservent;
10164 if (name[5] == 'c' &&
10170 return -KEY_getsockopt;
10190 if (name[2] == 't')
10195 if (name[4] == 'o' &&
10202 return -KEY_sethostent;
10211 if (name[5] == 'r' &&
10217 return -KEY_setservent;
10223 if (name[5] == 'c' &&
10229 return -KEY_setsockopt;
10246 if (name[2] == 'c' &&
10255 return -KEY_socketpair;
10268 case 11: /* 8 tokens of length 11 */
10272 if (name[1] == '_' &&
10282 { /* __PACKAGE__ */
10283 return -KEY___PACKAGE__;
10289 if (name[1] == 'n' &&
10299 { /* endprotoent */
10300 return -KEY_endprotoent;
10306 if (name[1] == 'e' &&
10315 if (name[5] == 'e' &&
10321 { /* getpeername */
10322 return -KEY_getpeername;
10331 if (name[6] == 'o' &&
10336 { /* getpriority */
10337 return -KEY_getpriority;
10343 if (name[6] == 't' &&
10348 { /* getprotoent */
10349 return -KEY_getprotoent;
10363 if (name[4] == 'o' &&
10370 { /* getsockname */
10371 return -KEY_getsockname;
10384 if (name[1] == 'e' &&
10392 if (name[6] == 'o' &&
10397 { /* setpriority */
10398 return -KEY_setpriority;
10404 if (name[6] == 't' &&
10409 { /* setprotoent */
10410 return -KEY_setprotoent;
10426 case 12: /* 2 tokens of length 12 */
10427 if (name[0] == 'g' &&
10439 if (name[9] == 'd' &&
10442 { /* getnetbyaddr */
10443 return -KEY_getnetbyaddr;
10449 if (name[9] == 'a' &&
10452 { /* getnetbyname */
10453 return -KEY_getnetbyname;
10465 case 13: /* 4 tokens of length 13 */
10466 if (name[0] == 'g' &&
10473 if (name[4] == 'o' &&
10482 if (name[10] == 'd' &&
10485 { /* gethostbyaddr */
10486 return -KEY_gethostbyaddr;
10492 if (name[10] == 'a' &&
10495 { /* gethostbyname */
10496 return -KEY_gethostbyname;
10509 if (name[4] == 'e' &&
10518 if (name[10] == 'a' &&
10521 { /* getservbyname */
10522 return -KEY_getservbyname;
10528 if (name[10] == 'o' &&
10531 { /* getservbyport */
10532 return -KEY_getservbyport;
10551 case 14: /* 1 tokens of length 14 */
10552 if (name[0] == 'g' &&
10566 { /* getprotobyname */
10567 return -KEY_getprotobyname;
10572 case 16: /* 1 tokens of length 16 */
10573 if (name[0] == 'g' &&
10589 { /* getprotobynumber */
10590 return -KEY_getprotobynumber;
10604 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10608 PERL_ARGS_ASSERT_CHECKCOMMA;
10610 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10611 if (ckWARN(WARN_SYNTAX)) {
10614 for (w = s+2; *w && level; w++) {
10617 else if (*w == ')')
10620 while (isSPACE(*w))
10622 /* the list of chars below is for end of statements or
10623 * block / parens, boolean operators (&&, ||, //) and branch
10624 * constructs (or, and, if, until, unless, while, err, for).
10625 * Not a very solid hack... */
10626 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
10627 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10628 "%s (...) interpreted as function",name);
10631 while (s < PL_bufend && isSPACE(*s))
10635 while (s < PL_bufend && isSPACE(*s))
10637 if (isIDFIRST_lazy_if(s,UTF)) {
10638 const char * const w = s++;
10639 while (isALNUM_lazy_if(s,UTF))
10641 while (s < PL_bufend && isSPACE(*s))
10645 if (keyword(w, s - w, 0))
10648 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10649 if (gv && GvCVu(gv))
10651 Perl_croak(aTHX_ "No comma allowed after %s", what);
10656 /* Either returns sv, or mortalizes sv and returns a new SV*.
10657 Best used as sv=new_constant(..., sv, ...).
10658 If s, pv are NULL, calls subroutine with one argument,
10659 and type is used with error messages only. */
10662 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
10663 SV *sv, SV *pv, const char *type, STRLEN typelen)
10666 HV * const table = GvHV(PL_hintgv); /* ^H */
10670 const char *why1 = "", *why2 = "", *why3 = "";
10672 PERL_ARGS_ASSERT_NEW_CONSTANT;
10674 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10677 why2 = (const char *)
10678 (strEQ(key,"charnames")
10679 ? "(possibly a missing \"use charnames ...\")"
10681 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10682 (type ? type: "undef"), why2);
10684 /* This is convoluted and evil ("goto considered harmful")
10685 * but I do not understand the intricacies of all the different
10686 * failure modes of %^H in here. The goal here is to make
10687 * the most probable error message user-friendly. --jhi */
10692 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10693 (type ? type: "undef"), why1, why2, why3);
10695 yyerror(SvPVX_const(msg));
10699 cvp = hv_fetch(table, key, keylen, FALSE);
10700 if (!cvp || !SvOK(*cvp)) {
10703 why3 = "} is not defined";
10706 sv_2mortal(sv); /* Parent created it permanently */
10709 pv = newSVpvn_flags(s, len, SVs_TEMP);
10711 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
10713 typesv = &PL_sv_undef;
10715 PUSHSTACKi(PERLSI_OVERLOAD);
10727 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10731 /* Check the eval first */
10732 if (!PL_in_eval && SvTRUE(ERRSV)) {
10733 sv_catpvs(ERRSV, "Propagated");
10734 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10736 res = SvREFCNT_inc_simple(sv);
10740 SvREFCNT_inc_simple_void(res);
10749 why1 = "Call to &{$^H{";
10751 why3 = "}} did not return a defined value";
10759 /* Returns a NUL terminated string, with the length of the string written to
10763 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10766 register char *d = dest;
10767 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10769 PERL_ARGS_ASSERT_SCAN_WORD;
10773 Perl_croak(aTHX_ ident_too_long);
10774 if (isALNUM(*s)) /* UTF handled below */
10776 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10781 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10785 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10786 char *t = s + UTF8SKIP(s);
10788 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10792 Perl_croak(aTHX_ ident_too_long);
10793 Copy(s, d, len, char);
10806 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10809 char *bracket = NULL;
10811 register char *d = dest;
10812 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10814 PERL_ARGS_ASSERT_SCAN_IDENT;
10819 while (isDIGIT(*s)) {
10821 Perl_croak(aTHX_ ident_too_long);
10828 Perl_croak(aTHX_ ident_too_long);
10829 if (isALNUM(*s)) /* UTF handled below */
10831 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10836 else if (*s == ':' && s[1] == ':') {
10840 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10841 char *t = s + UTF8SKIP(s);
10842 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10844 if (d + (t - s) > e)
10845 Perl_croak(aTHX_ ident_too_long);
10846 Copy(s, d, t - s, char);
10857 if (PL_lex_state != LEX_NORMAL)
10858 PL_lex_state = LEX_INTERPENDMAYBE;
10861 if (*s == '$' && s[1] &&
10862 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10875 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10880 if (isSPACE(s[-1])) {
10882 const char ch = *s++;
10883 if (!SPACE_OR_TAB(ch)) {
10889 if (isIDFIRST_lazy_if(d,UTF)) {
10893 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10894 end += UTF8SKIP(end);
10895 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10896 end += UTF8SKIP(end);
10898 Copy(s, d, end - s, char);
10903 while ((isALNUM(*s) || *s == ':') && d < e)
10906 Perl_croak(aTHX_ ident_too_long);
10909 while (s < send && SPACE_OR_TAB(*s))
10911 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10912 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10913 const char * const brack =
10915 ((*s == '[') ? "[...]" : "{...}");
10916 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10917 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10918 funny, dest, brack, funny, dest, brack);
10921 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10925 /* Handle extended ${^Foo} variables
10926 * 1999-02-27 mjd-perl-patch@plover.com */
10927 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10931 while (isALNUM(*s) && d < e) {
10935 Perl_croak(aTHX_ ident_too_long);
10940 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10941 PL_lex_state = LEX_INTERPEND;
10944 if (PL_lex_state == LEX_NORMAL) {
10945 if (ckWARN(WARN_AMBIGUOUS) &&
10946 (keyword(dest, d - dest, 0)
10947 || get_cvn_flags(dest, d - dest, 0)))
10951 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10952 "Ambiguous use of %c{%s} resolved to %c%s",
10953 funny, dest, funny, dest);
10958 s = bracket; /* let the parser handle it */
10962 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10963 PL_lex_state = LEX_INTERPEND;
10968 S_pmflag(U32 pmfl, const char ch) {
10970 CASE_STD_PMMOD_FLAGS_PARSE_SET(&pmfl);
10971 case GLOBAL_PAT_MOD: pmfl |= PMf_GLOBAL; break;
10972 case CONTINUE_PAT_MOD: pmfl |= PMf_CONTINUE; break;
10973 case ONCE_PAT_MOD: pmfl |= PMf_KEEP; break;
10974 case KEEPCOPY_PAT_MOD: pmfl |= PMf_KEEPCOPY; break;
10980 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10982 PERL_ARGS_ASSERT_PMFLAG;
10984 Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
10985 "Perl_pmflag() is deprecated, and will be removed from the XS API");
10988 *pmfl = S_pmflag(*pmfl, (char)ch);
10993 S_scan_pat(pTHX_ char *start, I32 type)
10997 char *s = scan_str(start,!!PL_madskills,FALSE);
10998 const char * const valid_flags =
10999 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
11004 PERL_ARGS_ASSERT_SCAN_PAT;
11007 const char * const delimiter = skipspace(start);
11011 ? "Search pattern not terminated or ternary operator parsed as search pattern"
11012 : "Search pattern not terminated" ));
11015 pm = (PMOP*)newPMOP(type, 0);
11016 if (PL_multi_open == '?') {
11017 /* This is the only point in the code that sets PMf_ONCE: */
11018 pm->op_pmflags |= PMf_ONCE;
11020 /* Hence it's safe to do this bit of PMOP book-keeping here, which
11021 allows us to restrict the list needed by reset to just the ??
11023 assert(type != OP_TRANS);
11025 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
11028 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
11031 elements = mg->mg_len / sizeof(PMOP**);
11032 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
11033 ((PMOP**)mg->mg_ptr) [elements++] = pm;
11034 mg->mg_len = elements * sizeof(PMOP**);
11035 PmopSTASH_set(pm,PL_curstash);
11041 while (*s && strchr(valid_flags, *s))
11042 pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
11044 if (PL_madskills && modstart != s) {
11045 SV* tmptoken = newSVpvn(modstart, s - modstart);
11046 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
11049 /* issue a warning if /c is specified,but /g is not */
11050 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
11052 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
11053 "Use of /c modifier is meaningless without /g" );
11056 PL_lex_op = (OP*)pm;
11057 pl_yylval.ival = OP_MATCH;
11062 S_scan_subst(pTHX_ char *start)
11073 PERL_ARGS_ASSERT_SCAN_SUBST;
11075 pl_yylval.ival = OP_NULL;
11077 s = scan_str(start,!!PL_madskills,FALSE);
11080 Perl_croak(aTHX_ "Substitution pattern not terminated");
11082 if (s[-1] == PL_multi_open)
11085 if (PL_madskills) {
11086 CURMAD('q', PL_thisopen);
11087 CURMAD('_', PL_thiswhite);
11088 CURMAD('E', PL_thisstuff);
11089 CURMAD('Q', PL_thisclose);
11090 PL_realtokenstart = s - SvPVX(PL_linestr);
11094 first_start = PL_multi_start;
11095 s = scan_str(s,!!PL_madskills,FALSE);
11097 if (PL_lex_stuff) {
11098 SvREFCNT_dec(PL_lex_stuff);
11099 PL_lex_stuff = NULL;
11101 Perl_croak(aTHX_ "Substitution replacement not terminated");
11103 PL_multi_start = first_start; /* so whole substitution is taken together */
11105 pm = (PMOP*)newPMOP(OP_SUBST, 0);
11108 if (PL_madskills) {
11109 CURMAD('z', PL_thisopen);
11110 CURMAD('R', PL_thisstuff);
11111 CURMAD('Z', PL_thisclose);
11117 if (*s == EXEC_PAT_MOD) {
11121 else if (strchr(S_PAT_MODS, *s))
11122 pm->op_pmflags = S_pmflag(pm->op_pmflags, *s++);
11128 if (PL_madskills) {
11130 curmad('m', newSVpvn(modstart, s - modstart));
11131 append_madprops(PL_thismad, (OP*)pm, 0);
11135 if ((pm->op_pmflags & PMf_CONTINUE)) {
11136 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
11140 SV * const repl = newSVpvs("");
11142 PL_sublex_info.super_bufptr = s;
11143 PL_sublex_info.super_bufend = PL_bufend;
11145 pm->op_pmflags |= PMf_EVAL;
11148 sv_catpvs(repl, "eval ");
11150 sv_catpvs(repl, "do ");
11152 sv_catpvs(repl, "{");
11153 sv_catsv(repl, PL_lex_repl);
11154 if (strchr(SvPVX(PL_lex_repl), '#'))
11155 sv_catpvs(repl, "\n");
11156 sv_catpvs(repl, "}");
11158 SvREFCNT_dec(PL_lex_repl);
11159 PL_lex_repl = repl;
11162 PL_lex_op = (OP*)pm;
11163 pl_yylval.ival = OP_SUBST;
11168 S_scan_trans(pTHX_ char *start)
11181 PERL_ARGS_ASSERT_SCAN_TRANS;
11183 pl_yylval.ival = OP_NULL;
11185 s = scan_str(start,!!PL_madskills,FALSE);
11187 Perl_croak(aTHX_ "Transliteration pattern not terminated");
11189 if (s[-1] == PL_multi_open)
11192 if (PL_madskills) {
11193 CURMAD('q', PL_thisopen);
11194 CURMAD('_', PL_thiswhite);
11195 CURMAD('E', PL_thisstuff);
11196 CURMAD('Q', PL_thisclose);
11197 PL_realtokenstart = s - SvPVX(PL_linestr);
11201 s = scan_str(s,!!PL_madskills,FALSE);
11203 if (PL_lex_stuff) {
11204 SvREFCNT_dec(PL_lex_stuff);
11205 PL_lex_stuff = NULL;
11207 Perl_croak(aTHX_ "Transliteration replacement not terminated");
11209 if (PL_madskills) {
11210 CURMAD('z', PL_thisopen);
11211 CURMAD('R', PL_thisstuff);
11212 CURMAD('Z', PL_thisclose);
11215 complement = del = squash = 0;
11222 complement = OPpTRANS_COMPLEMENT;
11225 del = OPpTRANS_DELETE;
11228 squash = OPpTRANS_SQUASH;
11237 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11238 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11239 o->op_private &= ~OPpTRANS_ALL;
11240 o->op_private |= del|squash|complement|
11241 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11242 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11245 pl_yylval.ival = OP_TRANS;
11248 if (PL_madskills) {
11250 curmad('m', newSVpvn(modstart, s - modstart));
11251 append_madprops(PL_thismad, o, 0);
11260 S_scan_heredoc(pTHX_ register char *s)
11264 I32 op_type = OP_SCALAR;
11268 const char *found_newline;
11272 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11274 I32 stuffstart = s - SvPVX(PL_linestr);
11277 PL_realtokenstart = -1;
11280 PERL_ARGS_ASSERT_SCAN_HEREDOC;
11284 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11288 while (SPACE_OR_TAB(*peek))
11290 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11293 s = delimcpy(d, e, s, PL_bufend, term, &len);
11303 if (!isALNUM_lazy_if(s,UTF))
11304 deprecate("bare << to mean <<\"\"");
11305 for (; isALNUM_lazy_if(s,UTF); s++) {
11310 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11311 Perl_croak(aTHX_ "Delimiter for here document is too long");
11314 len = d - PL_tokenbuf;
11317 if (PL_madskills) {
11318 tstart = PL_tokenbuf + !outer;
11319 PL_thisclose = newSVpvn(tstart, len - !outer);
11320 tstart = SvPVX(PL_linestr) + stuffstart;
11321 PL_thisopen = newSVpvn(tstart, s - tstart);
11322 stuffstart = s - SvPVX(PL_linestr);
11325 #ifndef PERL_STRICT_CR
11326 d = strchr(s, '\r');
11328 char * const olds = s;
11330 while (s < PL_bufend) {
11336 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11345 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11352 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11353 herewas = newSVpvn(s,PL_bufend-s);
11357 herewas = newSVpvn(s-1,found_newline-s+1);
11360 herewas = newSVpvn(s,found_newline-s);
11364 if (PL_madskills) {
11365 tstart = SvPVX(PL_linestr) + stuffstart;
11367 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11369 PL_thisstuff = newSVpvn(tstart, s - tstart);
11372 s += SvCUR(herewas);
11375 stuffstart = s - SvPVX(PL_linestr);
11381 tmpstr = newSV_type(SVt_PVIV);
11382 SvGROW(tmpstr, 80);
11383 if (term == '\'') {
11384 op_type = OP_CONST;
11385 SvIV_set(tmpstr, -1);
11387 else if (term == '`') {
11388 op_type = OP_BACKTICK;
11389 SvIV_set(tmpstr, '\\');
11393 PL_multi_start = CopLINE(PL_curcop);
11394 PL_multi_open = PL_multi_close = '<';
11395 term = *PL_tokenbuf;
11396 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11397 char * const bufptr = PL_sublex_info.super_bufptr;
11398 char * const bufend = PL_sublex_info.super_bufend;
11399 char * const olds = s - SvCUR(herewas);
11400 s = strchr(bufptr, '\n');
11404 while (s < bufend &&
11405 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11407 CopLINE_inc(PL_curcop);
11410 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11411 missingterm(PL_tokenbuf);
11413 sv_setpvn(herewas,bufptr,d-bufptr+1);
11414 sv_setpvn(tmpstr,d+1,s-d);
11416 sv_catpvn(herewas,s,bufend-s);
11417 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11424 while (s < PL_bufend &&
11425 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11427 CopLINE_inc(PL_curcop);
11429 if (s >= PL_bufend) {
11430 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11431 missingterm(PL_tokenbuf);
11433 sv_setpvn(tmpstr,d+1,s-d);
11435 if (PL_madskills) {
11437 sv_catpvn(PL_thisstuff, d + 1, s - d);
11439 PL_thisstuff = newSVpvn(d + 1, s - d);
11440 stuffstart = s - SvPVX(PL_linestr);
11444 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11446 sv_catpvn(herewas,s,PL_bufend-s);
11447 sv_setsv(PL_linestr,herewas);
11448 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11449 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11450 PL_last_lop = PL_last_uni = NULL;
11453 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
11454 while (s >= PL_bufend) { /* multiple line string? */
11456 if (PL_madskills) {
11457 tstart = SvPVX(PL_linestr) + stuffstart;
11459 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11461 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11465 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart
11466 = filter_gets(PL_linestr, 0))) {
11467 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11468 missingterm(PL_tokenbuf);
11471 stuffstart = s - SvPVX(PL_linestr);
11473 CopLINE_inc(PL_curcop);
11474 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11475 PL_last_lop = PL_last_uni = NULL;
11476 #ifndef PERL_STRICT_CR
11477 if (PL_bufend - PL_linestart >= 2) {
11478 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11479 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11481 PL_bufend[-2] = '\n';
11483 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11485 else if (PL_bufend[-1] == '\r')
11486 PL_bufend[-1] = '\n';
11488 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11489 PL_bufend[-1] = '\n';
11491 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11492 update_debugger_info(PL_linestr, NULL, 0);
11493 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11494 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11495 *(SvPVX(PL_linestr) + off ) = ' ';
11496 sv_catsv(PL_linestr,herewas);
11497 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11498 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11502 sv_catsv(tmpstr,PL_linestr);
11507 PL_multi_end = CopLINE(PL_curcop);
11508 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11509 SvPV_shrink_to_cur(tmpstr);
11511 SvREFCNT_dec(herewas);
11513 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11515 else if (PL_encoding)
11516 sv_recode_to_utf8(tmpstr, PL_encoding);
11518 PL_lex_stuff = tmpstr;
11519 pl_yylval.ival = op_type;
11523 /* scan_inputsymbol
11524 takes: current position in input buffer
11525 returns: new position in input buffer
11526 side-effects: pl_yylval and lex_op are set.
11531 <FH> read from filehandle
11532 <pkg::FH> read from package qualified filehandle
11533 <pkg'FH> read from package qualified filehandle
11534 <$fh> read from filehandle in $fh
11535 <*.h> filename glob
11540 S_scan_inputsymbol(pTHX_ char *start)
11543 register char *s = start; /* current position in buffer */
11546 char *d = PL_tokenbuf; /* start of temp holding space */
11547 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11549 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
11551 end = strchr(s, '\n');
11554 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11556 /* die if we didn't have space for the contents of the <>,
11557 or if it didn't end, or if we see a newline
11560 if (len >= (I32)sizeof PL_tokenbuf)
11561 Perl_croak(aTHX_ "Excessively long <> operator");
11563 Perl_croak(aTHX_ "Unterminated <> operator");
11568 Remember, only scalar variables are interpreted as filehandles by
11569 this code. Anything more complex (e.g., <$fh{$num}>) will be
11570 treated as a glob() call.
11571 This code makes use of the fact that except for the $ at the front,
11572 a scalar variable and a filehandle look the same.
11574 if (*d == '$' && d[1]) d++;
11576 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11577 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11580 /* If we've tried to read what we allow filehandles to look like, and
11581 there's still text left, then it must be a glob() and not a getline.
11582 Use scan_str to pull out the stuff between the <> and treat it
11583 as nothing more than a string.
11586 if (d - PL_tokenbuf != len) {
11587 pl_yylval.ival = OP_GLOB;
11588 s = scan_str(start,!!PL_madskills,FALSE);
11590 Perl_croak(aTHX_ "Glob not terminated");
11594 bool readline_overriden = FALSE;
11597 /* we're in a filehandle read situation */
11600 /* turn <> into <ARGV> */
11602 Copy("ARGV",d,5,char);
11604 /* Check whether readline() is overriden */
11605 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11607 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11609 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11610 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11611 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11612 readline_overriden = TRUE;
11614 /* if <$fh>, create the ops to turn the variable into a
11618 /* try to find it in the pad for this block, otherwise find
11619 add symbol table ops
11621 const PADOFFSET tmp = pad_findmy(d, len, 0);
11622 if (tmp != NOT_IN_PAD) {
11623 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11624 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11625 HEK * const stashname = HvNAME_HEK(stash);
11626 SV * const sym = sv_2mortal(newSVhek(stashname));
11627 sv_catpvs(sym, "::");
11628 sv_catpv(sym, d+1);
11633 OP * const o = newOP(OP_PADSV, 0);
11635 PL_lex_op = readline_overriden
11636 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11637 append_elem(OP_LIST, o,
11638 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11639 : (OP*)newUNOP(OP_READLINE, 0, o);
11648 ? (GV_ADDMULTI | GV_ADDINEVAL)
11651 PL_lex_op = readline_overriden
11652 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11653 append_elem(OP_LIST,
11654 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11655 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11656 : (OP*)newUNOP(OP_READLINE, 0,
11657 newUNOP(OP_RV2SV, 0,
11658 newGVOP(OP_GV, 0, gv)));
11660 if (!readline_overriden)
11661 PL_lex_op->op_flags |= OPf_SPECIAL;
11662 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
11663 pl_yylval.ival = OP_NULL;
11666 /* If it's none of the above, it must be a literal filehandle
11667 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11669 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11670 PL_lex_op = readline_overriden
11671 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11672 append_elem(OP_LIST,
11673 newGVOP(OP_GV, 0, gv),
11674 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11675 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11676 pl_yylval.ival = OP_NULL;
11685 takes: start position in buffer
11686 keep_quoted preserve \ on the embedded delimiter(s)
11687 keep_delims preserve the delimiters around the string
11688 returns: position to continue reading from buffer
11689 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11690 updates the read buffer.
11692 This subroutine pulls a string out of the input. It is called for:
11693 q single quotes q(literal text)
11694 ' single quotes 'literal text'
11695 qq double quotes qq(interpolate $here please)
11696 " double quotes "interpolate $here please"
11697 qx backticks qx(/bin/ls -l)
11698 ` backticks `/bin/ls -l`
11699 qw quote words @EXPORT_OK = qw( func() $spam )
11700 m// regexp match m/this/
11701 s/// regexp substitute s/this/that/
11702 tr/// string transliterate tr/this/that/
11703 y/// string transliterate y/this/that/
11704 ($*@) sub prototypes sub foo ($)
11705 (stuff) sub attr parameters sub foo : attr(stuff)
11706 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11708 In most of these cases (all but <>, patterns and transliterate)
11709 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11710 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11711 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11714 It skips whitespace before the string starts, and treats the first
11715 character as the delimiter. If the delimiter is one of ([{< then
11716 the corresponding "close" character )]}> is used as the closing
11717 delimiter. It allows quoting of delimiters, and if the string has
11718 balanced delimiters ([{<>}]) it allows nesting.
11720 On success, the SV with the resulting string is put into lex_stuff or,
11721 if that is already non-NULL, into lex_repl. The second case occurs only
11722 when parsing the RHS of the special constructs s/// and tr/// (y///).
11723 For convenience, the terminating delimiter character is stuffed into
11728 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11731 SV *sv; /* scalar value: string */
11732 const char *tmps; /* temp string, used for delimiter matching */
11733 register char *s = start; /* current position in the buffer */
11734 register char term; /* terminating character */
11735 register char *to; /* current position in the sv's data */
11736 I32 brackets = 1; /* bracket nesting level */
11737 bool has_utf8 = FALSE; /* is there any utf8 content? */
11738 I32 termcode; /* terminating char. code */
11739 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11740 STRLEN termlen; /* length of terminating string */
11741 int last_off = 0; /* last position for nesting bracket */
11747 PERL_ARGS_ASSERT_SCAN_STR;
11749 /* skip space before the delimiter */
11755 if (PL_realtokenstart >= 0) {
11756 stuffstart = PL_realtokenstart;
11757 PL_realtokenstart = -1;
11760 stuffstart = start - SvPVX(PL_linestr);
11762 /* mark where we are, in case we need to report errors */
11765 /* after skipping whitespace, the next character is the terminator */
11768 termcode = termstr[0] = term;
11772 termcode = utf8_to_uvchr((U8*)s, &termlen);
11773 Copy(s, termstr, termlen, U8);
11774 if (!UTF8_IS_INVARIANT(term))
11778 /* mark where we are */
11779 PL_multi_start = CopLINE(PL_curcop);
11780 PL_multi_open = term;
11782 /* find corresponding closing delimiter */
11783 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11784 termcode = termstr[0] = term = tmps[5];
11786 PL_multi_close = term;
11788 /* create a new SV to hold the contents. 79 is the SV's initial length.
11789 What a random number. */
11790 sv = newSV_type(SVt_PVIV);
11792 SvIV_set(sv, termcode);
11793 (void)SvPOK_only(sv); /* validate pointer */
11795 /* move past delimiter and try to read a complete string */
11797 sv_catpvn(sv, s, termlen);
11800 tstart = SvPVX(PL_linestr) + stuffstart;
11801 if (!PL_thisopen && !keep_delims) {
11802 PL_thisopen = newSVpvn(tstart, s - tstart);
11803 stuffstart = s - SvPVX(PL_linestr);
11807 if (PL_encoding && !UTF) {
11811 int offset = s - SvPVX_const(PL_linestr);
11812 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11813 &offset, (char*)termstr, termlen);
11814 const char * const ns = SvPVX_const(PL_linestr) + offset;
11815 char * const svlast = SvEND(sv) - 1;
11817 for (; s < ns; s++) {
11818 if (*s == '\n' && !PL_rsfp)
11819 CopLINE_inc(PL_curcop);
11822 goto read_more_line;
11824 /* handle quoted delimiters */
11825 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11827 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11829 if ((svlast-1 - t) % 2) {
11830 if (!keep_quoted) {
11831 *(svlast-1) = term;
11833 SvCUR_set(sv, SvCUR(sv) - 1);
11838 if (PL_multi_open == PL_multi_close) {
11844 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11845 /* At here, all closes are "was quoted" one,
11846 so we don't check PL_multi_close. */
11848 if (!keep_quoted && *(t+1) == PL_multi_open)
11853 else if (*t == PL_multi_open)
11861 SvCUR_set(sv, w - SvPVX_const(sv));
11863 last_off = w - SvPVX(sv);
11864 if (--brackets <= 0)
11869 if (!keep_delims) {
11870 SvCUR_set(sv, SvCUR(sv) - 1);
11876 /* extend sv if need be */
11877 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11878 /* set 'to' to the next character in the sv's string */
11879 to = SvPVX(sv)+SvCUR(sv);
11881 /* if open delimiter is the close delimiter read unbridle */
11882 if (PL_multi_open == PL_multi_close) {
11883 for (; s < PL_bufend; s++,to++) {
11884 /* embedded newlines increment the current line number */
11885 if (*s == '\n' && !PL_rsfp)
11886 CopLINE_inc(PL_curcop);
11887 /* handle quoted delimiters */
11888 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11889 if (!keep_quoted && s[1] == term)
11891 /* any other quotes are simply copied straight through */
11895 /* terminate when run out of buffer (the for() condition), or
11896 have found the terminator */
11897 else if (*s == term) {
11900 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11903 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11909 /* if the terminator isn't the same as the start character (e.g.,
11910 matched brackets), we have to allow more in the quoting, and
11911 be prepared for nested brackets.
11914 /* read until we run out of string, or we find the terminator */
11915 for (; s < PL_bufend; s++,to++) {
11916 /* embedded newlines increment the line count */
11917 if (*s == '\n' && !PL_rsfp)
11918 CopLINE_inc(PL_curcop);
11919 /* backslashes can escape the open or closing characters */
11920 if (*s == '\\' && s+1 < PL_bufend) {
11921 if (!keep_quoted &&
11922 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11927 /* allow nested opens and closes */
11928 else if (*s == PL_multi_close && --brackets <= 0)
11930 else if (*s == PL_multi_open)
11932 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11937 /* terminate the copied string and update the sv's end-of-string */
11939 SvCUR_set(sv, to - SvPVX_const(sv));
11942 * this next chunk reads more into the buffer if we're not done yet
11946 break; /* handle case where we are done yet :-) */
11948 #ifndef PERL_STRICT_CR
11949 if (to - SvPVX_const(sv) >= 2) {
11950 if ((to[-2] == '\r' && to[-1] == '\n') ||
11951 (to[-2] == '\n' && to[-1] == '\r'))
11955 SvCUR_set(sv, to - SvPVX_const(sv));
11957 else if (to[-1] == '\r')
11960 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11965 /* if we're out of file, or a read fails, bail and reset the current
11966 line marker so we can report where the unterminated string began
11969 if (PL_madskills) {
11970 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11972 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11974 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11978 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart
11979 = filter_gets(PL_linestr, 0))) {
11981 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11987 /* we read a line, so increment our line counter */
11988 CopLINE_inc(PL_curcop);
11990 /* update debugger info */
11991 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11992 update_debugger_info(PL_linestr, NULL, 0);
11994 /* having changed the buffer, we must update PL_bufend */
11995 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11996 PL_last_lop = PL_last_uni = NULL;
11999 /* at this point, we have successfully read the delimited string */
12001 if (!PL_encoding || UTF) {
12003 if (PL_madskills) {
12004 char * const tstart = SvPVX(PL_linestr) + stuffstart;
12005 const int len = s - tstart;
12007 sv_catpvn(PL_thisstuff, tstart, len);
12009 PL_thisstuff = newSVpvn(tstart, len);
12010 if (!PL_thisclose && !keep_delims)
12011 PL_thisclose = newSVpvn(s,termlen);
12016 sv_catpvn(sv, s, termlen);
12021 if (PL_madskills) {
12022 char * const tstart = SvPVX(PL_linestr) + stuffstart;
12023 const int len = s - tstart - termlen;
12025 sv_catpvn(PL_thisstuff, tstart, len);
12027 PL_thisstuff = newSVpvn(tstart, len);
12028 if (!PL_thisclose && !keep_delims)
12029 PL_thisclose = newSVpvn(s - termlen,termlen);
12033 if (has_utf8 || PL_encoding)
12036 PL_multi_end = CopLINE(PL_curcop);
12038 /* if we allocated too much space, give some back */
12039 if (SvCUR(sv) + 5 < SvLEN(sv)) {
12040 SvLEN_set(sv, SvCUR(sv) + 1);
12041 SvPV_renew(sv, SvLEN(sv));
12044 /* decide whether this is the first or second quoted string we've read
12057 takes: pointer to position in buffer
12058 returns: pointer to new position in buffer
12059 side-effects: builds ops for the constant in pl_yylval.op
12061 Read a number in any of the formats that Perl accepts:
12063 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
12064 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
12067 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
12069 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
12072 If it reads a number without a decimal point or an exponent, it will
12073 try converting the number to an integer and see if it can do so
12074 without loss of precision.
12078 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
12081 register const char *s = start; /* current position in buffer */
12082 register char *d; /* destination in temp buffer */
12083 register char *e; /* end of temp buffer */
12084 NV nv; /* number read, as a double */
12085 SV *sv = NULL; /* place to put the converted number */
12086 bool floatit; /* boolean: int or float? */
12087 const char *lastub = NULL; /* position of last underbar */
12088 static char const number_too_long[] = "Number too long";
12090 PERL_ARGS_ASSERT_SCAN_NUM;
12092 /* We use the first character to decide what type of number this is */
12096 Perl_croak(aTHX_ "panic: scan_num");
12098 /* if it starts with a 0, it could be an octal number, a decimal in
12099 0.13 disguise, or a hexadecimal number, or a binary number. */
12103 u holds the "number so far"
12104 shift the power of 2 of the base
12105 (hex == 4, octal == 3, binary == 1)
12106 overflowed was the number more than we can hold?
12108 Shift is used when we add a digit. It also serves as an "are
12109 we in octal/hex/binary?" indicator to disallow hex characters
12110 when in octal mode.
12115 bool overflowed = FALSE;
12116 bool just_zero = TRUE; /* just plain 0 or binary number? */
12117 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
12118 static const char* const bases[5] =
12119 { "", "binary", "", "octal", "hexadecimal" };
12120 static const char* const Bases[5] =
12121 { "", "Binary", "", "Octal", "Hexadecimal" };
12122 static const char* const maxima[5] =
12124 "0b11111111111111111111111111111111",
12128 const char *base, *Base, *max;
12130 /* check for hex */
12135 } else if (s[1] == 'b') {
12140 /* check for a decimal in disguise */
12141 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
12143 /* so it must be octal */
12150 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12151 "Misplaced _ in number");
12155 base = bases[shift];
12156 Base = Bases[shift];
12157 max = maxima[shift];
12159 /* read the rest of the number */
12161 /* x is used in the overflow test,
12162 b is the digit we're adding on. */
12167 /* if we don't mention it, we're done */
12171 /* _ are ignored -- but warned about if consecutive */
12173 if (lastub && s == lastub + 1)
12174 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12175 "Misplaced _ in number");
12179 /* 8 and 9 are not octal */
12180 case '8': case '9':
12182 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
12186 case '2': case '3': case '4':
12187 case '5': case '6': case '7':
12189 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
12192 case '0': case '1':
12193 b = *s++ & 15; /* ASCII digit -> value of digit */
12197 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
12198 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
12199 /* make sure they said 0x */
12202 b = (*s++ & 7) + 9;
12204 /* Prepare to put the digit we have onto the end
12205 of the number so far. We check for overflows.
12211 x = u << shift; /* make room for the digit */
12213 if ((x >> shift) != u
12214 && !(PL_hints & HINT_NEW_BINARY)) {
12217 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
12218 "Integer overflow in %s number",
12221 u = x | b; /* add the digit to the end */
12224 n *= nvshift[shift];
12225 /* If an NV has not enough bits in its
12226 * mantissa to represent an UV this summing of
12227 * small low-order numbers is a waste of time
12228 * (because the NV cannot preserve the
12229 * low-order bits anyway): we could just
12230 * remember when did we overflow and in the
12231 * end just multiply n by the right
12239 /* if we get here, we had success: make a scalar value from
12244 /* final misplaced underbar check */
12245 if (s[-1] == '_') {
12246 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12251 if (n > 4294967295.0)
12252 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
12253 "%s number > %s non-portable",
12259 if (u > 0xffffffff)
12260 Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
12261 "%s number > %s non-portable",
12266 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12267 sv = new_constant(start, s - start, "integer",
12268 sv, NULL, NULL, 0);
12269 else if (PL_hints & HINT_NEW_BINARY)
12270 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
12275 handle decimal numbers.
12276 we're also sent here when we read a 0 as the first digit
12278 case '1': case '2': case '3': case '4': case '5':
12279 case '6': case '7': case '8': case '9': case '.':
12282 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12285 /* read next group of digits and _ and copy into d */
12286 while (isDIGIT(*s) || *s == '_') {
12287 /* skip underscores, checking for misplaced ones
12291 if (lastub && s == lastub + 1)
12292 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12293 "Misplaced _ in number");
12297 /* check for end of fixed-length buffer */
12299 Perl_croak(aTHX_ number_too_long);
12300 /* if we're ok, copy the character */
12305 /* final misplaced underbar check */
12306 if (lastub && s == lastub + 1) {
12307 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12310 /* read a decimal portion if there is one. avoid
12311 3..5 being interpreted as the number 3. followed
12314 if (*s == '.' && s[1] != '.') {
12319 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12320 "Misplaced _ in number");
12324 /* copy, ignoring underbars, until we run out of digits.
12326 for (; isDIGIT(*s) || *s == '_'; s++) {
12327 /* fixed length buffer check */
12329 Perl_croak(aTHX_ number_too_long);
12331 if (lastub && s == lastub + 1)
12332 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12333 "Misplaced _ in number");
12339 /* fractional part ending in underbar? */
12340 if (s[-1] == '_') {
12341 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12342 "Misplaced _ in number");
12344 if (*s == '.' && isDIGIT(s[1])) {
12345 /* oops, it's really a v-string, but without the "v" */
12351 /* read exponent part, if present */
12352 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12356 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12357 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12359 /* stray preinitial _ */
12361 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12362 "Misplaced _ in number");
12366 /* allow positive or negative exponent */
12367 if (*s == '+' || *s == '-')
12370 /* stray initial _ */
12372 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12373 "Misplaced _ in number");
12377 /* read digits of exponent */
12378 while (isDIGIT(*s) || *s == '_') {
12381 Perl_croak(aTHX_ number_too_long);
12385 if (((lastub && s == lastub + 1) ||
12386 (!isDIGIT(s[1]) && s[1] != '_')))
12387 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
12388 "Misplaced _ in number");
12395 /* make an sv from the string */
12399 We try to do an integer conversion first if no characters
12400 indicating "float" have been found.
12405 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12407 if (flags == IS_NUMBER_IN_UV) {
12409 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12412 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12413 if (uv <= (UV) IV_MIN)
12414 sv_setiv(sv, -(IV)uv);
12421 /* terminate the string */
12423 nv = Atof(PL_tokenbuf);
12428 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
12429 const char *const key = floatit ? "float" : "integer";
12430 const STRLEN keylen = floatit ? 5 : 7;
12431 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
12432 key, keylen, sv, NULL, NULL, 0);
12436 /* if it starts with a v, it could be a v-string */
12439 sv = newSV(5); /* preallocate storage space */
12440 s = scan_vstring(s, PL_bufend, sv);
12444 /* make the op for the constant and return */
12447 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12449 lvalp->opval = NULL;
12455 S_scan_formline(pTHX_ register char *s)
12458 register char *eol;
12460 SV * const stuff = newSVpvs("");
12461 bool needargs = FALSE;
12462 bool eofmt = FALSE;
12464 char *tokenstart = s;
12465 SV* savewhite = NULL;
12467 if (PL_madskills) {
12468 savewhite = PL_thiswhite;
12473 PERL_ARGS_ASSERT_SCAN_FORMLINE;
12475 while (!needargs) {
12478 #ifdef PERL_STRICT_CR
12479 while (SPACE_OR_TAB(*t))
12482 while (SPACE_OR_TAB(*t) || *t == '\r')
12485 if (*t == '\n' || t == PL_bufend) {
12490 if (PL_in_eval && !PL_rsfp) {
12491 eol = (char *) memchr(s,'\n',PL_bufend-s);
12496 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12498 for (t = s; t < eol; t++) {
12499 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12501 goto enough; /* ~~ must be first line in formline */
12503 if (*t == '@' || *t == '^')
12507 sv_catpvn(stuff, s, eol-s);
12508 #ifndef PERL_STRICT_CR
12509 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12510 char *end = SvPVX(stuff) + SvCUR(stuff);
12513 SvCUR_set(stuff, SvCUR(stuff) - 1);
12523 if (PL_madskills) {
12525 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12527 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12530 s = filter_gets(PL_linestr, 0);
12532 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12534 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12536 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12537 PL_last_lop = PL_last_uni = NULL;
12546 if (SvCUR(stuff)) {
12549 PL_lex_state = LEX_NORMAL;
12550 start_force(PL_curforce);
12551 NEXTVAL_NEXTTOKE.ival = 0;
12555 PL_lex_state = LEX_FORMLINE;
12557 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12559 else if (PL_encoding)
12560 sv_recode_to_utf8(stuff, PL_encoding);
12562 start_force(PL_curforce);
12563 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12565 start_force(PL_curforce);
12566 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12570 SvREFCNT_dec(stuff);
12572 PL_lex_formbrack = 0;
12576 if (PL_madskills) {
12578 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12580 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12581 PL_thiswhite = savewhite;
12588 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12591 const I32 oldsavestack_ix = PL_savestack_ix;
12592 CV* const outsidecv = PL_compcv;
12595 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12597 SAVEI32(PL_subline);
12598 save_item(PL_subname);
12599 SAVESPTR(PL_compcv);
12601 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
12602 CvFLAGS(PL_compcv) |= flags;
12604 PL_subline = CopLINE(PL_curcop);
12605 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12606 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
12607 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12609 return oldsavestack_ix;
12613 #pragma segment Perl_yylex
12616 S_yywarn(pTHX_ const char *const s)
12620 PERL_ARGS_ASSERT_YYWARN;
12622 PL_in_eval |= EVAL_WARNONLY;
12624 PL_in_eval &= ~EVAL_WARNONLY;
12629 Perl_yyerror(pTHX_ const char *const s)
12632 const char *where = NULL;
12633 const char *context = NULL;
12636 int yychar = PL_parser->yychar;
12638 PERL_ARGS_ASSERT_YYERROR;
12640 if (!yychar || (yychar == ';' && !PL_rsfp))
12642 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12643 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12644 PL_oldbufptr != PL_bufptr) {
12647 The code below is removed for NetWare because it abends/crashes on NetWare
12648 when the script has error such as not having the closing quotes like:
12649 if ($var eq "value)
12650 Checking of white spaces is anyway done in NetWare code.
12653 while (isSPACE(*PL_oldoldbufptr))
12656 context = PL_oldoldbufptr;
12657 contlen = PL_bufptr - PL_oldoldbufptr;
12659 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12660 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12663 The code below is removed for NetWare because it abends/crashes on NetWare
12664 when the script has error such as not having the closing quotes like:
12665 if ($var eq "value)
12666 Checking of white spaces is anyway done in NetWare code.
12669 while (isSPACE(*PL_oldbufptr))
12672 context = PL_oldbufptr;
12673 contlen = PL_bufptr - PL_oldbufptr;
12675 else if (yychar > 255)
12676 where = "next token ???";
12677 else if (yychar == -2) { /* YYEMPTY */
12678 if (PL_lex_state == LEX_NORMAL ||
12679 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12680 where = "at end of line";
12681 else if (PL_lex_inpat)
12682 where = "within pattern";
12684 where = "within string";
12687 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
12689 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12690 else if (isPRINT_LC(yychar)) {
12691 const char string = yychar;
12692 sv_catpvn(where_sv, &string, 1);
12695 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12696 where = SvPVX_const(where_sv);
12698 msg = sv_2mortal(newSVpv(s, 0));
12699 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12700 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12702 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12704 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12705 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12706 Perl_sv_catpvf(aTHX_ msg,
12707 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12708 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12711 if (PL_in_eval & EVAL_WARNONLY) {
12712 Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12716 if (PL_error_count >= 10) {
12717 if (PL_in_eval && SvCUR(ERRSV))
12718 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12719 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12721 Perl_croak(aTHX_ "%s has too many errors.\n",
12722 OutCopFILE(PL_curcop));
12725 PL_in_my_stash = NULL;
12729 #pragma segment Main
12733 S_swallow_bom(pTHX_ U8 *s)
12736 const STRLEN slen = SvCUR(PL_linestr);
12738 PERL_ARGS_ASSERT_SWALLOW_BOM;
12742 if (s[1] == 0xFE) {
12743 /* UTF-16 little-endian? (or UTF32-LE?) */
12744 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12745 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12746 #ifndef PERL_NO_UTF16_FILTER
12747 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12749 if (PL_bufend > (char*)s) {
12750 s = add_utf16_textfilter(s, TRUE);
12753 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12758 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12759 #ifndef PERL_NO_UTF16_FILTER
12760 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12762 if (PL_bufend > (char *)s) {
12763 s = add_utf16_textfilter(s, FALSE);
12766 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12771 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12772 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12773 s += 3; /* UTF-8 */
12779 if (s[2] == 0xFE && s[3] == 0xFF) {
12780 /* UTF-32 big-endian */
12781 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12784 else if (s[2] == 0 && s[3] != 0) {
12787 * are a good indicator of UTF-16BE. */
12788 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12789 s = add_utf16_textfilter(s, FALSE);
12794 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12795 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12796 s += 4; /* UTF-8 */
12802 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12805 * are a good indicator of UTF-16LE. */
12806 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12807 s = add_utf16_textfilter(s, TRUE);
12814 #ifndef PERL_NO_UTF16_FILTER
12816 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12819 SV *const filter = FILTER_DATA(idx);
12820 /* We re-use this each time round, throwing the contents away before we
12822 SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
12823 SV *const utf8_buffer = filter;
12824 IV status = IoPAGE(filter);
12825 const bool reverse = (bool) IoLINES(filter);
12828 /* As we're automatically added, at the lowest level, and hence only called
12829 from this file, we can be sure that we're not called in block mode. Hence
12830 don't bother writing code to deal with block mode. */
12832 Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
12835 Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
12837 DEBUG_P(PerlIO_printf(Perl_debug_log,
12838 "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
12839 FPTR2DPTR(void *, S_utf16_textfilter),
12840 reverse ? 'l' : 'b', idx, maxlen, status,
12841 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12848 /* First, look in our buffer of existing UTF-8 data: */
12849 char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
12853 } else if (status == 0) {
12855 IoPAGE(filter) = 0;
12856 nl = SvEND(utf8_buffer);
12859 STRLEN got = nl - SvPVX(utf8_buffer);
12860 /* Did we have anything to append? */
12862 sv_catpvn(sv, SvPVX(utf8_buffer), got);
12863 /* Everything else in this code works just fine if SVp_POK isn't
12864 set. This, however, needs it, and we need it to work, else
12865 we loop infinitely because the buffer is never consumed. */
12866 sv_chop(utf8_buffer, nl);
12870 /* OK, not a complete line there, so need to read some more UTF-16.
12871 Read an extra octect if the buffer currently has an odd number. */
12875 if (SvCUR(utf16_buffer) >= 2) {
12876 /* Location of the high octet of the last complete code point.
12877 Gosh, UTF-16 is a pain. All the benefits of variable length,
12878 *coupled* with all the benefits of partial reads and
12880 const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
12881 + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
12883 if (*last_hi < 0xd8 || *last_hi > 0xdb) {
12887 /* We have the first half of a surrogate. Read more. */
12888 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
12891 status = FILTER_READ(idx + 1, utf16_buffer,
12892 160 + (SvCUR(utf16_buffer) & 1));
12893 DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
12894 DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
12897 IoPAGE(filter) = status;
12902 chars = SvCUR(utf16_buffer) >> 1;
12903 have = SvCUR(utf8_buffer);
12904 SvGROW(utf8_buffer, have + chars * 3 + 1);
12907 end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
12908 (U8*)SvPVX_const(utf8_buffer) + have,
12909 chars * 2, &newlen);
12911 end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
12912 (U8*)SvPVX_const(utf8_buffer) + have,
12913 chars * 2, &newlen);
12915 SvCUR_set(utf8_buffer, have + newlen);
12918 /* No need to keep this SV "well-formed" with a '\0' after the end, as
12919 it's private to us, and utf16_to_utf8{,reversed} take a
12920 (pointer,length) pair, rather than a NUL-terminated string. */
12921 if(SvCUR(utf16_buffer) & 1) {
12922 *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
12923 SvCUR_set(utf16_buffer, 1);
12925 SvCUR_set(utf16_buffer, 0);
12928 DEBUG_P(PerlIO_printf(Perl_debug_log,
12929 "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
12931 (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
12932 DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
12937 S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
12939 SV *filter = filter_add(S_utf16_textfilter, NULL);
12941 IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
12942 sv_setpvs(filter, "");
12943 IoLINES(filter) = reversed;
12944 IoPAGE(filter) = 1; /* Not EOF */
12946 /* Sadly, we have to return a valid pointer, come what may, so we have to
12947 ignore any error return from this. */
12948 SvCUR_set(PL_linestr, 0);
12949 if (FILTER_READ(0, PL_linestr, 0)) {
12950 SvUTF8_on(PL_linestr);
12952 SvUTF8_on(PL_linestr);
12954 PL_bufend = SvEND(PL_linestr);
12955 return (U8*)SvPVX(PL_linestr);
12960 Returns a pointer to the next character after the parsed
12961 vstring, as well as updating the passed in sv.
12963 Function must be called like
12966 s = scan_vstring(s,e,sv);
12968 where s and e are the start and end of the string.
12969 The sv should already be large enough to store the vstring
12970 passed in, for performance reasons.
12975 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12978 const char *pos = s;
12979 const char *start = s;
12981 PERL_ARGS_ASSERT_SCAN_VSTRING;
12983 if (*pos == 'v') pos++; /* get past 'v' */
12984 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12986 if ( *pos != '.') {
12987 /* this may not be a v-string if followed by => */
12988 const char *next = pos;
12989 while (next < e && isSPACE(*next))
12991 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12992 /* return string not v-string */
12993 sv_setpvn(sv,(char *)s,pos-s);
12994 return (char *)pos;
12998 if (!isALPHA(*pos)) {
12999 U8 tmpbuf[UTF8_MAXBYTES+1];
13002 s++; /* get past 'v' */
13007 /* this is atoi() that tolerates underscores */
13010 const char *end = pos;
13012 while (--end >= s) {
13014 const UV orev = rev;
13015 rev += (*end - '0') * mult;
13018 Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
13019 "Integer overflow in decimal number");
13023 if (rev > 0x7FFFFFFF)
13024 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
13026 /* Append native character for the rev point */
13027 tmpend = uvchr_to_utf8(tmpbuf, rev);
13028 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
13029 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
13031 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
13037 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
13041 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
13048 Perl_keyword_plugin_standard(pTHX_
13049 char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
13051 PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
13052 PERL_UNUSED_CONTEXT;
13053 PERL_UNUSED_ARG(keyword_ptr);
13054 PERL_UNUSED_ARG(keyword_len);
13055 PERL_UNUSED_ARG(op_ptr);
13056 return KEYWORD_PLUGIN_DECLINE;
13061 * c-indentation-style: bsd
13062 * c-basic-offset: 4
13063 * indent-tabs-mode: t
13066 * ex: set ts=8 sts=4 sw=4 noet: