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)
100 S_pending_ident(pTHX);
102 static const char ident_too_long[] = "Identifier too long";
103 static const char commaless_variable_list[] = "comma-less variable list";
105 #ifndef PERL_NO_UTF16_FILTER
106 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
107 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
111 # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
112 # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
114 # define CURMAD(slot,sv)
115 # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
118 #define XFAKEBRACK 128
119 #define XENUMMASK 127
121 #ifdef USE_UTF8_SCRIPTS
122 # define UTF (!IN_BYTES)
124 # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
127 /* The maximum number of characters preceding the unrecognized one to display */
128 #define UNRECOGNIZED_PRECEDE_COUNT 10
130 /* In variables named $^X, these are the legal values for X.
131 * 1999-02-27 mjd-perl-patch@plover.com */
132 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
134 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
136 /* LEX_* are values for PL_lex_state, the state of the lexer.
137 * They are arranged oddly so that the guard on the switch statement
138 * can get by with a single comparison (if the compiler is smart enough).
141 /* #define LEX_NOTPARSING 11 is done in perl.h. */
143 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
144 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
145 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
146 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
147 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
149 /* at end of code, eg "$x" followed by: */
150 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
151 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
153 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
154 string or after \E, $foo, etc */
155 #define LEX_INTERPCONST 2 /* NOT USED */
156 #define LEX_FORMLINE 1 /* expecting a format line */
157 #define LEX_KNOWNEXT 0 /* next token known; just return it */
161 static const char* const lex_state_names[] = {
180 #include "keywords.h"
182 /* CLINE is a macro that ensures PL_copline has a sane value */
187 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
190 # define SKIPSPACE0(s) skipspace0(s)
191 # define SKIPSPACE1(s) skipspace1(s)
192 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
193 # define PEEKSPACE(s) skipspace2(s,0)
195 # define SKIPSPACE0(s) skipspace(s)
196 # define SKIPSPACE1(s) skipspace(s)
197 # define SKIPSPACE2(s,tsv) skipspace(s)
198 # define PEEKSPACE(s) skipspace(s)
202 * Convenience functions to return different tokens and prime the
203 * lexer for the next token. They all take an argument.
205 * TOKEN : generic token (used for '(', DOLSHARP, etc)
206 * OPERATOR : generic operator
207 * AOPERATOR : assignment operator
208 * PREBLOCK : beginning the block after an if, while, foreach, ...
209 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
210 * PREREF : *EXPR where EXPR is not a simple identifier
211 * TERM : expression term
212 * LOOPX : loop exiting command (goto, last, dump, etc)
213 * FTST : file test operator
214 * FUN0 : zero-argument function
215 * FUN1 : not used, except for not, which isn't a UNIOP
216 * BOop : bitwise or or xor
218 * SHop : shift operator
219 * PWop : power operator
220 * PMop : pattern-matching operator
221 * Aop : addition-level operator
222 * Mop : multiplication-level operator
223 * Eop : equality-testing operator
224 * Rop : relational operator <= != gt
226 * Also see LOP and lop() below.
229 #ifdef DEBUGGING /* Serve -DT. */
230 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
232 # define REPORT(retval) (retval)
235 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
236 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
237 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
238 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
239 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
240 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
241 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
242 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
243 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
244 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
245 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
246 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
247 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
248 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
249 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
250 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
251 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
252 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
253 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
254 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
256 /* This bit of chicanery makes a unary function followed by
257 * a parenthesis into a function with one argument, highest precedence.
258 * The UNIDOR macro is for unary functions that can be followed by the //
259 * operator (such as C<shift // 0>).
261 #define UNI2(f,x) { \
262 pl_yylval.ival = f; \
265 PL_last_uni = PL_oldbufptr; \
266 PL_last_lop_op = f; \
268 return REPORT( (int)FUNC1 ); \
270 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
272 #define UNI(f) UNI2(f,XTERM)
273 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
275 #define UNIBRACK(f) { \
276 pl_yylval.ival = f; \
278 PL_last_uni = PL_oldbufptr; \
280 return REPORT( (int)FUNC1 ); \
282 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
285 /* grandfather return to old style */
286 #define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
290 /* how to interpret the pl_yylval associated with the token */
294 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
300 static struct debug_tokens {
302 enum token_type type;
304 } const debug_tokens[] =
306 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
307 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
308 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
309 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
310 { ARROW, TOKENTYPE_NONE, "ARROW" },
311 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
312 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
313 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
314 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
315 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
316 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
317 { DO, TOKENTYPE_NONE, "DO" },
318 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
319 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
320 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
321 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
322 { ELSE, TOKENTYPE_NONE, "ELSE" },
323 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
324 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
325 { FOR, TOKENTYPE_IVAL, "FOR" },
326 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
327 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
328 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
329 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
330 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
331 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
332 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
333 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
334 { IF, TOKENTYPE_IVAL, "IF" },
335 { LABEL, TOKENTYPE_PVAL, "LABEL" },
336 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
337 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
338 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
339 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
340 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
341 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
342 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
343 { MY, TOKENTYPE_IVAL, "MY" },
344 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
345 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
346 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
347 { OROP, TOKENTYPE_IVAL, "OROP" },
348 { OROR, TOKENTYPE_NONE, "OROR" },
349 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
350 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
351 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
352 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
353 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
354 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
355 { PREINC, TOKENTYPE_NONE, "PREINC" },
356 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
357 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
358 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
359 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
360 { SUB, TOKENTYPE_NONE, "SUB" },
361 { THING, TOKENTYPE_OPVAL, "THING" },
362 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
363 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
364 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
365 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
366 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
367 { USE, TOKENTYPE_IVAL, "USE" },
368 { WHEN, TOKENTYPE_IVAL, "WHEN" },
369 { WHILE, TOKENTYPE_IVAL, "WHILE" },
370 { WORD, TOKENTYPE_OPVAL, "WORD" },
371 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
372 { 0, TOKENTYPE_NONE, NULL }
375 /* dump the returned token in rv, plus any optional arg in pl_yylval */
378 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
382 PERL_ARGS_ASSERT_TOKEREPORT;
385 const char *name = NULL;
386 enum token_type type = TOKENTYPE_NONE;
387 const struct debug_tokens *p;
388 SV* const report = newSVpvs("<== ");
390 for (p = debug_tokens; p->token; p++) {
391 if (p->token == (int)rv) {
398 Perl_sv_catpv(aTHX_ report, name);
399 else if ((char)rv > ' ' && (char)rv < '~')
400 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
402 sv_catpvs(report, "EOF");
404 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
407 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
410 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
412 case TOKENTYPE_OPNUM:
413 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
414 PL_op_name[lvalp->ival]);
417 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
419 case TOKENTYPE_OPVAL:
421 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
422 PL_op_name[lvalp->opval->op_type]);
423 if (lvalp->opval->op_type == OP_CONST) {
424 Perl_sv_catpvf(aTHX_ report, " %s",
425 SvPEEK(cSVOPx_sv(lvalp->opval)));
430 sv_catpvs(report, "(opval=null)");
433 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
439 /* print the buffer with suitable escapes */
442 S_printbuf(pTHX_ const char *const fmt, const char *const s)
444 SV* const tmp = newSVpvs("");
446 PERL_ARGS_ASSERT_PRINTBUF;
448 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
457 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
458 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
462 S_ao(pTHX_ int toketype)
465 if (*PL_bufptr == '=') {
467 if (toketype == ANDAND)
468 pl_yylval.ival = OP_ANDASSIGN;
469 else if (toketype == OROR)
470 pl_yylval.ival = OP_ORASSIGN;
471 else if (toketype == DORDOR)
472 pl_yylval.ival = OP_DORASSIGN;
480 * When Perl expects an operator and finds something else, no_op
481 * prints the warning. It always prints "<something> found where
482 * operator expected. It prints "Missing semicolon on previous line?"
483 * if the surprise occurs at the start of the line. "do you need to
484 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
485 * where the compiler doesn't know if foo is a method call or a function.
486 * It prints "Missing operator before end of line" if there's nothing
487 * after the missing operator, or "... before <...>" if there is something
488 * after the missing operator.
492 S_no_op(pTHX_ const char *const what, char *s)
495 char * const oldbp = PL_bufptr;
496 const bool is_first = (PL_oldbufptr == PL_linestart);
498 PERL_ARGS_ASSERT_NO_OP;
504 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
505 if (ckWARN_d(WARN_SYNTAX)) {
507 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
508 "\t(Missing semicolon on previous line?)\n");
509 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
511 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
513 if (t < PL_bufptr && isSPACE(*t))
514 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
515 "\t(Do you need to predeclare %.*s?)\n",
516 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
520 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
521 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
529 * Complain about missing quote/regexp/heredoc terminator.
530 * If it's called with NULL then it cauterizes the line buffer.
531 * If we're in a delimited string and the delimiter is a control
532 * character, it's reformatted into a two-char sequence like ^C.
537 S_missingterm(pTHX_ char *s)
543 char * const nl = strrchr(s,'\n');
547 else if (isCNTRL(PL_multi_close)) {
549 tmpbuf[1] = (char)toCTRL(PL_multi_close);
554 *tmpbuf = (char)PL_multi_close;
558 q = strchr(s,'"') ? '\'' : '"';
559 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
562 #define FEATURE_IS_ENABLED(name) \
563 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
564 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
565 /* The longest string we pass in. */
566 #define MAX_FEATURE_LEN (sizeof("switch")-1)
569 * S_feature_is_enabled
570 * Check whether the named feature is enabled.
573 S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
576 HV * const hinthv = GvHV(PL_hintgv);
577 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
579 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
581 assert(namelen <= MAX_FEATURE_LEN);
582 memcpy(&he_name[8], name, namelen);
584 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
592 Perl_deprecate(pTHX_ const char *const s)
594 PERL_ARGS_ASSERT_DEPRECATE;
596 if (ckWARN(WARN_DEPRECATED))
597 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
601 Perl_deprecate_old(pTHX_ const char *const s)
603 /* This function should NOT be called for any new deprecated warnings */
604 /* Use Perl_deprecate instead */
606 /* It is here to maintain backward compatibility with the pre-5.8 */
607 /* warnings category hierarchy. The "deprecated" category used to */
608 /* live under the "syntax" category. It is now a top-level category */
609 /* in its own right. */
611 PERL_ARGS_ASSERT_DEPRECATE_OLD;
613 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
614 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
615 "Use of %s is deprecated", s);
619 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
620 * utf16-to-utf8-reversed.
623 #ifdef PERL_CR_FILTER
627 register const char *s = SvPVX_const(sv);
628 register const char * const e = s + SvCUR(sv);
630 PERL_ARGS_ASSERT_STRIP_RETURN;
632 /* outer loop optimized to do nothing if there are no CR-LFs */
634 if (*s++ == '\r' && *s == '\n') {
635 /* hit a CR-LF, need to copy the rest */
636 register char *d = s - 1;
639 if (*s == '\r' && s[1] == '\n')
650 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
652 const I32 count = FILTER_READ(idx+1, sv, maxlen);
653 if (count > 0 && !maxlen)
664 * Create a parser object and initialise its parser and lexer fields
666 * rsfp is the opened file handle to read from (if any),
668 * line holds any initial content already read from the file (or in
669 * the case of no file, such as an eval, the whole contents);
671 * new_filter indicates that this is a new file and it shouldn't inherit
672 * the filters from the current parser (ie require).
676 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
679 const char *s = NULL;
681 yy_parser *parser, *oparser;
683 /* create and initialise a parser */
685 Newxz(parser, 1, yy_parser);
686 parser->old_parser = oparser = PL_parser;
689 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
690 parser->ps = parser->stack;
691 parser->stack_size = YYINITDEPTH;
693 parser->stack->state = 0;
694 parser->yyerrstatus = 0;
695 parser->yychar = YYEMPTY; /* Cause a token to be read. */
697 /* on scope exit, free this parser and restore any outer one */
699 parser->saved_curcop = PL_curcop;
701 /* initialise lexer state */
704 parser->curforce = -1;
706 parser->nexttoke = 0;
708 parser->error_count = oparser ? oparser->error_count : 0;
709 parser->copline = NOLINE;
710 parser->lex_state = LEX_NORMAL;
711 parser->expect = XSTATE;
713 parser->rsfp_filters = (new_filter || !oparser) ? newAV()
714 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
716 Newx(parser->lex_brackstack, 120, char);
717 Newx(parser->lex_casestack, 12, char);
718 *parser->lex_casestack = '\0';
721 s = SvPV_const(line, len);
727 parser->linestr = newSVpvs("\n;");
728 } else if (SvREADONLY(line) || s[len-1] != ';') {
729 parser->linestr = newSVsv(line);
731 sv_catpvs(parser->linestr, "\n;");
734 SvREFCNT_inc_simple_void_NN(line);
735 parser->linestr = line;
737 parser->oldoldbufptr =
740 parser->linestart = SvPVX(parser->linestr);
741 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
742 parser->last_lop = parser->last_uni = NULL;
746 /* delete a parser object */
749 Perl_parser_free(pTHX_ const yy_parser *parser)
751 PERL_ARGS_ASSERT_PARSER_FREE;
753 PL_curcop = parser->saved_curcop;
754 SvREFCNT_dec(parser->linestr);
756 if (parser->rsfp == PerlIO_stdin())
757 PerlIO_clearerr(parser->rsfp);
758 else if (parser->rsfp && (!parser->old_parser ||
759 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
760 PerlIO_close(parser->rsfp);
761 SvREFCNT_dec(parser->rsfp_filters);
763 Safefree(parser->stack);
764 Safefree(parser->lex_brackstack);
765 Safefree(parser->lex_casestack);
766 PL_parser = parser->old_parser;
773 * Finalizer for lexing operations. Must be called when the parser is
774 * done with the lexer.
781 PL_doextract = FALSE;
786 * This subroutine has nothing to do with tilting, whether at windmills
787 * or pinball tables. Its name is short for "increment line". It
788 * increments the current line number in CopLINE(PL_curcop) and checks
789 * to see whether the line starts with a comment of the form
790 * # line 500 "foo.pm"
791 * If so, it sets the current line number and file to the values in the comment.
795 S_incline(pTHX_ const char *s)
802 PERL_ARGS_ASSERT_INCLINE;
804 CopLINE_inc(PL_curcop);
807 while (SPACE_OR_TAB(*s))
809 if (strnEQ(s, "line", 4))
813 if (SPACE_OR_TAB(*s))
817 while (SPACE_OR_TAB(*s))
825 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
827 while (SPACE_OR_TAB(*s))
829 if (*s == '"' && (t = strchr(s+1, '"'))) {
839 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
841 if (*e != '\n' && *e != '\0')
842 return; /* false alarm */
845 const STRLEN len = t - s;
847 SV *const temp_sv = CopFILESV(PL_curcop);
853 tmplen = SvCUR(temp_sv);
859 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
860 /* must copy *{"::_<(eval N)[oldfilename:L]"}
861 * to *{"::_<newfilename"} */
862 /* However, the long form of evals is only turned on by the
863 debugger - usually they're "(eval %lu)" */
867 STRLEN tmplen2 = len;
868 if (tmplen + 2 <= sizeof smallbuf)
871 Newx(tmpbuf, tmplen + 2, char);
874 memcpy(tmpbuf + 2, cf, tmplen);
876 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
881 if (tmplen2 + 2 <= sizeof smallbuf)
884 Newx(tmpbuf2, tmplen2 + 2, char);
886 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
887 /* Either they malloc'd it, or we malloc'd it,
888 so no prefix is present in ours. */
893 memcpy(tmpbuf2 + 2, s, tmplen2);
896 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
898 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
899 /* adjust ${"::_<newfilename"} to store the new file name */
900 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
901 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
902 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
905 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
907 if (tmpbuf != smallbuf) Safefree(tmpbuf);
910 CopFILE_free(PL_curcop);
911 CopFILE_setn(PL_curcop, s, len);
913 CopLINE_set(PL_curcop, atoi(n)-1);
917 /* skip space before PL_thistoken */
920 S_skipspace0(pTHX_ register char *s)
922 PERL_ARGS_ASSERT_SKIPSPACE0;
929 PL_thiswhite = newSVpvs("");
930 sv_catsv(PL_thiswhite, PL_skipwhite);
931 sv_free(PL_skipwhite);
934 PL_realtokenstart = s - SvPVX(PL_linestr);
938 /* skip space after PL_thistoken */
941 S_skipspace1(pTHX_ register char *s)
943 const char *start = s;
944 I32 startoff = start - SvPVX(PL_linestr);
946 PERL_ARGS_ASSERT_SKIPSPACE1;
951 start = SvPVX(PL_linestr) + startoff;
952 if (!PL_thistoken && PL_realtokenstart >= 0) {
953 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
954 PL_thistoken = newSVpvn(tstart, start - tstart);
956 PL_realtokenstart = -1;
959 PL_nextwhite = newSVpvs("");
960 sv_catsv(PL_nextwhite, PL_skipwhite);
961 sv_free(PL_skipwhite);
968 S_skipspace2(pTHX_ register char *s, SV **svp)
971 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
972 const I32 startoff = s - SvPVX(PL_linestr);
974 PERL_ARGS_ASSERT_SKIPSPACE2;
977 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
978 if (!PL_madskills || !svp)
980 start = SvPVX(PL_linestr) + startoff;
981 if (!PL_thistoken && PL_realtokenstart >= 0) {
982 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
983 PL_thistoken = newSVpvn(tstart, start - tstart);
984 PL_realtokenstart = -1;
989 sv_setsv(*svp, PL_skipwhite);
990 sv_free(PL_skipwhite);
999 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1001 AV *av = CopFILEAVx(PL_curcop);
1003 SV * const sv = newSV_type(SVt_PVMG);
1005 sv_setsv(sv, orig_sv);
1007 sv_setpvn(sv, buf, len);
1010 av_store(av, (I32)CopLINE(PL_curcop), sv);
1016 * Called to gobble the appropriate amount and type of whitespace.
1017 * Skips comments as well.
1021 S_skipspace(pTHX_ register char *s)
1026 int startoff = s - SvPVX(PL_linestr);
1028 PERL_ARGS_ASSERT_SKIPSPACE;
1031 sv_free(PL_skipwhite);
1035 PERL_ARGS_ASSERT_SKIPSPACE;
1037 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1038 while (s < PL_bufend && SPACE_OR_TAB(*s))
1048 SSize_t oldprevlen, oldoldprevlen;
1049 SSize_t oldloplen = 0, oldunilen = 0;
1050 while (s < PL_bufend && isSPACE(*s)) {
1051 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1056 if (s < PL_bufend && *s == '#') {
1057 while (s < PL_bufend && *s != '\n')
1059 if (s < PL_bufend) {
1061 if (PL_in_eval && !PL_rsfp) {
1068 /* only continue to recharge the buffer if we're at the end
1069 * of the buffer, we're not reading from a source filter, and
1070 * we're in normal lexing mode
1072 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1073 PL_lex_state == LEX_FORMLINE)
1080 /* try to recharge the buffer */
1082 curoff = s - SvPVX(PL_linestr);
1085 if ((s = filter_gets(PL_linestr, PL_rsfp,
1086 (prevlen = SvCUR(PL_linestr)))) == NULL)
1089 if (PL_madskills && curoff != startoff) {
1091 PL_skipwhite = newSVpvs("");
1092 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1096 /* mustn't throw out old stuff yet if madpropping */
1097 SvCUR(PL_linestr) = curoff;
1098 s = SvPVX(PL_linestr) + curoff;
1100 if (curoff && s[-1] == '\n')
1104 /* end of file. Add on the -p or -n magic */
1105 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1108 sv_catpvs(PL_linestr,
1109 ";}continue{print or die qq(-p destination: $!\\n);}");
1111 sv_setpvs(PL_linestr,
1112 ";}continue{print or die qq(-p destination: $!\\n);}");
1114 PL_minus_n = PL_minus_p = 0;
1116 else if (PL_minus_n) {
1118 sv_catpvs(PL_linestr, ";}");
1120 sv_setpvs(PL_linestr, ";}");
1126 sv_catpvs(PL_linestr,";");
1128 sv_setpvs(PL_linestr,";");
1131 /* reset variables for next time we lex */
1132 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1138 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1139 PL_last_lop = PL_last_uni = NULL;
1141 /* Close the filehandle. Could be from
1142 * STDIN, or a regular file. If we were reading code from
1143 * STDIN (because the commandline held no -e or filename)
1144 * then we don't close it, we reset it so the code can
1145 * read from STDIN too.
1148 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1149 PerlIO_clearerr(PL_rsfp);
1151 (void)PerlIO_close(PL_rsfp);
1156 /* not at end of file, so we only read another line */
1157 /* make corresponding updates to old pointers, for yyerror() */
1158 oldprevlen = PL_oldbufptr - PL_bufend;
1159 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1161 oldunilen = PL_last_uni - PL_bufend;
1163 oldloplen = PL_last_lop - PL_bufend;
1164 PL_linestart = PL_bufptr = s + prevlen;
1165 PL_bufend = s + SvCUR(PL_linestr);
1167 PL_oldbufptr = s + oldprevlen;
1168 PL_oldoldbufptr = s + oldoldprevlen;
1170 PL_last_uni = s + oldunilen;
1172 PL_last_lop = s + oldloplen;
1175 /* debugger active and we're not compiling the debugger code,
1176 * so store the line into the debugger's array of lines
1178 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
1179 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1186 PL_skipwhite = newSVpvs("");
1187 curoff = s - SvPVX(PL_linestr);
1188 if (curoff - startoff)
1189 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1198 * Check the unary operators to ensure there's no ambiguity in how they're
1199 * used. An ambiguous piece of code would be:
1201 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1202 * the +5 is its argument.
1212 if (PL_oldoldbufptr != PL_last_uni)
1214 while (isSPACE(*PL_last_uni))
1217 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1219 if ((t = strchr(s, '(')) && t < PL_bufptr)
1222 if (ckWARN_d(WARN_AMBIGUOUS)){
1223 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1224 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1225 (int)(s - PL_last_uni), PL_last_uni);
1230 * LOP : macro to build a list operator. Its behaviour has been replaced
1231 * with a subroutine, S_lop() for which LOP is just another name.
1234 #define LOP(f,x) return lop(f,x,s)
1238 * Build a list operator (or something that might be one). The rules:
1239 * - if we have a next token, then it's a list operator [why?]
1240 * - if the next thing is an opening paren, then it's a function
1241 * - else it's a list operator
1245 S_lop(pTHX_ I32 f, int x, char *s)
1249 PERL_ARGS_ASSERT_LOP;
1255 PL_last_lop = PL_oldbufptr;
1256 PL_last_lop_op = (OPCODE)f;
1259 return REPORT(LSTOP);
1262 return REPORT(LSTOP);
1265 return REPORT(FUNC);
1268 return REPORT(FUNC);
1270 return REPORT(LSTOP);
1276 * Sets up for an eventual force_next(). start_force(0) basically does
1277 * an unshift, while start_force(-1) does a push. yylex removes items
1282 S_start_force(pTHX_ int where)
1286 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1287 where = PL_lasttoke;
1288 assert(PL_curforce < 0 || PL_curforce == where);
1289 if (PL_curforce != where) {
1290 for (i = PL_lasttoke; i > where; --i) {
1291 PL_nexttoke[i] = PL_nexttoke[i-1];
1295 if (PL_curforce < 0) /* in case of duplicate start_force() */
1296 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1297 PL_curforce = where;
1300 curmad('^', newSVpvs(""));
1301 CURMAD('_', PL_nextwhite);
1306 S_curmad(pTHX_ char slot, SV *sv)
1312 if (PL_curforce < 0)
1313 where = &PL_thismad;
1315 where = &PL_nexttoke[PL_curforce].next_mad;
1321 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1323 else if (PL_encoding) {
1324 sv_recode_to_utf8(sv, PL_encoding);
1329 /* keep a slot open for the head of the list? */
1330 if (slot != '_' && *where && (*where)->mad_key == '^') {
1331 (*where)->mad_key = slot;
1332 sv_free(MUTABLE_SV(((*where)->mad_val)));
1333 (*where)->mad_val = (void*)sv;
1336 addmad(newMADsv(slot, sv), where, 0);
1339 # define start_force(where) NOOP
1340 # define curmad(slot, sv) NOOP
1345 * When the lexer realizes it knows the next token (for instance,
1346 * it is reordering tokens for the parser) then it can call S_force_next
1347 * to know what token to return the next time the lexer is called. Caller
1348 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1349 * and possibly PL_expect to ensure the lexer handles the token correctly.
1353 S_force_next(pTHX_ I32 type)
1358 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1359 tokereport(type, &NEXTVAL_NEXTTOKE);
1363 if (PL_curforce < 0)
1364 start_force(PL_lasttoke);
1365 PL_nexttoke[PL_curforce].next_type = type;
1366 if (PL_lex_state != LEX_KNOWNEXT)
1367 PL_lex_defer = PL_lex_state;
1368 PL_lex_state = LEX_KNOWNEXT;
1369 PL_lex_expect = PL_expect;
1372 PL_nexttype[PL_nexttoke] = type;
1374 if (PL_lex_state != LEX_KNOWNEXT) {
1375 PL_lex_defer = PL_lex_state;
1376 PL_lex_expect = PL_expect;
1377 PL_lex_state = LEX_KNOWNEXT;
1383 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1386 SV * const sv = newSVpvn_utf8(start, len,
1388 && is_utf8_string((const U8*)start, len));
1394 * When the lexer knows the next thing is a word (for instance, it has
1395 * just seen -> and it knows that the next char is a word char, then
1396 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1400 * char *start : buffer position (must be within PL_linestr)
1401 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1402 * int check_keyword : if true, Perl checks to make sure the word isn't
1403 * a keyword (do this if the word is a label, e.g. goto FOO)
1404 * int allow_pack : if true, : characters will also be allowed (require,
1405 * use, etc. do this)
1406 * int allow_initial_tick : used by the "sub" lexer only.
1410 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1416 PERL_ARGS_ASSERT_FORCE_WORD;
1418 start = SKIPSPACE1(start);
1420 if (isIDFIRST_lazy_if(s,UTF) ||
1421 (allow_pack && *s == ':') ||
1422 (allow_initial_tick && *s == '\'') )
1424 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1425 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1427 start_force(PL_curforce);
1429 curmad('X', newSVpvn(start,s-start));
1430 if (token == METHOD) {
1435 PL_expect = XOPERATOR;
1439 curmad('g', newSVpvs( "forced" ));
1440 NEXTVAL_NEXTTOKE.opval
1441 = (OP*)newSVOP(OP_CONST,0,
1442 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1443 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1451 * Called when the lexer wants $foo *foo &foo etc, but the program
1452 * text only contains the "foo" portion. The first argument is a pointer
1453 * to the "foo", and the second argument is the type symbol to prefix.
1454 * Forces the next token to be a "WORD".
1455 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1459 S_force_ident(pTHX_ register const char *s, int kind)
1463 PERL_ARGS_ASSERT_FORCE_IDENT;
1466 const STRLEN len = strlen(s);
1467 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1468 start_force(PL_curforce);
1469 NEXTVAL_NEXTTOKE.opval = o;
1472 o->op_private = OPpCONST_ENTERED;
1473 /* XXX see note in pp_entereval() for why we forgo typo
1474 warnings if the symbol must be introduced in an eval.
1476 gv_fetchpvn_flags(s, len,
1477 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1479 kind == '$' ? SVt_PV :
1480 kind == '@' ? SVt_PVAV :
1481 kind == '%' ? SVt_PVHV :
1489 Perl_str_to_version(pTHX_ SV *sv)
1494 const char *start = SvPV_const(sv,len);
1495 const char * const end = start + len;
1496 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1498 PERL_ARGS_ASSERT_STR_TO_VERSION;
1500 while (start < end) {
1504 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1509 retval += ((NV)n)/nshift;
1518 * Forces the next token to be a version number.
1519 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1520 * and if "guessing" is TRUE, then no new token is created (and the caller
1521 * must use an alternative parsing method).
1525 S_force_version(pTHX_ char *s, int guessing)
1531 I32 startoff = s - SvPVX(PL_linestr);
1534 PERL_ARGS_ASSERT_FORCE_VERSION;
1542 while (isDIGIT(*d) || *d == '_' || *d == '.')
1546 start_force(PL_curforce);
1547 curmad('X', newSVpvn(s,d-s));
1550 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1552 s = scan_num(s, &pl_yylval);
1553 version = pl_yylval.opval;
1554 ver = cSVOPx(version)->op_sv;
1555 if (SvPOK(ver) && !SvNIOK(ver)) {
1556 SvUPGRADE(ver, SVt_PVNV);
1557 SvNV_set(ver, str_to_version(ver));
1558 SvNOK_on(ver); /* hint that it is a version */
1561 else if (guessing) {
1564 sv_free(PL_nextwhite); /* let next token collect whitespace */
1566 s = SvPVX(PL_linestr) + startoff;
1574 if (PL_madskills && !version) {
1575 sv_free(PL_nextwhite); /* let next token collect whitespace */
1577 s = SvPVX(PL_linestr) + startoff;
1580 /* NOTE: The parser sees the package name and the VERSION swapped */
1581 start_force(PL_curforce);
1582 NEXTVAL_NEXTTOKE.opval = version;
1590 * Tokenize a quoted string passed in as an SV. It finds the next
1591 * chunk, up to end of string or a backslash. It may make a new
1592 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1597 S_tokeq(pTHX_ SV *sv)
1601 register char *send;
1606 PERL_ARGS_ASSERT_TOKEQ;
1611 s = SvPV_force(sv, len);
1612 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1615 while (s < send && *s != '\\')
1620 if ( PL_hints & HINT_NEW_STRING ) {
1621 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
1625 if (s + 1 < send && (s[1] == '\\'))
1626 s++; /* all that, just for this */
1631 SvCUR_set(sv, d - SvPVX_const(sv));
1633 if ( PL_hints & HINT_NEW_STRING )
1634 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
1639 * Now come three functions related to double-quote context,
1640 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1641 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1642 * interact with PL_lex_state, and create fake ( ... ) argument lists
1643 * to handle functions and concatenation.
1644 * They assume that whoever calls them will be setting up a fake
1645 * join call, because each subthing puts a ',' after it. This lets
1648 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1650 * (I'm not sure whether the spurious commas at the end of lcfirst's
1651 * arguments and join's arguments are created or not).
1656 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1658 * Pattern matching will set PL_lex_op to the pattern-matching op to
1659 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
1661 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1663 * Everything else becomes a FUNC.
1665 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1666 * had an OP_CONST or OP_READLINE). This just sets us up for a
1667 * call to S_sublex_push().
1671 S_sublex_start(pTHX)
1674 register const I32 op_type = pl_yylval.ival;
1676 if (op_type == OP_NULL) {
1677 pl_yylval.opval = PL_lex_op;
1681 if (op_type == OP_CONST || op_type == OP_READLINE) {
1682 SV *sv = tokeq(PL_lex_stuff);
1684 if (SvTYPE(sv) == SVt_PVIV) {
1685 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1687 const char * const p = SvPV_const(sv, len);
1688 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
1692 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1693 PL_lex_stuff = NULL;
1694 /* Allow <FH> // "foo" */
1695 if (op_type == OP_READLINE)
1696 PL_expect = XTERMORDORDOR;
1699 else if (op_type == OP_BACKTICK && PL_lex_op) {
1700 /* readpipe() vas overriden */
1701 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1702 pl_yylval.opval = PL_lex_op;
1704 PL_lex_stuff = NULL;
1708 PL_sublex_info.super_state = PL_lex_state;
1709 PL_sublex_info.sub_inwhat = (U16)op_type;
1710 PL_sublex_info.sub_op = PL_lex_op;
1711 PL_lex_state = LEX_INTERPPUSH;
1715 pl_yylval.opval = PL_lex_op;
1725 * Create a new scope to save the lexing state. The scope will be
1726 * ended in S_sublex_done. Returns a '(', starting the function arguments
1727 * to the uc, lc, etc. found before.
1728 * Sets PL_lex_state to LEX_INTERPCONCAT.
1737 PL_lex_state = PL_sublex_info.super_state;
1738 SAVEBOOL(PL_lex_dojoin);
1739 SAVEI32(PL_lex_brackets);
1740 SAVEI32(PL_lex_casemods);
1741 SAVEI32(PL_lex_starts);
1742 SAVEI8(PL_lex_state);
1743 SAVEVPTR(PL_lex_inpat);
1744 SAVEI16(PL_lex_inwhat);
1745 SAVECOPLINE(PL_curcop);
1746 SAVEPPTR(PL_bufptr);
1747 SAVEPPTR(PL_bufend);
1748 SAVEPPTR(PL_oldbufptr);
1749 SAVEPPTR(PL_oldoldbufptr);
1750 SAVEPPTR(PL_last_lop);
1751 SAVEPPTR(PL_last_uni);
1752 SAVEPPTR(PL_linestart);
1753 SAVESPTR(PL_linestr);
1754 SAVEGENERICPV(PL_lex_brackstack);
1755 SAVEGENERICPV(PL_lex_casestack);
1757 PL_linestr = PL_lex_stuff;
1758 PL_lex_stuff = NULL;
1760 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1761 = SvPVX(PL_linestr);
1762 PL_bufend += SvCUR(PL_linestr);
1763 PL_last_lop = PL_last_uni = NULL;
1764 SAVEFREESV(PL_linestr);
1766 PL_lex_dojoin = FALSE;
1767 PL_lex_brackets = 0;
1768 Newx(PL_lex_brackstack, 120, char);
1769 Newx(PL_lex_casestack, 12, char);
1770 PL_lex_casemods = 0;
1771 *PL_lex_casestack = '\0';
1773 PL_lex_state = LEX_INTERPCONCAT;
1774 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1776 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1777 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1778 PL_lex_inpat = PL_sublex_info.sub_op;
1780 PL_lex_inpat = NULL;
1787 * Restores lexer state after a S_sublex_push.
1794 if (!PL_lex_starts++) {
1795 SV * const sv = newSVpvs("");
1796 if (SvUTF8(PL_linestr))
1798 PL_expect = XOPERATOR;
1799 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1803 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1804 PL_lex_state = LEX_INTERPCASEMOD;
1808 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1809 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1810 PL_linestr = PL_lex_repl;
1812 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1813 PL_bufend += SvCUR(PL_linestr);
1814 PL_last_lop = PL_last_uni = NULL;
1815 SAVEFREESV(PL_linestr);
1816 PL_lex_dojoin = FALSE;
1817 PL_lex_brackets = 0;
1818 PL_lex_casemods = 0;
1819 *PL_lex_casestack = '\0';
1821 if (SvEVALED(PL_lex_repl)) {
1822 PL_lex_state = LEX_INTERPNORMAL;
1824 /* we don't clear PL_lex_repl here, so that we can check later
1825 whether this is an evalled subst; that means we rely on the
1826 logic to ensure sublex_done() is called again only via the
1827 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1830 PL_lex_state = LEX_INTERPCONCAT;
1840 PL_endwhite = newSVpvs("");
1841 sv_catsv(PL_endwhite, PL_thiswhite);
1845 sv_setpvs(PL_thistoken,"");
1847 PL_realtokenstart = -1;
1851 PL_bufend = SvPVX(PL_linestr);
1852 PL_bufend += SvCUR(PL_linestr);
1853 PL_expect = XOPERATOR;
1854 PL_sublex_info.sub_inwhat = 0;
1862 Extracts a pattern, double-quoted string, or transliteration. This
1865 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1866 processing a pattern (PL_lex_inpat is true), a transliteration
1867 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1869 Returns a pointer to the character scanned up to. If this is
1870 advanced from the start pointer supplied (i.e. if anything was
1871 successfully parsed), will leave an OP for the substring scanned
1872 in pl_yylval. Caller must intuit reason for not parsing further
1873 by looking at the next characters herself.
1877 double-quoted style: \r and \n
1878 regexp special ones: \D \s
1881 case and quoting: \U \Q \E
1882 stops on @ and $, but not for $ as tail anchor
1884 In transliterations:
1885 characters are VERY literal, except for - not at the start or end
1886 of the string, which indicates a range. If the range is in bytes,
1887 scan_const expands the range to the full set of intermediate
1888 characters. If the range is in utf8, the hyphen is replaced with
1889 a certain range mark which will be handled by pmtrans() in op.c.
1891 In double-quoted strings:
1893 double-quoted style: \r and \n
1895 deprecated backrefs: \1 (in substitution replacements)
1896 case and quoting: \U \Q \E
1899 scan_const does *not* construct ops to handle interpolated strings.
1900 It stops processing as soon as it finds an embedded $ or @ variable
1901 and leaves it to the caller to work out what's going on.
1903 embedded arrays (whether in pattern or not) could be:
1904 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1906 $ in double-quoted strings must be the symbol of an embedded scalar.
1908 $ in pattern could be $foo or could be tail anchor. Assumption:
1909 it's a tail anchor if $ is the last thing in the string, or if it's
1910 followed by one of "()| \r\n\t"
1912 \1 (backreferences) are turned into $1
1914 The structure of the code is
1915 while (there's a character to process) {
1916 handle transliteration ranges
1917 skip regexp comments /(?#comment)/ and codes /(?{code})/
1918 skip #-initiated comments in //x patterns
1919 check for embedded arrays
1920 check for embedded scalars
1922 leave intact backslashes from leaveit (below)
1923 deprecate \1 in substitution replacements
1924 handle string-changing backslashes \l \U \Q \E, etc.
1925 switch (what was escaped) {
1926 handle \- in a transliteration (becomes a literal -)
1927 handle \132 (octal characters)
1928 handle \x15 and \x{1234} (hex characters)
1929 handle \N{name} (named characters)
1930 handle \cV (control characters)
1931 handle printf-style backslashes (\f, \r, \n, etc)
1934 } (end if backslash)
1935 handle regular character
1936 } (end while character to read)
1941 S_scan_const(pTHX_ char *start)
1944 register char *send = PL_bufend; /* end of the constant */
1945 SV *sv = newSV(send - start); /* sv for the constant. See
1946 note below on sizing. */
1947 register char *s = start; /* start of the constant */
1948 register char *d = SvPVX(sv); /* destination for copies */
1949 bool dorange = FALSE; /* are we in a translit range? */
1950 bool didrange = FALSE; /* did we just finish a range? */
1951 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1952 I32 this_utf8 = UTF; /* Is the source string assumed
1953 to be UTF8? But, this can
1954 show as true when the source
1955 isn't utf8, as for example
1956 when it is entirely composed
1959 /* Note on sizing: The scanned constant is placed into sv, which is
1960 * initialized by newSV() assuming one byte of output for every byte of
1961 * input. This routine expects newSV() to allocate an extra byte for a
1962 * trailing NUL, which this routine will append if it gets to the end of
1963 * the input. There may be more bytes of input than output (eg., \N{LATIN
1964 * CAPITAL LETTER A}), or more output than input if the constant ends up
1965 * recoded to utf8, but each time a construct is found that might increase
1966 * the needed size, SvGROW() is called. Its size parameter each time is
1967 * based on the best guess estimate at the time, namely the length used so
1968 * far, plus the length the current construct will occupy, plus room for
1969 * the trailing NUL, plus one byte for every input byte still unscanned */
1973 UV literal_endpoint = 0;
1974 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1977 PERL_ARGS_ASSERT_SCAN_CONST;
1979 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1980 /* If we are doing a trans and we know we want UTF8 set expectation */
1981 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1982 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1986 while (s < send || dorange) {
1987 /* get transliterations out of the way (they're most literal) */
1988 if (PL_lex_inwhat == OP_TRANS) {
1989 /* expand a range A-Z to the full set of characters. AIE! */
1991 I32 i; /* current expanded character */
1992 I32 min; /* first character in range */
1993 I32 max; /* last character in range */
2004 char * const c = (char*)utf8_hop((U8*)d, -1);
2008 *c = (char)UTF_TO_NATIVE(0xff);
2009 /* mark the range as done, and continue */
2015 i = d - SvPVX_const(sv); /* remember current offset */
2018 SvLEN(sv) + (has_utf8 ?
2019 (512 - UTF_CONTINUATION_MARK +
2022 /* How many two-byte within 0..255: 128 in UTF-8,
2023 * 96 in UTF-8-mod. */
2025 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2027 d = SvPVX(sv) + i; /* refresh d after realloc */
2031 for (j = 0; j <= 1; j++) {
2032 char * const c = (char*)utf8_hop((U8*)d, -1);
2033 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2039 max = (U8)0xff; /* only to \xff */
2040 uvmax = uv; /* \x{100} to uvmax */
2042 d = c; /* eat endpoint chars */
2047 d -= 2; /* eat the first char and the - */
2048 min = (U8)*d; /* first char in range */
2049 max = (U8)d[1]; /* last char in range */
2056 "Invalid range \"%c-%c\" in transliteration operator",
2057 (char)min, (char)max);
2061 if (literal_endpoint == 2 &&
2062 ((isLOWER(min) && isLOWER(max)) ||
2063 (isUPPER(min) && isUPPER(max)))) {
2065 for (i = min; i <= max; i++)
2067 *d++ = NATIVE_TO_NEED(has_utf8,i);
2069 for (i = min; i <= max; i++)
2071 *d++ = NATIVE_TO_NEED(has_utf8,i);
2076 for (i = min; i <= max; i++)
2079 const U8 ch = (U8)NATIVE_TO_UTF(i);
2080 if (UNI_IS_INVARIANT(ch))
2083 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2084 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2093 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2095 *d++ = (char)UTF_TO_NATIVE(0xff);
2097 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2101 /* mark the range as done, and continue */
2105 literal_endpoint = 0;
2110 /* range begins (ignore - as first or last char) */
2111 else if (*s == '-' && s+1 < send && s != start) {
2113 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2120 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2130 literal_endpoint = 0;
2131 native_range = TRUE;
2136 /* if we get here, we're not doing a transliteration */
2138 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2139 except for the last char, which will be done separately. */
2140 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2142 while (s+1 < send && *s != ')')
2143 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2145 else if (s[2] == '{' /* This should match regcomp.c */
2146 || (s[2] == '?' && s[3] == '{'))
2149 char *regparse = s + (s[2] == '{' ? 3 : 4);
2152 while (count && (c = *regparse)) {
2153 if (c == '\\' && regparse[1])
2161 if (*regparse != ')')
2162 regparse--; /* Leave one char for continuation. */
2163 while (s < regparse)
2164 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2168 /* likewise skip #-initiated comments in //x patterns */
2169 else if (*s == '#' && PL_lex_inpat &&
2170 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2171 while (s+1 < send && *s != '\n')
2172 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2175 /* check for embedded arrays
2176 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2178 else if (*s == '@' && s[1]) {
2179 if (isALNUM_lazy_if(s+1,UTF))
2181 if (strchr(":'{$", s[1]))
2183 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2184 break; /* in regexp, neither @+ nor @- are interpolated */
2187 /* check for embedded scalars. only stop if we're sure it's a
2190 else if (*s == '$') {
2191 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2193 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2194 if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) {
2195 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2196 "Possible unintended interpolation of $\\ in regex");
2198 break; /* in regexp, $ might be tail anchor */
2202 /* End of else if chain - OP_TRANS rejoin rest */
2205 if (*s == '\\' && s+1 < send) {
2208 /* deprecate \1 in strings and substitution replacements */
2209 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2210 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2212 if (ckWARN(WARN_SYNTAX))
2213 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2218 /* string-change backslash escapes */
2219 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2223 /* skip any other backslash escapes in a pattern */
2224 else if (PL_lex_inpat) {
2225 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2226 goto default_action;
2229 /* if we get here, it's either a quoted -, or a digit */
2232 /* quoted - in transliterations */
2234 if (PL_lex_inwhat == OP_TRANS) {
2241 if ((isALPHA(*s) || isDIGIT(*s)) &&
2243 Perl_warner(aTHX_ packWARN(WARN_MISC),
2244 "Unrecognized escape \\%c passed through",
2246 /* default action is to copy the quoted character */
2247 goto default_action;
2250 /* eg. \132 indicates the octal constant 0x132 */
2251 case '0': case '1': case '2': case '3':
2252 case '4': case '5': case '6': case '7':
2256 uv = NATIVE_TO_UNI(grok_oct(s, &len, &flags, NULL));
2259 goto NUM_ESCAPE_INSERT;
2261 /* eg. \x24 indicates the hex constant 0x24 */
2265 char* const e = strchr(s, '}');
2266 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2267 PERL_SCAN_DISALLOW_PREFIX;
2272 yyerror("Missing right brace on \\x{}");
2276 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2282 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2283 uv = NATIVE_TO_UNI(grok_hex(s, &len, &flags, NULL));
2289 /* Insert oct, hex, or \N{U+...} escaped character. There will
2290 * always be enough room in sv since such escapes will be
2291 * longer than any UTF-8 sequence they can end up as, except if
2292 * they force us to recode the rest of the string into utf8 */
2294 /* Here uv is the ordinal of the next character being added in
2295 * unicode (converted from native). (It has to be done before
2296 * here because \N is interpreted as unicode, and oct and hex
2298 if (!UNI_IS_INVARIANT(uv)) {
2299 if (!has_utf8 && uv > 255) {
2300 /* Might need to recode whatever we have accumulated so
2301 * far if it contains any chars variant in utf8 or
2304 SvCUR_set(sv, d - SvPVX_const(sv));
2307 /* See Note on sizing above. */
2308 sv_utf8_upgrade_flags_grow(sv,
2309 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2310 UNISKIP(uv) + (STRLEN)(send - s) + 1);
2311 d = SvPVX(sv) + SvCUR(sv);
2316 d = (char*)uvuni_to_utf8((U8*)d, uv);
2317 if (PL_lex_inwhat == OP_TRANS &&
2318 PL_sublex_info.sub_op) {
2319 PL_sublex_info.sub_op->op_private |=
2320 (PL_lex_repl ? OPpTRANS_FROM_UTF
2324 if (uv > 255 && !dorange)
2325 native_range = FALSE;
2337 /* \N{LATIN SMALL LETTER A} is a named character, and so is
2342 char* e = strchr(s, '}');
2348 yyerror("Missing right brace on \\N{}");
2352 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2353 /* \N{U+...} The ... is a unicode value even on EBCDIC
2355 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2356 PERL_SCAN_DISALLOW_PREFIX;
2359 uv = grok_hex(s, &len, &flags, NULL);
2360 if ( e > s && len != (STRLEN)(e - s) ) {
2364 goto NUM_ESCAPE_INSERT;
2366 res = newSVpvn(s + 1, e - s - 1);
2367 res = new_constant( NULL, 0, "charnames",
2368 res, NULL, s - 2, e - s + 3 );
2370 sv_utf8_upgrade(res);
2371 str = SvPV_const(res,len);
2372 #ifdef EBCDIC_NEVER_MIND
2373 /* charnames uses pack U and that has been
2374 * recently changed to do the below uni->native
2375 * mapping, so this would be redundant (and wrong,
2376 * the code point would be doubly converted).
2377 * But leave this in just in case the pack U change
2378 * gets revoked, but the semantics is still
2379 * desireable for charnames. --jhi */
2381 UV uv = utf8_to_uvchr((const U8*)str, 0);
2384 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2386 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2387 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2388 str = SvPV_const(res, len);
2392 /* If destination is not in utf8 but this new character is,
2393 * recode the dest to utf8 */
2394 if (!has_utf8 && SvUTF8(res)) {
2395 SvCUR_set(sv, d - SvPVX_const(sv));
2398 /* See Note on sizing above. */
2399 sv_utf8_upgrade_flags_grow(sv,
2400 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2401 len + (STRLEN)(send - s) + 1);
2402 d = SvPVX(sv) + SvCUR(sv);
2404 } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2406 /* See Note on sizing above. (NOTE: SvCUR() is not set
2407 * correctly here). */
2408 const STRLEN off = d - SvPVX_const(sv);
2409 d = SvGROW(sv, off + len + (STRLEN)(send - s) + 1) + off;
2413 native_range = FALSE; /* \N{} is guessed to be Unicode */
2415 Copy(str, d, len, char);
2422 yyerror("Missing braces on \\N{}");
2425 /* \c is a control character */
2434 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2437 yyerror("Missing control char name in \\c");
2441 /* printf-style backslashes, formfeeds, newlines, etc */
2443 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2446 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2449 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2452 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2455 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2458 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2461 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2467 } /* end if (backslash) */
2474 /* If we started with encoded form, or already know we want it,
2475 then encode the next character */
2476 if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
2480 /* One might think that it is wasted effort in the case of the
2481 * source being utf8 (this_utf8 == TRUE) to take the next character
2482 * in the source, convert it to an unsigned value, and then convert
2483 * it back again. But the source has not been validated here. The
2484 * routine that does the conversion checks for errors like
2487 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2488 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2490 SvCUR_set(sv, d - SvPVX_const(sv));
2493 /* See Note on sizing above. */
2494 sv_utf8_upgrade_flags_grow(sv,
2495 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
2496 need + (STRLEN)(send - s) + 1);
2497 d = SvPVX(sv) + SvCUR(sv);
2499 } else if (need > len) {
2500 /* encoded value larger than old, may need extra space (NOTE:
2501 * SvCUR() is not set correctly here). See Note on sizing
2503 const STRLEN off = d - SvPVX_const(sv);
2504 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
2508 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2510 if (uv > 255 && !dorange)
2511 native_range = FALSE;
2515 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2517 } /* while loop to process each character */
2519 /* terminate the string and set up the sv */
2521 SvCUR_set(sv, d - SvPVX_const(sv));
2522 if (SvCUR(sv) >= SvLEN(sv))
2523 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2526 if (PL_encoding && !has_utf8) {
2527 sv_recode_to_utf8(sv, PL_encoding);
2533 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2534 PL_sublex_info.sub_op->op_private |=
2535 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2539 /* shrink the sv if we allocated more than we used */
2540 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2541 SvPV_shrink_to_cur(sv);
2544 /* return the substring (via pl_yylval) only if we parsed anything */
2545 if (s > PL_bufptr) {
2546 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
2547 const char *const key = PL_lex_inpat ? "qr" : "q";
2548 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
2552 if (PL_lex_inwhat == OP_TRANS) {
2555 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
2563 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
2566 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2573 * Returns TRUE if there's more to the expression (e.g., a subscript),
2576 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2578 * ->[ and ->{ return TRUE
2579 * { and [ outside a pattern are always subscripts, so return TRUE
2580 * if we're outside a pattern and it's not { or [, then return FALSE
2581 * if we're in a pattern and the first char is a {
2582 * {4,5} (any digits around the comma) returns FALSE
2583 * if we're in a pattern and the first char is a [
2585 * [SOMETHING] has a funky algorithm to decide whether it's a
2586 * character class or not. It has to deal with things like
2587 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2588 * anything else returns TRUE
2591 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2594 S_intuit_more(pTHX_ register char *s)
2598 PERL_ARGS_ASSERT_INTUIT_MORE;
2600 if (PL_lex_brackets)
2602 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2604 if (*s != '{' && *s != '[')
2609 /* In a pattern, so maybe we have {n,m}. */
2626 /* On the other hand, maybe we have a character class */
2629 if (*s == ']' || *s == '^')
2632 /* this is terrifying, and it works */
2633 int weight = 2; /* let's weigh the evidence */
2635 unsigned char un_char = 255, last_un_char;
2636 const char * const send = strchr(s,']');
2637 char tmpbuf[sizeof PL_tokenbuf * 4];
2639 if (!send) /* has to be an expression */
2642 Zero(seen,256,char);
2645 else if (isDIGIT(*s)) {
2647 if (isDIGIT(s[1]) && s[2] == ']')
2653 for (; s < send; s++) {
2654 last_un_char = un_char;
2655 un_char = (unsigned char)*s;
2660 weight -= seen[un_char] * 10;
2661 if (isALNUM_lazy_if(s+1,UTF)) {
2663 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2664 len = (int)strlen(tmpbuf);
2665 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2670 else if (*s == '$' && s[1] &&
2671 strchr("[#!%*<>()-=",s[1])) {
2672 if (/*{*/ strchr("])} =",s[2]))
2681 if (strchr("wds]",s[1]))
2683 else if (seen[(U8)'\''] || seen[(U8)'"'])
2685 else if (strchr("rnftbxcav",s[1]))
2687 else if (isDIGIT(s[1])) {
2689 while (s[1] && isDIGIT(s[1]))
2699 if (strchr("aA01! ",last_un_char))
2701 if (strchr("zZ79~",s[1]))
2703 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2704 weight -= 5; /* cope with negative subscript */
2707 if (!isALNUM(last_un_char)
2708 && !(last_un_char == '$' || last_un_char == '@'
2709 || last_un_char == '&')
2710 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2715 if (keyword(tmpbuf, d - tmpbuf, 0))
2718 if (un_char == last_un_char + 1)
2720 weight -= seen[un_char];
2725 if (weight >= 0) /* probably a character class */
2735 * Does all the checking to disambiguate
2737 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2738 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2740 * First argument is the stuff after the first token, e.g. "bar".
2742 * Not a method if bar is a filehandle.
2743 * Not a method if foo is a subroutine prototyped to take a filehandle.
2744 * Not a method if it's really "Foo $bar"
2745 * Method if it's "foo $bar"
2746 * Not a method if it's really "print foo $bar"
2747 * Method if it's really "foo package::" (interpreted as package->foo)
2748 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2749 * Not a method if bar is a filehandle or package, but is quoted with
2754 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2757 char *s = start + (*start == '$');
2758 char tmpbuf[sizeof PL_tokenbuf];
2765 PERL_ARGS_ASSERT_INTUIT_METHOD;
2768 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2772 const char *proto = SvPVX_const(cv);
2783 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2784 /* start is the beginning of the possible filehandle/object,
2785 * and s is the end of it
2786 * tmpbuf is a copy of it
2789 if (*start == '$') {
2790 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2791 isUPPER(*PL_tokenbuf))
2794 len = start - SvPVX(PL_linestr);
2798 start = SvPVX(PL_linestr) + len;
2802 return *s == '(' ? FUNCMETH : METHOD;
2804 if (!keyword(tmpbuf, len, 0)) {
2805 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2809 soff = s - SvPVX(PL_linestr);
2813 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2814 if (indirgv && GvCVu(indirgv))
2816 /* filehandle or package name makes it a method */
2817 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2819 soff = s - SvPVX(PL_linestr);
2822 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2823 return 0; /* no assumptions -- "=>" quotes bearword */
2825 start_force(PL_curforce);
2826 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2827 newSVpvn(tmpbuf,len));
2828 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2830 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2835 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2837 return *s == '(' ? FUNCMETH : METHOD;
2843 /* Encoded script support. filter_add() effectively inserts a
2844 * 'pre-processing' function into the current source input stream.
2845 * Note that the filter function only applies to the current source file
2846 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2848 * The datasv parameter (which may be NULL) can be used to pass
2849 * private data to this instance of the filter. The filter function
2850 * can recover the SV using the FILTER_DATA macro and use it to
2851 * store private buffers and state information.
2853 * The supplied datasv parameter is upgraded to a PVIO type
2854 * and the IoDIRP/IoANY field is used to store the function pointer,
2855 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2856 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2857 * private use must be set using malloc'd pointers.
2861 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2870 if (!PL_rsfp_filters)
2871 PL_rsfp_filters = newAV();
2874 SvUPGRADE(datasv, SVt_PVIO);
2875 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2876 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2877 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2878 FPTR2DPTR(void *, IoANY(datasv)),
2879 SvPV_nolen(datasv)));
2880 av_unshift(PL_rsfp_filters, 1);
2881 av_store(PL_rsfp_filters, 0, datasv) ;
2886 /* Delete most recently added instance of this filter function. */
2888 Perl_filter_del(pTHX_ filter_t funcp)
2893 PERL_ARGS_ASSERT_FILTER_DEL;
2896 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2897 FPTR2DPTR(void*, funcp)));
2899 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2901 /* if filter is on top of stack (usual case) just pop it off */
2902 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2903 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2904 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2905 IoANY(datasv) = (void *)NULL;
2906 sv_free(av_pop(PL_rsfp_filters));
2910 /* we need to search for the correct entry and clear it */
2911 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2915 /* Invoke the idxth filter function for the current rsfp. */
2916 /* maxlen 0 = read one text line */
2918 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2923 /* This API is bad. It should have been using unsigned int for maxlen.
2924 Not sure if we want to change the API, but if not we should sanity
2925 check the value here. */
2926 const unsigned int correct_length
2935 PERL_ARGS_ASSERT_FILTER_READ;
2937 if (!PL_parser || !PL_rsfp_filters)
2939 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2940 /* Provide a default input filter to make life easy. */
2941 /* Note that we append to the line. This is handy. */
2942 DEBUG_P(PerlIO_printf(Perl_debug_log,
2943 "filter_read %d: from rsfp\n", idx));
2944 if (correct_length) {
2947 const int old_len = SvCUR(buf_sv);
2949 /* ensure buf_sv is large enough */
2950 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2951 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2952 correct_length)) <= 0) {
2953 if (PerlIO_error(PL_rsfp))
2954 return -1; /* error */
2956 return 0 ; /* end of file */
2958 SvCUR_set(buf_sv, old_len + len) ;
2961 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2962 if (PerlIO_error(PL_rsfp))
2963 return -1; /* error */
2965 return 0 ; /* end of file */
2968 return SvCUR(buf_sv);
2970 /* Skip this filter slot if filter has been deleted */
2971 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2972 DEBUG_P(PerlIO_printf(Perl_debug_log,
2973 "filter_read %d: skipped (filter deleted)\n",
2975 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2977 /* Get function pointer hidden within datasv */
2978 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2979 DEBUG_P(PerlIO_printf(Perl_debug_log,
2980 "filter_read %d: via function %p (%s)\n",
2981 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2982 /* Call function. The function is expected to */
2983 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2984 /* Return: <0:error, =0:eof, >0:not eof */
2985 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2989 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2993 PERL_ARGS_ASSERT_FILTER_GETS;
2995 #ifdef PERL_CR_FILTER
2996 if (!PL_rsfp_filters) {
2997 filter_add(S_cr_textfilter,NULL);
3000 if (PL_rsfp_filters) {
3002 SvCUR_set(sv, 0); /* start with empty line */
3003 if (FILTER_READ(0, sv, 0) > 0)
3004 return ( SvPVX(sv) ) ;
3009 return (sv_gets(sv, fp, append));
3013 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
3018 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
3020 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3024 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3025 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3027 return GvHV(gv); /* Foo:: */
3030 /* use constant CLASS => 'MyClass' */
3031 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3032 if (gv && GvCV(gv)) {
3033 SV * const sv = cv_const_sv(GvCV(gv));
3035 pkgname = SvPV_const(sv, len);
3038 return gv_stashpvn(pkgname, len, 0);
3042 * S_readpipe_override
3043 * Check whether readpipe() is overriden, and generates the appropriate
3044 * optree, provided sublex_start() is called afterwards.
3047 S_readpipe_override(pTHX)
3050 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
3051 pl_yylval.ival = OP_BACKTICK;
3053 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
3055 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
3056 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
3057 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
3059 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
3060 append_elem(OP_LIST,
3061 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
3062 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
3069 * The intent of this yylex wrapper is to minimize the changes to the
3070 * tokener when we aren't interested in collecting madprops. It remains
3071 * to be seen how successful this strategy will be...
3078 char *s = PL_bufptr;
3080 /* make sure PL_thiswhite is initialized */
3084 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
3085 if (PL_pending_ident)
3086 return S_pending_ident(aTHX);
3088 /* previous token ate up our whitespace? */
3089 if (!PL_lasttoke && PL_nextwhite) {
3090 PL_thiswhite = PL_nextwhite;
3094 /* isolate the token, and figure out where it is without whitespace */
3095 PL_realtokenstart = -1;
3099 assert(PL_curforce < 0);
3101 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
3102 if (!PL_thistoken) {
3103 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3104 PL_thistoken = newSVpvs("");
3106 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3107 PL_thistoken = newSVpvn(tstart, s - tstart);
3110 if (PL_thismad) /* install head */
3111 CURMAD('X', PL_thistoken);
3114 /* last whitespace of a sublex? */
3115 if (optype == ')' && PL_endwhite) {
3116 CURMAD('X', PL_endwhite);
3121 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
3122 if (!PL_thiswhite && !PL_endwhite && !optype) {
3123 sv_free(PL_thistoken);
3128 /* put off final whitespace till peg */
3129 if (optype == ';' && !PL_rsfp) {
3130 PL_nextwhite = PL_thiswhite;
3133 else if (PL_thisopen) {
3134 CURMAD('q', PL_thisopen);
3136 sv_free(PL_thistoken);
3140 /* Store actual token text as madprop X */
3141 CURMAD('X', PL_thistoken);
3145 /* add preceding whitespace as madprop _ */
3146 CURMAD('_', PL_thiswhite);
3150 /* add quoted material as madprop = */
3151 CURMAD('=', PL_thisstuff);
3155 /* add terminating quote as madprop Q */
3156 CURMAD('Q', PL_thisclose);
3160 /* special processing based on optype */
3164 /* opval doesn't need a TOKEN since it can already store mp */
3174 if (pl_yylval.opval)
3175 append_madprops(PL_thismad, pl_yylval.opval, 0);
3183 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3192 /* remember any fake bracket that lexer is about to discard */
3193 if (PL_lex_brackets == 1 &&
3194 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3197 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3200 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3201 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3204 break; /* don't bother looking for trailing comment */
3213 /* attach a trailing comment to its statement instead of next token */
3217 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3219 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3221 if (*s == '\n' || *s == '#') {
3222 while (s < PL_bufend && *s != '\n')
3226 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3227 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3244 /* Create new token struct. Note: opvals return early above. */
3245 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
3252 S_tokenize_use(pTHX_ int is_use, char *s) {
3255 PERL_ARGS_ASSERT_TOKENIZE_USE;
3257 if (PL_expect != XSTATE)
3258 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3259 is_use ? "use" : "no"));
3261 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3262 s = force_version(s, TRUE);
3263 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3264 start_force(PL_curforce);
3265 NEXTVAL_NEXTTOKE.opval = NULL;
3268 else if (*s == 'v') {
3269 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3270 s = force_version(s, FALSE);
3274 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3275 s = force_version(s, FALSE);
3277 pl_yylval.ival = is_use;
3281 static const char* const exp_name[] =
3282 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3283 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3290 Works out what to call the token just pulled out of the input
3291 stream. The yacc parser takes care of taking the ops we return and
3292 stitching them into a tree.
3298 if read an identifier
3299 if we're in a my declaration
3300 croak if they tried to say my($foo::bar)
3301 build the ops for a my() declaration
3302 if it's an access to a my() variable
3303 are we in a sort block?
3304 croak if my($a); $a <=> $b
3305 build ops for access to a my() variable
3306 if in a dq string, and they've said @foo and we can't find @foo
3308 build ops for a bareword
3309 if we already built the token before, use it.
3314 #pragma segment Perl_yylex
3320 register char *s = PL_bufptr;
3325 /* orig_keyword, gvp, and gv are initialized here because
3326 * jump to the label just_a_word_zero can bypass their
3327 * initialization later. */
3328 I32 orig_keyword = 0;
3333 SV* tmp = newSVpvs("");
3334 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3335 (IV)CopLINE(PL_curcop),
3336 lex_state_names[PL_lex_state],
3337 exp_name[PL_expect],
3338 pv_display(tmp, s, strlen(s), 0, 60));
3341 /* check if there's an identifier for us to look at */
3342 if (PL_pending_ident)
3343 return REPORT(S_pending_ident(aTHX));
3345 /* no identifier pending identification */
3347 switch (PL_lex_state) {
3349 case LEX_NORMAL: /* Some compilers will produce faster */
3350 case LEX_INTERPNORMAL: /* code if we comment these out. */
3354 /* when we've already built the next token, just pull it out of the queue */
3358 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
3360 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3361 PL_nexttoke[PL_lasttoke].next_mad = 0;
3362 if (PL_thismad && PL_thismad->mad_key == '_') {
3363 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
3364 PL_thismad->mad_val = 0;
3365 mad_free(PL_thismad);
3370 PL_lex_state = PL_lex_defer;
3371 PL_expect = PL_lex_expect;
3372 PL_lex_defer = LEX_NORMAL;
3373 if (!PL_nexttoke[PL_lasttoke].next_type)
3378 pl_yylval = PL_nextval[PL_nexttoke];
3380 PL_lex_state = PL_lex_defer;
3381 PL_expect = PL_lex_expect;
3382 PL_lex_defer = LEX_NORMAL;
3386 /* FIXME - can these be merged? */
3387 return(PL_nexttoke[PL_lasttoke].next_type);
3389 return REPORT(PL_nexttype[PL_nexttoke]);
3392 /* interpolated case modifiers like \L \U, including \Q and \E.
3393 when we get here, PL_bufptr is at the \
3395 case LEX_INTERPCASEMOD:
3397 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3398 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3400 /* handle \E or end of string */
3401 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3403 if (PL_lex_casemods) {
3404 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3405 PL_lex_casestack[PL_lex_casemods] = '\0';
3407 if (PL_bufptr != PL_bufend
3408 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3410 PL_lex_state = LEX_INTERPCONCAT;
3413 PL_thistoken = newSVpvs("\\E");
3419 while (PL_bufptr != PL_bufend &&
3420 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3422 PL_thiswhite = newSVpvs("");
3423 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3427 if (PL_bufptr != PL_bufend)
3430 PL_lex_state = LEX_INTERPCONCAT;
3434 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3435 "### Saw case modifier\n"); });
3437 if (s[1] == '\\' && s[2] == 'E') {
3440 PL_thiswhite = newSVpvs("");
3441 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3444 PL_lex_state = LEX_INTERPCONCAT;
3449 if (!PL_madskills) /* when just compiling don't need correct */
3450 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3451 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3452 if ((*s == 'L' || *s == 'U') &&
3453 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3454 PL_lex_casestack[--PL_lex_casemods] = '\0';
3457 if (PL_lex_casemods > 10)
3458 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3459 PL_lex_casestack[PL_lex_casemods++] = *s;
3460 PL_lex_casestack[PL_lex_casemods] = '\0';
3461 PL_lex_state = LEX_INTERPCONCAT;
3462 start_force(PL_curforce);
3463 NEXTVAL_NEXTTOKE.ival = 0;
3465 start_force(PL_curforce);
3467 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3469 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3471 NEXTVAL_NEXTTOKE.ival = OP_LC;
3473 NEXTVAL_NEXTTOKE.ival = OP_UC;
3475 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3477 Perl_croak(aTHX_ "panic: yylex");
3479 SV* const tmpsv = newSVpvs("\\ ");
3480 /* replace the space with the character we want to escape
3482 SvPVX(tmpsv)[1] = *s;
3488 if (PL_lex_starts) {
3494 sv_free(PL_thistoken);
3495 PL_thistoken = newSVpvs("");
3498 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3499 if (PL_lex_casemods == 1 && PL_lex_inpat)
3508 case LEX_INTERPPUSH:
3509 return REPORT(sublex_push());
3511 case LEX_INTERPSTART:
3512 if (PL_bufptr == PL_bufend)
3513 return REPORT(sublex_done());
3514 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3515 "### Interpolated variable\n"); });
3517 PL_lex_dojoin = (*PL_bufptr == '@');
3518 PL_lex_state = LEX_INTERPNORMAL;
3519 if (PL_lex_dojoin) {
3520 start_force(PL_curforce);
3521 NEXTVAL_NEXTTOKE.ival = 0;
3523 start_force(PL_curforce);
3524 force_ident("\"", '$');
3525 start_force(PL_curforce);
3526 NEXTVAL_NEXTTOKE.ival = 0;
3528 start_force(PL_curforce);
3529 NEXTVAL_NEXTTOKE.ival = 0;
3531 start_force(PL_curforce);
3532 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3535 if (PL_lex_starts++) {
3540 sv_free(PL_thistoken);
3541 PL_thistoken = newSVpvs("");
3544 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3545 if (!PL_lex_casemods && PL_lex_inpat)
3552 case LEX_INTERPENDMAYBE:
3553 if (intuit_more(PL_bufptr)) {
3554 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3560 if (PL_lex_dojoin) {
3561 PL_lex_dojoin = FALSE;
3562 PL_lex_state = LEX_INTERPCONCAT;
3566 sv_free(PL_thistoken);
3567 PL_thistoken = newSVpvs("");
3572 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3573 && SvEVALED(PL_lex_repl))
3575 if (PL_bufptr != PL_bufend)
3576 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3580 case LEX_INTERPCONCAT:
3582 if (PL_lex_brackets)
3583 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3585 if (PL_bufptr == PL_bufend)
3586 return REPORT(sublex_done());
3588 if (SvIVX(PL_linestr) == '\'') {
3589 SV *sv = newSVsv(PL_linestr);
3592 else if ( PL_hints & HINT_NEW_RE )
3593 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
3594 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3598 s = scan_const(PL_bufptr);
3600 PL_lex_state = LEX_INTERPCASEMOD;
3602 PL_lex_state = LEX_INTERPSTART;
3605 if (s != PL_bufptr) {
3606 start_force(PL_curforce);
3608 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3610 NEXTVAL_NEXTTOKE = pl_yylval;
3613 if (PL_lex_starts++) {
3617 sv_free(PL_thistoken);
3618 PL_thistoken = newSVpvs("");
3621 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3622 if (!PL_lex_casemods && PL_lex_inpat)
3635 PL_lex_state = LEX_NORMAL;
3636 s = scan_formline(PL_bufptr);
3637 if (!PL_lex_formbrack)
3643 PL_oldoldbufptr = PL_oldbufptr;
3649 sv_free(PL_thistoken);
3652 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3656 if (isIDFIRST_lazy_if(s,UTF))
3659 unsigned char c = *s;
3660 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
3661 if (len > UNRECOGNIZED_PRECEDE_COUNT) {
3662 d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
3667 Perl_croak(aTHX_ "Unrecognized character \\x%02X; marked by <-- HERE after %s<-- HERE near column %d", c, d, (int) len + 1);
3671 goto fake_eof; /* emulate EOF on ^D or ^Z */
3680 if (PL_lex_brackets) {
3681 yyerror((const char *)
3683 ? "Format not terminated"
3684 : "Missing right curly or square bracket"));
3686 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3687 "### Tokener got EOF\n");
3691 if (s++ < PL_bufend)
3692 goto retry; /* ignore stray nulls */
3695 if (!PL_in_eval && !PL_preambled) {
3696 PL_preambled = TRUE;
3702 /* Generate a string of Perl code to load the debugger.
3703 * If PERL5DB is set, it will return the contents of that,
3704 * otherwise a compile-time require of perl5db.pl. */
3706 const char * const pdb = PerlEnv_getenv("PERL5DB");
3709 sv_setpv(PL_linestr, pdb);
3710 sv_catpvs(PL_linestr,";");
3712 SETERRNO(0,SS_NORMAL);
3713 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
3716 sv_setpvs(PL_linestr,"");
3717 if (PL_preambleav) {
3718 SV **svp = AvARRAY(PL_preambleav);
3719 SV **const end = svp + AvFILLp(PL_preambleav);
3721 sv_catsv(PL_linestr, *svp);
3723 sv_catpvs(PL_linestr, ";");
3725 sv_free(MUTABLE_SV(PL_preambleav));
3726 PL_preambleav = NULL;
3729 sv_catpvs(PL_linestr,
3730 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
3731 if (PL_minus_n || PL_minus_p) {
3732 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3734 sv_catpvs(PL_linestr,"chomp;");
3737 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3738 || *PL_splitstr == '"')
3739 && strchr(PL_splitstr + 1, *PL_splitstr))
3740 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3742 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3743 bytes can be used as quoting characters. :-) */
3744 const char *splits = PL_splitstr;
3745 sv_catpvs(PL_linestr, "our @F=split(q\0");
3748 if (*splits == '\\')
3749 sv_catpvn(PL_linestr, splits, 1);
3750 sv_catpvn(PL_linestr, splits, 1);
3751 } while (*splits++);
3752 /* This loop will embed the trailing NUL of
3753 PL_linestr as the last thing it does before
3755 sv_catpvs(PL_linestr, ");");
3759 sv_catpvs(PL_linestr,"our @F=split(' ');");
3762 sv_catpvs(PL_linestr, "\n");
3763 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3764 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3765 PL_last_lop = PL_last_uni = NULL;
3766 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3767 update_debugger_info(PL_linestr, NULL, 0);
3771 bof = PL_rsfp ? TRUE : FALSE;
3772 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3775 PL_realtokenstart = -1;
3778 if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3779 PerlIO_clearerr(PL_rsfp);
3781 (void)PerlIO_close(PL_rsfp);
3783 PL_doextract = FALSE;
3785 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3791 sv_setpvs(PL_linestr, ";}continue{print;}");
3793 sv_setpvs(PL_linestr, ";}");
3794 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3795 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3796 PL_last_lop = PL_last_uni = NULL;
3797 PL_minus_n = PL_minus_p = 0;
3800 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3801 PL_last_lop = PL_last_uni = NULL;
3802 sv_setpvs(PL_linestr,"");
3803 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3805 /* If it looks like the start of a BOM or raw UTF-16,
3806 * check if it in fact is. */
3812 #ifdef PERLIO_IS_STDIO
3813 # ifdef __GNU_LIBRARY__
3814 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3815 # define FTELL_FOR_PIPE_IS_BROKEN
3819 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3820 # define FTELL_FOR_PIPE_IS_BROKEN
3825 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3827 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3828 s = swallow_bom((U8*)s);
3832 /* Incest with pod. */
3835 sv_catsv(PL_thiswhite, PL_linestr);
3837 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3838 sv_setpvs(PL_linestr, "");
3839 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3840 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3841 PL_last_lop = PL_last_uni = NULL;
3842 PL_doextract = FALSE;
3846 } while (PL_doextract);
3847 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3848 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3849 update_debugger_info(PL_linestr, NULL, 0);
3850 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3851 PL_last_lop = PL_last_uni = NULL;
3852 if (CopLINE(PL_curcop) == 1) {
3853 while (s < PL_bufend && isSPACE(*s))
3855 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3859 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3863 if (*s == '#' && *(s+1) == '!')
3865 #ifdef ALTERNATE_SHEBANG
3867 static char const as[] = ALTERNATE_SHEBANG;
3868 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3869 d = s + (sizeof(as) - 1);
3871 #endif /* ALTERNATE_SHEBANG */
3880 while (*d && !isSPACE(*d))
3884 #ifdef ARG_ZERO_IS_SCRIPT
3885 if (ipathend > ipath) {
3887 * HP-UX (at least) sets argv[0] to the script name,
3888 * which makes $^X incorrect. And Digital UNIX and Linux,
3889 * at least, set argv[0] to the basename of the Perl
3890 * interpreter. So, having found "#!", we'll set it right.
3892 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3894 assert(SvPOK(x) || SvGMAGICAL(x));
3895 if (sv_eq(x, CopFILESV(PL_curcop))) {
3896 sv_setpvn(x, ipath, ipathend - ipath);
3902 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3903 const char * const lstart = SvPV_const(x,llen);
3905 bstart += blen - llen;
3906 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3907 sv_setpvn(x, ipath, ipathend - ipath);
3912 TAINT_NOT; /* $^X is always tainted, but that's OK */
3914 #endif /* ARG_ZERO_IS_SCRIPT */
3919 d = instr(s,"perl -");
3921 d = instr(s,"perl");
3923 /* avoid getting into infinite loops when shebang
3924 * line contains "Perl" rather than "perl" */
3926 for (d = ipathend-4; d >= ipath; --d) {
3927 if ((*d == 'p' || *d == 'P')
3928 && !ibcmp(d, "perl", 4))
3938 #ifdef ALTERNATE_SHEBANG
3940 * If the ALTERNATE_SHEBANG on this system starts with a
3941 * character that can be part of a Perl expression, then if
3942 * we see it but not "perl", we're probably looking at the
3943 * start of Perl code, not a request to hand off to some
3944 * other interpreter. Similarly, if "perl" is there, but
3945 * not in the first 'word' of the line, we assume the line
3946 * contains the start of the Perl program.
3948 if (d && *s != '#') {
3949 const char *c = ipath;
3950 while (*c && !strchr("; \t\r\n\f\v#", *c))
3953 d = NULL; /* "perl" not in first word; ignore */
3955 *s = '#'; /* Don't try to parse shebang line */
3957 #endif /* ALTERNATE_SHEBANG */
3962 !instr(s,"indir") &&
3963 instr(PL_origargv[0],"perl"))
3970 while (s < PL_bufend && isSPACE(*s))
3972 if (s < PL_bufend) {
3973 Newx(newargv,PL_origargc+3,char*);
3975 while (s < PL_bufend && !isSPACE(*s))
3978 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3981 newargv = PL_origargv;
3984 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3986 Perl_croak(aTHX_ "Can't exec %s", ipath);
3989 while (*d && !isSPACE(*d))
3991 while (SPACE_OR_TAB(*d))
3995 const bool switches_done = PL_doswitches;
3996 const U32 oldpdb = PL_perldb;
3997 const bool oldn = PL_minus_n;
3998 const bool oldp = PL_minus_p;
4002 bool baduni = FALSE;
4004 const char *d2 = d1 + 1;
4005 if (parse_unicode_opts((const char **)&d2)
4009 if (baduni || *d1 == 'M' || *d1 == 'm') {
4010 const char * const m = d1;
4011 while (*d1 && !isSPACE(*d1))
4013 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
4016 d1 = moreswitches(d1);
4018 if (PL_doswitches && !switches_done) {
4019 int argc = PL_origargc;
4020 char **argv = PL_origargv;
4023 } while (argc && argv[0][0] == '-' && argv[0][1]);
4024 init_argv_symbols(argc,argv);
4026 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
4027 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
4028 /* if we have already added "LINE: while (<>) {",
4029 we must not do it again */
4031 sv_setpvs(PL_linestr, "");
4032 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
4033 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
4034 PL_last_lop = PL_last_uni = NULL;
4035 PL_preambled = FALSE;
4036 if (PERLDB_LINE || PERLDB_SAVESRC)
4037 (void)gv_fetchfile(PL_origfilename);
4044 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4046 PL_lex_state = LEX_FORMLINE;
4051 #ifdef PERL_STRICT_CR
4052 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4054 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4056 case ' ': case '\t': case '\f': case 013:
4058 PL_realtokenstart = -1;
4060 PL_thiswhite = newSVpvs("");
4061 sv_catpvn(PL_thiswhite, s, 1);
4068 PL_realtokenstart = -1;
4072 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
4073 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
4074 /* handle eval qq[#line 1 "foo"\n ...] */
4075 CopLINE_dec(PL_curcop);
4078 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
4080 if (!PL_in_eval || PL_rsfp)
4085 while (d < PL_bufend && *d != '\n')
4089 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4090 Perl_croak(aTHX_ "panic: input overflow");
4093 PL_thiswhite = newSVpvn(s, d - s);
4098 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4100 PL_lex_state = LEX_FORMLINE;
4106 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
4107 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
4110 TOKEN(PEG); /* make sure any #! line is accessible */
4115 /* if (PL_madskills && PL_lex_formbrack) { */
4117 while (d < PL_bufend && *d != '\n')
4121 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4122 Perl_croak(aTHX_ "panic: input overflow");
4123 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4125 PL_thiswhite = newSVpvs("");
4126 if (CopLINE(PL_curcop) == 1) {
4127 sv_setpvs(PL_thiswhite, "");
4130 sv_catpvn(PL_thiswhite, s, d - s);
4144 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4152 while (s < PL_bufend && SPACE_OR_TAB(*s))
4155 if (strnEQ(s,"=>",2)) {
4156 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4157 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4158 OPERATOR('-'); /* unary minus */
4160 PL_last_uni = PL_oldbufptr;
4162 case 'r': ftst = OP_FTEREAD; break;
4163 case 'w': ftst = OP_FTEWRITE; break;
4164 case 'x': ftst = OP_FTEEXEC; break;
4165 case 'o': ftst = OP_FTEOWNED; break;
4166 case 'R': ftst = OP_FTRREAD; break;
4167 case 'W': ftst = OP_FTRWRITE; break;
4168 case 'X': ftst = OP_FTREXEC; break;
4169 case 'O': ftst = OP_FTROWNED; break;
4170 case 'e': ftst = OP_FTIS; break;
4171 case 'z': ftst = OP_FTZERO; break;
4172 case 's': ftst = OP_FTSIZE; break;
4173 case 'f': ftst = OP_FTFILE; break;
4174 case 'd': ftst = OP_FTDIR; break;
4175 case 'l': ftst = OP_FTLINK; break;
4176 case 'p': ftst = OP_FTPIPE; break;
4177 case 'S': ftst = OP_FTSOCK; break;
4178 case 'u': ftst = OP_FTSUID; break;
4179 case 'g': ftst = OP_FTSGID; break;
4180 case 'k': ftst = OP_FTSVTX; break;
4181 case 'b': ftst = OP_FTBLK; break;
4182 case 'c': ftst = OP_FTCHR; break;
4183 case 't': ftst = OP_FTTTY; break;
4184 case 'T': ftst = OP_FTTEXT; break;
4185 case 'B': ftst = OP_FTBINARY; break;
4186 case 'M': case 'A': case 'C':
4187 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4189 case 'M': ftst = OP_FTMTIME; break;
4190 case 'A': ftst = OP_FTATIME; break;
4191 case 'C': ftst = OP_FTCTIME; break;
4199 PL_last_lop_op = (OPCODE)ftst;
4200 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4201 "### Saw file test %c\n", (int)tmp);
4206 /* Assume it was a minus followed by a one-letter named
4207 * subroutine call (or a -bareword), then. */
4208 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4209 "### '-%c' looked like a file test but was not\n",
4216 const char tmp = *s++;
4219 if (PL_expect == XOPERATOR)
4224 else if (*s == '>') {
4227 if (isIDFIRST_lazy_if(s,UTF)) {
4228 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4236 if (PL_expect == XOPERATOR)
4239 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4241 OPERATOR('-'); /* unary minus */
4247 const char tmp = *s++;
4250 if (PL_expect == XOPERATOR)
4255 if (PL_expect == XOPERATOR)
4258 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4265 if (PL_expect != XOPERATOR) {
4266 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4267 PL_expect = XOPERATOR;
4268 force_ident(PL_tokenbuf, '*');
4281 if (PL_expect == XOPERATOR) {
4285 PL_tokenbuf[0] = '%';
4286 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4287 sizeof PL_tokenbuf - 1, FALSE);
4288 if (!PL_tokenbuf[1]) {
4291 PL_pending_ident = '%';
4300 const char tmp = *s++;
4305 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4312 const char tmp = *s++;
4318 goto just_a_word_zero_gv;
4321 switch (PL_expect) {
4327 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4329 PL_bufptr = s; /* update in case we back off */
4335 PL_expect = XTERMBLOCK;
4338 stuffstart = s - SvPVX(PL_linestr) - 1;
4342 while (isIDFIRST_lazy_if(s,UTF)) {
4345 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4346 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4347 if (tmp < 0) tmp = -tmp;
4362 sv = newSVpvn(s, len);
4364 d = scan_str(d,TRUE,TRUE);
4366 /* MUST advance bufptr here to avoid bogus
4367 "at end of line" context messages from yyerror().
4369 PL_bufptr = s + len;
4370 yyerror("Unterminated attribute parameter in attribute list");
4374 return REPORT(0); /* EOF indicator */
4378 sv_catsv(sv, PL_lex_stuff);
4379 attrs = append_elem(OP_LIST, attrs,
4380 newSVOP(OP_CONST, 0, sv));
4381 SvREFCNT_dec(PL_lex_stuff);
4382 PL_lex_stuff = NULL;
4385 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4387 if (PL_in_my == KEY_our) {
4388 deprecate(":unique");
4391 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4394 /* NOTE: any CV attrs applied here need to be part of
4395 the CVf_BUILTIN_ATTRS define in cv.h! */
4396 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4398 CvLVALUE_on(PL_compcv);
4400 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4402 deprecate(":locked");
4404 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4406 CvMETHOD_on(PL_compcv);
4408 /* After we've set the flags, it could be argued that
4409 we don't need to do the attributes.pm-based setting
4410 process, and shouldn't bother appending recognized
4411 flags. To experiment with that, uncomment the
4412 following "else". (Note that's already been
4413 uncommented. That keeps the above-applied built-in
4414 attributes from being intercepted (and possibly
4415 rejected) by a package's attribute routines, but is
4416 justified by the performance win for the common case
4417 of applying only built-in attributes.) */
4419 attrs = append_elem(OP_LIST, attrs,
4420 newSVOP(OP_CONST, 0,
4424 if (*s == ':' && s[1] != ':')
4427 break; /* require real whitespace or :'s */
4428 /* XXX losing whitespace on sequential attributes here */
4432 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4433 if (*s != ';' && *s != '}' && *s != tmp
4434 && (tmp != '=' || *s != ')')) {
4435 const char q = ((*s == '\'') ? '"' : '\'');
4436 /* If here for an expression, and parsed no attrs, back
4438 if (tmp == '=' && !attrs) {
4442 /* MUST advance bufptr here to avoid bogus "at end of line"
4443 context messages from yyerror().
4446 yyerror( (const char *)
4448 ? Perl_form(aTHX_ "Invalid separator character "
4449 "%c%c%c in attribute list", q, *s, q)
4450 : "Unterminated attribute list" ) );
4458 start_force(PL_curforce);
4459 NEXTVAL_NEXTTOKE.opval = attrs;
4460 CURMAD('_', PL_nextwhite);
4465 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4466 (s - SvPVX(PL_linestr)) - stuffstart);
4474 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4475 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4483 const char tmp = *s++;
4488 const char tmp = *s++;
4496 if (PL_lex_brackets <= 0)
4497 yyerror("Unmatched right square bracket");
4500 if (PL_lex_state == LEX_INTERPNORMAL) {
4501 if (PL_lex_brackets == 0) {
4502 if (*s == '-' && s[1] == '>')
4503 PL_lex_state = LEX_INTERPENDMAYBE;
4504 else if (*s != '[' && *s != '{')
4505 PL_lex_state = LEX_INTERPEND;
4512 if (PL_lex_brackets > 100) {
4513 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4515 switch (PL_expect) {
4517 if (PL_lex_formbrack) {
4521 if (PL_oldoldbufptr == PL_last_lop)
4522 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4524 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4525 OPERATOR(HASHBRACK);
4527 while (s < PL_bufend && SPACE_OR_TAB(*s))
4530 PL_tokenbuf[0] = '\0';
4531 if (d < PL_bufend && *d == '-') {
4532 PL_tokenbuf[0] = '-';
4534 while (d < PL_bufend && SPACE_OR_TAB(*d))
4537 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4538 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4540 while (d < PL_bufend && SPACE_OR_TAB(*d))
4543 const char minus = (PL_tokenbuf[0] == '-');
4544 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4552 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4557 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4562 if (PL_oldoldbufptr == PL_last_lop)
4563 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4565 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4568 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4570 /* This hack is to get the ${} in the message. */
4572 yyerror("syntax error");
4575 OPERATOR(HASHBRACK);
4577 /* This hack serves to disambiguate a pair of curlies
4578 * as being a block or an anon hash. Normally, expectation
4579 * determines that, but in cases where we're not in a
4580 * position to expect anything in particular (like inside
4581 * eval"") we have to resolve the ambiguity. This code
4582 * covers the case where the first term in the curlies is a
4583 * quoted string. Most other cases need to be explicitly
4584 * disambiguated by prepending a "+" before the opening
4585 * curly in order to force resolution as an anon hash.
4587 * XXX should probably propagate the outer expectation
4588 * into eval"" to rely less on this hack, but that could
4589 * potentially break current behavior of eval"".
4593 if (*s == '\'' || *s == '"' || *s == '`') {
4594 /* common case: get past first string, handling escapes */
4595 for (t++; t < PL_bufend && *t != *s;)
4596 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4600 else if (*s == 'q') {
4603 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4606 /* skip q//-like construct */
4608 char open, close, term;
4611 while (t < PL_bufend && isSPACE(*t))
4613 /* check for q => */
4614 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4615 OPERATOR(HASHBRACK);
4619 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4623 for (t++; t < PL_bufend; t++) {
4624 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4626 else if (*t == open)
4630 for (t++; t < PL_bufend; t++) {
4631 if (*t == '\\' && t+1 < PL_bufend)
4633 else if (*t == close && --brackets <= 0)
4635 else if (*t == open)
4642 /* skip plain q word */
4643 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4646 else if (isALNUM_lazy_if(t,UTF)) {
4648 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4651 while (t < PL_bufend && isSPACE(*t))
4653 /* if comma follows first term, call it an anon hash */
4654 /* XXX it could be a comma expression with loop modifiers */
4655 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4656 || (*t == '=' && t[1] == '>')))
4657 OPERATOR(HASHBRACK);
4658 if (PL_expect == XREF)
4661 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4667 pl_yylval.ival = CopLINE(PL_curcop);
4668 if (isSPACE(*s) || *s == '#')
4669 PL_copline = NOLINE; /* invalidate current command line number */
4674 if (PL_lex_brackets <= 0)
4675 yyerror("Unmatched right curly bracket");
4677 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4678 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4679 PL_lex_formbrack = 0;
4680 if (PL_lex_state == LEX_INTERPNORMAL) {
4681 if (PL_lex_brackets == 0) {
4682 if (PL_expect & XFAKEBRACK) {
4683 PL_expect &= XENUMMASK;
4684 PL_lex_state = LEX_INTERPEND;
4689 PL_thiswhite = newSVpvs("");
4690 sv_catpvs(PL_thiswhite,"}");
4693 return yylex(); /* ignore fake brackets */
4695 if (*s == '-' && s[1] == '>')
4696 PL_lex_state = LEX_INTERPENDMAYBE;
4697 else if (*s != '[' && *s != '{')
4698 PL_lex_state = LEX_INTERPEND;
4701 if (PL_expect & XFAKEBRACK) {
4702 PL_expect &= XENUMMASK;
4704 return yylex(); /* ignore fake brackets */
4706 start_force(PL_curforce);
4708 curmad('X', newSVpvn(s-1,1));
4709 CURMAD('_', PL_thiswhite);
4714 PL_thistoken = newSVpvs("");
4722 if (PL_expect == XOPERATOR) {
4723 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4724 && isIDFIRST_lazy_if(s,UTF))
4726 CopLINE_dec(PL_curcop);
4727 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
4728 CopLINE_inc(PL_curcop);
4733 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4735 PL_expect = XOPERATOR;
4736 force_ident(PL_tokenbuf, '&');
4740 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
4752 const char tmp = *s++;
4759 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4760 && strchr("+-*/%.^&|<",tmp))
4761 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4762 "Reversed %c= operator",(int)tmp);
4764 if (PL_expect == XSTATE && isALPHA(tmp) &&
4765 (s == PL_linestart+1 || s[-2] == '\n') )
4767 if (PL_in_eval && !PL_rsfp) {
4772 if (strnEQ(s,"=cut",4)) {
4788 PL_thiswhite = newSVpvs("");
4789 sv_catpvn(PL_thiswhite, PL_linestart,
4790 PL_bufend - PL_linestart);
4794 PL_doextract = TRUE;
4798 if (PL_lex_brackets < PL_lex_formbrack) {
4800 #ifdef PERL_STRICT_CR
4801 while (SPACE_OR_TAB(*t))
4803 while (SPACE_OR_TAB(*t) || *t == '\r')
4806 if (*t == '\n' || *t == '#') {
4817 const char tmp = *s++;
4819 /* was this !=~ where !~ was meant?
4820 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4822 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4823 const char *t = s+1;
4825 while (t < PL_bufend && isSPACE(*t))
4828 if (*t == '/' || *t == '?' ||
4829 ((*t == 'm' || *t == 's' || *t == 'y')
4830 && !isALNUM(t[1])) ||
4831 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4832 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4833 "!=~ should be !~");
4843 if (PL_expect != XOPERATOR) {
4844 if (s[1] != '<' && !strchr(s,'>'))
4847 s = scan_heredoc(s);
4849 s = scan_inputsymbol(s);
4850 TERM(sublex_start());
4856 SHop(OP_LEFT_SHIFT);
4870 const char tmp = *s++;
4872 SHop(OP_RIGHT_SHIFT);
4873 else if (tmp == '=')
4882 if (PL_expect == XOPERATOR) {
4883 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4885 deprecate_old(commaless_variable_list);
4886 return REPORT(','); /* grandfather non-comma-format format */
4890 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4891 PL_tokenbuf[0] = '@';
4892 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4893 sizeof PL_tokenbuf - 1, FALSE);
4894 if (PL_expect == XOPERATOR)
4895 no_op("Array length", s);
4896 if (!PL_tokenbuf[1])
4898 PL_expect = XOPERATOR;
4899 PL_pending_ident = '#';
4903 PL_tokenbuf[0] = '$';
4904 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4905 sizeof PL_tokenbuf - 1, FALSE);
4906 if (PL_expect == XOPERATOR)
4908 if (!PL_tokenbuf[1]) {
4910 yyerror("Final $ should be \\$ or $name");
4914 /* This kludge not intended to be bulletproof. */
4915 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4916 pl_yylval.opval = newSVOP(OP_CONST, 0,
4917 newSViv(CopARYBASE_get(&PL_compiling)));
4918 pl_yylval.opval->op_private = OPpCONST_ARYBASE;
4924 const char tmp = *s;
4925 if (PL_lex_state == LEX_NORMAL)
4928 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4929 && intuit_more(s)) {
4931 PL_tokenbuf[0] = '@';
4932 if (ckWARN(WARN_SYNTAX)) {
4935 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4938 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4939 while (t < PL_bufend && *t != ']')
4941 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4942 "Multidimensional syntax %.*s not supported",
4943 (int)((t - PL_bufptr) + 1), PL_bufptr);
4947 else if (*s == '{') {
4949 PL_tokenbuf[0] = '%';
4950 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4951 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4953 char tmpbuf[sizeof PL_tokenbuf];
4956 } while (isSPACE(*t));
4957 if (isIDFIRST_lazy_if(t,UTF)) {
4959 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4963 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4964 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4965 "You need to quote \"%s\"",
4972 PL_expect = XOPERATOR;
4973 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4974 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4975 if (!islop || PL_last_lop_op == OP_GREPSTART)
4976 PL_expect = XOPERATOR;
4977 else if (strchr("$@\"'`q", *s))
4978 PL_expect = XTERM; /* e.g. print $fh "foo" */
4979 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4980 PL_expect = XTERM; /* e.g. print $fh &sub */
4981 else if (isIDFIRST_lazy_if(s,UTF)) {
4982 char tmpbuf[sizeof PL_tokenbuf];
4984 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4985 if ((t2 = keyword(tmpbuf, len, 0))) {
4986 /* binary operators exclude handle interpretations */
4998 PL_expect = XTERM; /* e.g. print $fh length() */
5003 PL_expect = XTERM; /* e.g. print $fh subr() */
5006 else if (isDIGIT(*s))
5007 PL_expect = XTERM; /* e.g. print $fh 3 */
5008 else if (*s == '.' && isDIGIT(s[1]))
5009 PL_expect = XTERM; /* e.g. print $fh .3 */
5010 else if ((*s == '?' || *s == '-' || *s == '+')
5011 && !isSPACE(s[1]) && s[1] != '=')
5012 PL_expect = XTERM; /* e.g. print $fh -1 */
5013 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
5015 PL_expect = XTERM; /* e.g. print $fh /.../
5016 XXX except DORDOR operator
5018 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
5020 PL_expect = XTERM; /* print $fh <<"EOF" */
5023 PL_pending_ident = '$';
5027 if (PL_expect == XOPERATOR)
5029 PL_tokenbuf[0] = '@';
5030 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5031 if (!PL_tokenbuf[1]) {
5034 if (PL_lex_state == LEX_NORMAL)
5036 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5038 PL_tokenbuf[0] = '%';
5040 /* Warn about @ where they meant $. */
5041 if (*s == '[' || *s == '{') {
5042 if (ckWARN(WARN_SYNTAX)) {
5043 const char *t = s + 1;
5044 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
5046 if (*t == '}' || *t == ']') {
5048 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
5049 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5050 "Scalar value %.*s better written as $%.*s",
5051 (int)(t-PL_bufptr), PL_bufptr,
5052 (int)(t-PL_bufptr-1), PL_bufptr+1);
5057 PL_pending_ident = '@';
5060 case '/': /* may be division, defined-or, or pattern */
5061 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
5065 case '?': /* may either be conditional or pattern */
5066 if (PL_expect == XOPERATOR) {
5074 /* A // operator. */
5084 /* Disable warning on "study /blah/" */
5085 if (PL_oldoldbufptr == PL_last_uni
5086 && (*PL_last_uni != 's' || s - PL_last_uni < 5
5087 || memNE(PL_last_uni, "study", 5)
5088 || isALNUM_lazy_if(PL_last_uni+5,UTF)
5091 s = scan_pat(s,OP_MATCH);
5092 TERM(sublex_start());
5096 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
5097 #ifdef PERL_STRICT_CR
5100 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
5102 && (s == PL_linestart || s[-1] == '\n') )
5104 PL_lex_formbrack = 0;
5108 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
5112 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
5118 pl_yylval.ival = OPf_SPECIAL;
5124 if (PL_expect != XOPERATOR)
5129 case '0': case '1': case '2': case '3': case '4':
5130 case '5': case '6': case '7': case '8': case '9':
5131 s = scan_num(s, &pl_yylval);
5132 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
5133 if (PL_expect == XOPERATOR)
5138 s = scan_str(s,!!PL_madskills,FALSE);
5139 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5140 if (PL_expect == XOPERATOR) {
5141 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5143 deprecate_old(commaless_variable_list);
5144 return REPORT(','); /* grandfather non-comma-format format */
5151 pl_yylval.ival = OP_CONST;
5152 TERM(sublex_start());
5155 s = scan_str(s,!!PL_madskills,FALSE);
5156 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5157 if (PL_expect == XOPERATOR) {
5158 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5160 deprecate_old(commaless_variable_list);
5161 return REPORT(','); /* grandfather non-comma-format format */
5168 pl_yylval.ival = OP_CONST;
5169 /* FIXME. I think that this can be const if char *d is replaced by
5170 more localised variables. */
5171 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5172 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5173 pl_yylval.ival = OP_STRINGIFY;
5177 TERM(sublex_start());
5180 s = scan_str(s,!!PL_madskills,FALSE);
5181 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5182 if (PL_expect == XOPERATOR)
5183 no_op("Backticks",s);
5186 readpipe_override();
5187 TERM(sublex_start());
5191 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5192 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5194 if (PL_expect == XOPERATOR)
5195 no_op("Backslash",s);
5199 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5200 char *start = s + 2;
5201 while (isDIGIT(*start) || *start == '_')
5203 if (*start == '.' && isDIGIT(start[1])) {
5204 s = scan_num(s, &pl_yylval);
5207 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5208 else if (!isALPHA(*start) && (PL_expect == XTERM
5209 || PL_expect == XREF || PL_expect == XSTATE
5210 || PL_expect == XTERMORDORDOR)) {
5211 GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
5213 s = scan_num(s, &pl_yylval);
5220 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5262 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5264 /* Some keywords can be followed by any delimiter, including ':' */
5265 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5266 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5267 (PL_tokenbuf[0] == 'q' &&
5268 strchr("qwxr", PL_tokenbuf[1])))));
5270 /* x::* is just a word, unless x is "CORE" */
5271 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5275 while (d < PL_bufend && isSPACE(*d))
5276 d++; /* no comments skipped here, or s### is misparsed */
5278 /* Is this a label? */
5279 if (!tmp && PL_expect == XSTATE
5280 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5281 tmp = keyword(PL_tokenbuf, len, 0);
5283 Perl_croak(aTHX_ "Can't use keyword '%s' as a label", PL_tokenbuf);
5285 pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5290 /* Check for keywords */
5291 tmp = keyword(PL_tokenbuf, len, 0);
5293 /* Is this a word before a => operator? */
5294 if (*d == '=' && d[1] == '>') {
5297 = (OP*)newSVOP(OP_CONST, 0,
5298 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5299 pl_yylval.opval->op_private = OPpCONST_BARE;
5303 if (tmp < 0) { /* second-class keyword? */
5304 GV *ogv = NULL; /* override (winner) */
5305 GV *hgv = NULL; /* hidden (loser) */
5306 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5308 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5311 if (GvIMPORTED_CV(gv))
5313 else if (! CvMETHOD(cv))
5317 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5318 (gv = *gvp) && isGV_with_GP(gv) &&
5319 GvCVu(gv) && GvIMPORTED_CV(gv))
5326 tmp = 0; /* overridden by import or by GLOBAL */
5329 && -tmp==KEY_lock /* XXX generalizable kludge */
5332 tmp = 0; /* any sub overrides "weak" keyword */
5334 else { /* no override */
5336 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5337 Perl_warner(aTHX_ packWARN(WARN_MISC),
5338 "dump() better written as CORE::dump()");
5342 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5343 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
5344 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5345 "Ambiguous call resolved as CORE::%s(), %s",
5346 GvENAME(hgv), "qualify as such or use &");
5353 default: /* not a keyword */
5354 /* Trade off - by using this evil construction we can pull the
5355 variable gv into the block labelled keylookup. If not, then
5356 we have to give it function scope so that the goto from the
5357 earlier ':' case doesn't bypass the initialisation. */
5359 just_a_word_zero_gv:
5367 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5370 SV *nextPL_nextwhite = 0;
5374 /* Get the rest if it looks like a package qualifier */
5376 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5378 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5381 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5382 *s == '\'' ? "'" : "::");
5387 if (PL_expect == XOPERATOR) {
5388 if (PL_bufptr == PL_linestart) {
5389 CopLINE_dec(PL_curcop);
5390 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5391 CopLINE_inc(PL_curcop);
5394 no_op("Bareword",s);
5397 /* Look for a subroutine with this name in current package,
5398 unless name is "Foo::", in which case Foo is a bearword
5399 (and a package name). */
5401 if (len > 2 && !PL_madskills &&
5402 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5404 if (ckWARN(WARN_BAREWORD)
5405 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5406 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5407 "Bareword \"%s\" refers to nonexistent package",
5410 PL_tokenbuf[len] = '\0';
5416 /* Mustn't actually add anything to a symbol table.
5417 But also don't want to "initialise" any placeholder
5418 constants that might already be there into full
5419 blown PVGVs with attached PVCV. */
5420 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5421 GV_NOADD_NOINIT, SVt_PVCV);
5426 /* if we saw a global override before, get the right name */
5429 sv = newSVpvs("CORE::GLOBAL::");
5430 sv_catpv(sv,PL_tokenbuf);
5433 /* If len is 0, newSVpv does strlen(), which is correct.
5434 If len is non-zero, then it will be the true length,
5435 and so the scalar will be created correctly. */
5436 sv = newSVpv(PL_tokenbuf,len);
5439 if (PL_madskills && !PL_thistoken) {
5440 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5441 PL_thistoken = newSVpvn(start,s - start);
5442 PL_realtokenstart = s - SvPVX(PL_linestr);
5446 /* Presume this is going to be a bareword of some sort. */
5449 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5450 pl_yylval.opval->op_private = OPpCONST_BARE;
5451 /* UTF-8 package name? */
5452 if (UTF && !IN_BYTES &&
5453 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5456 /* And if "Foo::", then that's what it certainly is. */
5461 /* Do the explicit type check so that we don't need to force
5462 the initialisation of the symbol table to have a real GV.
5463 Beware - gv may not really be a PVGV, cv may not really be
5464 a PVCV, (because of the space optimisations that gv_init
5465 understands) But they're true if for this symbol there is
5466 respectively a typeglob and a subroutine.
5468 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5469 /* Real typeglob, so get the real subroutine: */
5471 /* A proxy for a subroutine in this package? */
5472 : SvOK(gv) ? MUTABLE_CV(gv) : NULL)
5475 /* See if it's the indirect object for a list operator. */
5477 if (PL_oldoldbufptr &&
5478 PL_oldoldbufptr < PL_bufptr &&
5479 (PL_oldoldbufptr == PL_last_lop
5480 || PL_oldoldbufptr == PL_last_uni) &&
5481 /* NO SKIPSPACE BEFORE HERE! */
5482 (PL_expect == XREF ||
5483 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5485 bool immediate_paren = *s == '(';
5487 /* (Now we can afford to cross potential line boundary.) */
5488 s = SKIPSPACE2(s,nextPL_nextwhite);
5490 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5493 /* Two barewords in a row may indicate method call. */
5495 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5496 (tmp = intuit_method(s, gv, cv)))
5499 /* If not a declared subroutine, it's an indirect object. */
5500 /* (But it's an indir obj regardless for sort.) */
5501 /* Also, if "_" follows a filetest operator, it's a bareword */
5504 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5506 (PL_last_lop_op != OP_MAPSTART &&
5507 PL_last_lop_op != OP_GREPSTART))))
5508 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5509 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5512 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5517 PL_expect = XOPERATOR;
5520 s = SKIPSPACE2(s,nextPL_nextwhite);
5521 PL_nextwhite = nextPL_nextwhite;
5526 /* Is this a word before a => operator? */
5527 if (*s == '=' && s[1] == '>' && !pkgname) {
5529 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
5530 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5531 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
5535 /* If followed by a paren, it's certainly a subroutine. */
5540 while (SPACE_OR_TAB(*d))
5542 if (*d == ')' && (sv = gv_const_sv(gv))) {
5549 PL_nextwhite = PL_thiswhite;
5552 start_force(PL_curforce);
5554 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5555 PL_expect = XOPERATOR;
5558 PL_nextwhite = nextPL_nextwhite;
5559 curmad('X', PL_thistoken);
5560 PL_thistoken = newSVpvs("");
5568 /* If followed by var or block, call it a method (unless sub) */
5570 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5571 PL_last_lop = PL_oldbufptr;
5572 PL_last_lop_op = OP_METHOD;
5576 /* If followed by a bareword, see if it looks like indir obj. */
5579 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5580 && (tmp = intuit_method(s, gv, cv)))
5583 /* Not a method, so call it a subroutine (if defined) */
5586 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5587 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5588 "Ambiguous use of -%s resolved as -&%s()",
5589 PL_tokenbuf, PL_tokenbuf);
5590 /* Check for a constant sub */
5591 if ((sv = gv_const_sv(gv))) {
5593 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
5594 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5595 pl_yylval.opval->op_private = 0;
5599 /* Resolve to GV now. */
5600 if (SvTYPE(gv) != SVt_PVGV) {
5601 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5602 assert (SvTYPE(gv) == SVt_PVGV);
5603 /* cv must have been some sort of placeholder, so
5604 now needs replacing with a real code reference. */
5608 op_free(pl_yylval.opval);
5609 pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5610 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5611 PL_last_lop = PL_oldbufptr;
5612 PL_last_lop_op = OP_ENTERSUB;
5613 /* Is there a prototype? */
5621 const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
5624 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5626 while (*proto == ';')
5628 if (*proto == '&' && *s == '{') {
5630 sv_setpvs(PL_subname, "__ANON__");
5632 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5639 PL_nextwhite = PL_thiswhite;
5642 start_force(PL_curforce);
5643 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5646 PL_nextwhite = nextPL_nextwhite;
5647 curmad('X', PL_thistoken);
5648 PL_thistoken = newSVpvs("");
5655 /* Guess harder when madskills require "best effort". */
5656 if (PL_madskills && (!gv || !GvCVu(gv))) {
5657 int probable_sub = 0;
5658 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5660 else if (isALPHA(*s)) {
5664 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5665 if (!keyword(tmpbuf, tmplen, 0))
5668 while (d < PL_bufend && isSPACE(*d))
5670 if (*d == '=' && d[1] == '>')
5675 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5676 op_free(pl_yylval.opval);
5677 pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5678 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5679 PL_last_lop = PL_oldbufptr;
5680 PL_last_lop_op = OP_ENTERSUB;
5681 PL_nextwhite = PL_thiswhite;
5683 start_force(PL_curforce);
5684 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5686 PL_nextwhite = nextPL_nextwhite;
5687 curmad('X', PL_thistoken);
5688 PL_thistoken = newSVpvs("");
5693 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5700 /* Call it a bare word */
5703 if (PL_hints & HINT_STRICT_SUBS)
5704 pl_yylval.opval->op_private |= OPpCONST_STRICT;
5706 if (lastchar != '-') {
5707 if (ckWARN(WARN_RESERVED)) {
5711 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5712 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5719 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5720 && ckWARN_d(WARN_AMBIGUOUS)) {
5721 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5722 "Operator or semicolon missing before %c%s",
5723 lastchar, PL_tokenbuf);
5724 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5725 "Ambiguous use of %c resolved as operator %c",
5726 lastchar, lastchar);
5732 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5733 newSVpv(CopFILE(PL_curcop),0));
5737 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5738 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5741 case KEY___PACKAGE__:
5742 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5744 ? newSVhek(HvNAME_HEK(PL_curstash))
5751 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5752 const char *pname = "main";
5753 if (PL_tokenbuf[2] == 'D')
5754 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5755 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5759 GvIOp(gv) = newIO();
5760 IoIFP(GvIOp(gv)) = PL_rsfp;
5761 #if defined(HAS_FCNTL) && defined(F_SETFD)
5763 const int fd = PerlIO_fileno(PL_rsfp);
5764 fcntl(fd,F_SETFD,fd >= 3);
5767 /* Mark this internal pseudo-handle as clean */
5768 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5769 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5770 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5772 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5773 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5774 /* if the script was opened in binmode, we need to revert
5775 * it to text mode for compatibility; but only iff it has CRs
5776 * XXX this is a questionable hack at best. */
5777 if (PL_bufend-PL_bufptr > 2
5778 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5781 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5782 loc = PerlIO_tell(PL_rsfp);
5783 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5786 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5788 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5789 #endif /* NETWARE */
5790 #ifdef PERLIO_IS_STDIO /* really? */
5791 # if defined(__BORLANDC__)
5792 /* XXX see note in do_binmode() */
5793 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5797 PerlIO_seek(PL_rsfp, loc, 0);
5801 #ifdef PERLIO_LAYERS
5804 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5805 else if (PL_encoding) {
5812 XPUSHs(PL_encoding);
5814 call_method("name", G_SCALAR);
5818 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5819 Perl_form(aTHX_ ":encoding(%"SVf")",
5828 if (PL_realtokenstart >= 0) {
5829 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5831 PL_endwhite = newSVpvs("");
5832 sv_catsv(PL_endwhite, PL_thiswhite);
5834 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5835 PL_realtokenstart = -1;
5837 while ((s = filter_gets(PL_endwhite, PL_rsfp,
5838 SvCUR(PL_endwhite))) != NULL) ;
5853 if (PL_expect == XSTATE) {
5860 if (*s == ':' && s[1] == ':') {
5863 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5864 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5865 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5868 else if (tmp == KEY_require || tmp == KEY_do)
5869 /* that's a way to remember we saw "CORE::" */
5882 LOP(OP_ACCEPT,XTERM);
5888 LOP(OP_ATAN2,XTERM);
5894 LOP(OP_BINMODE,XTERM);
5897 LOP(OP_BLESS,XTERM);
5906 /* When 'use switch' is in effect, continue has a dual
5907 life as a control operator. */
5909 if (!FEATURE_IS_ENABLED("switch"))
5912 /* We have to disambiguate the two senses of
5913 "continue". If the next token is a '{' then
5914 treat it as the start of a continue block;
5915 otherwise treat it as a control operator.
5927 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5944 if (!PL_cryptseen) {
5945 PL_cryptseen = TRUE;
5949 LOP(OP_CRYPT,XTERM);
5952 LOP(OP_CHMOD,XTERM);
5955 LOP(OP_CHOWN,XTERM);
5958 LOP(OP_CONNECT,XTERM);
5977 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5978 if (orig_keyword == KEY_do) {
5987 PL_hints |= HINT_BLOCK_SCOPE;
5997 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5998 LOP(OP_DBMOPEN,XTERM);
6004 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6011 pl_yylval.ival = CopLINE(PL_curcop);
6027 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
6028 UNIBRACK(OP_ENTEREVAL);
6042 case KEY_endhostent:
6048 case KEY_endservent:
6051 case KEY_endprotoent:
6062 pl_yylval.ival = CopLINE(PL_curcop);
6064 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
6067 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
6070 if ((PL_bufend - p) >= 3 &&
6071 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
6073 else if ((PL_bufend - p) >= 4 &&
6074 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
6077 if (isIDFIRST_lazy_if(p,UTF)) {
6078 p = scan_ident(p, PL_bufend,
6079 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
6083 Perl_croak(aTHX_ "Missing $ on loop variable");
6085 s = SvPVX(PL_linestr) + soff;
6091 LOP(OP_FORMLINE,XTERM);
6097 LOP(OP_FCNTL,XTERM);
6103 LOP(OP_FLOCK,XTERM);
6112 LOP(OP_GREPSTART, XREF);
6115 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6130 case KEY_getpriority:
6131 LOP(OP_GETPRIORITY,XTERM);
6133 case KEY_getprotobyname:
6136 case KEY_getprotobynumber:
6137 LOP(OP_GPBYNUMBER,XTERM);
6139 case KEY_getprotoent:
6151 case KEY_getpeername:
6152 UNI(OP_GETPEERNAME);
6154 case KEY_gethostbyname:
6157 case KEY_gethostbyaddr:
6158 LOP(OP_GHBYADDR,XTERM);
6160 case KEY_gethostent:
6163 case KEY_getnetbyname:
6166 case KEY_getnetbyaddr:
6167 LOP(OP_GNBYADDR,XTERM);
6172 case KEY_getservbyname:
6173 LOP(OP_GSBYNAME,XTERM);
6175 case KEY_getservbyport:
6176 LOP(OP_GSBYPORT,XTERM);
6178 case KEY_getservent:
6181 case KEY_getsockname:
6182 UNI(OP_GETSOCKNAME);
6184 case KEY_getsockopt:
6185 LOP(OP_GSOCKOPT,XTERM);
6200 pl_yylval.ival = CopLINE(PL_curcop);
6210 pl_yylval.ival = CopLINE(PL_curcop);
6214 LOP(OP_INDEX,XTERM);
6220 LOP(OP_IOCTL,XTERM);
6232 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6264 LOP(OP_LISTEN,XTERM);
6273 s = scan_pat(s,OP_MATCH);
6274 TERM(sublex_start());
6277 LOP(OP_MAPSTART, XREF);
6280 LOP(OP_MKDIR,XTERM);
6283 LOP(OP_MSGCTL,XTERM);
6286 LOP(OP_MSGGET,XTERM);
6289 LOP(OP_MSGRCV,XTERM);
6292 LOP(OP_MSGSND,XTERM);
6297 PL_in_my = (U16)tmp;
6299 if (isIDFIRST_lazy_if(s,UTF)) {
6303 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6304 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6306 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6307 if (!PL_in_my_stash) {
6310 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6314 if (PL_madskills) { /* just add type to declarator token */
6315 sv_catsv(PL_thistoken, PL_nextwhite);
6317 sv_catpvn(PL_thistoken, start, s - start);
6325 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6332 s = tokenize_use(0, s);
6336 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6343 if (isIDFIRST_lazy_if(s,UTF)) {
6345 for (d = s; isALNUM_lazy_if(d,UTF);)
6347 for (t=d; isSPACE(*t);)
6349 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6351 && !(t[0] == '=' && t[1] == '>')
6353 int parms_len = (int)(d-s);
6354 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6355 "Precedence problem: open %.*s should be open(%.*s)",
6356 parms_len, s, parms_len, s);
6362 pl_yylval.ival = OP_OR;
6372 LOP(OP_OPEN_DIR,XTERM);
6375 checkcomma(s,PL_tokenbuf,"filehandle");
6379 checkcomma(s,PL_tokenbuf,"filehandle");
6398 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6402 LOP(OP_PIPE_OP,XTERM);
6405 s = scan_str(s,!!PL_madskills,FALSE);
6408 pl_yylval.ival = OP_CONST;
6409 TERM(sublex_start());
6415 s = scan_str(s,!!PL_madskills,FALSE);
6418 PL_expect = XOPERATOR;
6420 if (SvCUR(PL_lex_stuff)) {
6423 d = SvPV_force(PL_lex_stuff, len);
6425 for (; isSPACE(*d) && len; --len, ++d)
6430 if (!warned && ckWARN(WARN_QW)) {
6431 for (; !isSPACE(*d) && len; --len, ++d) {
6433 Perl_warner(aTHX_ packWARN(WARN_QW),
6434 "Possible attempt to separate words with commas");
6437 else if (*d == '#') {
6438 Perl_warner(aTHX_ packWARN(WARN_QW),
6439 "Possible attempt to put comments in qw() list");
6445 for (; !isSPACE(*d) && len; --len, ++d)
6448 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
6449 words = append_elem(OP_LIST, words,
6450 newSVOP(OP_CONST, 0, tokeq(sv)));
6454 start_force(PL_curforce);
6455 NEXTVAL_NEXTTOKE.opval = words;
6460 SvREFCNT_dec(PL_lex_stuff);
6461 PL_lex_stuff = NULL;
6467 s = scan_str(s,!!PL_madskills,FALSE);
6470 pl_yylval.ival = OP_STRINGIFY;
6471 if (SvIVX(PL_lex_stuff) == '\'')
6472 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6473 TERM(sublex_start());
6476 s = scan_pat(s,OP_QR);
6477 TERM(sublex_start());
6480 s = scan_str(s,!!PL_madskills,FALSE);
6483 readpipe_override();
6484 TERM(sublex_start());
6492 s = force_version(s, FALSE);
6494 else if (*s != 'v' || !isDIGIT(s[1])
6495 || (s = force_version(s, TRUE), *s == 'v'))
6497 *PL_tokenbuf = '\0';
6498 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6499 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6500 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6502 yyerror("<> should be quotes");
6504 if (orig_keyword == KEY_require) {
6512 PL_last_uni = PL_oldbufptr;
6513 PL_last_lop_op = OP_REQUIRE;
6515 return REPORT( (int)REQUIRE );
6521 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6525 LOP(OP_RENAME,XTERM);
6534 LOP(OP_RINDEX,XTERM);
6543 UNIDOR(OP_READLINE);
6546 UNIDOR(OP_BACKTICK);
6555 LOP(OP_REVERSE,XTERM);
6558 UNIDOR(OP_READLINK);
6565 if (pl_yylval.opval)
6566 TERM(sublex_start());
6568 TOKEN(1); /* force error */
6571 checkcomma(s,PL_tokenbuf,"filehandle");
6581 LOP(OP_SELECT,XTERM);
6587 LOP(OP_SEMCTL,XTERM);
6590 LOP(OP_SEMGET,XTERM);
6593 LOP(OP_SEMOP,XTERM);
6599 LOP(OP_SETPGRP,XTERM);
6601 case KEY_setpriority:
6602 LOP(OP_SETPRIORITY,XTERM);
6604 case KEY_sethostent:
6610 case KEY_setservent:
6613 case KEY_setprotoent:
6623 LOP(OP_SEEKDIR,XTERM);
6625 case KEY_setsockopt:
6626 LOP(OP_SSOCKOPT,XTERM);
6632 LOP(OP_SHMCTL,XTERM);
6635 LOP(OP_SHMGET,XTERM);
6638 LOP(OP_SHMREAD,XTERM);
6641 LOP(OP_SHMWRITE,XTERM);
6644 LOP(OP_SHUTDOWN,XTERM);
6653 LOP(OP_SOCKET,XTERM);
6655 case KEY_socketpair:
6656 LOP(OP_SOCKPAIR,XTERM);
6659 checkcomma(s,PL_tokenbuf,"subroutine name");
6661 if (*s == ';' || *s == ')') /* probably a close */
6662 Perl_croak(aTHX_ "sort is now a reserved word");
6664 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6668 LOP(OP_SPLIT,XTERM);
6671 LOP(OP_SPRINTF,XTERM);
6674 LOP(OP_SPLICE,XTERM);
6689 LOP(OP_SUBSTR,XTERM);
6695 char tmpbuf[sizeof PL_tokenbuf];
6696 SSize_t tboffset = 0;
6697 expectation attrful;
6698 bool have_name, have_proto;
6699 const int key = tmp;
6704 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6705 SV *subtoken = newSVpvn(tstart, s - tstart);
6709 s = SKIPSPACE2(s,tmpwhite);
6714 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6715 (*s == ':' && s[1] == ':'))
6718 SV *nametoke = NULL;
6722 attrful = XATTRBLOCK;
6723 /* remember buffer pos'n for later force_word */
6724 tboffset = s - PL_oldbufptr;
6725 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6728 nametoke = newSVpvn(s, d - s);
6730 if (memchr(tmpbuf, ':', len))
6731 sv_setpvn(PL_subname, tmpbuf, len);
6733 sv_setsv(PL_subname,PL_curstname);
6734 sv_catpvs(PL_subname,"::");
6735 sv_catpvn(PL_subname,tmpbuf,len);
6742 CURMAD('X', nametoke);
6743 CURMAD('_', tmpwhite);
6744 (void) force_word(PL_oldbufptr + tboffset, WORD,
6747 s = SKIPSPACE2(d,tmpwhite);
6754 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6755 PL_expect = XTERMBLOCK;
6756 attrful = XATTRTERM;
6757 sv_setpvs(PL_subname,"?");
6761 if (key == KEY_format) {
6763 PL_lex_formbrack = PL_lex_brackets + 1;
6765 PL_thistoken = subtoken;
6769 (void) force_word(PL_oldbufptr + tboffset, WORD,
6775 /* Look for a prototype */
6778 bool bad_proto = FALSE;
6779 bool in_brackets = FALSE;
6780 char greedy_proto = ' ';
6781 bool proto_after_greedy_proto = FALSE;
6782 bool must_be_last = FALSE;
6783 bool underscore = FALSE;
6784 bool seen_underscore = FALSE;
6785 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6787 s = scan_str(s,!!PL_madskills,FALSE);
6789 Perl_croak(aTHX_ "Prototype not terminated");
6790 /* strip spaces and check for bad characters */
6791 d = SvPVX(PL_lex_stuff);
6793 for (p = d; *p; ++p) {
6799 proto_after_greedy_proto = TRUE;
6800 if (!strchr("$@%*;[]&\\_", *p)) {
6812 else if ( *p == ']' ) {
6813 in_brackets = FALSE;
6815 else if ( (*p == '@' || *p == '%') &&
6816 ( tmp < 2 || d[tmp-2] != '\\' ) &&
6818 must_be_last = TRUE;
6821 else if ( *p == '_' ) {
6822 underscore = seen_underscore = TRUE;
6829 if (proto_after_greedy_proto)
6830 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6831 "Prototype after '%c' for %"SVf" : %s",
6832 greedy_proto, SVfARG(PL_subname), d);
6834 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6835 "Illegal character %sin prototype for %"SVf" : %s",
6836 seen_underscore ? "after '_' " : "",
6837 SVfARG(PL_subname), d);
6838 SvCUR_set(PL_lex_stuff, tmp);
6843 CURMAD('q', PL_thisopen);
6844 CURMAD('_', tmpwhite);
6845 CURMAD('=', PL_thisstuff);
6846 CURMAD('Q', PL_thisclose);
6847 NEXTVAL_NEXTTOKE.opval =
6848 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6849 PL_lex_stuff = NULL;
6852 s = SKIPSPACE2(s,tmpwhite);
6860 if (*s == ':' && s[1] != ':')
6861 PL_expect = attrful;
6862 else if (*s != '{' && key == KEY_sub) {
6864 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6866 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6873 curmad('^', newSVpvs(""));
6874 CURMAD('_', tmpwhite);
6878 PL_thistoken = subtoken;
6881 NEXTVAL_NEXTTOKE.opval =
6882 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6883 PL_lex_stuff = NULL;
6889 sv_setpvs(PL_subname, "__ANON__");
6891 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6895 (void) force_word(PL_oldbufptr + tboffset, WORD,
6904 LOP(OP_SYSTEM,XREF);
6907 LOP(OP_SYMLINK,XTERM);
6910 LOP(OP_SYSCALL,XTERM);
6913 LOP(OP_SYSOPEN,XTERM);
6916 LOP(OP_SYSSEEK,XTERM);
6919 LOP(OP_SYSREAD,XTERM);
6922 LOP(OP_SYSWRITE,XTERM);
6926 TERM(sublex_start());
6947 LOP(OP_TRUNCATE,XTERM);
6959 pl_yylval.ival = CopLINE(PL_curcop);
6963 pl_yylval.ival = CopLINE(PL_curcop);
6967 LOP(OP_UNLINK,XTERM);
6973 LOP(OP_UNPACK,XTERM);
6976 LOP(OP_UTIME,XTERM);
6982 LOP(OP_UNSHIFT,XTERM);
6985 s = tokenize_use(1, s);
6995 pl_yylval.ival = CopLINE(PL_curcop);
6999 pl_yylval.ival = CopLINE(PL_curcop);
7003 PL_hints |= HINT_BLOCK_SCOPE;
7010 LOP(OP_WAITPID,XTERM);
7019 ctl_l[0] = toCTRL('L');
7021 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
7024 /* Make sure $^L is defined */
7025 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
7030 if (PL_expect == XOPERATOR)
7036 pl_yylval.ival = OP_XOR;
7041 TERM(sublex_start());
7046 #pragma segment Main
7050 S_pending_ident(pTHX)
7055 /* pit holds the identifier we read and pending_ident is reset */
7056 char pit = PL_pending_ident;
7057 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
7058 /* All routes through this function want to know if there is a colon. */
7059 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
7060 PL_pending_ident = 0;
7062 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
7063 DEBUG_T({ PerlIO_printf(Perl_debug_log,
7064 "### Pending identifier '%s'\n", PL_tokenbuf); });
7066 /* if we're in a my(), we can't allow dynamics here.
7067 $foo'bar has already been turned into $foo::bar, so
7068 just check for colons.
7070 if it's a legal name, the OP is a PADANY.
7073 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
7075 yyerror(Perl_form(aTHX_ "No package name allowed for "
7076 "variable %s in \"our\"",
7078 tmp = allocmy(PL_tokenbuf);
7082 yyerror(Perl_form(aTHX_ PL_no_myglob,
7083 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
7085 pl_yylval.opval = newOP(OP_PADANY, 0);
7086 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf);
7092 build the ops for accesses to a my() variable.
7094 Deny my($a) or my($b) in a sort block, *if* $a or $b is
7095 then used in a comparison. This catches most, but not
7096 all cases. For instance, it catches
7097 sort { my($a); $a <=> $b }
7099 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
7100 (although why you'd do that is anyone's guess).
7105 tmp = pad_findmy(PL_tokenbuf);
7106 if (tmp != NOT_IN_PAD) {
7107 /* might be an "our" variable" */
7108 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
7109 /* build ops for a bareword */
7110 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
7111 HEK * const stashname = HvNAME_HEK(stash);
7112 SV * const sym = newSVhek(stashname);
7113 sv_catpvs(sym, "::");
7114 sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
7115 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
7116 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7119 ? (GV_ADDMULTI | GV_ADDINEVAL)
7122 ((PL_tokenbuf[0] == '$') ? SVt_PV
7123 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7128 /* if it's a sort block and they're naming $a or $b */
7129 if (PL_last_lop_op == OP_SORT &&
7130 PL_tokenbuf[0] == '$' &&
7131 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
7134 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
7135 d < PL_bufend && *d != '\n';
7138 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
7139 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
7145 pl_yylval.opval = newOP(OP_PADANY, 0);
7146 pl_yylval.opval->op_targ = tmp;
7152 Whine if they've said @foo in a doublequoted string,
7153 and @foo isn't a variable we can find in the symbol
7156 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
7157 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
7159 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
7160 && ckWARN(WARN_AMBIGUOUS)
7161 /* DO NOT warn for @- and @+ */
7162 && !( PL_tokenbuf[2] == '\0' &&
7163 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
7166 /* Downgraded from fatal to warning 20000522 mjd */
7167 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7168 "Possible unintended interpolation of %s in string",
7173 /* build ops for a bareword */
7174 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
7176 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7178 PL_tokenbuf + 1, tokenbuf_len - 1,
7179 /* If the identifier refers to a stash, don't autovivify it.
7180 * Change 24660 had the side effect of causing symbol table
7181 * hashes to always be defined, even if they were freshly
7182 * created and the only reference in the entire program was
7183 * the single statement with the defined %foo::bar:: test.
7184 * It appears that all code in the wild doing this actually
7185 * wants to know whether sub-packages have been loaded, so
7186 * by avoiding auto-vivifying symbol tables, we ensure that
7187 * defined %foo::bar:: continues to be false, and the existing
7188 * tests still give the expected answers, even though what
7189 * they're actually testing has now changed subtly.
7191 (*PL_tokenbuf == '%'
7192 && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
7195 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7196 ((PL_tokenbuf[0] == '$') ? SVt_PV
7197 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7203 * The following code was generated by perl_keyword.pl.
7207 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7211 PERL_ARGS_ASSERT_KEYWORD;
7215 case 1: /* 5 tokens of length 1 */
7247 case 2: /* 18 tokens of length 2 */
7393 case 3: /* 29 tokens of length 3 */
7397 if (name[1] == 'N' &&
7460 if (name[1] == 'i' &&
7492 if (name[1] == 'o' &&
7501 if (name[1] == 'e' &&
7510 if (name[1] == 'n' &&
7519 if (name[1] == 'o' &&
7528 if (name[1] == 'a' &&
7537 if (name[1] == 'o' &&
7599 if (name[1] == 'e' &&
7613 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7639 if (name[1] == 'i' &&
7648 if (name[1] == 's' &&
7657 if (name[1] == 'e' &&
7666 if (name[1] == 'o' &&
7678 case 4: /* 41 tokens of length 4 */
7682 if (name[1] == 'O' &&
7692 if (name[1] == 'N' &&
7702 if (name[1] == 'i' &&
7712 if (name[1] == 'h' &&
7722 if (name[1] == 'u' &&
7735 if (name[2] == 'c' &&
7744 if (name[2] == 's' &&
7753 if (name[2] == 'a' &&
7789 if (name[1] == 'o' &&
7802 if (name[2] == 't' &&
7811 if (name[2] == 'o' &&
7820 if (name[2] == 't' &&
7829 if (name[2] == 'e' &&
7842 if (name[1] == 'o' &&
7855 if (name[2] == 'y' &&
7864 if (name[2] == 'l' &&
7880 if (name[2] == 's' &&
7889 if (name[2] == 'n' &&
7898 if (name[2] == 'c' &&
7911 if (name[1] == 'e' &&
7921 if (name[1] == 'p' &&
7934 if (name[2] == 'c' &&
7943 if (name[2] == 'p' &&
7952 if (name[2] == 's' &&
7968 if (name[2] == 'n' &&
8038 if (name[2] == 'r' &&
8047 if (name[2] == 'r' &&
8056 if (name[2] == 'a' &&
8072 if (name[2] == 'l' &&
8134 if (name[2] == 'e' &&
8137 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
8150 case 5: /* 39 tokens of length 5 */
8154 if (name[1] == 'E' &&
8165 if (name[1] == 'H' &&
8179 if (name[2] == 'a' &&
8189 if (name[2] == 'a' &&
8206 if (name[2] == 'e' &&
8216 if (name[2] == 'e' &&
8220 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8236 if (name[3] == 'i' &&
8245 if (name[3] == 'o' &&
8281 if (name[2] == 'o' &&
8291 if (name[2] == 'y' &&
8305 if (name[1] == 'l' &&
8319 if (name[2] == 'n' &&
8329 if (name[2] == 'o' &&
8343 if (name[1] == 'i' &&
8348 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8357 if (name[2] == 'd' &&
8367 if (name[2] == 'c' &&
8384 if (name[2] == 'c' &&
8394 if (name[2] == 't' &&
8408 if (name[1] == 'k' &&
8419 if (name[1] == 'r' &&
8433 if (name[2] == 's' &&
8443 if (name[2] == 'd' &&
8460 if (name[2] == 'm' &&
8470 if (name[2] == 'i' &&
8480 if (name[2] == 'e' &&
8490 if (name[2] == 'l' &&
8500 if (name[2] == 'a' &&
8513 if (name[3] == 't' &&
8516 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8522 if (name[3] == 'd' &&
8539 if (name[1] == 'i' &&
8553 if (name[2] == 'a' &&
8566 if (name[3] == 'e' &&
8601 if (name[2] == 'i' &&
8618 if (name[2] == 'i' &&
8628 if (name[2] == 'i' &&
8645 case 6: /* 33 tokens of length 6 */
8649 if (name[1] == 'c' &&
8664 if (name[2] == 'l' &&
8675 if (name[2] == 'r' &&
8690 if (name[1] == 'e' &&
8705 if (name[2] == 's' &&
8710 if(ckWARN_d(WARN_SYNTAX))
8711 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8717 if (name[2] == 'i' &&
8735 if (name[2] == 'l' &&
8746 if (name[2] == 'r' &&
8761 if (name[1] == 'm' &&
8776 if (name[2] == 'n' &&
8787 if (name[2] == 's' &&
8802 if (name[1] == 's' &&
8808 if (name[4] == 't' &&
8817 if (name[4] == 'e' &&
8826 if (name[4] == 'c' &&
8835 if (name[4] == 'n' &&
8851 if (name[1] == 'r' &&
8869 if (name[3] == 'a' &&
8879 if (name[3] == 'u' &&
8893 if (name[2] == 'n' &&
8911 if (name[2] == 'a' &&
8925 if (name[3] == 'e' &&
8938 if (name[4] == 't' &&
8947 if (name[4] == 'e' &&
8969 if (name[4] == 't' &&
8978 if (name[4] == 'e' &&
8994 if (name[2] == 'c' &&
9005 if (name[2] == 'l' &&
9016 if (name[2] == 'b' &&
9027 if (name[2] == 's' &&
9050 if (name[4] == 's' &&
9059 if (name[4] == 'n' &&
9072 if (name[3] == 'a' &&
9089 if (name[1] == 'a' &&
9104 case 7: /* 29 tokens of length 7 */
9108 if (name[1] == 'E' &&
9121 if (name[1] == '_' &&
9134 if (name[1] == 'i' &&
9141 return -KEY_binmode;
9147 if (name[1] == 'o' &&
9154 return -KEY_connect;
9163 if (name[2] == 'm' &&
9169 return -KEY_dbmopen;
9180 if (name[4] == 'u' &&
9184 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9190 if (name[4] == 'n' &&
9211 if (name[1] == 'o' &&
9224 if (name[1] == 'e' &&
9231 if (name[5] == 'r' &&
9234 return -KEY_getpgrp;
9240 if (name[5] == 'i' &&
9243 return -KEY_getppid;
9256 if (name[1] == 'c' &&
9263 return -KEY_lcfirst;
9269 if (name[1] == 'p' &&
9276 return -KEY_opendir;
9282 if (name[1] == 'a' &&
9300 if (name[3] == 'd' &&
9305 return -KEY_readdir;
9311 if (name[3] == 'u' &&
9322 if (name[3] == 'e' &&
9327 return -KEY_reverse;
9346 if (name[3] == 'k' &&
9351 return -KEY_seekdir;
9357 if (name[3] == 'p' &&
9362 return -KEY_setpgrp;
9372 if (name[2] == 'm' &&
9378 return -KEY_shmread;
9384 if (name[2] == 'r' &&
9390 return -KEY_sprintf;
9399 if (name[3] == 'l' &&
9404 return -KEY_symlink;
9413 if (name[4] == 'a' &&
9417 return -KEY_syscall;
9423 if (name[4] == 'p' &&
9427 return -KEY_sysopen;
9433 if (name[4] == 'e' &&
9437 return -KEY_sysread;
9443 if (name[4] == 'e' &&
9447 return -KEY_sysseek;
9465 if (name[1] == 'e' &&
9472 return -KEY_telldir;
9481 if (name[2] == 'f' &&
9487 return -KEY_ucfirst;
9493 if (name[2] == 's' &&
9499 return -KEY_unshift;
9509 if (name[1] == 'a' &&
9516 return -KEY_waitpid;
9525 case 8: /* 26 tokens of length 8 */
9529 if (name[1] == 'U' &&
9537 return KEY_AUTOLOAD;
9548 if (name[3] == 'A' &&
9554 return KEY___DATA__;
9560 if (name[3] == 'I' &&
9566 return -KEY___FILE__;
9572 if (name[3] == 'I' &&
9578 return -KEY___LINE__;
9594 if (name[2] == 'o' &&
9601 return -KEY_closedir;
9607 if (name[2] == 'n' &&
9614 return -KEY_continue;
9624 if (name[1] == 'b' &&
9632 return -KEY_dbmclose;
9638 if (name[1] == 'n' &&
9644 if (name[4] == 'r' &&
9649 return -KEY_endgrent;
9655 if (name[4] == 'w' &&
9660 return -KEY_endpwent;
9673 if (name[1] == 'o' &&
9681 return -KEY_formline;
9687 if (name[1] == 'e' &&
9698 if (name[6] == 'n' &&
9701 return -KEY_getgrent;
9707 if (name[6] == 'i' &&
9710 return -KEY_getgrgid;
9716 if (name[6] == 'a' &&
9719 return -KEY_getgrnam;
9732 if (name[4] == 'o' &&
9737 return -KEY_getlogin;
9748 if (name[6] == 'n' &&
9751 return -KEY_getpwent;
9757 if (name[6] == 'a' &&
9760 return -KEY_getpwnam;
9766 if (name[6] == 'i' &&
9769 return -KEY_getpwuid;
9789 if (name[1] == 'e' &&
9796 if (name[5] == 'i' &&
9803 return -KEY_readline;
9808 return -KEY_readlink;
9819 if (name[5] == 'i' &&
9823 return -KEY_readpipe;
9844 if (name[4] == 'r' &&
9849 return -KEY_setgrent;
9855 if (name[4] == 'w' &&
9860 return -KEY_setpwent;
9876 if (name[3] == 'w' &&
9882 return -KEY_shmwrite;
9888 if (name[3] == 't' &&
9894 return -KEY_shutdown;
9904 if (name[2] == 's' &&
9911 return -KEY_syswrite;
9921 if (name[1] == 'r' &&
9929 return -KEY_truncate;
9938 case 9: /* 9 tokens of length 9 */
9942 if (name[1] == 'N' &&
9951 return KEY_UNITCHECK;
9957 if (name[1] == 'n' &&
9966 return -KEY_endnetent;
9972 if (name[1] == 'e' &&
9981 return -KEY_getnetent;
9987 if (name[1] == 'o' &&
9996 return -KEY_localtime;
10002 if (name[1] == 'r' &&
10011 return KEY_prototype;
10017 if (name[1] == 'u' &&
10026 return -KEY_quotemeta;
10032 if (name[1] == 'e' &&
10041 return -KEY_rewinddir;
10047 if (name[1] == 'e' &&
10056 return -KEY_setnetent;
10062 if (name[1] == 'a' &&
10071 return -KEY_wantarray;
10080 case 10: /* 9 tokens of length 10 */
10084 if (name[1] == 'n' &&
10090 if (name[4] == 'o' &&
10097 return -KEY_endhostent;
10103 if (name[4] == 'e' &&
10110 return -KEY_endservent;
10123 if (name[1] == 'e' &&
10129 if (name[4] == 'o' &&
10136 return -KEY_gethostent;
10145 if (name[5] == 'r' &&
10151 return -KEY_getservent;
10157 if (name[5] == 'c' &&
10163 return -KEY_getsockopt;
10183 if (name[2] == 't')
10188 if (name[4] == 'o' &&
10195 return -KEY_sethostent;
10204 if (name[5] == 'r' &&
10210 return -KEY_setservent;
10216 if (name[5] == 'c' &&
10222 return -KEY_setsockopt;
10239 if (name[2] == 'c' &&
10248 return -KEY_socketpair;
10261 case 11: /* 8 tokens of length 11 */
10265 if (name[1] == '_' &&
10275 { /* __PACKAGE__ */
10276 return -KEY___PACKAGE__;
10282 if (name[1] == 'n' &&
10292 { /* endprotoent */
10293 return -KEY_endprotoent;
10299 if (name[1] == 'e' &&
10308 if (name[5] == 'e' &&
10314 { /* getpeername */
10315 return -KEY_getpeername;
10324 if (name[6] == 'o' &&
10329 { /* getpriority */
10330 return -KEY_getpriority;
10336 if (name[6] == 't' &&
10341 { /* getprotoent */
10342 return -KEY_getprotoent;
10356 if (name[4] == 'o' &&
10363 { /* getsockname */
10364 return -KEY_getsockname;
10377 if (name[1] == 'e' &&
10385 if (name[6] == 'o' &&
10390 { /* setpriority */
10391 return -KEY_setpriority;
10397 if (name[6] == 't' &&
10402 { /* setprotoent */
10403 return -KEY_setprotoent;
10419 case 12: /* 2 tokens of length 12 */
10420 if (name[0] == 'g' &&
10432 if (name[9] == 'd' &&
10435 { /* getnetbyaddr */
10436 return -KEY_getnetbyaddr;
10442 if (name[9] == 'a' &&
10445 { /* getnetbyname */
10446 return -KEY_getnetbyname;
10458 case 13: /* 4 tokens of length 13 */
10459 if (name[0] == 'g' &&
10466 if (name[4] == 'o' &&
10475 if (name[10] == 'd' &&
10478 { /* gethostbyaddr */
10479 return -KEY_gethostbyaddr;
10485 if (name[10] == 'a' &&
10488 { /* gethostbyname */
10489 return -KEY_gethostbyname;
10502 if (name[4] == 'e' &&
10511 if (name[10] == 'a' &&
10514 { /* getservbyname */
10515 return -KEY_getservbyname;
10521 if (name[10] == 'o' &&
10524 { /* getservbyport */
10525 return -KEY_getservbyport;
10544 case 14: /* 1 tokens of length 14 */
10545 if (name[0] == 'g' &&
10559 { /* getprotobyname */
10560 return -KEY_getprotobyname;
10565 case 16: /* 1 tokens of length 16 */
10566 if (name[0] == 'g' &&
10582 { /* getprotobynumber */
10583 return -KEY_getprotobynumber;
10597 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10601 PERL_ARGS_ASSERT_CHECKCOMMA;
10603 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10604 if (ckWARN(WARN_SYNTAX)) {
10607 for (w = s+2; *w && level; w++) {
10610 else if (*w == ')')
10613 while (isSPACE(*w))
10615 /* the list of chars below is for end of statements or
10616 * block / parens, boolean operators (&&, ||, //) and branch
10617 * constructs (or, and, if, until, unless, while, err, for).
10618 * Not a very solid hack... */
10619 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
10620 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10621 "%s (...) interpreted as function",name);
10624 while (s < PL_bufend && isSPACE(*s))
10628 while (s < PL_bufend && isSPACE(*s))
10630 if (isIDFIRST_lazy_if(s,UTF)) {
10631 const char * const w = s++;
10632 while (isALNUM_lazy_if(s,UTF))
10634 while (s < PL_bufend && isSPACE(*s))
10638 if (keyword(w, s - w, 0))
10641 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10642 if (gv && GvCVu(gv))
10644 Perl_croak(aTHX_ "No comma allowed after %s", what);
10649 /* Either returns sv, or mortalizes sv and returns a new SV*.
10650 Best used as sv=new_constant(..., sv, ...).
10651 If s, pv are NULL, calls subroutine with one argument,
10652 and type is used with error messages only. */
10655 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
10656 SV *sv, SV *pv, const char *type, STRLEN typelen)
10659 HV * const table = GvHV(PL_hintgv); /* ^H */
10663 const char *why1 = "", *why2 = "", *why3 = "";
10665 PERL_ARGS_ASSERT_NEW_CONSTANT;
10667 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10670 why2 = (const char *)
10671 (strEQ(key,"charnames")
10672 ? "(possibly a missing \"use charnames ...\")"
10674 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10675 (type ? type: "undef"), why2);
10677 /* This is convoluted and evil ("goto considered harmful")
10678 * but I do not understand the intricacies of all the different
10679 * failure modes of %^H in here. The goal here is to make
10680 * the most probable error message user-friendly. --jhi */
10685 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10686 (type ? type: "undef"), why1, why2, why3);
10688 yyerror(SvPVX_const(msg));
10692 cvp = hv_fetch(table, key, keylen, FALSE);
10693 if (!cvp || !SvOK(*cvp)) {
10696 why3 = "} is not defined";
10699 sv_2mortal(sv); /* Parent created it permanently */
10702 pv = newSVpvn_flags(s, len, SVs_TEMP);
10704 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
10706 typesv = &PL_sv_undef;
10708 PUSHSTACKi(PERLSI_OVERLOAD);
10720 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10724 /* Check the eval first */
10725 if (!PL_in_eval && SvTRUE(ERRSV)) {
10726 sv_catpvs(ERRSV, "Propagated");
10727 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10729 res = SvREFCNT_inc_simple(sv);
10733 SvREFCNT_inc_simple_void(res);
10742 why1 = "Call to &{$^H{";
10744 why3 = "}} did not return a defined value";
10752 /* Returns a NUL terminated string, with the length of the string written to
10756 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10759 register char *d = dest;
10760 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10762 PERL_ARGS_ASSERT_SCAN_WORD;
10766 Perl_croak(aTHX_ ident_too_long);
10767 if (isALNUM(*s)) /* UTF handled below */
10769 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10774 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10778 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10779 char *t = s + UTF8SKIP(s);
10781 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10785 Perl_croak(aTHX_ ident_too_long);
10786 Copy(s, d, len, char);
10799 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10802 char *bracket = NULL;
10804 register char *d = dest;
10805 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10807 PERL_ARGS_ASSERT_SCAN_IDENT;
10812 while (isDIGIT(*s)) {
10814 Perl_croak(aTHX_ ident_too_long);
10821 Perl_croak(aTHX_ ident_too_long);
10822 if (isALNUM(*s)) /* UTF handled below */
10824 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10829 else if (*s == ':' && s[1] == ':') {
10833 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10834 char *t = s + UTF8SKIP(s);
10835 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10837 if (d + (t - s) > e)
10838 Perl_croak(aTHX_ ident_too_long);
10839 Copy(s, d, t - s, char);
10850 if (PL_lex_state != LEX_NORMAL)
10851 PL_lex_state = LEX_INTERPENDMAYBE;
10854 if (*s == '$' && s[1] &&
10855 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10868 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10873 if (isSPACE(s[-1])) {
10875 const char ch = *s++;
10876 if (!SPACE_OR_TAB(ch)) {
10882 if (isIDFIRST_lazy_if(d,UTF)) {
10886 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10887 end += UTF8SKIP(end);
10888 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10889 end += UTF8SKIP(end);
10891 Copy(s, d, end - s, char);
10896 while ((isALNUM(*s) || *s == ':') && d < e)
10899 Perl_croak(aTHX_ ident_too_long);
10902 while (s < send && SPACE_OR_TAB(*s))
10904 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10905 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10906 const char * const brack =
10908 ((*s == '[') ? "[...]" : "{...}");
10909 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10910 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10911 funny, dest, brack, funny, dest, brack);
10914 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10918 /* Handle extended ${^Foo} variables
10919 * 1999-02-27 mjd-perl-patch@plover.com */
10920 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10924 while (isALNUM(*s) && d < e) {
10928 Perl_croak(aTHX_ ident_too_long);
10933 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10934 PL_lex_state = LEX_INTERPEND;
10937 if (PL_lex_state == LEX_NORMAL) {
10938 if (ckWARN(WARN_AMBIGUOUS) &&
10939 (keyword(dest, d - dest, 0)
10940 || get_cvn_flags(dest, d - dest, 0)))
10944 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10945 "Ambiguous use of %c{%s} resolved to %c%s",
10946 funny, dest, funny, dest);
10951 s = bracket; /* let the parser handle it */
10955 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10956 PL_lex_state = LEX_INTERPEND;
10961 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10963 PERL_ARGS_ASSERT_PMFLAG;
10965 PERL_UNUSED_CONTEXT;
10967 const char c = (char)ch;
10969 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
10970 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
10971 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
10972 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
10973 case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break;
10979 S_scan_pat(pTHX_ char *start, I32 type)
10983 char *s = scan_str(start,!!PL_madskills,FALSE);
10984 const char * const valid_flags =
10985 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10990 PERL_ARGS_ASSERT_SCAN_PAT;
10993 const char * const delimiter = skipspace(start);
10997 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10998 : "Search pattern not terminated" ));
11001 pm = (PMOP*)newPMOP(type, 0);
11002 if (PL_multi_open == '?') {
11003 /* This is the only point in the code that sets PMf_ONCE: */
11004 pm->op_pmflags |= PMf_ONCE;
11006 /* Hence it's safe to do this bit of PMOP book-keeping here, which
11007 allows us to restrict the list needed by reset to just the ??
11009 assert(type != OP_TRANS);
11011 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
11014 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
11017 elements = mg->mg_len / sizeof(PMOP**);
11018 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
11019 ((PMOP**)mg->mg_ptr) [elements++] = pm;
11020 mg->mg_len = elements * sizeof(PMOP**);
11021 PmopSTASH_set(pm,PL_curstash);
11027 while (*s && strchr(valid_flags, *s))
11028 pmflag(&pm->op_pmflags,*s++);
11030 if (PL_madskills && modstart != s) {
11031 SV* tmptoken = newSVpvn(modstart, s - modstart);
11032 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
11035 /* issue a warning if /c is specified,but /g is not */
11036 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
11037 && ckWARN(WARN_REGEXP))
11039 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
11040 "Use of /c modifier is meaningless without /g" );
11043 PL_lex_op = (OP*)pm;
11044 pl_yylval.ival = OP_MATCH;
11049 S_scan_subst(pTHX_ char *start)
11060 PERL_ARGS_ASSERT_SCAN_SUBST;
11062 pl_yylval.ival = OP_NULL;
11064 s = scan_str(start,!!PL_madskills,FALSE);
11067 Perl_croak(aTHX_ "Substitution pattern not terminated");
11069 if (s[-1] == PL_multi_open)
11072 if (PL_madskills) {
11073 CURMAD('q', PL_thisopen);
11074 CURMAD('_', PL_thiswhite);
11075 CURMAD('E', PL_thisstuff);
11076 CURMAD('Q', PL_thisclose);
11077 PL_realtokenstart = s - SvPVX(PL_linestr);
11081 first_start = PL_multi_start;
11082 s = scan_str(s,!!PL_madskills,FALSE);
11084 if (PL_lex_stuff) {
11085 SvREFCNT_dec(PL_lex_stuff);
11086 PL_lex_stuff = NULL;
11088 Perl_croak(aTHX_ "Substitution replacement not terminated");
11090 PL_multi_start = first_start; /* so whole substitution is taken together */
11092 pm = (PMOP*)newPMOP(OP_SUBST, 0);
11095 if (PL_madskills) {
11096 CURMAD('z', PL_thisopen);
11097 CURMAD('R', PL_thisstuff);
11098 CURMAD('Z', PL_thisclose);
11104 if (*s == EXEC_PAT_MOD) {
11108 else if (strchr(S_PAT_MODS, *s))
11109 pmflag(&pm->op_pmflags,*s++);
11115 if (PL_madskills) {
11117 curmad('m', newSVpvn(modstart, s - modstart));
11118 append_madprops(PL_thismad, (OP*)pm, 0);
11122 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
11123 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
11127 SV * const repl = newSVpvs("");
11129 PL_sublex_info.super_bufptr = s;
11130 PL_sublex_info.super_bufend = PL_bufend;
11132 pm->op_pmflags |= PMf_EVAL;
11135 sv_catpvs(repl, "eval ");
11137 sv_catpvs(repl, "do ");
11139 sv_catpvs(repl, "{");
11140 sv_catsv(repl, PL_lex_repl);
11141 if (strchr(SvPVX(PL_lex_repl), '#'))
11142 sv_catpvs(repl, "\n");
11143 sv_catpvs(repl, "}");
11145 SvREFCNT_dec(PL_lex_repl);
11146 PL_lex_repl = repl;
11149 PL_lex_op = (OP*)pm;
11150 pl_yylval.ival = OP_SUBST;
11155 S_scan_trans(pTHX_ char *start)
11168 PERL_ARGS_ASSERT_SCAN_TRANS;
11170 pl_yylval.ival = OP_NULL;
11172 s = scan_str(start,!!PL_madskills,FALSE);
11174 Perl_croak(aTHX_ "Transliteration pattern not terminated");
11176 if (s[-1] == PL_multi_open)
11179 if (PL_madskills) {
11180 CURMAD('q', PL_thisopen);
11181 CURMAD('_', PL_thiswhite);
11182 CURMAD('E', PL_thisstuff);
11183 CURMAD('Q', PL_thisclose);
11184 PL_realtokenstart = s - SvPVX(PL_linestr);
11188 s = scan_str(s,!!PL_madskills,FALSE);
11190 if (PL_lex_stuff) {
11191 SvREFCNT_dec(PL_lex_stuff);
11192 PL_lex_stuff = NULL;
11194 Perl_croak(aTHX_ "Transliteration replacement not terminated");
11196 if (PL_madskills) {
11197 CURMAD('z', PL_thisopen);
11198 CURMAD('R', PL_thisstuff);
11199 CURMAD('Z', PL_thisclose);
11202 complement = del = squash = 0;
11209 complement = OPpTRANS_COMPLEMENT;
11212 del = OPpTRANS_DELETE;
11215 squash = OPpTRANS_SQUASH;
11224 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11225 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11226 o->op_private &= ~OPpTRANS_ALL;
11227 o->op_private |= del|squash|complement|
11228 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11229 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11232 pl_yylval.ival = OP_TRANS;
11235 if (PL_madskills) {
11237 curmad('m', newSVpvn(modstart, s - modstart));
11238 append_madprops(PL_thismad, o, 0);
11247 S_scan_heredoc(pTHX_ register char *s)
11251 I32 op_type = OP_SCALAR;
11255 const char *found_newline;
11259 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11261 I32 stuffstart = s - SvPVX(PL_linestr);
11264 PL_realtokenstart = -1;
11267 PERL_ARGS_ASSERT_SCAN_HEREDOC;
11271 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11275 while (SPACE_OR_TAB(*peek))
11277 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11280 s = delimcpy(d, e, s, PL_bufend, term, &len);
11290 if (!isALNUM_lazy_if(s,UTF))
11291 deprecate_old("bare << to mean <<\"\"");
11292 for (; isALNUM_lazy_if(s,UTF); s++) {
11297 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11298 Perl_croak(aTHX_ "Delimiter for here document is too long");
11301 len = d - PL_tokenbuf;
11304 if (PL_madskills) {
11305 tstart = PL_tokenbuf + !outer;
11306 PL_thisclose = newSVpvn(tstart, len - !outer);
11307 tstart = SvPVX(PL_linestr) + stuffstart;
11308 PL_thisopen = newSVpvn(tstart, s - tstart);
11309 stuffstart = s - SvPVX(PL_linestr);
11312 #ifndef PERL_STRICT_CR
11313 d = strchr(s, '\r');
11315 char * const olds = s;
11317 while (s < PL_bufend) {
11323 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11332 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11339 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11340 herewas = newSVpvn(s,PL_bufend-s);
11344 herewas = newSVpvn(s-1,found_newline-s+1);
11347 herewas = newSVpvn(s,found_newline-s);
11351 if (PL_madskills) {
11352 tstart = SvPVX(PL_linestr) + stuffstart;
11354 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11356 PL_thisstuff = newSVpvn(tstart, s - tstart);
11359 s += SvCUR(herewas);
11362 stuffstart = s - SvPVX(PL_linestr);
11368 tmpstr = newSV_type(SVt_PVIV);
11369 SvGROW(tmpstr, 80);
11370 if (term == '\'') {
11371 op_type = OP_CONST;
11372 SvIV_set(tmpstr, -1);
11374 else if (term == '`') {
11375 op_type = OP_BACKTICK;
11376 SvIV_set(tmpstr, '\\');
11380 PL_multi_start = CopLINE(PL_curcop);
11381 PL_multi_open = PL_multi_close = '<';
11382 term = *PL_tokenbuf;
11383 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11384 char * const bufptr = PL_sublex_info.super_bufptr;
11385 char * const bufend = PL_sublex_info.super_bufend;
11386 char * const olds = s - SvCUR(herewas);
11387 s = strchr(bufptr, '\n');
11391 while (s < bufend &&
11392 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11394 CopLINE_inc(PL_curcop);
11397 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11398 missingterm(PL_tokenbuf);
11400 sv_setpvn(herewas,bufptr,d-bufptr+1);
11401 sv_setpvn(tmpstr,d+1,s-d);
11403 sv_catpvn(herewas,s,bufend-s);
11404 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11411 while (s < PL_bufend &&
11412 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11414 CopLINE_inc(PL_curcop);
11416 if (s >= PL_bufend) {
11417 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11418 missingterm(PL_tokenbuf);
11420 sv_setpvn(tmpstr,d+1,s-d);
11422 if (PL_madskills) {
11424 sv_catpvn(PL_thisstuff, d + 1, s - d);
11426 PL_thisstuff = newSVpvn(d + 1, s - d);
11427 stuffstart = s - SvPVX(PL_linestr);
11431 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11433 sv_catpvn(herewas,s,PL_bufend-s);
11434 sv_setsv(PL_linestr,herewas);
11435 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11436 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11437 PL_last_lop = PL_last_uni = NULL;
11440 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
11441 while (s >= PL_bufend) { /* multiple line string? */
11443 if (PL_madskills) {
11444 tstart = SvPVX(PL_linestr) + stuffstart;
11446 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11448 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11452 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11453 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11454 missingterm(PL_tokenbuf);
11457 stuffstart = s - SvPVX(PL_linestr);
11459 CopLINE_inc(PL_curcop);
11460 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11461 PL_last_lop = PL_last_uni = NULL;
11462 #ifndef PERL_STRICT_CR
11463 if (PL_bufend - PL_linestart >= 2) {
11464 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11465 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11467 PL_bufend[-2] = '\n';
11469 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11471 else if (PL_bufend[-1] == '\r')
11472 PL_bufend[-1] = '\n';
11474 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11475 PL_bufend[-1] = '\n';
11477 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11478 update_debugger_info(PL_linestr, NULL, 0);
11479 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11480 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11481 *(SvPVX(PL_linestr) + off ) = ' ';
11482 sv_catsv(PL_linestr,herewas);
11483 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11484 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11488 sv_catsv(tmpstr,PL_linestr);
11493 PL_multi_end = CopLINE(PL_curcop);
11494 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11495 SvPV_shrink_to_cur(tmpstr);
11497 SvREFCNT_dec(herewas);
11499 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11501 else if (PL_encoding)
11502 sv_recode_to_utf8(tmpstr, PL_encoding);
11504 PL_lex_stuff = tmpstr;
11505 pl_yylval.ival = op_type;
11509 /* scan_inputsymbol
11510 takes: current position in input buffer
11511 returns: new position in input buffer
11512 side-effects: pl_yylval and lex_op are set.
11517 <FH> read from filehandle
11518 <pkg::FH> read from package qualified filehandle
11519 <pkg'FH> read from package qualified filehandle
11520 <$fh> read from filehandle in $fh
11521 <*.h> filename glob
11526 S_scan_inputsymbol(pTHX_ char *start)
11529 register char *s = start; /* current position in buffer */
11532 char *d = PL_tokenbuf; /* start of temp holding space */
11533 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11535 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
11537 end = strchr(s, '\n');
11540 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11542 /* die if we didn't have space for the contents of the <>,
11543 or if it didn't end, or if we see a newline
11546 if (len >= (I32)sizeof PL_tokenbuf)
11547 Perl_croak(aTHX_ "Excessively long <> operator");
11549 Perl_croak(aTHX_ "Unterminated <> operator");
11554 Remember, only scalar variables are interpreted as filehandles by
11555 this code. Anything more complex (e.g., <$fh{$num}>) will be
11556 treated as a glob() call.
11557 This code makes use of the fact that except for the $ at the front,
11558 a scalar variable and a filehandle look the same.
11560 if (*d == '$' && d[1]) d++;
11562 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11563 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11566 /* If we've tried to read what we allow filehandles to look like, and
11567 there's still text left, then it must be a glob() and not a getline.
11568 Use scan_str to pull out the stuff between the <> and treat it
11569 as nothing more than a string.
11572 if (d - PL_tokenbuf != len) {
11573 pl_yylval.ival = OP_GLOB;
11574 s = scan_str(start,!!PL_madskills,FALSE);
11576 Perl_croak(aTHX_ "Glob not terminated");
11580 bool readline_overriden = FALSE;
11583 /* we're in a filehandle read situation */
11586 /* turn <> into <ARGV> */
11588 Copy("ARGV",d,5,char);
11590 /* Check whether readline() is overriden */
11591 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11593 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11595 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11596 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11597 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11598 readline_overriden = TRUE;
11600 /* if <$fh>, create the ops to turn the variable into a
11604 /* try to find it in the pad for this block, otherwise find
11605 add symbol table ops
11607 const PADOFFSET tmp = pad_findmy(d);
11608 if (tmp != NOT_IN_PAD) {
11609 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11610 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11611 HEK * const stashname = HvNAME_HEK(stash);
11612 SV * const sym = sv_2mortal(newSVhek(stashname));
11613 sv_catpvs(sym, "::");
11614 sv_catpv(sym, d+1);
11619 OP * const o = newOP(OP_PADSV, 0);
11621 PL_lex_op = readline_overriden
11622 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11623 append_elem(OP_LIST, o,
11624 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11625 : (OP*)newUNOP(OP_READLINE, 0, o);
11634 ? (GV_ADDMULTI | GV_ADDINEVAL)
11637 PL_lex_op = readline_overriden
11638 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11639 append_elem(OP_LIST,
11640 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11641 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11642 : (OP*)newUNOP(OP_READLINE, 0,
11643 newUNOP(OP_RV2SV, 0,
11644 newGVOP(OP_GV, 0, gv)));
11646 if (!readline_overriden)
11647 PL_lex_op->op_flags |= OPf_SPECIAL;
11648 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
11649 pl_yylval.ival = OP_NULL;
11652 /* If it's none of the above, it must be a literal filehandle
11653 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11655 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11656 PL_lex_op = readline_overriden
11657 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11658 append_elem(OP_LIST,
11659 newGVOP(OP_GV, 0, gv),
11660 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11661 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11662 pl_yylval.ival = OP_NULL;
11671 takes: start position in buffer
11672 keep_quoted preserve \ on the embedded delimiter(s)
11673 keep_delims preserve the delimiters around the string
11674 returns: position to continue reading from buffer
11675 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11676 updates the read buffer.
11678 This subroutine pulls a string out of the input. It is called for:
11679 q single quotes q(literal text)
11680 ' single quotes 'literal text'
11681 qq double quotes qq(interpolate $here please)
11682 " double quotes "interpolate $here please"
11683 qx backticks qx(/bin/ls -l)
11684 ` backticks `/bin/ls -l`
11685 qw quote words @EXPORT_OK = qw( func() $spam )
11686 m// regexp match m/this/
11687 s/// regexp substitute s/this/that/
11688 tr/// string transliterate tr/this/that/
11689 y/// string transliterate y/this/that/
11690 ($*@) sub prototypes sub foo ($)
11691 (stuff) sub attr parameters sub foo : attr(stuff)
11692 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11694 In most of these cases (all but <>, patterns and transliterate)
11695 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11696 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11697 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11700 It skips whitespace before the string starts, and treats the first
11701 character as the delimiter. If the delimiter is one of ([{< then
11702 the corresponding "close" character )]}> is used as the closing
11703 delimiter. It allows quoting of delimiters, and if the string has
11704 balanced delimiters ([{<>}]) it allows nesting.
11706 On success, the SV with the resulting string is put into lex_stuff or,
11707 if that is already non-NULL, into lex_repl. The second case occurs only
11708 when parsing the RHS of the special constructs s/// and tr/// (y///).
11709 For convenience, the terminating delimiter character is stuffed into
11714 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11717 SV *sv; /* scalar value: string */
11718 const char *tmps; /* temp string, used for delimiter matching */
11719 register char *s = start; /* current position in the buffer */
11720 register char term; /* terminating character */
11721 register char *to; /* current position in the sv's data */
11722 I32 brackets = 1; /* bracket nesting level */
11723 bool has_utf8 = FALSE; /* is there any utf8 content? */
11724 I32 termcode; /* terminating char. code */
11725 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11726 STRLEN termlen; /* length of terminating string */
11727 int last_off = 0; /* last position for nesting bracket */
11733 PERL_ARGS_ASSERT_SCAN_STR;
11735 /* skip space before the delimiter */
11741 if (PL_realtokenstart >= 0) {
11742 stuffstart = PL_realtokenstart;
11743 PL_realtokenstart = -1;
11746 stuffstart = start - SvPVX(PL_linestr);
11748 /* mark where we are, in case we need to report errors */
11751 /* after skipping whitespace, the next character is the terminator */
11754 termcode = termstr[0] = term;
11758 termcode = utf8_to_uvchr((U8*)s, &termlen);
11759 Copy(s, termstr, termlen, U8);
11760 if (!UTF8_IS_INVARIANT(term))
11764 /* mark where we are */
11765 PL_multi_start = CopLINE(PL_curcop);
11766 PL_multi_open = term;
11768 /* find corresponding closing delimiter */
11769 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11770 termcode = termstr[0] = term = tmps[5];
11772 PL_multi_close = term;
11774 /* create a new SV to hold the contents. 79 is the SV's initial length.
11775 What a random number. */
11776 sv = newSV_type(SVt_PVIV);
11778 SvIV_set(sv, termcode);
11779 (void)SvPOK_only(sv); /* validate pointer */
11781 /* move past delimiter and try to read a complete string */
11783 sv_catpvn(sv, s, termlen);
11786 tstart = SvPVX(PL_linestr) + stuffstart;
11787 if (!PL_thisopen && !keep_delims) {
11788 PL_thisopen = newSVpvn(tstart, s - tstart);
11789 stuffstart = s - SvPVX(PL_linestr);
11793 if (PL_encoding && !UTF) {
11797 int offset = s - SvPVX_const(PL_linestr);
11798 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11799 &offset, (char*)termstr, termlen);
11800 const char * const ns = SvPVX_const(PL_linestr) + offset;
11801 char * const svlast = SvEND(sv) - 1;
11803 for (; s < ns; s++) {
11804 if (*s == '\n' && !PL_rsfp)
11805 CopLINE_inc(PL_curcop);
11808 goto read_more_line;
11810 /* handle quoted delimiters */
11811 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11813 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11815 if ((svlast-1 - t) % 2) {
11816 if (!keep_quoted) {
11817 *(svlast-1) = term;
11819 SvCUR_set(sv, SvCUR(sv) - 1);
11824 if (PL_multi_open == PL_multi_close) {
11830 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11831 /* At here, all closes are "was quoted" one,
11832 so we don't check PL_multi_close. */
11834 if (!keep_quoted && *(t+1) == PL_multi_open)
11839 else if (*t == PL_multi_open)
11847 SvCUR_set(sv, w - SvPVX_const(sv));
11849 last_off = w - SvPVX(sv);
11850 if (--brackets <= 0)
11855 if (!keep_delims) {
11856 SvCUR_set(sv, SvCUR(sv) - 1);
11862 /* extend sv if need be */
11863 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11864 /* set 'to' to the next character in the sv's string */
11865 to = SvPVX(sv)+SvCUR(sv);
11867 /* if open delimiter is the close delimiter read unbridle */
11868 if (PL_multi_open == PL_multi_close) {
11869 for (; s < PL_bufend; s++,to++) {
11870 /* embedded newlines increment the current line number */
11871 if (*s == '\n' && !PL_rsfp)
11872 CopLINE_inc(PL_curcop);
11873 /* handle quoted delimiters */
11874 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11875 if (!keep_quoted && s[1] == term)
11877 /* any other quotes are simply copied straight through */
11881 /* terminate when run out of buffer (the for() condition), or
11882 have found the terminator */
11883 else if (*s == term) {
11886 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11889 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11895 /* if the terminator isn't the same as the start character (e.g.,
11896 matched brackets), we have to allow more in the quoting, and
11897 be prepared for nested brackets.
11900 /* read until we run out of string, or we find the terminator */
11901 for (; s < PL_bufend; s++,to++) {
11902 /* embedded newlines increment the line count */
11903 if (*s == '\n' && !PL_rsfp)
11904 CopLINE_inc(PL_curcop);
11905 /* backslashes can escape the open or closing characters */
11906 if (*s == '\\' && s+1 < PL_bufend) {
11907 if (!keep_quoted &&
11908 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11913 /* allow nested opens and closes */
11914 else if (*s == PL_multi_close && --brackets <= 0)
11916 else if (*s == PL_multi_open)
11918 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11923 /* terminate the copied string and update the sv's end-of-string */
11925 SvCUR_set(sv, to - SvPVX_const(sv));
11928 * this next chunk reads more into the buffer if we're not done yet
11932 break; /* handle case where we are done yet :-) */
11934 #ifndef PERL_STRICT_CR
11935 if (to - SvPVX_const(sv) >= 2) {
11936 if ((to[-2] == '\r' && to[-1] == '\n') ||
11937 (to[-2] == '\n' && to[-1] == '\r'))
11941 SvCUR_set(sv, to - SvPVX_const(sv));
11943 else if (to[-1] == '\r')
11946 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11951 /* if we're out of file, or a read fails, bail and reset the current
11952 line marker so we can report where the unterminated string began
11955 if (PL_madskills) {
11956 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11958 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11960 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11964 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11966 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11972 /* we read a line, so increment our line counter */
11973 CopLINE_inc(PL_curcop);
11975 /* update debugger info */
11976 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11977 update_debugger_info(PL_linestr, NULL, 0);
11979 /* having changed the buffer, we must update PL_bufend */
11980 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11981 PL_last_lop = PL_last_uni = NULL;
11984 /* at this point, we have successfully read the delimited string */
11986 if (!PL_encoding || UTF) {
11988 if (PL_madskills) {
11989 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11990 const int len = s - tstart;
11992 sv_catpvn(PL_thisstuff, tstart, len);
11994 PL_thisstuff = newSVpvn(tstart, len);
11995 if (!PL_thisclose && !keep_delims)
11996 PL_thisclose = newSVpvn(s,termlen);
12001 sv_catpvn(sv, s, termlen);
12006 if (PL_madskills) {
12007 char * const tstart = SvPVX(PL_linestr) + stuffstart;
12008 const int len = s - tstart - termlen;
12010 sv_catpvn(PL_thisstuff, tstart, len);
12012 PL_thisstuff = newSVpvn(tstart, len);
12013 if (!PL_thisclose && !keep_delims)
12014 PL_thisclose = newSVpvn(s - termlen,termlen);
12018 if (has_utf8 || PL_encoding)
12021 PL_multi_end = CopLINE(PL_curcop);
12023 /* if we allocated too much space, give some back */
12024 if (SvCUR(sv) + 5 < SvLEN(sv)) {
12025 SvLEN_set(sv, SvCUR(sv) + 1);
12026 SvPV_renew(sv, SvLEN(sv));
12029 /* decide whether this is the first or second quoted string we've read
12042 takes: pointer to position in buffer
12043 returns: pointer to new position in buffer
12044 side-effects: builds ops for the constant in pl_yylval.op
12046 Read a number in any of the formats that Perl accepts:
12048 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
12049 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
12052 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
12054 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
12057 If it reads a number without a decimal point or an exponent, it will
12058 try converting the number to an integer and see if it can do so
12059 without loss of precision.
12063 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
12066 register const char *s = start; /* current position in buffer */
12067 register char *d; /* destination in temp buffer */
12068 register char *e; /* end of temp buffer */
12069 NV nv; /* number read, as a double */
12070 SV *sv = NULL; /* place to put the converted number */
12071 bool floatit; /* boolean: int or float? */
12072 const char *lastub = NULL; /* position of last underbar */
12073 static char const number_too_long[] = "Number too long";
12075 PERL_ARGS_ASSERT_SCAN_NUM;
12077 /* We use the first character to decide what type of number this is */
12081 Perl_croak(aTHX_ "panic: scan_num");
12083 /* if it starts with a 0, it could be an octal number, a decimal in
12084 0.13 disguise, or a hexadecimal number, or a binary number. */
12088 u holds the "number so far"
12089 shift the power of 2 of the base
12090 (hex == 4, octal == 3, binary == 1)
12091 overflowed was the number more than we can hold?
12093 Shift is used when we add a digit. It also serves as an "are
12094 we in octal/hex/binary?" indicator to disallow hex characters
12095 when in octal mode.
12100 bool overflowed = FALSE;
12101 bool just_zero = TRUE; /* just plain 0 or binary number? */
12102 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
12103 static const char* const bases[5] =
12104 { "", "binary", "", "octal", "hexadecimal" };
12105 static const char* const Bases[5] =
12106 { "", "Binary", "", "Octal", "Hexadecimal" };
12107 static const char* const maxima[5] =
12109 "0b11111111111111111111111111111111",
12113 const char *base, *Base, *max;
12115 /* check for hex */
12120 } else if (s[1] == 'b') {
12125 /* check for a decimal in disguise */
12126 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
12128 /* so it must be octal */
12135 if (ckWARN(WARN_SYNTAX))
12136 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12137 "Misplaced _ in number");
12141 base = bases[shift];
12142 Base = Bases[shift];
12143 max = maxima[shift];
12145 /* read the rest of the number */
12147 /* x is used in the overflow test,
12148 b is the digit we're adding on. */
12153 /* if we don't mention it, we're done */
12157 /* _ are ignored -- but warned about if consecutive */
12159 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12160 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12161 "Misplaced _ in number");
12165 /* 8 and 9 are not octal */
12166 case '8': case '9':
12168 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
12172 case '2': case '3': case '4':
12173 case '5': case '6': case '7':
12175 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
12178 case '0': case '1':
12179 b = *s++ & 15; /* ASCII digit -> value of digit */
12183 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
12184 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
12185 /* make sure they said 0x */
12188 b = (*s++ & 7) + 9;
12190 /* Prepare to put the digit we have onto the end
12191 of the number so far. We check for overflows.
12197 x = u << shift; /* make room for the digit */
12199 if ((x >> shift) != u
12200 && !(PL_hints & HINT_NEW_BINARY)) {
12203 if (ckWARN_d(WARN_OVERFLOW))
12204 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12205 "Integer overflow in %s number",
12208 u = x | b; /* add the digit to the end */
12211 n *= nvshift[shift];
12212 /* If an NV has not enough bits in its
12213 * mantissa to represent an UV this summing of
12214 * small low-order numbers is a waste of time
12215 * (because the NV cannot preserve the
12216 * low-order bits anyway): we could just
12217 * remember when did we overflow and in the
12218 * end just multiply n by the right
12226 /* if we get here, we had success: make a scalar value from
12231 /* final misplaced underbar check */
12232 if (s[-1] == '_') {
12233 if (ckWARN(WARN_SYNTAX))
12234 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12239 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12240 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12241 "%s number > %s non-portable",
12247 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12248 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12249 "%s number > %s non-portable",
12254 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12255 sv = new_constant(start, s - start, "integer",
12256 sv, NULL, NULL, 0);
12257 else if (PL_hints & HINT_NEW_BINARY)
12258 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
12263 handle decimal numbers.
12264 we're also sent here when we read a 0 as the first digit
12266 case '1': case '2': case '3': case '4': case '5':
12267 case '6': case '7': case '8': case '9': case '.':
12270 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12273 /* read next group of digits and _ and copy into d */
12274 while (isDIGIT(*s) || *s == '_') {
12275 /* skip underscores, checking for misplaced ones
12279 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12280 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12281 "Misplaced _ in number");
12285 /* check for end of fixed-length buffer */
12287 Perl_croak(aTHX_ number_too_long);
12288 /* if we're ok, copy the character */
12293 /* final misplaced underbar check */
12294 if (lastub && s == lastub + 1) {
12295 if (ckWARN(WARN_SYNTAX))
12296 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12299 /* read a decimal portion if there is one. avoid
12300 3..5 being interpreted as the number 3. followed
12303 if (*s == '.' && s[1] != '.') {
12308 if (ckWARN(WARN_SYNTAX))
12309 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12310 "Misplaced _ in number");
12314 /* copy, ignoring underbars, until we run out of digits.
12316 for (; isDIGIT(*s) || *s == '_'; s++) {
12317 /* fixed length buffer check */
12319 Perl_croak(aTHX_ number_too_long);
12321 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12322 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12323 "Misplaced _ in number");
12329 /* fractional part ending in underbar? */
12330 if (s[-1] == '_') {
12331 if (ckWARN(WARN_SYNTAX))
12332 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12333 "Misplaced _ in number");
12335 if (*s == '.' && isDIGIT(s[1])) {
12336 /* oops, it's really a v-string, but without the "v" */
12342 /* read exponent part, if present */
12343 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12347 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12348 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12350 /* stray preinitial _ */
12352 if (ckWARN(WARN_SYNTAX))
12353 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12354 "Misplaced _ in number");
12358 /* allow positive or negative exponent */
12359 if (*s == '+' || *s == '-')
12362 /* stray initial _ */
12364 if (ckWARN(WARN_SYNTAX))
12365 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12366 "Misplaced _ in number");
12370 /* read digits of exponent */
12371 while (isDIGIT(*s) || *s == '_') {
12374 Perl_croak(aTHX_ number_too_long);
12378 if (((lastub && s == lastub + 1) ||
12379 (!isDIGIT(s[1]) && s[1] != '_'))
12380 && ckWARN(WARN_SYNTAX))
12381 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12382 "Misplaced _ in number");
12389 /* make an sv from the string */
12393 We try to do an integer conversion first if no characters
12394 indicating "float" have been found.
12399 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12401 if (flags == IS_NUMBER_IN_UV) {
12403 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12406 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12407 if (uv <= (UV) IV_MIN)
12408 sv_setiv(sv, -(IV)uv);
12415 /* terminate the string */
12417 nv = Atof(PL_tokenbuf);
12422 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
12423 const char *const key = floatit ? "float" : "integer";
12424 const STRLEN keylen = floatit ? 5 : 7;
12425 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
12426 key, keylen, sv, NULL, NULL, 0);
12430 /* if it starts with a v, it could be a v-string */
12433 sv = newSV(5); /* preallocate storage space */
12434 s = scan_vstring(s, PL_bufend, sv);
12438 /* make the op for the constant and return */
12441 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12443 lvalp->opval = NULL;
12449 S_scan_formline(pTHX_ register char *s)
12452 register char *eol;
12454 SV * const stuff = newSVpvs("");
12455 bool needargs = FALSE;
12456 bool eofmt = FALSE;
12458 char *tokenstart = s;
12459 SV* savewhite = NULL;
12461 if (PL_madskills) {
12462 savewhite = PL_thiswhite;
12467 PERL_ARGS_ASSERT_SCAN_FORMLINE;
12469 while (!needargs) {
12472 #ifdef PERL_STRICT_CR
12473 while (SPACE_OR_TAB(*t))
12476 while (SPACE_OR_TAB(*t) || *t == '\r')
12479 if (*t == '\n' || t == PL_bufend) {
12484 if (PL_in_eval && !PL_rsfp) {
12485 eol = (char *) memchr(s,'\n',PL_bufend-s);
12490 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12492 for (t = s; t < eol; t++) {
12493 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12495 goto enough; /* ~~ must be first line in formline */
12497 if (*t == '@' || *t == '^')
12501 sv_catpvn(stuff, s, eol-s);
12502 #ifndef PERL_STRICT_CR
12503 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12504 char *end = SvPVX(stuff) + SvCUR(stuff);
12507 SvCUR_set(stuff, SvCUR(stuff) - 1);
12517 if (PL_madskills) {
12519 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12521 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12524 s = filter_gets(PL_linestr, PL_rsfp, 0);
12526 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12528 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12530 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12531 PL_last_lop = PL_last_uni = NULL;
12540 if (SvCUR(stuff)) {
12543 PL_lex_state = LEX_NORMAL;
12544 start_force(PL_curforce);
12545 NEXTVAL_NEXTTOKE.ival = 0;
12549 PL_lex_state = LEX_FORMLINE;
12551 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12553 else if (PL_encoding)
12554 sv_recode_to_utf8(stuff, PL_encoding);
12556 start_force(PL_curforce);
12557 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12559 start_force(PL_curforce);
12560 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12564 SvREFCNT_dec(stuff);
12566 PL_lex_formbrack = 0;
12570 if (PL_madskills) {
12572 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12574 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12575 PL_thiswhite = savewhite;
12582 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12585 const I32 oldsavestack_ix = PL_savestack_ix;
12586 CV* const outsidecv = PL_compcv;
12589 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12591 SAVEI32(PL_subline);
12592 save_item(PL_subname);
12593 SAVESPTR(PL_compcv);
12595 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
12596 CvFLAGS(PL_compcv) |= flags;
12598 PL_subline = CopLINE(PL_curcop);
12599 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12600 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
12601 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12603 return oldsavestack_ix;
12607 #pragma segment Perl_yylex
12610 S_yywarn(pTHX_ const char *const s)
12614 PERL_ARGS_ASSERT_YYWARN;
12616 PL_in_eval |= EVAL_WARNONLY;
12618 PL_in_eval &= ~EVAL_WARNONLY;
12623 Perl_yyerror(pTHX_ const char *const s)
12626 const char *where = NULL;
12627 const char *context = NULL;
12630 int yychar = PL_parser->yychar;
12632 PERL_ARGS_ASSERT_YYERROR;
12634 if (!yychar || (yychar == ';' && !PL_rsfp))
12636 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12637 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12638 PL_oldbufptr != PL_bufptr) {
12641 The code below is removed for NetWare because it abends/crashes on NetWare
12642 when the script has error such as not having the closing quotes like:
12643 if ($var eq "value)
12644 Checking of white spaces is anyway done in NetWare code.
12647 while (isSPACE(*PL_oldoldbufptr))
12650 context = PL_oldoldbufptr;
12651 contlen = PL_bufptr - PL_oldoldbufptr;
12653 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12654 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12657 The code below is removed for NetWare because it abends/crashes on NetWare
12658 when the script has error such as not having the closing quotes like:
12659 if ($var eq "value)
12660 Checking of white spaces is anyway done in NetWare code.
12663 while (isSPACE(*PL_oldbufptr))
12666 context = PL_oldbufptr;
12667 contlen = PL_bufptr - PL_oldbufptr;
12669 else if (yychar > 255)
12670 where = "next token ???";
12671 else if (yychar == -2) { /* YYEMPTY */
12672 if (PL_lex_state == LEX_NORMAL ||
12673 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12674 where = "at end of line";
12675 else if (PL_lex_inpat)
12676 where = "within pattern";
12678 where = "within string";
12681 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
12683 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12684 else if (isPRINT_LC(yychar)) {
12685 const char string = yychar;
12686 sv_catpvn(where_sv, &string, 1);
12689 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12690 where = SvPVX_const(where_sv);
12692 msg = sv_2mortal(newSVpv(s, 0));
12693 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12694 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12696 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12698 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12699 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12700 Perl_sv_catpvf(aTHX_ msg,
12701 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12702 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12705 if (PL_in_eval & EVAL_WARNONLY) {
12706 if (ckWARN_d(WARN_SYNTAX))
12707 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12711 if (PL_error_count >= 10) {
12712 if (PL_in_eval && SvCUR(ERRSV))
12713 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12714 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12716 Perl_croak(aTHX_ "%s has too many errors.\n",
12717 OutCopFILE(PL_curcop));
12720 PL_in_my_stash = NULL;
12724 #pragma segment Main
12728 S_swallow_bom(pTHX_ U8 *s)
12731 const STRLEN slen = SvCUR(PL_linestr);
12733 PERL_ARGS_ASSERT_SWALLOW_BOM;
12737 if (s[1] == 0xFE) {
12738 /* UTF-16 little-endian? (or UTF32-LE?) */
12739 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12740 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12741 #ifndef PERL_NO_UTF16_FILTER
12742 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12745 if (PL_bufend > (char*)s) {
12749 filter_add(utf16rev_textfilter, NULL);
12750 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12751 utf16_to_utf8_reversed(s, news,
12752 PL_bufend - (char*)s - 1,
12754 sv_setpvn(PL_linestr, (const char*)news, newlen);
12756 s = (U8*)SvPVX(PL_linestr);
12757 Copy(news, s, newlen, U8);
12761 SvUTF8_on(PL_linestr);
12762 s = (U8*)SvPVX(PL_linestr);
12764 /* FIXME - is this a general bug fix? */
12767 PL_bufend = SvPVX(PL_linestr) + newlen;
12770 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12775 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12776 #ifndef PERL_NO_UTF16_FILTER
12777 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12780 if (PL_bufend > (char *)s) {
12784 filter_add(utf16_textfilter, NULL);
12785 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12786 utf16_to_utf8(s, news,
12787 PL_bufend - (char*)s,
12789 sv_setpvn(PL_linestr, (const char*)news, newlen);
12791 SvUTF8_on(PL_linestr);
12792 s = (U8*)SvPVX(PL_linestr);
12793 PL_bufend = SvPVX(PL_linestr) + newlen;
12796 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12801 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12802 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12803 s += 3; /* UTF-8 */
12809 if (s[2] == 0xFE && s[3] == 0xFF) {
12810 /* UTF-32 big-endian */
12811 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12814 else if (s[2] == 0 && s[3] != 0) {
12817 * are a good indicator of UTF-16BE. */
12818 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12824 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12825 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12826 s += 4; /* UTF-8 */
12832 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12835 * are a good indicator of UTF-16LE. */
12836 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12844 #ifndef PERL_NO_UTF16_FILTER
12846 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12849 const STRLEN old = SvCUR(sv);
12850 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12851 DEBUG_P(PerlIO_printf(Perl_debug_log,
12852 "utf16_textfilter(%p): %d %d (%d)\n",
12853 FPTR2DPTR(void *, utf16_textfilter),
12854 idx, maxlen, (int) count));
12858 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12859 Copy(SvPVX_const(sv), tmps, old, char);
12860 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12861 SvCUR(sv) - old, &newlen);
12862 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12864 DEBUG_P({sv_dump(sv);});
12869 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12872 const STRLEN old = SvCUR(sv);
12873 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12874 DEBUG_P(PerlIO_printf(Perl_debug_log,
12875 "utf16rev_textfilter(%p): %d %d (%d)\n",
12876 FPTR2DPTR(void *, utf16rev_textfilter),
12877 idx, maxlen, (int) count));
12881 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12882 Copy(SvPVX_const(sv), tmps, old, char);
12883 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12884 SvCUR(sv) - old, &newlen);
12885 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12887 DEBUG_P({ sv_dump(sv); });
12893 Returns a pointer to the next character after the parsed
12894 vstring, as well as updating the passed in sv.
12896 Function must be called like
12899 s = scan_vstring(s,e,sv);
12901 where s and e are the start and end of the string.
12902 The sv should already be large enough to store the vstring
12903 passed in, for performance reasons.
12908 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12911 const char *pos = s;
12912 const char *start = s;
12914 PERL_ARGS_ASSERT_SCAN_VSTRING;
12916 if (*pos == 'v') pos++; /* get past 'v' */
12917 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12919 if ( *pos != '.') {
12920 /* this may not be a v-string if followed by => */
12921 const char *next = pos;
12922 while (next < e && isSPACE(*next))
12924 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12925 /* return string not v-string */
12926 sv_setpvn(sv,(char *)s,pos-s);
12927 return (char *)pos;
12931 if (!isALPHA(*pos)) {
12932 U8 tmpbuf[UTF8_MAXBYTES+1];
12935 s++; /* get past 'v' */
12940 /* this is atoi() that tolerates underscores */
12943 const char *end = pos;
12945 while (--end >= s) {
12947 const UV orev = rev;
12948 rev += (*end - '0') * mult;
12950 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12951 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12952 "Integer overflow in decimal number");
12956 if (rev > 0x7FFFFFFF)
12957 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12959 /* Append native character for the rev point */
12960 tmpend = uvchr_to_utf8(tmpbuf, rev);
12961 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12962 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12964 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12970 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12974 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12982 * c-indentation-style: bsd
12983 * c-basic-offset: 4
12984 * indent-tabs-mode: t
12987 * ex: set ts=8 sts=4 sw=4 noet: