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 /* In variables named $^X, these are the legal values for X.
128 * 1999-02-27 mjd-perl-patch@plover.com */
129 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
131 /* On MacOS, respect nonbreaking spaces */
132 #ifdef MACOS_TRADITIONAL
133 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
135 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
138 /* LEX_* are values for PL_lex_state, the state of the lexer.
139 * They are arranged oddly so that the guard on the switch statement
140 * can get by with a single comparison (if the compiler is smart enough).
143 /* #define LEX_NOTPARSING 11 is done in perl.h. */
145 #define LEX_NORMAL 10 /* normal code (ie not within "...") */
146 #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
147 #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
148 #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
149 #define LEX_INTERPSTART 6 /* expecting the start of a $var */
151 /* at end of code, eg "$x" followed by: */
152 #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
153 #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
155 #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
156 string or after \E, $foo, etc */
157 #define LEX_INTERPCONST 2 /* NOT USED */
158 #define LEX_FORMLINE 1 /* expecting a format line */
159 #define LEX_KNOWNEXT 0 /* next token known; just return it */
163 static const char* const lex_state_names[] = {
182 #include "keywords.h"
184 /* CLINE is a macro that ensures PL_copline has a sane value */
189 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
192 # define SKIPSPACE0(s) skipspace0(s)
193 # define SKIPSPACE1(s) skipspace1(s)
194 # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
195 # define PEEKSPACE(s) skipspace2(s,0)
197 # define SKIPSPACE0(s) skipspace(s)
198 # define SKIPSPACE1(s) skipspace(s)
199 # define SKIPSPACE2(s,tsv) skipspace(s)
200 # define PEEKSPACE(s) skipspace(s)
204 * Convenience functions to return different tokens and prime the
205 * lexer for the next token. They all take an argument.
207 * TOKEN : generic token (used for '(', DOLSHARP, etc)
208 * OPERATOR : generic operator
209 * AOPERATOR : assignment operator
210 * PREBLOCK : beginning the block after an if, while, foreach, ...
211 * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
212 * PREREF : *EXPR where EXPR is not a simple identifier
213 * TERM : expression term
214 * LOOPX : loop exiting command (goto, last, dump, etc)
215 * FTST : file test operator
216 * FUN0 : zero-argument function
217 * FUN1 : not used, except for not, which isn't a UNIOP
218 * BOop : bitwise or or xor
220 * SHop : shift operator
221 * PWop : power operator
222 * PMop : pattern-matching operator
223 * Aop : addition-level operator
224 * Mop : multiplication-level operator
225 * Eop : equality-testing operator
226 * Rop : relational operator <= != gt
228 * Also see LOP and lop() below.
231 #ifdef DEBUGGING /* Serve -DT. */
232 # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
234 # define REPORT(retval) (retval)
237 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
238 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
239 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
240 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
241 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
242 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
243 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
244 #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
245 #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
246 #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
247 #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
248 #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
249 #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
250 #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
251 #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
252 #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
253 #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
254 #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
255 #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
256 #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
258 /* This bit of chicanery makes a unary function followed by
259 * a parenthesis into a function with one argument, highest precedence.
260 * The UNIDOR macro is for unary functions that can be followed by the //
261 * operator (such as C<shift // 0>).
263 #define UNI2(f,x) { \
264 pl_yylval.ival = f; \
267 PL_last_uni = PL_oldbufptr; \
268 PL_last_lop_op = f; \
270 return REPORT( (int)FUNC1 ); \
272 return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
274 #define UNI(f) UNI2(f,XTERM)
275 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
277 #define UNIBRACK(f) { \
278 pl_yylval.ival = f; \
280 PL_last_uni = PL_oldbufptr; \
282 return REPORT( (int)FUNC1 ); \
284 return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
287 /* grandfather return to old style */
288 #define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
292 /* how to interpret the pl_yylval associated with the token */
296 TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
302 static struct debug_tokens {
304 enum token_type type;
306 } const debug_tokens[] =
308 { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
309 { ANDAND, TOKENTYPE_NONE, "ANDAND" },
310 { ANDOP, TOKENTYPE_NONE, "ANDOP" },
311 { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
312 { ARROW, TOKENTYPE_NONE, "ARROW" },
313 { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
314 { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
315 { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
316 { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
317 { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
318 { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
319 { DO, TOKENTYPE_NONE, "DO" },
320 { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
321 { DORDOR, TOKENTYPE_NONE, "DORDOR" },
322 { DOROP, TOKENTYPE_OPNUM, "DOROP" },
323 { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
324 { ELSE, TOKENTYPE_NONE, "ELSE" },
325 { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
326 { EQOP, TOKENTYPE_OPNUM, "EQOP" },
327 { FOR, TOKENTYPE_IVAL, "FOR" },
328 { FORMAT, TOKENTYPE_NONE, "FORMAT" },
329 { FUNC, TOKENTYPE_OPNUM, "FUNC" },
330 { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
331 { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
332 { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
333 { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
334 { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
335 { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
336 { IF, TOKENTYPE_IVAL, "IF" },
337 { LABEL, TOKENTYPE_PVAL, "LABEL" },
338 { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
339 { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
340 { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
341 { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
342 { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
343 { METHOD, TOKENTYPE_OPVAL, "METHOD" },
344 { MULOP, TOKENTYPE_OPNUM, "MULOP" },
345 { MY, TOKENTYPE_IVAL, "MY" },
346 { MYSUB, TOKENTYPE_NONE, "MYSUB" },
347 { NOAMP, TOKENTYPE_NONE, "NOAMP" },
348 { NOTOP, TOKENTYPE_NONE, "NOTOP" },
349 { OROP, TOKENTYPE_IVAL, "OROP" },
350 { OROR, TOKENTYPE_NONE, "OROR" },
351 { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
352 { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
353 { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
354 { POSTINC, TOKENTYPE_NONE, "POSTINC" },
355 { POWOP, TOKENTYPE_OPNUM, "POWOP" },
356 { PREDEC, TOKENTYPE_NONE, "PREDEC" },
357 { PREINC, TOKENTYPE_NONE, "PREINC" },
358 { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
359 { REFGEN, TOKENTYPE_NONE, "REFGEN" },
360 { RELOP, TOKENTYPE_OPNUM, "RELOP" },
361 { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
362 { SUB, TOKENTYPE_NONE, "SUB" },
363 { THING, TOKENTYPE_OPVAL, "THING" },
364 { UMINUS, TOKENTYPE_NONE, "UMINUS" },
365 { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
366 { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
367 { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
368 { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
369 { USE, TOKENTYPE_IVAL, "USE" },
370 { WHEN, TOKENTYPE_IVAL, "WHEN" },
371 { WHILE, TOKENTYPE_IVAL, "WHILE" },
372 { WORD, TOKENTYPE_OPVAL, "WORD" },
373 { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
374 { 0, TOKENTYPE_NONE, NULL }
377 /* dump the returned token in rv, plus any optional arg in pl_yylval */
380 S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
384 PERL_ARGS_ASSERT_TOKEREPORT;
387 const char *name = NULL;
388 enum token_type type = TOKENTYPE_NONE;
389 const struct debug_tokens *p;
390 SV* const report = newSVpvs("<== ");
392 for (p = debug_tokens; p->token; p++) {
393 if (p->token == (int)rv) {
400 Perl_sv_catpv(aTHX_ report, name);
401 else if ((char)rv > ' ' && (char)rv < '~')
402 Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
404 sv_catpvs(report, "EOF");
406 Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
409 case TOKENTYPE_GVVAL: /* doesn't appear to be used */
412 Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
414 case TOKENTYPE_OPNUM:
415 Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
416 PL_op_name[lvalp->ival]);
419 Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
421 case TOKENTYPE_OPVAL:
423 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
424 PL_op_name[lvalp->opval->op_type]);
425 if (lvalp->opval->op_type == OP_CONST) {
426 Perl_sv_catpvf(aTHX_ report, " %s",
427 SvPEEK(cSVOPx_sv(lvalp->opval)));
432 sv_catpvs(report, "(opval=null)");
435 PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
441 /* print the buffer with suitable escapes */
444 S_printbuf(pTHX_ const char *const fmt, const char *const s)
446 SV* const tmp = newSVpvs("");
448 PERL_ARGS_ASSERT_PRINTBUF;
450 PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
459 * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
460 * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
464 S_ao(pTHX_ int toketype)
467 if (*PL_bufptr == '=') {
469 if (toketype == ANDAND)
470 pl_yylval.ival = OP_ANDASSIGN;
471 else if (toketype == OROR)
472 pl_yylval.ival = OP_ORASSIGN;
473 else if (toketype == DORDOR)
474 pl_yylval.ival = OP_DORASSIGN;
482 * When Perl expects an operator and finds something else, no_op
483 * prints the warning. It always prints "<something> found where
484 * operator expected. It prints "Missing semicolon on previous line?"
485 * if the surprise occurs at the start of the line. "do you need to
486 * predeclare ..." is printed out for code like "sub bar; foo bar $x"
487 * where the compiler doesn't know if foo is a method call or a function.
488 * It prints "Missing operator before end of line" if there's nothing
489 * after the missing operator, or "... before <...>" if there is something
490 * after the missing operator.
494 S_no_op(pTHX_ const char *const what, char *s)
497 char * const oldbp = PL_bufptr;
498 const bool is_first = (PL_oldbufptr == PL_linestart);
500 PERL_ARGS_ASSERT_NO_OP;
506 yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
507 if (ckWARN_d(WARN_SYNTAX)) {
509 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
510 "\t(Missing semicolon on previous line?)\n");
511 else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
513 for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
515 if (t < PL_bufptr && isSPACE(*t))
516 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
517 "\t(Do you need to predeclare %.*s?)\n",
518 (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
522 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
523 "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
531 * Complain about missing quote/regexp/heredoc terminator.
532 * If it's called with NULL then it cauterizes the line buffer.
533 * If we're in a delimited string and the delimiter is a control
534 * character, it's reformatted into a two-char sequence like ^C.
539 S_missingterm(pTHX_ char *s)
545 char * const nl = strrchr(s,'\n');
549 else if (isCNTRL(PL_multi_close)) {
551 tmpbuf[1] = (char)toCTRL(PL_multi_close);
556 *tmpbuf = (char)PL_multi_close;
560 q = strchr(s,'"') ? '\'' : '"';
561 Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
564 #define FEATURE_IS_ENABLED(name) \
565 ((0 != (PL_hints & HINT_LOCALIZE_HH)) \
566 && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
567 /* The longest string we pass in. */
568 #define MAX_FEATURE_LEN (sizeof("switch")-1)
571 * S_feature_is_enabled
572 * Check whether the named feature is enabled.
575 S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
578 HV * const hinthv = GvHV(PL_hintgv);
579 char he_name[8 + MAX_FEATURE_LEN] = "feature_";
581 PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
583 assert(namelen <= MAX_FEATURE_LEN);
584 memcpy(&he_name[8], name, namelen);
586 return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
594 Perl_deprecate(pTHX_ const char *const s)
596 PERL_ARGS_ASSERT_DEPRECATE;
598 if (ckWARN(WARN_DEPRECATED))
599 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
603 Perl_deprecate_old(pTHX_ const char *const s)
605 /* This function should NOT be called for any new deprecated warnings */
606 /* Use Perl_deprecate instead */
608 /* It is here to maintain backward compatibility with the pre-5.8 */
609 /* warnings category hierarchy. The "deprecated" category used to */
610 /* live under the "syntax" category. It is now a top-level category */
611 /* in its own right. */
613 PERL_ARGS_ASSERT_DEPRECATE_OLD;
615 if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
616 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
617 "Use of %s is deprecated", s);
621 * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
622 * utf16-to-utf8-reversed.
625 #ifdef PERL_CR_FILTER
629 register const char *s = SvPVX_const(sv);
630 register const char * const e = s + SvCUR(sv);
632 PERL_ARGS_ASSERT_STRIP_RETURN;
634 /* outer loop optimized to do nothing if there are no CR-LFs */
636 if (*s++ == '\r' && *s == '\n') {
637 /* hit a CR-LF, need to copy the rest */
638 register char *d = s - 1;
641 if (*s == '\r' && s[1] == '\n')
652 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
654 const I32 count = FILTER_READ(idx+1, sv, maxlen);
655 if (count > 0 && !maxlen)
666 * Create a parser object and initialise its parser and lexer fields
668 * rsfp is the opened file handle to read from (if any),
670 * line holds any initial content already read from the file (or in
671 * the case of no file, such as an eval, the whole contents);
673 * new_filter indicates that this is a new file and it shouldn't inherit
674 * the filters from the current parser (ie require).
678 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, bool new_filter)
681 const char *s = NULL;
683 yy_parser *parser, *oparser;
685 /* create and initialise a parser */
687 Newxz(parser, 1, yy_parser);
688 parser->old_parser = oparser = PL_parser;
691 Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
692 parser->ps = parser->stack;
693 parser->stack_size = YYINITDEPTH;
695 parser->stack->state = 0;
696 parser->yyerrstatus = 0;
697 parser->yychar = YYEMPTY; /* Cause a token to be read. */
699 /* on scope exit, free this parser and restore any outer one */
701 parser->saved_curcop = PL_curcop;
703 /* initialise lexer state */
706 parser->curforce = -1;
708 parser->nexttoke = 0;
710 parser->error_count = oparser ? oparser->error_count : 0;
711 parser->copline = NOLINE;
712 parser->lex_state = LEX_NORMAL;
713 parser->expect = XSTATE;
715 parser->rsfp_filters = (new_filter || !oparser) ? newAV()
716 : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
718 Newx(parser->lex_brackstack, 120, char);
719 Newx(parser->lex_casestack, 12, char);
720 *parser->lex_casestack = '\0';
723 s = SvPV_const(line, len);
729 parser->linestr = newSVpvs("\n;");
730 } else if (SvREADONLY(line) || s[len-1] != ';') {
731 parser->linestr = newSVsv(line);
733 sv_catpvs(parser->linestr, "\n;");
736 SvREFCNT_inc_simple_void_NN(line);
737 parser->linestr = line;
739 parser->oldoldbufptr =
742 parser->linestart = SvPVX(parser->linestr);
743 parser->bufend = parser->bufptr + SvCUR(parser->linestr);
744 parser->last_lop = parser->last_uni = NULL;
748 /* delete a parser object */
751 Perl_parser_free(pTHX_ const yy_parser *parser)
753 PERL_ARGS_ASSERT_PARSER_FREE;
755 PL_curcop = parser->saved_curcop;
756 SvREFCNT_dec(parser->linestr);
758 if (parser->rsfp == PerlIO_stdin())
759 PerlIO_clearerr(parser->rsfp);
760 else if (parser->rsfp && (!parser->old_parser ||
761 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
762 PerlIO_close(parser->rsfp);
763 SvREFCNT_dec(parser->rsfp_filters);
765 Safefree(parser->stack);
766 Safefree(parser->lex_brackstack);
767 Safefree(parser->lex_casestack);
768 PL_parser = parser->old_parser;
775 * Finalizer for lexing operations. Must be called when the parser is
776 * done with the lexer.
783 PL_doextract = FALSE;
788 * This subroutine has nothing to do with tilting, whether at windmills
789 * or pinball tables. Its name is short for "increment line". It
790 * increments the current line number in CopLINE(PL_curcop) and checks
791 * to see whether the line starts with a comment of the form
792 * # line 500 "foo.pm"
793 * If so, it sets the current line number and file to the values in the comment.
797 S_incline(pTHX_ const char *s)
804 PERL_ARGS_ASSERT_INCLINE;
806 CopLINE_inc(PL_curcop);
809 while (SPACE_OR_TAB(*s))
811 if (strnEQ(s, "line", 4))
815 if (SPACE_OR_TAB(*s))
819 while (SPACE_OR_TAB(*s))
827 if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
829 while (SPACE_OR_TAB(*s))
831 if (*s == '"' && (t = strchr(s+1, '"'))) {
841 while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
843 if (*e != '\n' && *e != '\0')
844 return; /* false alarm */
847 const STRLEN len = t - s;
849 SV *const temp_sv = CopFILESV(PL_curcop);
855 tmplen = SvCUR(temp_sv);
861 if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
862 /* must copy *{"::_<(eval N)[oldfilename:L]"}
863 * to *{"::_<newfilename"} */
864 /* However, the long form of evals is only turned on by the
865 debugger - usually they're "(eval %lu)" */
869 STRLEN tmplen2 = len;
870 if (tmplen + 2 <= sizeof smallbuf)
873 Newx(tmpbuf, tmplen + 2, char);
876 memcpy(tmpbuf + 2, cf, tmplen);
878 gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
883 if (tmplen2 + 2 <= sizeof smallbuf)
886 Newx(tmpbuf2, tmplen2 + 2, char);
888 if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
889 /* Either they malloc'd it, or we malloc'd it,
890 so no prefix is present in ours. */
895 memcpy(tmpbuf2 + 2, s, tmplen2);
898 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
900 gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
901 /* adjust ${"::_<newfilename"} to store the new file name */
902 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
903 GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
904 GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
907 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
909 if (tmpbuf != smallbuf) Safefree(tmpbuf);
912 CopFILE_free(PL_curcop);
913 CopFILE_setn(PL_curcop, s, len);
915 CopLINE_set(PL_curcop, atoi(n)-1);
919 /* skip space before PL_thistoken */
922 S_skipspace0(pTHX_ register char *s)
924 PERL_ARGS_ASSERT_SKIPSPACE0;
931 PL_thiswhite = newSVpvs("");
932 sv_catsv(PL_thiswhite, PL_skipwhite);
933 sv_free(PL_skipwhite);
936 PL_realtokenstart = s - SvPVX(PL_linestr);
940 /* skip space after PL_thistoken */
943 S_skipspace1(pTHX_ register char *s)
945 const char *start = s;
946 I32 startoff = start - SvPVX(PL_linestr);
948 PERL_ARGS_ASSERT_SKIPSPACE1;
953 start = SvPVX(PL_linestr) + startoff;
954 if (!PL_thistoken && PL_realtokenstart >= 0) {
955 const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
956 PL_thistoken = newSVpvn(tstart, start - tstart);
958 PL_realtokenstart = -1;
961 PL_nextwhite = newSVpvs("");
962 sv_catsv(PL_nextwhite, PL_skipwhite);
963 sv_free(PL_skipwhite);
970 S_skipspace2(pTHX_ register char *s, SV **svp)
973 const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
974 const I32 startoff = s - SvPVX(PL_linestr);
976 PERL_ARGS_ASSERT_SKIPSPACE2;
979 PL_bufptr = SvPVX(PL_linestr) + bufptroff;
980 if (!PL_madskills || !svp)
982 start = SvPVX(PL_linestr) + startoff;
983 if (!PL_thistoken && PL_realtokenstart >= 0) {
984 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
985 PL_thistoken = newSVpvn(tstart, start - tstart);
986 PL_realtokenstart = -1;
991 sv_setsv(*svp, PL_skipwhite);
992 sv_free(PL_skipwhite);
1001 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1003 AV *av = CopFILEAVx(PL_curcop);
1005 SV * const sv = newSV_type(SVt_PVMG);
1007 sv_setsv(sv, orig_sv);
1009 sv_setpvn(sv, buf, len);
1012 av_store(av, (I32)CopLINE(PL_curcop), sv);
1018 * Called to gobble the appropriate amount and type of whitespace.
1019 * Skips comments as well.
1023 S_skipspace(pTHX_ register char *s)
1028 int startoff = s - SvPVX(PL_linestr);
1030 PERL_ARGS_ASSERT_SKIPSPACE;
1033 sv_free(PL_skipwhite);
1037 PERL_ARGS_ASSERT_SKIPSPACE;
1039 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1040 while (s < PL_bufend && SPACE_OR_TAB(*s))
1050 SSize_t oldprevlen, oldoldprevlen;
1051 SSize_t oldloplen = 0, oldunilen = 0;
1052 while (s < PL_bufend && isSPACE(*s)) {
1053 if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
1058 if (s < PL_bufend && *s == '#') {
1059 while (s < PL_bufend && *s != '\n')
1061 if (s < PL_bufend) {
1063 if (PL_in_eval && !PL_rsfp) {
1070 /* only continue to recharge the buffer if we're at the end
1071 * of the buffer, we're not reading from a source filter, and
1072 * we're in normal lexing mode
1074 if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
1075 PL_lex_state == LEX_FORMLINE)
1082 /* try to recharge the buffer */
1084 curoff = s - SvPVX(PL_linestr);
1087 if ((s = filter_gets(PL_linestr, PL_rsfp,
1088 (prevlen = SvCUR(PL_linestr)))) == NULL)
1091 if (PL_madskills && curoff != startoff) {
1093 PL_skipwhite = newSVpvs("");
1094 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1098 /* mustn't throw out old stuff yet if madpropping */
1099 SvCUR(PL_linestr) = curoff;
1100 s = SvPVX(PL_linestr) + curoff;
1102 if (curoff && s[-1] == '\n')
1106 /* end of file. Add on the -p or -n magic */
1107 /* XXX these shouldn't really be added here, can't set PL_faketokens */
1110 sv_catpvs(PL_linestr,
1111 ";}continue{print or die qq(-p destination: $!\\n);}");
1113 sv_setpvs(PL_linestr,
1114 ";}continue{print or die qq(-p destination: $!\\n);}");
1116 PL_minus_n = PL_minus_p = 0;
1118 else if (PL_minus_n) {
1120 sv_catpvs(PL_linestr, ";}");
1122 sv_setpvs(PL_linestr, ";}");
1128 sv_catpvs(PL_linestr,";");
1130 sv_setpvs(PL_linestr,";");
1133 /* reset variables for next time we lex */
1134 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1140 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1141 PL_last_lop = PL_last_uni = NULL;
1143 /* Close the filehandle. Could be from
1144 * STDIN, or a regular file. If we were reading code from
1145 * STDIN (because the commandline held no -e or filename)
1146 * then we don't close it, we reset it so the code can
1147 * read from STDIN too.
1150 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1151 PerlIO_clearerr(PL_rsfp);
1153 (void)PerlIO_close(PL_rsfp);
1158 /* not at end of file, so we only read another line */
1159 /* make corresponding updates to old pointers, for yyerror() */
1160 oldprevlen = PL_oldbufptr - PL_bufend;
1161 oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1163 oldunilen = PL_last_uni - PL_bufend;
1165 oldloplen = PL_last_lop - PL_bufend;
1166 PL_linestart = PL_bufptr = s + prevlen;
1167 PL_bufend = s + SvCUR(PL_linestr);
1169 PL_oldbufptr = s + oldprevlen;
1170 PL_oldoldbufptr = s + oldoldprevlen;
1172 PL_last_uni = s + oldunilen;
1174 PL_last_lop = s + oldloplen;
1177 /* debugger active and we're not compiling the debugger code,
1178 * so store the line into the debugger's array of lines
1180 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
1181 update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1188 PL_skipwhite = newSVpvs("");
1189 curoff = s - SvPVX(PL_linestr);
1190 if (curoff - startoff)
1191 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1200 * Check the unary operators to ensure there's no ambiguity in how they're
1201 * used. An ambiguous piece of code would be:
1203 * This doesn't mean rand() + 5. Because rand() is a unary operator,
1204 * the +5 is its argument.
1214 if (PL_oldoldbufptr != PL_last_uni)
1216 while (isSPACE(*PL_last_uni))
1219 while (isALNUM_lazy_if(s,UTF) || *s == '-')
1221 if ((t = strchr(s, '(')) && t < PL_bufptr)
1224 if (ckWARN_d(WARN_AMBIGUOUS)){
1225 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1226 "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1227 (int)(s - PL_last_uni), PL_last_uni);
1232 * LOP : macro to build a list operator. Its behaviour has been replaced
1233 * with a subroutine, S_lop() for which LOP is just another name.
1236 #define LOP(f,x) return lop(f,x,s)
1240 * Build a list operator (or something that might be one). The rules:
1241 * - if we have a next token, then it's a list operator [why?]
1242 * - if the next thing is an opening paren, then it's a function
1243 * - else it's a list operator
1247 S_lop(pTHX_ I32 f, int x, char *s)
1251 PERL_ARGS_ASSERT_LOP;
1257 PL_last_lop = PL_oldbufptr;
1258 PL_last_lop_op = (OPCODE)f;
1261 return REPORT(LSTOP);
1264 return REPORT(LSTOP);
1267 return REPORT(FUNC);
1270 return REPORT(FUNC);
1272 return REPORT(LSTOP);
1278 * Sets up for an eventual force_next(). start_force(0) basically does
1279 * an unshift, while start_force(-1) does a push. yylex removes items
1284 S_start_force(pTHX_ int where)
1288 if (where < 0) /* so people can duplicate start_force(PL_curforce) */
1289 where = PL_lasttoke;
1290 assert(PL_curforce < 0 || PL_curforce == where);
1291 if (PL_curforce != where) {
1292 for (i = PL_lasttoke; i > where; --i) {
1293 PL_nexttoke[i] = PL_nexttoke[i-1];
1297 if (PL_curforce < 0) /* in case of duplicate start_force() */
1298 Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1299 PL_curforce = where;
1302 curmad('^', newSVpvs(""));
1303 CURMAD('_', PL_nextwhite);
1308 S_curmad(pTHX_ char slot, SV *sv)
1314 if (PL_curforce < 0)
1315 where = &PL_thismad;
1317 where = &PL_nexttoke[PL_curforce].next_mad;
1323 if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1325 else if (PL_encoding) {
1326 sv_recode_to_utf8(sv, PL_encoding);
1331 /* keep a slot open for the head of the list? */
1332 if (slot != '_' && *where && (*where)->mad_key == '^') {
1333 (*where)->mad_key = slot;
1334 sv_free(MUTABLE_SV(((*where)->mad_val)));
1335 (*where)->mad_val = (void*)sv;
1338 addmad(newMADsv(slot, sv), where, 0);
1341 # define start_force(where) NOOP
1342 # define curmad(slot, sv) NOOP
1347 * When the lexer realizes it knows the next token (for instance,
1348 * it is reordering tokens for the parser) then it can call S_force_next
1349 * to know what token to return the next time the lexer is called. Caller
1350 * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1351 * and possibly PL_expect to ensure the lexer handles the token correctly.
1355 S_force_next(pTHX_ I32 type)
1360 PerlIO_printf(Perl_debug_log, "### forced token:\n");
1361 tokereport(type, &NEXTVAL_NEXTTOKE);
1365 if (PL_curforce < 0)
1366 start_force(PL_lasttoke);
1367 PL_nexttoke[PL_curforce].next_type = type;
1368 if (PL_lex_state != LEX_KNOWNEXT)
1369 PL_lex_defer = PL_lex_state;
1370 PL_lex_state = LEX_KNOWNEXT;
1371 PL_lex_expect = PL_expect;
1374 PL_nexttype[PL_nexttoke] = type;
1376 if (PL_lex_state != LEX_KNOWNEXT) {
1377 PL_lex_defer = PL_lex_state;
1378 PL_lex_expect = PL_expect;
1379 PL_lex_state = LEX_KNOWNEXT;
1385 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
1388 SV * const sv = newSVpvn_utf8(start, len,
1390 && is_utf8_string((const U8*)start, len));
1396 * When the lexer knows the next thing is a word (for instance, it has
1397 * just seen -> and it knows that the next char is a word char, then
1398 * it calls S_force_word to stick the next word into the PL_nexttoke/val
1402 * char *start : buffer position (must be within PL_linestr)
1403 * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1404 * int check_keyword : if true, Perl checks to make sure the word isn't
1405 * a keyword (do this if the word is a label, e.g. goto FOO)
1406 * int allow_pack : if true, : characters will also be allowed (require,
1407 * use, etc. do this)
1408 * int allow_initial_tick : used by the "sub" lexer only.
1412 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1418 PERL_ARGS_ASSERT_FORCE_WORD;
1420 start = SKIPSPACE1(start);
1422 if (isIDFIRST_lazy_if(s,UTF) ||
1423 (allow_pack && *s == ':') ||
1424 (allow_initial_tick && *s == '\'') )
1426 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1427 if (check_keyword && keyword(PL_tokenbuf, len, 0))
1429 start_force(PL_curforce);
1431 curmad('X', newSVpvn(start,s-start));
1432 if (token == METHOD) {
1437 PL_expect = XOPERATOR;
1441 curmad('g', newSVpvs( "forced" ));
1442 NEXTVAL_NEXTTOKE.opval
1443 = (OP*)newSVOP(OP_CONST,0,
1444 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1445 NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1453 * Called when the lexer wants $foo *foo &foo etc, but the program
1454 * text only contains the "foo" portion. The first argument is a pointer
1455 * to the "foo", and the second argument is the type symbol to prefix.
1456 * Forces the next token to be a "WORD".
1457 * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1461 S_force_ident(pTHX_ register const char *s, int kind)
1465 PERL_ARGS_ASSERT_FORCE_IDENT;
1468 const STRLEN len = strlen(s);
1469 OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1470 start_force(PL_curforce);
1471 NEXTVAL_NEXTTOKE.opval = o;
1474 o->op_private = OPpCONST_ENTERED;
1475 /* XXX see note in pp_entereval() for why we forgo typo
1476 warnings if the symbol must be introduced in an eval.
1478 gv_fetchpvn_flags(s, len,
1479 PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1481 kind == '$' ? SVt_PV :
1482 kind == '@' ? SVt_PVAV :
1483 kind == '%' ? SVt_PVHV :
1491 Perl_str_to_version(pTHX_ SV *sv)
1496 const char *start = SvPV_const(sv,len);
1497 const char * const end = start + len;
1498 const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1500 PERL_ARGS_ASSERT_STR_TO_VERSION;
1502 while (start < end) {
1506 n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1511 retval += ((NV)n)/nshift;
1520 * Forces the next token to be a version number.
1521 * If the next token appears to be an invalid version number, (e.g. "v2b"),
1522 * and if "guessing" is TRUE, then no new token is created (and the caller
1523 * must use an alternative parsing method).
1527 S_force_version(pTHX_ char *s, int guessing)
1533 I32 startoff = s - SvPVX(PL_linestr);
1536 PERL_ARGS_ASSERT_FORCE_VERSION;
1544 while (isDIGIT(*d) || *d == '_' || *d == '.')
1548 start_force(PL_curforce);
1549 curmad('X', newSVpvn(s,d-s));
1552 if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1554 s = scan_num(s, &pl_yylval);
1555 version = pl_yylval.opval;
1556 ver = cSVOPx(version)->op_sv;
1557 if (SvPOK(ver) && !SvNIOK(ver)) {
1558 SvUPGRADE(ver, SVt_PVNV);
1559 SvNV_set(ver, str_to_version(ver));
1560 SvNOK_on(ver); /* hint that it is a version */
1563 else if (guessing) {
1566 sv_free(PL_nextwhite); /* let next token collect whitespace */
1568 s = SvPVX(PL_linestr) + startoff;
1576 if (PL_madskills && !version) {
1577 sv_free(PL_nextwhite); /* let next token collect whitespace */
1579 s = SvPVX(PL_linestr) + startoff;
1582 /* NOTE: The parser sees the package name and the VERSION swapped */
1583 start_force(PL_curforce);
1584 NEXTVAL_NEXTTOKE.opval = version;
1592 * Tokenize a quoted string passed in as an SV. It finds the next
1593 * chunk, up to end of string or a backslash. It may make a new
1594 * SV containing that chunk (if HINT_NEW_STRING is on). It also
1599 S_tokeq(pTHX_ SV *sv)
1603 register char *send;
1608 PERL_ARGS_ASSERT_TOKEQ;
1613 s = SvPV_force(sv, len);
1614 if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1617 while (s < send && *s != '\\')
1622 if ( PL_hints & HINT_NEW_STRING ) {
1623 pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
1627 if (s + 1 < send && (s[1] == '\\'))
1628 s++; /* all that, just for this */
1633 SvCUR_set(sv, d - SvPVX_const(sv));
1635 if ( PL_hints & HINT_NEW_STRING )
1636 return new_constant(NULL, 0, "q", sv, pv, "q", 1);
1641 * Now come three functions related to double-quote context,
1642 * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
1643 * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
1644 * interact with PL_lex_state, and create fake ( ... ) argument lists
1645 * to handle functions and concatenation.
1646 * They assume that whoever calls them will be setting up a fake
1647 * join call, because each subthing puts a ',' after it. This lets
1650 * join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1652 * (I'm not sure whether the spurious commas at the end of lcfirst's
1653 * arguments and join's arguments are created or not).
1658 * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1660 * Pattern matching will set PL_lex_op to the pattern-matching op to
1661 * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
1663 * OP_CONST and OP_READLINE are easy--just make the new op and return.
1665 * Everything else becomes a FUNC.
1667 * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1668 * had an OP_CONST or OP_READLINE). This just sets us up for a
1669 * call to S_sublex_push().
1673 S_sublex_start(pTHX)
1676 register const I32 op_type = pl_yylval.ival;
1678 if (op_type == OP_NULL) {
1679 pl_yylval.opval = PL_lex_op;
1683 if (op_type == OP_CONST || op_type == OP_READLINE) {
1684 SV *sv = tokeq(PL_lex_stuff);
1686 if (SvTYPE(sv) == SVt_PVIV) {
1687 /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1689 const char * const p = SvPV_const(sv, len);
1690 SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
1694 pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1695 PL_lex_stuff = NULL;
1696 /* Allow <FH> // "foo" */
1697 if (op_type == OP_READLINE)
1698 PL_expect = XTERMORDORDOR;
1701 else if (op_type == OP_BACKTICK && PL_lex_op) {
1702 /* readpipe() vas overriden */
1703 cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1704 pl_yylval.opval = PL_lex_op;
1706 PL_lex_stuff = NULL;
1710 PL_sublex_info.super_state = PL_lex_state;
1711 PL_sublex_info.sub_inwhat = (U16)op_type;
1712 PL_sublex_info.sub_op = PL_lex_op;
1713 PL_lex_state = LEX_INTERPPUSH;
1717 pl_yylval.opval = PL_lex_op;
1727 * Create a new scope to save the lexing state. The scope will be
1728 * ended in S_sublex_done. Returns a '(', starting the function arguments
1729 * to the uc, lc, etc. found before.
1730 * Sets PL_lex_state to LEX_INTERPCONCAT.
1739 PL_lex_state = PL_sublex_info.super_state;
1740 SAVEBOOL(PL_lex_dojoin);
1741 SAVEI32(PL_lex_brackets);
1742 SAVEI32(PL_lex_casemods);
1743 SAVEI32(PL_lex_starts);
1744 SAVEI8(PL_lex_state);
1745 SAVEVPTR(PL_lex_inpat);
1746 SAVEI16(PL_lex_inwhat);
1747 SAVECOPLINE(PL_curcop);
1748 SAVEPPTR(PL_bufptr);
1749 SAVEPPTR(PL_bufend);
1750 SAVEPPTR(PL_oldbufptr);
1751 SAVEPPTR(PL_oldoldbufptr);
1752 SAVEPPTR(PL_last_lop);
1753 SAVEPPTR(PL_last_uni);
1754 SAVEPPTR(PL_linestart);
1755 SAVESPTR(PL_linestr);
1756 SAVEGENERICPV(PL_lex_brackstack);
1757 SAVEGENERICPV(PL_lex_casestack);
1759 PL_linestr = PL_lex_stuff;
1760 PL_lex_stuff = NULL;
1762 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1763 = SvPVX(PL_linestr);
1764 PL_bufend += SvCUR(PL_linestr);
1765 PL_last_lop = PL_last_uni = NULL;
1766 SAVEFREESV(PL_linestr);
1768 PL_lex_dojoin = FALSE;
1769 PL_lex_brackets = 0;
1770 Newx(PL_lex_brackstack, 120, char);
1771 Newx(PL_lex_casestack, 12, char);
1772 PL_lex_casemods = 0;
1773 *PL_lex_casestack = '\0';
1775 PL_lex_state = LEX_INTERPCONCAT;
1776 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1778 PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1779 if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1780 PL_lex_inpat = PL_sublex_info.sub_op;
1782 PL_lex_inpat = NULL;
1789 * Restores lexer state after a S_sublex_push.
1796 if (!PL_lex_starts++) {
1797 SV * const sv = newSVpvs("");
1798 if (SvUTF8(PL_linestr))
1800 PL_expect = XOPERATOR;
1801 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1805 if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
1806 PL_lex_state = LEX_INTERPCASEMOD;
1810 /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1811 if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1812 PL_linestr = PL_lex_repl;
1814 PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1815 PL_bufend += SvCUR(PL_linestr);
1816 PL_last_lop = PL_last_uni = NULL;
1817 SAVEFREESV(PL_linestr);
1818 PL_lex_dojoin = FALSE;
1819 PL_lex_brackets = 0;
1820 PL_lex_casemods = 0;
1821 *PL_lex_casestack = '\0';
1823 if (SvEVALED(PL_lex_repl)) {
1824 PL_lex_state = LEX_INTERPNORMAL;
1826 /* we don't clear PL_lex_repl here, so that we can check later
1827 whether this is an evalled subst; that means we rely on the
1828 logic to ensure sublex_done() is called again only via the
1829 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1832 PL_lex_state = LEX_INTERPCONCAT;
1842 PL_endwhite = newSVpvs("");
1843 sv_catsv(PL_endwhite, PL_thiswhite);
1847 sv_setpvs(PL_thistoken,"");
1849 PL_realtokenstart = -1;
1853 PL_bufend = SvPVX(PL_linestr);
1854 PL_bufend += SvCUR(PL_linestr);
1855 PL_expect = XOPERATOR;
1856 PL_sublex_info.sub_inwhat = 0;
1864 Extracts a pattern, double-quoted string, or transliteration. This
1867 It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1868 processing a pattern (PL_lex_inpat is true), a transliteration
1869 (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1871 Returns a pointer to the character scanned up to. If this is
1872 advanced from the start pointer supplied (i.e. if anything was
1873 successfully parsed), will leave an OP for the substring scanned
1874 in pl_yylval. Caller must intuit reason for not parsing further
1875 by looking at the next characters herself.
1879 double-quoted style: \r and \n
1880 regexp special ones: \D \s
1883 case and quoting: \U \Q \E
1884 stops on @ and $, but not for $ as tail anchor
1886 In transliterations:
1887 characters are VERY literal, except for - not at the start or end
1888 of the string, which indicates a range. If the range is in bytes,
1889 scan_const expands the range to the full set of intermediate
1890 characters. If the range is in utf8, the hyphen is replaced with
1891 a certain range mark which will be handled by pmtrans() in op.c.
1893 In double-quoted strings:
1895 double-quoted style: \r and \n
1897 deprecated backrefs: \1 (in substitution replacements)
1898 case and quoting: \U \Q \E
1901 scan_const does *not* construct ops to handle interpolated strings.
1902 It stops processing as soon as it finds an embedded $ or @ variable
1903 and leaves it to the caller to work out what's going on.
1905 embedded arrays (whether in pattern or not) could be:
1906 @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1908 $ in double-quoted strings must be the symbol of an embedded scalar.
1910 $ in pattern could be $foo or could be tail anchor. Assumption:
1911 it's a tail anchor if $ is the last thing in the string, or if it's
1912 followed by one of "()| \r\n\t"
1914 \1 (backreferences) are turned into $1
1916 The structure of the code is
1917 while (there's a character to process) {
1918 handle transliteration ranges
1919 skip regexp comments /(?#comment)/ and codes /(?{code})/
1920 skip #-initiated comments in //x patterns
1921 check for embedded arrays
1922 check for embedded scalars
1924 leave intact backslashes from leaveit (below)
1925 deprecate \1 in substitution replacements
1926 handle string-changing backslashes \l \U \Q \E, etc.
1927 switch (what was escaped) {
1928 handle \- in a transliteration (becomes a literal -)
1929 handle \132 (octal characters)
1930 handle \x15 and \x{1234} (hex characters)
1931 handle \N{name} (named characters)
1932 handle \cV (control characters)
1933 handle printf-style backslashes (\f, \r, \n, etc)
1935 } (end if backslash)
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 */
1946 register char *s = start; /* start of the constant */
1947 register char *d = SvPVX(sv); /* destination for copies */
1948 bool dorange = FALSE; /* are we in a translit range? */
1949 bool didrange = FALSE; /* did we just finish a range? */
1950 I32 has_utf8 = FALSE; /* Output constant is UTF8 */
1951 I32 this_utf8 = UTF; /* The source string is assumed to be UTF8 */
1954 UV literal_endpoint = 0;
1955 bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1958 PERL_ARGS_ASSERT_SCAN_CONST;
1960 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1961 /* If we are doing a trans and we know we want UTF8 set expectation */
1962 has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1963 this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1967 while (s < send || dorange) {
1968 /* get transliterations out of the way (they're most literal) */
1969 if (PL_lex_inwhat == OP_TRANS) {
1970 /* expand a range A-Z to the full set of characters. AIE! */
1972 I32 i; /* current expanded character */
1973 I32 min; /* first character in range */
1974 I32 max; /* last character in range */
1985 char * const c = (char*)utf8_hop((U8*)d, -1);
1989 *c = (char)UTF_TO_NATIVE(0xff);
1990 /* mark the range as done, and continue */
1996 i = d - SvPVX_const(sv); /* remember current offset */
1999 SvLEN(sv) + (has_utf8 ?
2000 (512 - UTF_CONTINUATION_MARK +
2003 /* How many two-byte within 0..255: 128 in UTF-8,
2004 * 96 in UTF-8-mod. */
2006 SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
2008 d = SvPVX(sv) + i; /* refresh d after realloc */
2012 for (j = 0; j <= 1; j++) {
2013 char * const c = (char*)utf8_hop((U8*)d, -1);
2014 const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2020 max = (U8)0xff; /* only to \xff */
2021 uvmax = uv; /* \x{100} to uvmax */
2023 d = c; /* eat endpoint chars */
2028 d -= 2; /* eat the first char and the - */
2029 min = (U8)*d; /* first char in range */
2030 max = (U8)d[1]; /* last char in range */
2037 "Invalid range \"%c-%c\" in transliteration operator",
2038 (char)min, (char)max);
2042 if (literal_endpoint == 2 &&
2043 ((isLOWER(min) && isLOWER(max)) ||
2044 (isUPPER(min) && isUPPER(max)))) {
2046 for (i = min; i <= max; i++)
2048 *d++ = NATIVE_TO_NEED(has_utf8,i);
2050 for (i = min; i <= max; i++)
2052 *d++ = NATIVE_TO_NEED(has_utf8,i);
2057 for (i = min; i <= max; i++)
2060 const U8 ch = (U8)NATIVE_TO_UTF(i);
2061 if (UNI_IS_INVARIANT(ch))
2064 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
2065 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
2074 d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2076 *d++ = (char)UTF_TO_NATIVE(0xff);
2078 d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2082 /* mark the range as done, and continue */
2086 literal_endpoint = 0;
2091 /* range begins (ignore - as first or last char) */
2092 else if (*s == '-' && s+1 < send && s != start) {
2094 Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2101 *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */
2111 literal_endpoint = 0;
2112 native_range = TRUE;
2117 /* if we get here, we're not doing a transliteration */
2119 /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2120 except for the last char, which will be done separately. */
2121 else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2123 while (s+1 < send && *s != ')')
2124 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2126 else if (s[2] == '{' /* This should match regcomp.c */
2127 || (s[2] == '?' && s[3] == '{'))
2130 char *regparse = s + (s[2] == '{' ? 3 : 4);
2133 while (count && (c = *regparse)) {
2134 if (c == '\\' && regparse[1])
2142 if (*regparse != ')')
2143 regparse--; /* Leave one char for continuation. */
2144 while (s < regparse)
2145 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2149 /* likewise skip #-initiated comments in //x patterns */
2150 else if (*s == '#' && PL_lex_inpat &&
2151 ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2152 while (s+1 < send && *s != '\n')
2153 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2156 /* check for embedded arrays
2157 (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2159 else if (*s == '@' && s[1]) {
2160 if (isALNUM_lazy_if(s+1,UTF))
2162 if (strchr(":'{$", s[1]))
2164 if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2165 break; /* in regexp, neither @+ nor @- are interpolated */
2168 /* check for embedded scalars. only stop if we're sure it's a
2171 else if (*s == '$') {
2172 if (!PL_lex_inpat) /* not a regexp, so $ must be var */
2174 if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
2175 if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) {
2176 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
2177 "Possible unintended interpolation of $\\ in regex");
2179 break; /* in regexp, $ might be tail anchor */
2183 /* End of else if chain - OP_TRANS rejoin rest */
2186 if (*s == '\\' && s+1 < send) {
2189 /* deprecate \1 in strings and substitution replacements */
2190 if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2191 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2193 if (ckWARN(WARN_SYNTAX))
2194 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2199 /* string-change backslash escapes */
2200 if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2204 /* skip any other backslash escapes in a pattern */
2205 else if (PL_lex_inpat) {
2206 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2207 goto default_action;
2210 /* if we get here, it's either a quoted -, or a digit */
2213 /* quoted - in transliterations */
2215 if (PL_lex_inwhat == OP_TRANS) {
2222 if ((isALPHA(*s) || isDIGIT(*s)) &&
2224 Perl_warner(aTHX_ packWARN(WARN_MISC),
2225 "Unrecognized escape \\%c passed through",
2227 /* default action is to copy the quoted character */
2228 goto default_action;
2231 /* \132 indicates an octal constant */
2232 case '0': case '1': case '2': case '3':
2233 case '4': case '5': case '6': case '7':
2237 uv = grok_oct(s, &len, &flags, NULL);
2240 goto NUM_ESCAPE_INSERT;
2242 /* \x24 indicates a hex constant */
2246 char* const e = strchr(s, '}');
2247 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2248 PERL_SCAN_DISALLOW_PREFIX;
2253 yyerror("Missing right brace on \\x{}");
2257 uv = grok_hex(s, &len, &flags, NULL);
2263 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2264 uv = grok_hex(s, &len, &flags, NULL);
2270 /* Insert oct or hex escaped character.
2271 * There will always enough room in sv since such
2272 * escapes will be longer than any UTF-8 sequence
2273 * they can end up as. */
2275 /* We need to map to chars to ASCII before doing the tests
2278 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2279 if (!has_utf8 && uv > 255) {
2280 /* Might need to recode whatever we have
2281 * accumulated so far if it contains any
2284 * (Can't we keep track of that and avoid
2285 * this rescan? --jhi)
2289 for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2290 if (!NATIVE_IS_INVARIANT(*c)) {
2295 const STRLEN offset = d - SvPVX_const(sv);
2297 d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2301 while (src >= (const U8 *)SvPVX_const(sv)) {
2302 if (!NATIVE_IS_INVARIANT(*src)) {
2303 const U8 ch = NATIVE_TO_ASCII(*src);
2304 *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2305 *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2315 if (has_utf8 || uv > 255) {
2316 d = (char*)uvchr_to_utf8((U8*)d, uv);
2318 if (PL_lex_inwhat == OP_TRANS &&
2319 PL_sublex_info.sub_op) {
2320 PL_sublex_info.sub_op->op_private |=
2321 (PL_lex_repl ? OPpTRANS_FROM_UTF
2325 if (uv > 255 && !dorange)
2326 native_range = FALSE;
2338 /* \N{LATIN SMALL LETTER A} is a named character */
2342 char* e = strchr(s, '}');
2348 yyerror("Missing right brace on \\N{}");
2352 if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2354 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2355 PERL_SCAN_DISALLOW_PREFIX;
2358 uv = grok_hex(s, &len, &flags, NULL);
2359 if ( e > s && len != (STRLEN)(e - s) ) {
2363 goto NUM_ESCAPE_INSERT;
2365 res = newSVpvn(s + 1, e - s - 1);
2366 res = new_constant( NULL, 0, "charnames",
2367 res, NULL, s - 2, e - s + 3 );
2369 sv_utf8_upgrade(res);
2370 str = SvPV_const(res,len);
2371 #ifdef EBCDIC_NEVER_MIND
2372 /* charnames uses pack U and that has been
2373 * recently changed to do the below uni->native
2374 * mapping, so this would be redundant (and wrong,
2375 * the code point would be doubly converted).
2376 * But leave this in just in case the pack U change
2377 * gets revoked, but the semantics is still
2378 * desireable for charnames. --jhi */
2380 UV uv = utf8_to_uvchr((const U8*)str, 0);
2383 U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2385 d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2386 sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2387 str = SvPV_const(res, len);
2391 if (!has_utf8 && SvUTF8(res)) {
2392 const char * const ostart = SvPVX_const(sv);
2393 SvCUR_set(sv, d - ostart);
2396 sv_utf8_upgrade(sv);
2397 /* this just broke our allocation above... */
2398 SvGROW(sv, (STRLEN)(send - start));
2399 d = SvPVX(sv) + SvCUR(sv);
2402 if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2403 const char * const odest = SvPVX_const(sv);
2405 SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2406 d = SvPVX(sv) + (d - odest);
2410 native_range = FALSE; /* \N{} is guessed to be Unicode */
2412 Copy(str, d, len, char);
2419 yyerror("Missing braces on \\N{}");
2422 /* \c is a control character */
2431 *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2434 yyerror("Missing control char name in \\c");
2438 /* printf-style backslashes, formfeeds, newlines, etc */
2440 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2443 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2446 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2449 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2452 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2455 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2458 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2464 } /* end if (backslash) */
2471 /* If we started with encoded form, or already know we want it
2472 and then encode the next character */
2473 if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2475 const UV nextuv = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2476 const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2479 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2480 const STRLEN off = d - SvPVX_const(sv);
2481 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2483 d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2486 if (uv > 255 && !dorange)
2487 native_range = FALSE;
2491 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2493 } /* while loop to process each character */
2495 /* terminate the string and set up the sv */
2497 SvCUR_set(sv, d - SvPVX_const(sv));
2498 if (SvCUR(sv) >= SvLEN(sv))
2499 Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2502 if (PL_encoding && !has_utf8) {
2503 sv_recode_to_utf8(sv, PL_encoding);
2509 if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2510 PL_sublex_info.sub_op->op_private |=
2511 (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2515 /* shrink the sv if we allocated more than we used */
2516 if (SvCUR(sv) + 5 < SvLEN(sv)) {
2517 SvPV_shrink_to_cur(sv);
2520 /* return the substring (via pl_yylval) only if we parsed anything */
2521 if (s > PL_bufptr) {
2522 if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
2523 const char *const key = PL_lex_inpat ? "qr" : "q";
2524 const STRLEN keylen = PL_lex_inpat ? 2 : 1;
2528 if (PL_lex_inwhat == OP_TRANS) {
2531 } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
2539 sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
2542 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2549 * Returns TRUE if there's more to the expression (e.g., a subscript),
2552 * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2554 * ->[ and ->{ return TRUE
2555 * { and [ outside a pattern are always subscripts, so return TRUE
2556 * if we're outside a pattern and it's not { or [, then return FALSE
2557 * if we're in a pattern and the first char is a {
2558 * {4,5} (any digits around the comma) returns FALSE
2559 * if we're in a pattern and the first char is a [
2561 * [SOMETHING] has a funky algorithm to decide whether it's a
2562 * character class or not. It has to deal with things like
2563 * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2564 * anything else returns TRUE
2567 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2570 S_intuit_more(pTHX_ register char *s)
2574 PERL_ARGS_ASSERT_INTUIT_MORE;
2576 if (PL_lex_brackets)
2578 if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2580 if (*s != '{' && *s != '[')
2585 /* In a pattern, so maybe we have {n,m}. */
2602 /* On the other hand, maybe we have a character class */
2605 if (*s == ']' || *s == '^')
2608 /* this is terrifying, and it works */
2609 int weight = 2; /* let's weigh the evidence */
2611 unsigned char un_char = 255, last_un_char;
2612 const char * const send = strchr(s,']');
2613 char tmpbuf[sizeof PL_tokenbuf * 4];
2615 if (!send) /* has to be an expression */
2618 Zero(seen,256,char);
2621 else if (isDIGIT(*s)) {
2623 if (isDIGIT(s[1]) && s[2] == ']')
2629 for (; s < send; s++) {
2630 last_un_char = un_char;
2631 un_char = (unsigned char)*s;
2636 weight -= seen[un_char] * 10;
2637 if (isALNUM_lazy_if(s+1,UTF)) {
2639 scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2640 len = (int)strlen(tmpbuf);
2641 if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2646 else if (*s == '$' && s[1] &&
2647 strchr("[#!%*<>()-=",s[1])) {
2648 if (/*{*/ strchr("])} =",s[2]))
2657 if (strchr("wds]",s[1]))
2659 else if (seen[(U8)'\''] || seen[(U8)'"'])
2661 else if (strchr("rnftbxcav",s[1]))
2663 else if (isDIGIT(s[1])) {
2665 while (s[1] && isDIGIT(s[1]))
2675 if (strchr("aA01! ",last_un_char))
2677 if (strchr("zZ79~",s[1]))
2679 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2680 weight -= 5; /* cope with negative subscript */
2683 if (!isALNUM(last_un_char)
2684 && !(last_un_char == '$' || last_un_char == '@'
2685 || last_un_char == '&')
2686 && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2691 if (keyword(tmpbuf, d - tmpbuf, 0))
2694 if (un_char == last_un_char + 1)
2696 weight -= seen[un_char];
2701 if (weight >= 0) /* probably a character class */
2711 * Does all the checking to disambiguate
2713 * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
2714 * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2716 * First argument is the stuff after the first token, e.g. "bar".
2718 * Not a method if bar is a filehandle.
2719 * Not a method if foo is a subroutine prototyped to take a filehandle.
2720 * Not a method if it's really "Foo $bar"
2721 * Method if it's "foo $bar"
2722 * Not a method if it's really "print foo $bar"
2723 * Method if it's really "foo package::" (interpreted as package->foo)
2724 * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2725 * Not a method if bar is a filehandle or package, but is quoted with
2730 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2733 char *s = start + (*start == '$');
2734 char tmpbuf[sizeof PL_tokenbuf];
2741 PERL_ARGS_ASSERT_INTUIT_METHOD;
2744 if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2748 const char *proto = SvPVX_const(cv);
2759 s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2760 /* start is the beginning of the possible filehandle/object,
2761 * and s is the end of it
2762 * tmpbuf is a copy of it
2765 if (*start == '$') {
2766 if (gv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
2767 isUPPER(*PL_tokenbuf))
2770 len = start - SvPVX(PL_linestr);
2774 start = SvPVX(PL_linestr) + len;
2778 return *s == '(' ? FUNCMETH : METHOD;
2780 if (!keyword(tmpbuf, len, 0)) {
2781 if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2785 soff = s - SvPVX(PL_linestr);
2789 indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2790 if (indirgv && GvCVu(indirgv))
2792 /* filehandle or package name makes it a method */
2793 if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
2795 soff = s - SvPVX(PL_linestr);
2798 if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2799 return 0; /* no assumptions -- "=>" quotes bearword */
2801 start_force(PL_curforce);
2802 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2803 newSVpvn(tmpbuf,len));
2804 NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2806 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2811 PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2813 return *s == '(' ? FUNCMETH : METHOD;
2819 /* Encoded script support. filter_add() effectively inserts a
2820 * 'pre-processing' function into the current source input stream.
2821 * Note that the filter function only applies to the current source file
2822 * (e.g., it will not affect files 'require'd or 'use'd by this one).
2824 * The datasv parameter (which may be NULL) can be used to pass
2825 * private data to this instance of the filter. The filter function
2826 * can recover the SV using the FILTER_DATA macro and use it to
2827 * store private buffers and state information.
2829 * The supplied datasv parameter is upgraded to a PVIO type
2830 * and the IoDIRP/IoANY field is used to store the function pointer,
2831 * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2832 * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2833 * private use must be set using malloc'd pointers.
2837 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2846 if (!PL_rsfp_filters)
2847 PL_rsfp_filters = newAV();
2850 SvUPGRADE(datasv, SVt_PVIO);
2851 IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2852 IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2853 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2854 FPTR2DPTR(void *, IoANY(datasv)),
2855 SvPV_nolen(datasv)));
2856 av_unshift(PL_rsfp_filters, 1);
2857 av_store(PL_rsfp_filters, 0, datasv) ;
2862 /* Delete most recently added instance of this filter function. */
2864 Perl_filter_del(pTHX_ filter_t funcp)
2869 PERL_ARGS_ASSERT_FILTER_DEL;
2872 DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2873 FPTR2DPTR(void*, funcp)));
2875 if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2877 /* if filter is on top of stack (usual case) just pop it off */
2878 datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2879 if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2880 IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2881 IoANY(datasv) = (void *)NULL;
2882 sv_free(av_pop(PL_rsfp_filters));
2886 /* we need to search for the correct entry and clear it */
2887 Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2891 /* Invoke the idxth filter function for the current rsfp. */
2892 /* maxlen 0 = read one text line */
2894 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2899 /* This API is bad. It should have been using unsigned int for maxlen.
2900 Not sure if we want to change the API, but if not we should sanity
2901 check the value here. */
2902 const unsigned int correct_length
2911 PERL_ARGS_ASSERT_FILTER_READ;
2913 if (!PL_parser || !PL_rsfp_filters)
2915 if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
2916 /* Provide a default input filter to make life easy. */
2917 /* Note that we append to the line. This is handy. */
2918 DEBUG_P(PerlIO_printf(Perl_debug_log,
2919 "filter_read %d: from rsfp\n", idx));
2920 if (correct_length) {
2923 const int old_len = SvCUR(buf_sv);
2925 /* ensure buf_sv is large enough */
2926 SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2927 if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2928 correct_length)) <= 0) {
2929 if (PerlIO_error(PL_rsfp))
2930 return -1; /* error */
2932 return 0 ; /* end of file */
2934 SvCUR_set(buf_sv, old_len + len) ;
2937 if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2938 if (PerlIO_error(PL_rsfp))
2939 return -1; /* error */
2941 return 0 ; /* end of file */
2944 return SvCUR(buf_sv);
2946 /* Skip this filter slot if filter has been deleted */
2947 if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2948 DEBUG_P(PerlIO_printf(Perl_debug_log,
2949 "filter_read %d: skipped (filter deleted)\n",
2951 return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2953 /* Get function pointer hidden within datasv */
2954 funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2955 DEBUG_P(PerlIO_printf(Perl_debug_log,
2956 "filter_read %d: via function %p (%s)\n",
2957 idx, (void*)datasv, SvPV_nolen_const(datasv)));
2958 /* Call function. The function is expected to */
2959 /* call "FILTER_READ(idx+1, buf_sv)" first. */
2960 /* Return: <0:error, =0:eof, >0:not eof */
2961 return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2965 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2969 PERL_ARGS_ASSERT_FILTER_GETS;
2971 #ifdef PERL_CR_FILTER
2972 if (!PL_rsfp_filters) {
2973 filter_add(S_cr_textfilter,NULL);
2976 if (PL_rsfp_filters) {
2978 SvCUR_set(sv, 0); /* start with empty line */
2979 if (FILTER_READ(0, sv, 0) > 0)
2980 return ( SvPVX(sv) ) ;
2985 return (sv_gets(sv, fp, append));
2989 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
2994 PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
2996 if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
3000 (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
3001 (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
3003 return GvHV(gv); /* Foo:: */
3006 /* use constant CLASS => 'MyClass' */
3007 gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
3008 if (gv && GvCV(gv)) {
3009 SV * const sv = cv_const_sv(GvCV(gv));
3011 pkgname = SvPV_const(sv, len);
3014 return gv_stashpvn(pkgname, len, 0);
3018 * S_readpipe_override
3019 * Check whether readpipe() is overriden, and generates the appropriate
3020 * optree, provided sublex_start() is called afterwards.
3023 S_readpipe_override(pTHX)
3026 GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
3027 pl_yylval.ival = OP_BACKTICK;
3029 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
3031 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
3032 && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
3033 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
3035 PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
3036 append_elem(OP_LIST,
3037 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
3038 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
3045 * The intent of this yylex wrapper is to minimize the changes to the
3046 * tokener when we aren't interested in collecting madprops. It remains
3047 * to be seen how successful this strategy will be...
3054 char *s = PL_bufptr;
3056 /* make sure PL_thiswhite is initialized */
3060 /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
3061 if (PL_pending_ident)
3062 return S_pending_ident(aTHX);
3064 /* previous token ate up our whitespace? */
3065 if (!PL_lasttoke && PL_nextwhite) {
3066 PL_thiswhite = PL_nextwhite;
3070 /* isolate the token, and figure out where it is without whitespace */
3071 PL_realtokenstart = -1;
3075 assert(PL_curforce < 0);
3077 if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
3078 if (!PL_thistoken) {
3079 if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
3080 PL_thistoken = newSVpvs("");
3082 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
3083 PL_thistoken = newSVpvn(tstart, s - tstart);
3086 if (PL_thismad) /* install head */
3087 CURMAD('X', PL_thistoken);
3090 /* last whitespace of a sublex? */
3091 if (optype == ')' && PL_endwhite) {
3092 CURMAD('X', PL_endwhite);
3097 /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
3098 if (!PL_thiswhite && !PL_endwhite && !optype) {
3099 sv_free(PL_thistoken);
3104 /* put off final whitespace till peg */
3105 if (optype == ';' && !PL_rsfp) {
3106 PL_nextwhite = PL_thiswhite;
3109 else if (PL_thisopen) {
3110 CURMAD('q', PL_thisopen);
3112 sv_free(PL_thistoken);
3116 /* Store actual token text as madprop X */
3117 CURMAD('X', PL_thistoken);
3121 /* add preceding whitespace as madprop _ */
3122 CURMAD('_', PL_thiswhite);
3126 /* add quoted material as madprop = */
3127 CURMAD('=', PL_thisstuff);
3131 /* add terminating quote as madprop Q */
3132 CURMAD('Q', PL_thisclose);
3136 /* special processing based on optype */
3140 /* opval doesn't need a TOKEN since it can already store mp */
3150 if (pl_yylval.opval)
3151 append_madprops(PL_thismad, pl_yylval.opval, 0);
3159 addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3168 /* remember any fake bracket that lexer is about to discard */
3169 if (PL_lex_brackets == 1 &&
3170 ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3173 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3176 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3177 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3180 break; /* don't bother looking for trailing comment */
3189 /* attach a trailing comment to its statement instead of next token */
3193 if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3195 while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3197 if (*s == '\n' || *s == '#') {
3198 while (s < PL_bufend && *s != '\n')
3202 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3203 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3220 /* Create new token struct. Note: opvals return early above. */
3221 pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
3228 S_tokenize_use(pTHX_ int is_use, char *s) {
3231 PERL_ARGS_ASSERT_TOKENIZE_USE;
3233 if (PL_expect != XSTATE)
3234 yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3235 is_use ? "use" : "no"));
3237 if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3238 s = force_version(s, TRUE);
3239 if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3240 start_force(PL_curforce);
3241 NEXTVAL_NEXTTOKE.opval = NULL;
3244 else if (*s == 'v') {
3245 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3246 s = force_version(s, FALSE);
3250 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3251 s = force_version(s, FALSE);
3253 pl_yylval.ival = is_use;
3257 static const char* const exp_name[] =
3258 { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3259 "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3266 Works out what to call the token just pulled out of the input
3267 stream. The yacc parser takes care of taking the ops we return and
3268 stitching them into a tree.
3274 if read an identifier
3275 if we're in a my declaration
3276 croak if they tried to say my($foo::bar)
3277 build the ops for a my() declaration
3278 if it's an access to a my() variable
3279 are we in a sort block?
3280 croak if my($a); $a <=> $b
3281 build ops for access to a my() variable
3282 if in a dq string, and they've said @foo and we can't find @foo
3284 build ops for a bareword
3285 if we already built the token before, use it.
3290 #pragma segment Perl_yylex
3296 register char *s = PL_bufptr;
3301 /* orig_keyword, gvp, and gv are initialized here because
3302 * jump to the label just_a_word_zero can bypass their
3303 * initialization later. */
3304 I32 orig_keyword = 0;
3309 SV* tmp = newSVpvs("");
3310 PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3311 (IV)CopLINE(PL_curcop),
3312 lex_state_names[PL_lex_state],
3313 exp_name[PL_expect],
3314 pv_display(tmp, s, strlen(s), 0, 60));
3317 /* check if there's an identifier for us to look at */
3318 if (PL_pending_ident)
3319 return REPORT(S_pending_ident(aTHX));
3321 /* no identifier pending identification */
3323 switch (PL_lex_state) {
3325 case LEX_NORMAL: /* Some compilers will produce faster */
3326 case LEX_INTERPNORMAL: /* code if we comment these out. */
3330 /* when we've already built the next token, just pull it out of the queue */
3334 pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
3336 PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3337 PL_nexttoke[PL_lasttoke].next_mad = 0;
3338 if (PL_thismad && PL_thismad->mad_key == '_') {
3339 PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
3340 PL_thismad->mad_val = 0;
3341 mad_free(PL_thismad);
3346 PL_lex_state = PL_lex_defer;
3347 PL_expect = PL_lex_expect;
3348 PL_lex_defer = LEX_NORMAL;
3349 if (!PL_nexttoke[PL_lasttoke].next_type)
3354 pl_yylval = PL_nextval[PL_nexttoke];
3356 PL_lex_state = PL_lex_defer;
3357 PL_expect = PL_lex_expect;
3358 PL_lex_defer = LEX_NORMAL;
3362 /* FIXME - can these be merged? */
3363 return(PL_nexttoke[PL_lasttoke].next_type);
3365 return REPORT(PL_nexttype[PL_nexttoke]);
3368 /* interpolated case modifiers like \L \U, including \Q and \E.
3369 when we get here, PL_bufptr is at the \
3371 case LEX_INTERPCASEMOD:
3373 if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3374 Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3376 /* handle \E or end of string */
3377 if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3379 if (PL_lex_casemods) {
3380 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3381 PL_lex_casestack[PL_lex_casemods] = '\0';
3383 if (PL_bufptr != PL_bufend
3384 && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3386 PL_lex_state = LEX_INTERPCONCAT;
3389 PL_thistoken = newSVpvs("\\E");
3395 while (PL_bufptr != PL_bufend &&
3396 PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3398 PL_thiswhite = newSVpvs("");
3399 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3403 if (PL_bufptr != PL_bufend)
3406 PL_lex_state = LEX_INTERPCONCAT;
3410 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3411 "### Saw case modifier\n"); });
3413 if (s[1] == '\\' && s[2] == 'E') {
3416 PL_thiswhite = newSVpvs("");
3417 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3420 PL_lex_state = LEX_INTERPCONCAT;
3425 if (!PL_madskills) /* when just compiling don't need correct */
3426 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3427 tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
3428 if ((*s == 'L' || *s == 'U') &&
3429 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3430 PL_lex_casestack[--PL_lex_casemods] = '\0';
3433 if (PL_lex_casemods > 10)
3434 Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3435 PL_lex_casestack[PL_lex_casemods++] = *s;
3436 PL_lex_casestack[PL_lex_casemods] = '\0';
3437 PL_lex_state = LEX_INTERPCONCAT;
3438 start_force(PL_curforce);
3439 NEXTVAL_NEXTTOKE.ival = 0;
3441 start_force(PL_curforce);
3443 NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3445 NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3447 NEXTVAL_NEXTTOKE.ival = OP_LC;
3449 NEXTVAL_NEXTTOKE.ival = OP_UC;
3451 NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3453 Perl_croak(aTHX_ "panic: yylex");
3455 SV* const tmpsv = newSVpvs("\\ ");
3456 /* replace the space with the character we want to escape
3458 SvPVX(tmpsv)[1] = *s;
3464 if (PL_lex_starts) {
3470 sv_free(PL_thistoken);
3471 PL_thistoken = newSVpvs("");
3474 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3475 if (PL_lex_casemods == 1 && PL_lex_inpat)
3484 case LEX_INTERPPUSH:
3485 return REPORT(sublex_push());
3487 case LEX_INTERPSTART:
3488 if (PL_bufptr == PL_bufend)
3489 return REPORT(sublex_done());
3490 DEBUG_T({ PerlIO_printf(Perl_debug_log,
3491 "### Interpolated variable\n"); });
3493 PL_lex_dojoin = (*PL_bufptr == '@');
3494 PL_lex_state = LEX_INTERPNORMAL;
3495 if (PL_lex_dojoin) {
3496 start_force(PL_curforce);
3497 NEXTVAL_NEXTTOKE.ival = 0;
3499 start_force(PL_curforce);
3500 force_ident("\"", '$');
3501 start_force(PL_curforce);
3502 NEXTVAL_NEXTTOKE.ival = 0;
3504 start_force(PL_curforce);
3505 NEXTVAL_NEXTTOKE.ival = 0;
3507 start_force(PL_curforce);
3508 NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
3511 if (PL_lex_starts++) {
3516 sv_free(PL_thistoken);
3517 PL_thistoken = newSVpvs("");
3520 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3521 if (!PL_lex_casemods && PL_lex_inpat)
3528 case LEX_INTERPENDMAYBE:
3529 if (intuit_more(PL_bufptr)) {
3530 PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
3536 if (PL_lex_dojoin) {
3537 PL_lex_dojoin = FALSE;
3538 PL_lex_state = LEX_INTERPCONCAT;
3542 sv_free(PL_thistoken);
3543 PL_thistoken = newSVpvs("");
3548 if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3549 && SvEVALED(PL_lex_repl))
3551 if (PL_bufptr != PL_bufend)
3552 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3556 case LEX_INTERPCONCAT:
3558 if (PL_lex_brackets)
3559 Perl_croak(aTHX_ "panic: INTERPCONCAT");
3561 if (PL_bufptr == PL_bufend)
3562 return REPORT(sublex_done());
3564 if (SvIVX(PL_linestr) == '\'') {
3565 SV *sv = newSVsv(PL_linestr);
3568 else if ( PL_hints & HINT_NEW_RE )
3569 sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
3570 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3574 s = scan_const(PL_bufptr);
3576 PL_lex_state = LEX_INTERPCASEMOD;
3578 PL_lex_state = LEX_INTERPSTART;
3581 if (s != PL_bufptr) {
3582 start_force(PL_curforce);
3584 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3586 NEXTVAL_NEXTTOKE = pl_yylval;
3589 if (PL_lex_starts++) {
3593 sv_free(PL_thistoken);
3594 PL_thistoken = newSVpvs("");
3597 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3598 if (!PL_lex_casemods && PL_lex_inpat)
3611 PL_lex_state = LEX_NORMAL;
3612 s = scan_formline(PL_bufptr);
3613 if (!PL_lex_formbrack)
3619 PL_oldoldbufptr = PL_oldbufptr;
3625 sv_free(PL_thistoken);
3628 PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
3632 if (isIDFIRST_lazy_if(s,UTF))
3634 len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
3635 Perl_croak(aTHX_ "Unrecognized character \\x%02X in column %d", *s & 255, (int) len + 1);
3638 goto fake_eof; /* emulate EOF on ^D or ^Z */
3647 if (PL_lex_brackets) {
3648 yyerror((const char *)
3650 ? "Format not terminated"
3651 : "Missing right curly or square bracket"));
3653 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3654 "### Tokener got EOF\n");
3658 if (s++ < PL_bufend)
3659 goto retry; /* ignore stray nulls */
3662 if (!PL_in_eval && !PL_preambled) {
3663 PL_preambled = TRUE;
3669 /* Generate a string of Perl code to load the debugger.
3670 * If PERL5DB is set, it will return the contents of that,
3671 * otherwise a compile-time require of perl5db.pl. */
3673 const char * const pdb = PerlEnv_getenv("PERL5DB");
3676 sv_setpv(PL_linestr, pdb);
3677 sv_catpvs(PL_linestr,";");
3679 SETERRNO(0,SS_NORMAL);
3680 sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
3683 sv_setpvs(PL_linestr,"");
3684 if (PL_preambleav) {
3685 SV **svp = AvARRAY(PL_preambleav);
3686 SV **const end = svp + AvFILLp(PL_preambleav);
3688 sv_catsv(PL_linestr, *svp);
3690 sv_catpvs(PL_linestr, ";");
3692 sv_free(MUTABLE_SV(PL_preambleav));
3693 PL_preambleav = NULL;
3696 sv_catpvs(PL_linestr,
3697 "use feature ':5." STRINGIFY(PERL_VERSION) "';");
3698 if (PL_minus_n || PL_minus_p) {
3699 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3701 sv_catpvs(PL_linestr,"chomp;");
3704 if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3705 || *PL_splitstr == '"')
3706 && strchr(PL_splitstr + 1, *PL_splitstr))
3707 Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3709 /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3710 bytes can be used as quoting characters. :-) */
3711 const char *splits = PL_splitstr;
3712 sv_catpvs(PL_linestr, "our @F=split(q\0");
3715 if (*splits == '\\')
3716 sv_catpvn(PL_linestr, splits, 1);
3717 sv_catpvn(PL_linestr, splits, 1);
3718 } while (*splits++);
3719 /* This loop will embed the trailing NUL of
3720 PL_linestr as the last thing it does before
3722 sv_catpvs(PL_linestr, ");");
3726 sv_catpvs(PL_linestr,"our @F=split(' ');");
3729 sv_catpvs(PL_linestr, "\n");
3730 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3731 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3732 PL_last_lop = PL_last_uni = NULL;
3733 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3734 update_debugger_info(PL_linestr, NULL, 0);
3738 bof = PL_rsfp ? TRUE : FALSE;
3739 if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3742 PL_realtokenstart = -1;
3745 if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3746 PerlIO_clearerr(PL_rsfp);
3748 (void)PerlIO_close(PL_rsfp);
3750 PL_doextract = FALSE;
3752 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3758 sv_setpvs(PL_linestr, ";}continue{print;}");
3760 sv_setpvs(PL_linestr, ";}");
3761 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3762 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3763 PL_last_lop = PL_last_uni = NULL;
3764 PL_minus_n = PL_minus_p = 0;
3767 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3768 PL_last_lop = PL_last_uni = NULL;
3769 sv_setpvs(PL_linestr,"");
3770 TOKEN(';'); /* not infinite loop because rsfp is NULL now */
3772 /* If it looks like the start of a BOM or raw UTF-16,
3773 * check if it in fact is. */
3779 #ifdef PERLIO_IS_STDIO
3780 # ifdef __GNU_LIBRARY__
3781 # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3782 # define FTELL_FOR_PIPE_IS_BROKEN
3786 # if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3787 # define FTELL_FOR_PIPE_IS_BROKEN
3792 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3794 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3795 s = swallow_bom((U8*)s);
3799 /* Incest with pod. */
3802 sv_catsv(PL_thiswhite, PL_linestr);
3804 if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
3805 sv_setpvs(PL_linestr, "");
3806 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3807 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3808 PL_last_lop = PL_last_uni = NULL;
3809 PL_doextract = FALSE;
3813 } while (PL_doextract);
3814 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3815 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3816 update_debugger_info(PL_linestr, NULL, 0);
3817 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3818 PL_last_lop = PL_last_uni = NULL;
3819 if (CopLINE(PL_curcop) == 1) {
3820 while (s < PL_bufend && isSPACE(*s))
3822 if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3826 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3830 if (*s == '#' && *(s+1) == '!')
3832 #ifdef ALTERNATE_SHEBANG
3834 static char const as[] = ALTERNATE_SHEBANG;
3835 if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3836 d = s + (sizeof(as) - 1);
3838 #endif /* ALTERNATE_SHEBANG */
3847 while (*d && !isSPACE(*d))
3851 #ifdef ARG_ZERO_IS_SCRIPT
3852 if (ipathend > ipath) {
3854 * HP-UX (at least) sets argv[0] to the script name,
3855 * which makes $^X incorrect. And Digital UNIX and Linux,
3856 * at least, set argv[0] to the basename of the Perl
3857 * interpreter. So, having found "#!", we'll set it right.
3859 SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3861 assert(SvPOK(x) || SvGMAGICAL(x));
3862 if (sv_eq(x, CopFILESV(PL_curcop))) {
3863 sv_setpvn(x, ipath, ipathend - ipath);
3869 const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3870 const char * const lstart = SvPV_const(x,llen);
3872 bstart += blen - llen;
3873 if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3874 sv_setpvn(x, ipath, ipathend - ipath);
3879 TAINT_NOT; /* $^X is always tainted, but that's OK */
3881 #endif /* ARG_ZERO_IS_SCRIPT */
3886 d = instr(s,"perl -");
3888 d = instr(s,"perl");
3890 /* avoid getting into infinite loops when shebang
3891 * line contains "Perl" rather than "perl" */
3893 for (d = ipathend-4; d >= ipath; --d) {
3894 if ((*d == 'p' || *d == 'P')
3895 && !ibcmp(d, "perl", 4))
3905 #ifdef ALTERNATE_SHEBANG
3907 * If the ALTERNATE_SHEBANG on this system starts with a
3908 * character that can be part of a Perl expression, then if
3909 * we see it but not "perl", we're probably looking at the
3910 * start of Perl code, not a request to hand off to some
3911 * other interpreter. Similarly, if "perl" is there, but
3912 * not in the first 'word' of the line, we assume the line
3913 * contains the start of the Perl program.
3915 if (d && *s != '#') {
3916 const char *c = ipath;
3917 while (*c && !strchr("; \t\r\n\f\v#", *c))
3920 d = NULL; /* "perl" not in first word; ignore */
3922 *s = '#'; /* Don't try to parse shebang line */
3924 #endif /* ALTERNATE_SHEBANG */
3925 #ifndef MACOS_TRADITIONAL
3930 !instr(s,"indir") &&
3931 instr(PL_origargv[0],"perl"))
3938 while (s < PL_bufend && isSPACE(*s))
3940 if (s < PL_bufend) {
3941 Newxz(newargv,PL_origargc+3,char*);
3943 while (s < PL_bufend && !isSPACE(*s))
3946 Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3949 newargv = PL_origargv;
3952 PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3954 Perl_croak(aTHX_ "Can't exec %s", ipath);
3958 while (*d && !isSPACE(*d))
3960 while (SPACE_OR_TAB(*d))
3964 const bool switches_done = PL_doswitches;
3965 const U32 oldpdb = PL_perldb;
3966 const bool oldn = PL_minus_n;
3967 const bool oldp = PL_minus_p;
3971 if (*d1 == 'M' || *d1 == 'm' || *d1 == 'C') {
3972 const char * const m = d1;
3973 while (*d1 && !isSPACE(*d1))
3975 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3978 d1 = moreswitches(d1);
3980 if (PL_doswitches && !switches_done) {
3981 int argc = PL_origargc;
3982 char **argv = PL_origargv;
3985 } while (argc && argv[0][0] == '-' && argv[0][1]);
3986 init_argv_symbols(argc,argv);
3988 if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
3989 ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3990 /* if we have already added "LINE: while (<>) {",
3991 we must not do it again */
3993 sv_setpvs(PL_linestr, "");
3994 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3995 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3996 PL_last_lop = PL_last_uni = NULL;
3997 PL_preambled = FALSE;
3998 if (PERLDB_LINE || PERLDB_SAVESRC)
3999 (void)gv_fetchfile(PL_origfilename);
4006 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4008 PL_lex_state = LEX_FORMLINE;
4013 #ifdef PERL_STRICT_CR
4014 Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
4016 "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
4018 case ' ': case '\t': case '\f': case 013:
4019 #ifdef MACOS_TRADITIONAL
4023 PL_realtokenstart = -1;
4025 PL_thiswhite = newSVpvs("");
4026 sv_catpvn(PL_thiswhite, s, 1);
4033 PL_realtokenstart = -1;
4037 if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
4038 if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
4039 /* handle eval qq[#line 1 "foo"\n ...] */
4040 CopLINE_dec(PL_curcop);
4043 if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
4045 if (!PL_in_eval || PL_rsfp)
4050 while (d < PL_bufend && *d != '\n')
4054 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4055 Perl_croak(aTHX_ "panic: input overflow");
4058 PL_thiswhite = newSVpvn(s, d - s);
4063 if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
4065 PL_lex_state = LEX_FORMLINE;
4071 if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
4072 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
4075 TOKEN(PEG); /* make sure any #! line is accessible */
4080 /* if (PL_madskills && PL_lex_formbrack) { */
4082 while (d < PL_bufend && *d != '\n')
4086 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
4087 Perl_croak(aTHX_ "panic: input overflow");
4088 if (PL_madskills && CopLINE(PL_curcop) >= 1) {
4090 PL_thiswhite = newSVpvs("");
4091 if (CopLINE(PL_curcop) == 1) {
4092 sv_setpvs(PL_thiswhite, "");
4095 sv_catpvn(PL_thiswhite, s, d - s);
4109 if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
4117 while (s < PL_bufend && SPACE_OR_TAB(*s))
4120 if (strnEQ(s,"=>",2)) {
4121 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
4122 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
4123 OPERATOR('-'); /* unary minus */
4125 PL_last_uni = PL_oldbufptr;
4127 case 'r': ftst = OP_FTEREAD; break;
4128 case 'w': ftst = OP_FTEWRITE; break;
4129 case 'x': ftst = OP_FTEEXEC; break;
4130 case 'o': ftst = OP_FTEOWNED; break;
4131 case 'R': ftst = OP_FTRREAD; break;
4132 case 'W': ftst = OP_FTRWRITE; break;
4133 case 'X': ftst = OP_FTREXEC; break;
4134 case 'O': ftst = OP_FTROWNED; break;
4135 case 'e': ftst = OP_FTIS; break;
4136 case 'z': ftst = OP_FTZERO; break;
4137 case 's': ftst = OP_FTSIZE; break;
4138 case 'f': ftst = OP_FTFILE; break;
4139 case 'd': ftst = OP_FTDIR; break;
4140 case 'l': ftst = OP_FTLINK; break;
4141 case 'p': ftst = OP_FTPIPE; break;
4142 case 'S': ftst = OP_FTSOCK; break;
4143 case 'u': ftst = OP_FTSUID; break;
4144 case 'g': ftst = OP_FTSGID; break;
4145 case 'k': ftst = OP_FTSVTX; break;
4146 case 'b': ftst = OP_FTBLK; break;
4147 case 'c': ftst = OP_FTCHR; break;
4148 case 't': ftst = OP_FTTTY; break;
4149 case 'T': ftst = OP_FTTEXT; break;
4150 case 'B': ftst = OP_FTBINARY; break;
4151 case 'M': case 'A': case 'C':
4152 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4154 case 'M': ftst = OP_FTMTIME; break;
4155 case 'A': ftst = OP_FTATIME; break;
4156 case 'C': ftst = OP_FTCTIME; break;
4164 PL_last_lop_op = (OPCODE)ftst;
4165 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4166 "### Saw file test %c\n", (int)tmp);
4171 /* Assume it was a minus followed by a one-letter named
4172 * subroutine call (or a -bareword), then. */
4173 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4174 "### '-%c' looked like a file test but was not\n",
4181 const char tmp = *s++;
4184 if (PL_expect == XOPERATOR)
4189 else if (*s == '>') {
4192 if (isIDFIRST_lazy_if(s,UTF)) {
4193 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4201 if (PL_expect == XOPERATOR)
4204 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4206 OPERATOR('-'); /* unary minus */
4212 const char tmp = *s++;
4215 if (PL_expect == XOPERATOR)
4220 if (PL_expect == XOPERATOR)
4223 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4230 if (PL_expect != XOPERATOR) {
4231 s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4232 PL_expect = XOPERATOR;
4233 force_ident(PL_tokenbuf, '*');
4246 if (PL_expect == XOPERATOR) {
4250 PL_tokenbuf[0] = '%';
4251 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4252 sizeof PL_tokenbuf - 1, FALSE);
4253 if (!PL_tokenbuf[1]) {
4256 PL_pending_ident = '%';
4267 && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
4274 const char tmp = *s++;
4280 goto just_a_word_zero_gv;
4283 switch (PL_expect) {
4289 if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4291 PL_bufptr = s; /* update in case we back off */
4297 PL_expect = XTERMBLOCK;
4300 stuffstart = s - SvPVX(PL_linestr) - 1;
4304 while (isIDFIRST_lazy_if(s,UTF)) {
4307 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4308 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4309 if (tmp < 0) tmp = -tmp;
4323 sv = newSVpvn(s, len);
4325 d = scan_str(d,TRUE,TRUE);
4327 /* MUST advance bufptr here to avoid bogus
4328 "at end of line" context messages from yyerror().
4330 PL_bufptr = s + len;
4331 yyerror("Unterminated attribute parameter in attribute list");
4335 return REPORT(0); /* EOF indicator */
4339 sv_catsv(sv, PL_lex_stuff);
4340 attrs = append_elem(OP_LIST, attrs,
4341 newSVOP(OP_CONST, 0, sv));
4342 SvREFCNT_dec(PL_lex_stuff);
4343 PL_lex_stuff = NULL;
4346 if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4348 if (PL_in_my == KEY_our) {
4350 GvUNIQUE_on(cGVOPx_gv(pl_yylval.opval));
4352 /* skip to avoid loading attributes.pm */
4354 deprecate(":unique");
4357 Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4360 /* NOTE: any CV attrs applied here need to be part of
4361 the CVf_BUILTIN_ATTRS define in cv.h! */
4362 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4364 CvLVALUE_on(PL_compcv);
4366 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4368 CvLOCKED_on(PL_compcv);
4370 else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4372 CvMETHOD_on(PL_compcv);
4374 /* After we've set the flags, it could be argued that
4375 we don't need to do the attributes.pm-based setting
4376 process, and shouldn't bother appending recognized
4377 flags. To experiment with that, uncomment the
4378 following "else". (Note that's already been
4379 uncommented. That keeps the above-applied built-in
4380 attributes from being intercepted (and possibly
4381 rejected) by a package's attribute routines, but is
4382 justified by the performance win for the common case
4383 of applying only built-in attributes.) */
4385 attrs = append_elem(OP_LIST, attrs,
4386 newSVOP(OP_CONST, 0,
4390 if (*s == ':' && s[1] != ':')
4393 break; /* require real whitespace or :'s */
4394 /* XXX losing whitespace on sequential attributes here */
4398 = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4399 if (*s != ';' && *s != '}' && *s != tmp
4400 && (tmp != '=' || *s != ')')) {
4401 const char q = ((*s == '\'') ? '"' : '\'');
4402 /* If here for an expression, and parsed no attrs, back
4404 if (tmp == '=' && !attrs) {
4408 /* MUST advance bufptr here to avoid bogus "at end of line"
4409 context messages from yyerror().
4412 yyerror( (const char *)
4414 ? Perl_form(aTHX_ "Invalid separator character "
4415 "%c%c%c in attribute list", q, *s, q)
4416 : "Unterminated attribute list" ) );
4424 start_force(PL_curforce);
4425 NEXTVAL_NEXTTOKE.opval = attrs;
4426 CURMAD('_', PL_nextwhite);
4431 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4432 (s - SvPVX(PL_linestr)) - stuffstart);
4440 if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4441 PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
4449 const char tmp = *s++;
4454 const char tmp = *s++;
4462 if (PL_lex_brackets <= 0)
4463 yyerror("Unmatched right square bracket");
4466 if (PL_lex_state == LEX_INTERPNORMAL) {
4467 if (PL_lex_brackets == 0) {
4468 if (*s == '-' && s[1] == '>')
4469 PL_lex_state = LEX_INTERPENDMAYBE;
4470 else if (*s != '[' && *s != '{')
4471 PL_lex_state = LEX_INTERPEND;
4478 if (PL_lex_brackets > 100) {
4479 Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4481 switch (PL_expect) {
4483 if (PL_lex_formbrack) {
4487 if (PL_oldoldbufptr == PL_last_lop)
4488 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4490 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4491 OPERATOR(HASHBRACK);
4493 while (s < PL_bufend && SPACE_OR_TAB(*s))
4496 PL_tokenbuf[0] = '\0';
4497 if (d < PL_bufend && *d == '-') {
4498 PL_tokenbuf[0] = '-';
4500 while (d < PL_bufend && SPACE_OR_TAB(*d))
4503 if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4504 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4506 while (d < PL_bufend && SPACE_OR_TAB(*d))
4509 const char minus = (PL_tokenbuf[0] == '-');
4510 s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4518 PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4523 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4528 if (PL_oldoldbufptr == PL_last_lop)
4529 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4531 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4534 if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4536 /* This hack is to get the ${} in the message. */
4538 yyerror("syntax error");
4541 OPERATOR(HASHBRACK);
4543 /* This hack serves to disambiguate a pair of curlies
4544 * as being a block or an anon hash. Normally, expectation
4545 * determines that, but in cases where we're not in a
4546 * position to expect anything in particular (like inside
4547 * eval"") we have to resolve the ambiguity. This code
4548 * covers the case where the first term in the curlies is a
4549 * quoted string. Most other cases need to be explicitly
4550 * disambiguated by prepending a "+" before the opening
4551 * curly in order to force resolution as an anon hash.
4553 * XXX should probably propagate the outer expectation
4554 * into eval"" to rely less on this hack, but that could
4555 * potentially break current behavior of eval"".
4559 if (*s == '\'' || *s == '"' || *s == '`') {
4560 /* common case: get past first string, handling escapes */
4561 for (t++; t < PL_bufend && *t != *s;)
4562 if (*t++ == '\\' && (*t == '\\' || *t == *s))
4566 else if (*s == 'q') {
4569 || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4572 /* skip q//-like construct */
4574 char open, close, term;
4577 while (t < PL_bufend && isSPACE(*t))
4579 /* check for q => */
4580 if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4581 OPERATOR(HASHBRACK);
4585 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4589 for (t++; t < PL_bufend; t++) {
4590 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4592 else if (*t == open)
4596 for (t++; t < PL_bufend; t++) {
4597 if (*t == '\\' && t+1 < PL_bufend)
4599 else if (*t == close && --brackets <= 0)
4601 else if (*t == open)
4608 /* skip plain q word */
4609 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4612 else if (isALNUM_lazy_if(t,UTF)) {
4614 while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4617 while (t < PL_bufend && isSPACE(*t))
4619 /* if comma follows first term, call it an anon hash */
4620 /* XXX it could be a comma expression with loop modifiers */
4621 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4622 || (*t == '=' && t[1] == '>')))
4623 OPERATOR(HASHBRACK);
4624 if (PL_expect == XREF)
4627 PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4633 pl_yylval.ival = CopLINE(PL_curcop);
4634 if (isSPACE(*s) || *s == '#')
4635 PL_copline = NOLINE; /* invalidate current command line number */
4640 if (PL_lex_brackets <= 0)
4641 yyerror("Unmatched right curly bracket");
4643 PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4644 if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4645 PL_lex_formbrack = 0;
4646 if (PL_lex_state == LEX_INTERPNORMAL) {
4647 if (PL_lex_brackets == 0) {
4648 if (PL_expect & XFAKEBRACK) {
4649 PL_expect &= XENUMMASK;
4650 PL_lex_state = LEX_INTERPEND;
4655 PL_thiswhite = newSVpvs("");
4656 sv_catpvs(PL_thiswhite,"}");
4659 return yylex(); /* ignore fake brackets */
4661 if (*s == '-' && s[1] == '>')
4662 PL_lex_state = LEX_INTERPENDMAYBE;
4663 else if (*s != '[' && *s != '{')
4664 PL_lex_state = LEX_INTERPEND;
4667 if (PL_expect & XFAKEBRACK) {
4668 PL_expect &= XENUMMASK;
4670 return yylex(); /* ignore fake brackets */
4672 start_force(PL_curforce);
4674 curmad('X', newSVpvn(s-1,1));
4675 CURMAD('_', PL_thiswhite);
4680 PL_thistoken = newSVpvs("");
4688 if (PL_expect == XOPERATOR) {
4689 if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4690 && isIDFIRST_lazy_if(s,UTF))
4692 CopLINE_dec(PL_curcop);
4693 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
4694 CopLINE_inc(PL_curcop);
4699 s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4701 PL_expect = XOPERATOR;
4702 force_ident(PL_tokenbuf, '&');
4706 pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
4718 const char tmp = *s++;
4725 if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4726 && strchr("+-*/%.^&|<",tmp))
4727 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4728 "Reversed %c= operator",(int)tmp);
4730 if (PL_expect == XSTATE && isALPHA(tmp) &&
4731 (s == PL_linestart+1 || s[-2] == '\n') )
4733 if (PL_in_eval && !PL_rsfp) {
4738 if (strnEQ(s,"=cut",4)) {
4754 PL_thiswhite = newSVpvs("");
4755 sv_catpvn(PL_thiswhite, PL_linestart,
4756 PL_bufend - PL_linestart);
4760 PL_doextract = TRUE;
4764 if (PL_lex_brackets < PL_lex_formbrack) {
4766 #ifdef PERL_STRICT_CR
4767 while (SPACE_OR_TAB(*t))
4769 while (SPACE_OR_TAB(*t) || *t == '\r')
4772 if (*t == '\n' || *t == '#') {
4781 if (PL_expect == XSTATE && s[1] == '!' && s[2] == '!') {
4787 const char tmp = *s++;
4789 /* was this !=~ where !~ was meant?
4790 * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4792 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4793 const char *t = s+1;
4795 while (t < PL_bufend && isSPACE(*t))
4798 if (*t == '/' || *t == '?' ||
4799 ((*t == 'm' || *t == 's' || *t == 'y')
4800 && !isALNUM(t[1])) ||
4801 (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4802 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4803 "!=~ should be !~");
4813 if (PL_expect != XOPERATOR) {
4814 if (s[1] != '<' && !strchr(s,'>'))
4817 s = scan_heredoc(s);
4819 s = scan_inputsymbol(s);
4820 TERM(sublex_start());
4826 SHop(OP_LEFT_SHIFT);
4840 const char tmp = *s++;
4842 SHop(OP_RIGHT_SHIFT);
4843 else if (tmp == '=')
4852 if (PL_expect == XOPERATOR) {
4853 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4855 deprecate_old(commaless_variable_list);
4856 return REPORT(','); /* grandfather non-comma-format format */
4860 if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4861 PL_tokenbuf[0] = '@';
4862 s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4863 sizeof PL_tokenbuf - 1, FALSE);
4864 if (PL_expect == XOPERATOR)
4865 no_op("Array length", s);
4866 if (!PL_tokenbuf[1])
4868 PL_expect = XOPERATOR;
4869 PL_pending_ident = '#';
4873 PL_tokenbuf[0] = '$';
4874 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4875 sizeof PL_tokenbuf - 1, FALSE);
4876 if (PL_expect == XOPERATOR)
4878 if (!PL_tokenbuf[1]) {
4880 yyerror("Final $ should be \\$ or $name");
4884 /* This kludge not intended to be bulletproof. */
4885 if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4886 pl_yylval.opval = newSVOP(OP_CONST, 0,
4887 newSViv(CopARYBASE_get(&PL_compiling)));
4888 pl_yylval.opval->op_private = OPpCONST_ARYBASE;
4894 const char tmp = *s;
4895 if (PL_lex_state == LEX_NORMAL)
4898 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4899 && intuit_more(s)) {
4901 PL_tokenbuf[0] = '@';
4902 if (ckWARN(WARN_SYNTAX)) {
4905 while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4908 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4909 while (t < PL_bufend && *t != ']')
4911 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4912 "Multidimensional syntax %.*s not supported",
4913 (int)((t - PL_bufptr) + 1), PL_bufptr);
4917 else if (*s == '{') {
4919 PL_tokenbuf[0] = '%';
4920 if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
4921 && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4923 char tmpbuf[sizeof PL_tokenbuf];
4926 } while (isSPACE(*t));
4927 if (isIDFIRST_lazy_if(t,UTF)) {
4929 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4933 if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
4934 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4935 "You need to quote \"%s\"",
4942 PL_expect = XOPERATOR;
4943 if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4944 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4945 if (!islop || PL_last_lop_op == OP_GREPSTART)
4946 PL_expect = XOPERATOR;
4947 else if (strchr("$@\"'`q", *s))
4948 PL_expect = XTERM; /* e.g. print $fh "foo" */
4949 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4950 PL_expect = XTERM; /* e.g. print $fh &sub */
4951 else if (isIDFIRST_lazy_if(s,UTF)) {
4952 char tmpbuf[sizeof PL_tokenbuf];
4954 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4955 if ((t2 = keyword(tmpbuf, len, 0))) {
4956 /* binary operators exclude handle interpretations */
4968 PL_expect = XTERM; /* e.g. print $fh length() */
4973 PL_expect = XTERM; /* e.g. print $fh subr() */
4976 else if (isDIGIT(*s))
4977 PL_expect = XTERM; /* e.g. print $fh 3 */
4978 else if (*s == '.' && isDIGIT(s[1]))
4979 PL_expect = XTERM; /* e.g. print $fh .3 */
4980 else if ((*s == '?' || *s == '-' || *s == '+')
4981 && !isSPACE(s[1]) && s[1] != '=')
4982 PL_expect = XTERM; /* e.g. print $fh -1 */
4983 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4985 PL_expect = XTERM; /* e.g. print $fh /.../
4986 XXX except DORDOR operator
4988 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4990 PL_expect = XTERM; /* print $fh <<"EOF" */
4993 PL_pending_ident = '$';
4997 if (PL_expect == XOPERATOR)
4999 PL_tokenbuf[0] = '@';
5000 s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
5001 if (!PL_tokenbuf[1]) {
5004 if (PL_lex_state == LEX_NORMAL)
5006 if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
5008 PL_tokenbuf[0] = '%';
5010 /* Warn about @ where they meant $. */
5011 if (*s == '[' || *s == '{') {
5012 if (ckWARN(WARN_SYNTAX)) {
5013 const char *t = s + 1;
5014 while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
5016 if (*t == '}' || *t == ']') {
5018 PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
5019 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5020 "Scalar value %.*s better written as $%.*s",
5021 (int)(t-PL_bufptr), PL_bufptr,
5022 (int)(t-PL_bufptr-1), PL_bufptr+1);
5027 PL_pending_ident = '@';
5030 case '/': /* may be division, defined-or, or pattern */
5031 if (PL_expect == XTERMORDORDOR && s[1] == '/') {
5035 case '?': /* may either be conditional or pattern */
5036 if (PL_expect == XSTATE && s[1] == '?' && s[2] == '?') {
5040 if (PL_expect == XOPERATOR) {
5048 /* A // operator. */
5058 /* Disable warning on "study /blah/" */
5059 if (PL_oldoldbufptr == PL_last_uni
5060 && (*PL_last_uni != 's' || s - PL_last_uni < 5
5061 || memNE(PL_last_uni, "study", 5)
5062 || isALNUM_lazy_if(PL_last_uni+5,UTF)
5065 s = scan_pat(s,OP_MATCH);
5066 TERM(sublex_start());
5070 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
5071 #ifdef PERL_STRICT_CR
5074 && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
5076 && (s == PL_linestart || s[-1] == '\n') )
5078 PL_lex_formbrack = 0;
5082 if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
5086 if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
5092 pl_yylval.ival = OPf_SPECIAL;
5098 if (PL_expect != XOPERATOR)
5103 case '0': case '1': case '2': case '3': case '4':
5104 case '5': case '6': case '7': case '8': case '9':
5105 s = scan_num(s, &pl_yylval);
5106 DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
5107 if (PL_expect == XOPERATOR)
5112 s = scan_str(s,!!PL_madskills,FALSE);
5113 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5114 if (PL_expect == XOPERATOR) {
5115 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5117 deprecate_old(commaless_variable_list);
5118 return REPORT(','); /* grandfather non-comma-format format */
5125 pl_yylval.ival = OP_CONST;
5126 TERM(sublex_start());
5129 s = scan_str(s,!!PL_madskills,FALSE);
5130 DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
5131 if (PL_expect == XOPERATOR) {
5132 if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
5134 deprecate_old(commaless_variable_list);
5135 return REPORT(','); /* grandfather non-comma-format format */
5142 pl_yylval.ival = OP_CONST;
5143 /* FIXME. I think that this can be const if char *d is replaced by
5144 more localised variables. */
5145 for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5146 if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5147 pl_yylval.ival = OP_STRINGIFY;
5151 TERM(sublex_start());
5154 s = scan_str(s,!!PL_madskills,FALSE);
5155 DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5156 if (PL_expect == XOPERATOR)
5157 no_op("Backticks",s);
5160 readpipe_override();
5161 TERM(sublex_start());
5165 if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5166 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5168 if (PL_expect == XOPERATOR)
5169 no_op("Backslash",s);
5173 if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5174 char *start = s + 2;
5175 while (isDIGIT(*start) || *start == '_')
5177 if (*start == '.' && isDIGIT(start[1])) {
5178 s = scan_num(s, &pl_yylval);
5181 /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5182 else if (!isALPHA(*start) && (PL_expect == XTERM
5183 || PL_expect == XREF || PL_expect == XSTATE
5184 || PL_expect == XTERMORDORDOR)) {
5185 GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
5187 s = scan_num(s, &pl_yylval);
5194 if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5236 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5238 /* Some keywords can be followed by any delimiter, including ':' */
5239 tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5240 (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5241 (PL_tokenbuf[0] == 'q' &&
5242 strchr("qwxr", PL_tokenbuf[1])))));
5244 /* x::* is just a word, unless x is "CORE" */
5245 if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5249 while (d < PL_bufend && isSPACE(*d))
5250 d++; /* no comments skipped here, or s### is misparsed */
5252 /* Is this a label? */
5253 if (!tmp && PL_expect == XSTATE
5254 && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5256 pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5261 /* Check for keywords */
5262 tmp = keyword(PL_tokenbuf, len, 0);
5264 /* Is this a word before a => operator? */
5265 if (*d == '=' && d[1] == '>') {
5268 = (OP*)newSVOP(OP_CONST, 0,
5269 S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5270 pl_yylval.opval->op_private = OPpCONST_BARE;
5274 if (tmp < 0) { /* second-class keyword? */
5275 GV *ogv = NULL; /* override (winner) */
5276 GV *hgv = NULL; /* hidden (loser) */
5277 if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5279 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5282 if (GvIMPORTED_CV(gv))
5284 else if (! CvMETHOD(cv))
5288 (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5289 (gv = *gvp) && isGV_with_GP(gv) &&
5290 GvCVu(gv) && GvIMPORTED_CV(gv))
5297 tmp = 0; /* overridden by import or by GLOBAL */
5300 && -tmp==KEY_lock /* XXX generalizable kludge */
5303 tmp = 0; /* any sub overrides "weak" keyword */
5305 else { /* no override */
5307 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5308 Perl_warner(aTHX_ packWARN(WARN_MISC),
5309 "dump() better written as CORE::dump()");
5313 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5314 && ckWARN(WARN_AMBIGUOUS)) /* never ambiguous */
5315 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5316 "Ambiguous call resolved as CORE::%s(), %s",
5317 GvENAME(hgv), "qualify as such or use &");
5324 default: /* not a keyword */
5325 /* Trade off - by using this evil construction we can pull the
5326 variable gv into the block labelled keylookup. If not, then
5327 we have to give it function scope so that the goto from the
5328 earlier ':' case doesn't bypass the initialisation. */
5330 just_a_word_zero_gv:
5338 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5341 SV *nextPL_nextwhite = 0;
5345 /* Get the rest if it looks like a package qualifier */
5347 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5349 s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5352 Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5353 *s == '\'' ? "'" : "::");
5358 if (PL_expect == XOPERATOR) {
5359 if (PL_bufptr == PL_linestart) {
5360 CopLINE_dec(PL_curcop);
5361 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
5362 CopLINE_inc(PL_curcop);
5365 no_op("Bareword",s);
5368 /* Look for a subroutine with this name in current package,
5369 unless name is "Foo::", in which case Foo is a bearword
5370 (and a package name). */
5372 if (len > 2 && !PL_madskills &&
5373 PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5375 if (ckWARN(WARN_BAREWORD)
5376 && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5377 Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5378 "Bareword \"%s\" refers to nonexistent package",
5381 PL_tokenbuf[len] = '\0';
5387 /* Mustn't actually add anything to a symbol table.
5388 But also don't want to "initialise" any placeholder
5389 constants that might already be there into full
5390 blown PVGVs with attached PVCV. */
5391 gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5392 GV_NOADD_NOINIT, SVt_PVCV);
5397 /* if we saw a global override before, get the right name */
5400 sv = newSVpvs("CORE::GLOBAL::");
5401 sv_catpv(sv,PL_tokenbuf);
5404 /* If len is 0, newSVpv does strlen(), which is correct.
5405 If len is non-zero, then it will be the true length,
5406 and so the scalar will be created correctly. */
5407 sv = newSVpv(PL_tokenbuf,len);
5410 if (PL_madskills && !PL_thistoken) {
5411 char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5412 PL_thistoken = newSVpvn(start,s - start);
5413 PL_realtokenstart = s - SvPVX(PL_linestr);
5417 /* Presume this is going to be a bareword of some sort. */
5420 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5421 pl_yylval.opval->op_private = OPpCONST_BARE;
5422 /* UTF-8 package name? */
5423 if (UTF && !IN_BYTES &&
5424 is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5427 /* And if "Foo::", then that's what it certainly is. */
5432 /* Do the explicit type check so that we don't need to force
5433 the initialisation of the symbol table to have a real GV.
5434 Beware - gv may not really be a PVGV, cv may not really be
5435 a PVCV, (because of the space optimisations that gv_init
5436 understands) But they're true if for this symbol there is
5437 respectively a typeglob and a subroutine.
5439 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5440 /* Real typeglob, so get the real subroutine: */
5442 /* A proxy for a subroutine in this package? */
5443 : SvOK(gv) ? MUTABLE_CV(gv) : NULL)
5446 /* See if it's the indirect object for a list operator. */
5448 if (PL_oldoldbufptr &&
5449 PL_oldoldbufptr < PL_bufptr &&
5450 (PL_oldoldbufptr == PL_last_lop
5451 || PL_oldoldbufptr == PL_last_uni) &&
5452 /* NO SKIPSPACE BEFORE HERE! */
5453 (PL_expect == XREF ||
5454 ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5456 bool immediate_paren = *s == '(';
5458 /* (Now we can afford to cross potential line boundary.) */
5459 s = SKIPSPACE2(s,nextPL_nextwhite);
5461 PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
5464 /* Two barewords in a row may indicate method call. */
5466 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5467 (tmp = intuit_method(s, gv, cv)))
5470 /* If not a declared subroutine, it's an indirect object. */
5471 /* (But it's an indir obj regardless for sort.) */
5472 /* Also, if "_" follows a filetest operator, it's a bareword */
5475 ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5477 (PL_last_lop_op != OP_MAPSTART &&
5478 PL_last_lop_op != OP_GREPSTART))))
5479 || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5480 && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5483 PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5488 PL_expect = XOPERATOR;
5491 s = SKIPSPACE2(s,nextPL_nextwhite);
5492 PL_nextwhite = nextPL_nextwhite;
5497 /* Is this a word before a => operator? */
5498 if (*s == '=' && s[1] == '>' && !pkgname) {
5500 sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
5501 if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5502 SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
5506 /* If followed by a paren, it's certainly a subroutine. */
5511 while (SPACE_OR_TAB(*d))
5513 if (*d == ')' && (sv = gv_const_sv(gv))) {
5520 PL_nextwhite = PL_thiswhite;
5523 start_force(PL_curforce);
5525 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5526 PL_expect = XOPERATOR;
5529 PL_nextwhite = nextPL_nextwhite;
5530 curmad('X', PL_thistoken);
5531 PL_thistoken = newSVpvs("");
5539 /* If followed by var or block, call it a method (unless sub) */
5541 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5542 PL_last_lop = PL_oldbufptr;
5543 PL_last_lop_op = OP_METHOD;
5547 /* If followed by a bareword, see if it looks like indir obj. */
5550 && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5551 && (tmp = intuit_method(s, gv, cv)))
5554 /* Not a method, so call it a subroutine (if defined) */
5557 if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5558 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5559 "Ambiguous use of -%s resolved as -&%s()",
5560 PL_tokenbuf, PL_tokenbuf);
5561 /* Check for a constant sub */
5562 if ((sv = gv_const_sv(gv))) {
5564 SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
5565 ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5566 pl_yylval.opval->op_private = 0;
5570 /* Resolve to GV now. */
5571 if (SvTYPE(gv) != SVt_PVGV) {
5572 gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5573 assert (SvTYPE(gv) == SVt_PVGV);
5574 /* cv must have been some sort of placeholder, so
5575 now needs replacing with a real code reference. */
5579 op_free(pl_yylval.opval);
5580 pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5581 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5582 PL_last_lop = PL_oldbufptr;
5583 PL_last_lop_op = OP_ENTERSUB;
5584 /* Is there a prototype? */
5592 const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
5595 if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5597 while (*proto == ';')
5599 if (*proto == '&' && *s == '{') {
5601 sv_setpvs(PL_subname, "__ANON__");
5603 sv_setpvs(PL_subname, "__ANON__::__ANON__");
5610 PL_nextwhite = PL_thiswhite;
5613 start_force(PL_curforce);
5614 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5617 PL_nextwhite = nextPL_nextwhite;
5618 curmad('X', PL_thistoken);
5619 PL_thistoken = newSVpvs("");
5626 /* Guess harder when madskills require "best effort". */
5627 if (PL_madskills && (!gv || !GvCVu(gv))) {
5628 int probable_sub = 0;
5629 if (strchr("\"'`$@%0123456789!*+{[<", *s))
5631 else if (isALPHA(*s)) {
5635 d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5636 if (!keyword(tmpbuf, tmplen, 0))
5639 while (d < PL_bufend && isSPACE(*d))
5641 if (*d == '=' && d[1] == '>')
5646 gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
5647 op_free(pl_yylval.opval);
5648 pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5649 pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5650 PL_last_lop = PL_oldbufptr;
5651 PL_last_lop_op = OP_ENTERSUB;
5652 PL_nextwhite = PL_thiswhite;
5654 start_force(PL_curforce);
5655 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5657 PL_nextwhite = nextPL_nextwhite;
5658 curmad('X', PL_thistoken);
5659 PL_thistoken = newSVpvs("");
5664 NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
5671 /* Call it a bare word */
5674 if (PL_hints & HINT_STRICT_SUBS)
5675 pl_yylval.opval->op_private |= OPpCONST_STRICT;
5677 if (lastchar != '-') {
5678 if (ckWARN(WARN_RESERVED)) {
5682 if (!*d && !gv_stashpv(PL_tokenbuf, 0))
5683 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5690 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5691 && ckWARN_d(WARN_AMBIGUOUS)) {
5692 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5693 "Operator or semicolon missing before %c%s",
5694 lastchar, PL_tokenbuf);
5695 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5696 "Ambiguous use of %c resolved as operator %c",
5697 lastchar, lastchar);
5703 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5704 newSVpv(CopFILE(PL_curcop),0));
5708 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5709 Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5712 case KEY___PACKAGE__:
5713 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5715 ? newSVhek(HvNAME_HEK(PL_curstash))
5722 if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5723 const char *pname = "main";
5724 if (PL_tokenbuf[2] == 'D')
5725 pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5726 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5730 GvIOp(gv) = newIO();
5731 IoIFP(GvIOp(gv)) = PL_rsfp;
5732 #if defined(HAS_FCNTL) && defined(F_SETFD)
5734 const int fd = PerlIO_fileno(PL_rsfp);
5735 fcntl(fd,F_SETFD,fd >= 3);
5738 /* Mark this internal pseudo-handle as clean */
5739 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5740 if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5741 IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5743 IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5744 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5745 /* if the script was opened in binmode, we need to revert
5746 * it to text mode for compatibility; but only iff it has CRs
5747 * XXX this is a questionable hack at best. */
5748 if (PL_bufend-PL_bufptr > 2
5749 && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5752 if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5753 loc = PerlIO_tell(PL_rsfp);
5754 (void)PerlIO_seek(PL_rsfp, 0L, 0);
5757 if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5759 if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5760 #endif /* NETWARE */
5761 #ifdef PERLIO_IS_STDIO /* really? */
5762 # if defined(__BORLANDC__)
5763 /* XXX see note in do_binmode() */
5764 ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5768 PerlIO_seek(PL_rsfp, loc, 0);
5772 #ifdef PERLIO_LAYERS
5775 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5776 else if (PL_encoding) {
5783 XPUSHs(PL_encoding);
5785 call_method("name", G_SCALAR);
5789 PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5790 Perl_form(aTHX_ ":encoding(%"SVf")",
5799 if (PL_realtokenstart >= 0) {
5800 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5802 PL_endwhite = newSVpvs("");
5803 sv_catsv(PL_endwhite, PL_thiswhite);
5805 sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5806 PL_realtokenstart = -1;
5808 while ((s = filter_gets(PL_endwhite, PL_rsfp,
5809 SvCUR(PL_endwhite))) != NULL) ;
5824 if (PL_expect == XSTATE) {
5831 if (*s == ':' && s[1] == ':') {
5834 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5835 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5836 Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5839 else if (tmp == KEY_require || tmp == KEY_do)
5840 /* that's a way to remember we saw "CORE::" */
5853 LOP(OP_ACCEPT,XTERM);
5859 LOP(OP_ATAN2,XTERM);
5865 LOP(OP_BINMODE,XTERM);
5868 LOP(OP_BLESS,XTERM);
5877 /* When 'use switch' is in effect, continue has a dual
5878 life as a control operator. */
5880 if (!FEATURE_IS_ENABLED("switch"))
5883 /* We have to disambiguate the two senses of
5884 "continue". If the next token is a '{' then
5885 treat it as the start of a continue block;
5886 otherwise treat it as a control operator.
5898 (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5915 if (!PL_cryptseen) {
5916 PL_cryptseen = TRUE;
5920 LOP(OP_CRYPT,XTERM);
5923 LOP(OP_CHMOD,XTERM);
5926 LOP(OP_CHOWN,XTERM);
5929 LOP(OP_CONNECT,XTERM);
5948 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5949 if (orig_keyword == KEY_do) {
5958 PL_hints |= HINT_BLOCK_SCOPE;
5968 gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5969 LOP(OP_DBMOPEN,XTERM);
5975 s = force_word(s,WORD,TRUE,FALSE,FALSE);
5982 pl_yylval.ival = CopLINE(PL_curcop);
5998 PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5999 UNIBRACK(OP_ENTEREVAL);
6013 case KEY_endhostent:
6019 case KEY_endservent:
6022 case KEY_endprotoent:
6033 pl_yylval.ival = CopLINE(PL_curcop);
6035 if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
6038 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
6041 if ((PL_bufend - p) >= 3 &&
6042 strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
6044 else if ((PL_bufend - p) >= 4 &&
6045 strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
6048 if (isIDFIRST_lazy_if(p,UTF)) {
6049 p = scan_ident(p, PL_bufend,
6050 PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
6054 Perl_croak(aTHX_ "Missing $ on loop variable");
6056 s = SvPVX(PL_linestr) + soff;
6062 LOP(OP_FORMLINE,XTERM);
6068 LOP(OP_FCNTL,XTERM);
6074 LOP(OP_FLOCK,XTERM);
6083 LOP(OP_GREPSTART, XREF);
6086 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6101 case KEY_getpriority:
6102 LOP(OP_GETPRIORITY,XTERM);
6104 case KEY_getprotobyname:
6107 case KEY_getprotobynumber:
6108 LOP(OP_GPBYNUMBER,XTERM);
6110 case KEY_getprotoent:
6122 case KEY_getpeername:
6123 UNI(OP_GETPEERNAME);
6125 case KEY_gethostbyname:
6128 case KEY_gethostbyaddr:
6129 LOP(OP_GHBYADDR,XTERM);
6131 case KEY_gethostent:
6134 case KEY_getnetbyname:
6137 case KEY_getnetbyaddr:
6138 LOP(OP_GNBYADDR,XTERM);
6143 case KEY_getservbyname:
6144 LOP(OP_GSBYNAME,XTERM);
6146 case KEY_getservbyport:
6147 LOP(OP_GSBYPORT,XTERM);
6149 case KEY_getservent:
6152 case KEY_getsockname:
6153 UNI(OP_GETSOCKNAME);
6155 case KEY_getsockopt:
6156 LOP(OP_GSOCKOPT,XTERM);
6171 pl_yylval.ival = CopLINE(PL_curcop);
6181 pl_yylval.ival = CopLINE(PL_curcop);
6185 LOP(OP_INDEX,XTERM);
6191 LOP(OP_IOCTL,XTERM);
6203 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6235 LOP(OP_LISTEN,XTERM);
6244 s = scan_pat(s,OP_MATCH);
6245 TERM(sublex_start());
6248 LOP(OP_MAPSTART, XREF);
6251 LOP(OP_MKDIR,XTERM);
6254 LOP(OP_MSGCTL,XTERM);
6257 LOP(OP_MSGGET,XTERM);
6260 LOP(OP_MSGRCV,XTERM);
6263 LOP(OP_MSGSND,XTERM);
6268 PL_in_my = (U16)tmp;
6270 if (isIDFIRST_lazy_if(s,UTF)) {
6274 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6275 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6277 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6278 if (!PL_in_my_stash) {
6281 my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6285 if (PL_madskills) { /* just add type to declarator token */
6286 sv_catsv(PL_thistoken, PL_nextwhite);
6288 sv_catpvn(PL_thistoken, start, s - start);
6296 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6303 s = tokenize_use(0, s);
6307 if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6314 if (isIDFIRST_lazy_if(s,UTF)) {
6316 for (d = s; isALNUM_lazy_if(d,UTF);)
6318 for (t=d; isSPACE(*t);)
6320 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6322 && !(t[0] == '=' && t[1] == '>')
6324 int parms_len = (int)(d-s);
6325 Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6326 "Precedence problem: open %.*s should be open(%.*s)",
6327 parms_len, s, parms_len, s);
6333 pl_yylval.ival = OP_OR;
6343 LOP(OP_OPEN_DIR,XTERM);
6346 checkcomma(s,PL_tokenbuf,"filehandle");
6350 checkcomma(s,PL_tokenbuf,"filehandle");
6369 s = force_word(s,WORD,FALSE,TRUE,FALSE);
6373 LOP(OP_PIPE_OP,XTERM);
6376 s = scan_str(s,!!PL_madskills,FALSE);
6379 pl_yylval.ival = OP_CONST;
6380 TERM(sublex_start());
6386 s = scan_str(s,!!PL_madskills,FALSE);
6389 PL_expect = XOPERATOR;
6391 if (SvCUR(PL_lex_stuff)) {
6394 d = SvPV_force(PL_lex_stuff, len);
6396 for (; isSPACE(*d) && len; --len, ++d)
6401 if (!warned && ckWARN(WARN_QW)) {
6402 for (; !isSPACE(*d) && len; --len, ++d) {
6404 Perl_warner(aTHX_ packWARN(WARN_QW),
6405 "Possible attempt to separate words with commas");
6408 else if (*d == '#') {
6409 Perl_warner(aTHX_ packWARN(WARN_QW),
6410 "Possible attempt to put comments in qw() list");
6416 for (; !isSPACE(*d) && len; --len, ++d)
6419 sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
6420 words = append_elem(OP_LIST, words,
6421 newSVOP(OP_CONST, 0, tokeq(sv)));
6425 start_force(PL_curforce);
6426 NEXTVAL_NEXTTOKE.opval = words;
6431 SvREFCNT_dec(PL_lex_stuff);
6432 PL_lex_stuff = NULL;
6438 s = scan_str(s,!!PL_madskills,FALSE);
6441 pl_yylval.ival = OP_STRINGIFY;
6442 if (SvIVX(PL_lex_stuff) == '\'')
6443 SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
6444 TERM(sublex_start());
6447 s = scan_pat(s,OP_QR);
6448 TERM(sublex_start());
6451 s = scan_str(s,!!PL_madskills,FALSE);
6454 readpipe_override();
6455 TERM(sublex_start());
6463 s = force_version(s, FALSE);
6465 else if (*s != 'v' || !isDIGIT(s[1])
6466 || (s = force_version(s, TRUE), *s == 'v'))
6468 *PL_tokenbuf = '\0';
6469 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6470 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6471 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
6473 yyerror("<> should be quotes");
6475 if (orig_keyword == KEY_require) {
6483 PL_last_uni = PL_oldbufptr;
6484 PL_last_lop_op = OP_REQUIRE;
6486 return REPORT( (int)REQUIRE );
6492 s = force_word(s,WORD,TRUE,FALSE,FALSE);
6496 LOP(OP_RENAME,XTERM);
6505 LOP(OP_RINDEX,XTERM);
6514 UNIDOR(OP_READLINE);
6517 UNIDOR(OP_BACKTICK);
6526 LOP(OP_REVERSE,XTERM);
6529 UNIDOR(OP_READLINK);
6536 if (pl_yylval.opval)
6537 TERM(sublex_start());
6539 TOKEN(1); /* force error */
6542 checkcomma(s,PL_tokenbuf,"filehandle");
6552 LOP(OP_SELECT,XTERM);
6558 LOP(OP_SEMCTL,XTERM);
6561 LOP(OP_SEMGET,XTERM);
6564 LOP(OP_SEMOP,XTERM);
6570 LOP(OP_SETPGRP,XTERM);
6572 case KEY_setpriority:
6573 LOP(OP_SETPRIORITY,XTERM);
6575 case KEY_sethostent:
6581 case KEY_setservent:
6584 case KEY_setprotoent:
6594 LOP(OP_SEEKDIR,XTERM);
6596 case KEY_setsockopt:
6597 LOP(OP_SSOCKOPT,XTERM);
6603 LOP(OP_SHMCTL,XTERM);
6606 LOP(OP_SHMGET,XTERM);
6609 LOP(OP_SHMREAD,XTERM);
6612 LOP(OP_SHMWRITE,XTERM);
6615 LOP(OP_SHUTDOWN,XTERM);
6624 LOP(OP_SOCKET,XTERM);
6626 case KEY_socketpair:
6627 LOP(OP_SOCKPAIR,XTERM);
6630 checkcomma(s,PL_tokenbuf,"subroutine name");
6632 if (*s == ';' || *s == ')') /* probably a close */
6633 Perl_croak(aTHX_ "sort is now a reserved word");
6635 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6639 LOP(OP_SPLIT,XTERM);
6642 LOP(OP_SPRINTF,XTERM);
6645 LOP(OP_SPLICE,XTERM);
6660 LOP(OP_SUBSTR,XTERM);
6666 char tmpbuf[sizeof PL_tokenbuf];
6667 SSize_t tboffset = 0;
6668 expectation attrful;
6669 bool have_name, have_proto;
6670 const int key = tmp;
6675 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6676 SV *subtoken = newSVpvn(tstart, s - tstart);
6680 s = SKIPSPACE2(s,tmpwhite);
6685 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6686 (*s == ':' && s[1] == ':'))
6689 SV *nametoke = NULL;
6693 attrful = XATTRBLOCK;
6694 /* remember buffer pos'n for later force_word */
6695 tboffset = s - PL_oldbufptr;
6696 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6699 nametoke = newSVpvn(s, d - s);
6701 if (memchr(tmpbuf, ':', len))
6702 sv_setpvn(PL_subname, tmpbuf, len);
6704 sv_setsv(PL_subname,PL_curstname);
6705 sv_catpvs(PL_subname,"::");
6706 sv_catpvn(PL_subname,tmpbuf,len);
6713 CURMAD('X', nametoke);
6714 CURMAD('_', tmpwhite);
6715 (void) force_word(PL_oldbufptr + tboffset, WORD,
6718 s = SKIPSPACE2(d,tmpwhite);
6725 Perl_croak(aTHX_ "Missing name in \"my sub\"");
6726 PL_expect = XTERMBLOCK;
6727 attrful = XATTRTERM;
6728 sv_setpvs(PL_subname,"?");
6732 if (key == KEY_format) {
6734 PL_lex_formbrack = PL_lex_brackets + 1;
6736 PL_thistoken = subtoken;
6740 (void) force_word(PL_oldbufptr + tboffset, WORD,
6746 /* Look for a prototype */
6749 bool bad_proto = FALSE;
6750 bool in_brackets = FALSE;
6751 char greedy_proto = ' ';
6752 bool proto_after_greedy_proto = FALSE;
6753 bool must_be_last = FALSE;
6754 bool underscore = FALSE;
6755 bool seen_underscore = FALSE;
6756 const bool warnsyntax = ckWARN(WARN_SYNTAX);
6758 s = scan_str(s,!!PL_madskills,FALSE);
6760 Perl_croak(aTHX_ "Prototype not terminated");
6761 /* strip spaces and check for bad characters */
6762 d = SvPVX(PL_lex_stuff);
6764 for (p = d; *p; ++p) {
6770 proto_after_greedy_proto = TRUE;
6771 if (!strchr("$@%*;[]&\\_", *p)) {
6783 else if ( *p == ']' ) {
6784 in_brackets = FALSE;
6786 else if ( (*p == '@' || *p == '%') &&
6787 ( tmp < 2 || d[tmp-2] != '\\' ) &&
6789 must_be_last = TRUE;
6792 else if ( *p == '_' ) {
6793 underscore = seen_underscore = TRUE;
6800 if (proto_after_greedy_proto)
6801 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6802 "Prototype after '%c' for %"SVf" : %s",
6803 greedy_proto, SVfARG(PL_subname), d);
6805 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6806 "Illegal character %sin prototype for %"SVf" : %s",
6807 seen_underscore ? "after '_' " : "",
6808 SVfARG(PL_subname), d);
6809 SvCUR_set(PL_lex_stuff, tmp);
6814 CURMAD('q', PL_thisopen);
6815 CURMAD('_', tmpwhite);
6816 CURMAD('=', PL_thisstuff);
6817 CURMAD('Q', PL_thisclose);
6818 NEXTVAL_NEXTTOKE.opval =
6819 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6820 PL_lex_stuff = NULL;
6823 s = SKIPSPACE2(s,tmpwhite);
6831 if (*s == ':' && s[1] != ':')
6832 PL_expect = attrful;
6833 else if (*s != '{' && key == KEY_sub) {
6835 Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6837 Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6844 curmad('^', newSVpvs(""));
6845 CURMAD('_', tmpwhite);
6849 PL_thistoken = subtoken;
6852 NEXTVAL_NEXTTOKE.opval =
6853 (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6854 PL_lex_stuff = NULL;
6860 sv_setpvs(PL_subname, "__ANON__");
6862 sv_setpvs(PL_subname, "__ANON__::__ANON__");
6866 (void) force_word(PL_oldbufptr + tboffset, WORD,
6875 LOP(OP_SYSTEM,XREF);
6878 LOP(OP_SYMLINK,XTERM);
6881 LOP(OP_SYSCALL,XTERM);
6884 LOP(OP_SYSOPEN,XTERM);
6887 LOP(OP_SYSSEEK,XTERM);
6890 LOP(OP_SYSREAD,XTERM);
6893 LOP(OP_SYSWRITE,XTERM);
6897 TERM(sublex_start());
6918 LOP(OP_TRUNCATE,XTERM);
6930 pl_yylval.ival = CopLINE(PL_curcop);
6934 pl_yylval.ival = CopLINE(PL_curcop);
6938 LOP(OP_UNLINK,XTERM);
6944 LOP(OP_UNPACK,XTERM);
6947 LOP(OP_UTIME,XTERM);
6953 LOP(OP_UNSHIFT,XTERM);
6956 s = tokenize_use(1, s);
6966 pl_yylval.ival = CopLINE(PL_curcop);
6970 pl_yylval.ival = CopLINE(PL_curcop);
6974 PL_hints |= HINT_BLOCK_SCOPE;
6981 LOP(OP_WAITPID,XTERM);
6990 ctl_l[0] = toCTRL('L');
6992 gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6995 /* Make sure $^L is defined */
6996 gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
7001 if (PL_expect == XOPERATOR)
7007 pl_yylval.ival = OP_XOR;
7012 TERM(sublex_start());
7017 #pragma segment Main
7021 S_pending_ident(pTHX)
7026 /* pit holds the identifier we read and pending_ident is reset */
7027 char pit = PL_pending_ident;
7028 const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
7029 /* All routes through this function want to know if there is a colon. */
7030 const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
7031 PL_pending_ident = 0;
7033 /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
7034 DEBUG_T({ PerlIO_printf(Perl_debug_log,
7035 "### Pending identifier '%s'\n", PL_tokenbuf); });
7037 /* if we're in a my(), we can't allow dynamics here.
7038 $foo'bar has already been turned into $foo::bar, so
7039 just check for colons.
7041 if it's a legal name, the OP is a PADANY.
7044 if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
7046 yyerror(Perl_form(aTHX_ "No package name allowed for "
7047 "variable %s in \"our\"",
7049 tmp = allocmy(PL_tokenbuf);
7053 yyerror(Perl_form(aTHX_ PL_no_myglob,
7054 PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
7056 pl_yylval.opval = newOP(OP_PADANY, 0);
7057 pl_yylval.opval->op_targ = allocmy(PL_tokenbuf);
7063 build the ops for accesses to a my() variable.
7065 Deny my($a) or my($b) in a sort block, *if* $a or $b is
7066 then used in a comparison. This catches most, but not
7067 all cases. For instance, it catches
7068 sort { my($a); $a <=> $b }
7070 sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
7071 (although why you'd do that is anyone's guess).
7076 tmp = pad_findmy(PL_tokenbuf);
7077 if (tmp != NOT_IN_PAD) {
7078 /* might be an "our" variable" */
7079 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
7080 /* build ops for a bareword */
7081 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
7082 HEK * const stashname = HvNAME_HEK(stash);
7083 SV * const sym = newSVhek(stashname);
7084 sv_catpvs(sym, "::");
7085 sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
7086 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
7087 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7090 ? (GV_ADDMULTI | GV_ADDINEVAL)
7093 ((PL_tokenbuf[0] == '$') ? SVt_PV
7094 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7099 /* if it's a sort block and they're naming $a or $b */
7100 if (PL_last_lop_op == OP_SORT &&
7101 PL_tokenbuf[0] == '$' &&
7102 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
7105 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
7106 d < PL_bufend && *d != '\n';
7109 if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
7110 Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
7116 pl_yylval.opval = newOP(OP_PADANY, 0);
7117 pl_yylval.opval->op_targ = tmp;
7123 Whine if they've said @foo in a doublequoted string,
7124 and @foo isn't a variable we can find in the symbol
7127 if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
7128 GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
7130 if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
7131 && ckWARN(WARN_AMBIGUOUS)
7132 /* DO NOT warn for @- and @+ */
7133 && !( PL_tokenbuf[2] == '\0' &&
7134 ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
7137 /* Downgraded from fatal to warning 20000522 mjd */
7138 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7139 "Possible unintended interpolation of %s in string",
7144 /* build ops for a bareword */
7145 pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
7147 pl_yylval.opval->op_private = OPpCONST_ENTERED;
7149 PL_tokenbuf + 1, tokenbuf_len - 1,
7150 /* If the identifier refers to a stash, don't autovivify it.
7151 * Change 24660 had the side effect of causing symbol table
7152 * hashes to always be defined, even if they were freshly
7153 * created and the only reference in the entire program was
7154 * the single statement with the defined %foo::bar:: test.
7155 * It appears that all code in the wild doing this actually
7156 * wants to know whether sub-packages have been loaded, so
7157 * by avoiding auto-vivifying symbol tables, we ensure that
7158 * defined %foo::bar:: continues to be false, and the existing
7159 * tests still give the expected answers, even though what
7160 * they're actually testing has now changed subtly.
7162 (*PL_tokenbuf == '%'
7163 && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
7166 : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7167 ((PL_tokenbuf[0] == '$') ? SVt_PV
7168 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7174 * The following code was generated by perl_keyword.pl.
7178 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7182 PERL_ARGS_ASSERT_KEYWORD;
7186 case 1: /* 5 tokens of length 1 */
7218 case 2: /* 18 tokens of length 2 */
7364 case 3: /* 29 tokens of length 3 */
7368 if (name[1] == 'N' &&
7431 if (name[1] == 'i' &&
7463 if (name[1] == 'o' &&
7472 if (name[1] == 'e' &&
7481 if (name[1] == 'n' &&
7490 if (name[1] == 'o' &&
7499 if (name[1] == 'a' &&
7508 if (name[1] == 'o' &&
7570 if (name[1] == 'e' &&
7584 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7610 if (name[1] == 'i' &&
7619 if (name[1] == 's' &&
7628 if (name[1] == 'e' &&
7637 if (name[1] == 'o' &&
7649 case 4: /* 41 tokens of length 4 */
7653 if (name[1] == 'O' &&
7663 if (name[1] == 'N' &&
7673 if (name[1] == 'i' &&
7683 if (name[1] == 'h' &&
7693 if (name[1] == 'u' &&
7706 if (name[2] == 'c' &&
7715 if (name[2] == 's' &&
7724 if (name[2] == 'a' &&
7760 if (name[1] == 'o' &&
7773 if (name[2] == 't' &&
7782 if (name[2] == 'o' &&
7791 if (name[2] == 't' &&
7800 if (name[2] == 'e' &&
7813 if (name[1] == 'o' &&
7826 if (name[2] == 'y' &&
7835 if (name[2] == 'l' &&
7851 if (name[2] == 's' &&
7860 if (name[2] == 'n' &&
7869 if (name[2] == 'c' &&
7882 if (name[1] == 'e' &&
7892 if (name[1] == 'p' &&
7905 if (name[2] == 'c' &&
7914 if (name[2] == 'p' &&
7923 if (name[2] == 's' &&
7939 if (name[2] == 'n' &&
8009 if (name[2] == 'r' &&
8018 if (name[2] == 'r' &&
8027 if (name[2] == 'a' &&
8043 if (name[2] == 'l' &&
8105 if (name[2] == 'e' &&
8108 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
8121 case 5: /* 39 tokens of length 5 */
8125 if (name[1] == 'E' &&
8136 if (name[1] == 'H' &&
8150 if (name[2] == 'a' &&
8160 if (name[2] == 'a' &&
8177 if (name[2] == 'e' &&
8187 if (name[2] == 'e' &&
8191 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8207 if (name[3] == 'i' &&
8216 if (name[3] == 'o' &&
8252 if (name[2] == 'o' &&
8262 if (name[2] == 'y' &&
8276 if (name[1] == 'l' &&
8290 if (name[2] == 'n' &&
8300 if (name[2] == 'o' &&
8314 if (name[1] == 'i' &&
8319 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8328 if (name[2] == 'd' &&
8338 if (name[2] == 'c' &&
8355 if (name[2] == 'c' &&
8365 if (name[2] == 't' &&
8379 if (name[1] == 'k' &&
8390 if (name[1] == 'r' &&
8404 if (name[2] == 's' &&
8414 if (name[2] == 'd' &&
8431 if (name[2] == 'm' &&
8441 if (name[2] == 'i' &&
8451 if (name[2] == 'e' &&
8461 if (name[2] == 'l' &&
8471 if (name[2] == 'a' &&
8484 if (name[3] == 't' &&
8487 return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8493 if (name[3] == 'd' &&
8510 if (name[1] == 'i' &&
8524 if (name[2] == 'a' &&
8537 if (name[3] == 'e' &&
8572 if (name[2] == 'i' &&
8589 if (name[2] == 'i' &&
8599 if (name[2] == 'i' &&
8616 case 6: /* 33 tokens of length 6 */
8620 if (name[1] == 'c' &&
8635 if (name[2] == 'l' &&
8646 if (name[2] == 'r' &&
8661 if (name[1] == 'e' &&
8676 if (name[2] == 's' &&
8681 if(ckWARN_d(WARN_SYNTAX))
8682 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8688 if (name[2] == 'i' &&
8706 if (name[2] == 'l' &&
8717 if (name[2] == 'r' &&
8732 if (name[1] == 'm' &&
8747 if (name[2] == 'n' &&
8758 if (name[2] == 's' &&
8773 if (name[1] == 's' &&
8779 if (name[4] == 't' &&
8788 if (name[4] == 'e' &&
8797 if (name[4] == 'c' &&
8806 if (name[4] == 'n' &&
8822 if (name[1] == 'r' &&
8840 if (name[3] == 'a' &&
8850 if (name[3] == 'u' &&
8864 if (name[2] == 'n' &&
8882 if (name[2] == 'a' &&
8896 if (name[3] == 'e' &&
8909 if (name[4] == 't' &&
8918 if (name[4] == 'e' &&
8940 if (name[4] == 't' &&
8949 if (name[4] == 'e' &&
8965 if (name[2] == 'c' &&
8976 if (name[2] == 'l' &&
8987 if (name[2] == 'b' &&
8998 if (name[2] == 's' &&
9021 if (name[4] == 's' &&
9030 if (name[4] == 'n' &&
9043 if (name[3] == 'a' &&
9060 if (name[1] == 'a' &&
9075 case 7: /* 29 tokens of length 7 */
9079 if (name[1] == 'E' &&
9092 if (name[1] == '_' &&
9105 if (name[1] == 'i' &&
9112 return -KEY_binmode;
9118 if (name[1] == 'o' &&
9125 return -KEY_connect;
9134 if (name[2] == 'm' &&
9140 return -KEY_dbmopen;
9151 if (name[4] == 'u' &&
9155 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9161 if (name[4] == 'n' &&
9182 if (name[1] == 'o' &&
9195 if (name[1] == 'e' &&
9202 if (name[5] == 'r' &&
9205 return -KEY_getpgrp;
9211 if (name[5] == 'i' &&
9214 return -KEY_getppid;
9227 if (name[1] == 'c' &&
9234 return -KEY_lcfirst;
9240 if (name[1] == 'p' &&
9247 return -KEY_opendir;
9253 if (name[1] == 'a' &&
9271 if (name[3] == 'd' &&
9276 return -KEY_readdir;
9282 if (name[3] == 'u' &&
9293 if (name[3] == 'e' &&
9298 return -KEY_reverse;
9317 if (name[3] == 'k' &&
9322 return -KEY_seekdir;
9328 if (name[3] == 'p' &&
9333 return -KEY_setpgrp;
9343 if (name[2] == 'm' &&
9349 return -KEY_shmread;
9355 if (name[2] == 'r' &&
9361 return -KEY_sprintf;
9370 if (name[3] == 'l' &&
9375 return -KEY_symlink;
9384 if (name[4] == 'a' &&
9388 return -KEY_syscall;
9394 if (name[4] == 'p' &&
9398 return -KEY_sysopen;
9404 if (name[4] == 'e' &&
9408 return -KEY_sysread;
9414 if (name[4] == 'e' &&
9418 return -KEY_sysseek;
9436 if (name[1] == 'e' &&
9443 return -KEY_telldir;
9452 if (name[2] == 'f' &&
9458 return -KEY_ucfirst;
9464 if (name[2] == 's' &&
9470 return -KEY_unshift;
9480 if (name[1] == 'a' &&
9487 return -KEY_waitpid;
9496 case 8: /* 26 tokens of length 8 */
9500 if (name[1] == 'U' &&
9508 return KEY_AUTOLOAD;
9519 if (name[3] == 'A' &&
9525 return KEY___DATA__;
9531 if (name[3] == 'I' &&
9537 return -KEY___FILE__;
9543 if (name[3] == 'I' &&
9549 return -KEY___LINE__;
9565 if (name[2] == 'o' &&
9572 return -KEY_closedir;
9578 if (name[2] == 'n' &&
9585 return -KEY_continue;
9595 if (name[1] == 'b' &&
9603 return -KEY_dbmclose;
9609 if (name[1] == 'n' &&
9615 if (name[4] == 'r' &&
9620 return -KEY_endgrent;
9626 if (name[4] == 'w' &&
9631 return -KEY_endpwent;
9644 if (name[1] == 'o' &&
9652 return -KEY_formline;
9658 if (name[1] == 'e' &&
9669 if (name[6] == 'n' &&
9672 return -KEY_getgrent;
9678 if (name[6] == 'i' &&
9681 return -KEY_getgrgid;
9687 if (name[6] == 'a' &&
9690 return -KEY_getgrnam;
9703 if (name[4] == 'o' &&
9708 return -KEY_getlogin;
9719 if (name[6] == 'n' &&
9722 return -KEY_getpwent;
9728 if (name[6] == 'a' &&
9731 return -KEY_getpwnam;
9737 if (name[6] == 'i' &&
9740 return -KEY_getpwuid;
9760 if (name[1] == 'e' &&
9767 if (name[5] == 'i' &&
9774 return -KEY_readline;
9779 return -KEY_readlink;
9790 if (name[5] == 'i' &&
9794 return -KEY_readpipe;
9815 if (name[4] == 'r' &&
9820 return -KEY_setgrent;
9826 if (name[4] == 'w' &&
9831 return -KEY_setpwent;
9847 if (name[3] == 'w' &&
9853 return -KEY_shmwrite;
9859 if (name[3] == 't' &&
9865 return -KEY_shutdown;
9875 if (name[2] == 's' &&
9882 return -KEY_syswrite;
9892 if (name[1] == 'r' &&
9900 return -KEY_truncate;
9909 case 9: /* 9 tokens of length 9 */
9913 if (name[1] == 'N' &&
9922 return KEY_UNITCHECK;
9928 if (name[1] == 'n' &&
9937 return -KEY_endnetent;
9943 if (name[1] == 'e' &&
9952 return -KEY_getnetent;
9958 if (name[1] == 'o' &&
9967 return -KEY_localtime;
9973 if (name[1] == 'r' &&
9982 return KEY_prototype;
9988 if (name[1] == 'u' &&
9997 return -KEY_quotemeta;
10003 if (name[1] == 'e' &&
10012 return -KEY_rewinddir;
10018 if (name[1] == 'e' &&
10027 return -KEY_setnetent;
10033 if (name[1] == 'a' &&
10042 return -KEY_wantarray;
10051 case 10: /* 9 tokens of length 10 */
10055 if (name[1] == 'n' &&
10061 if (name[4] == 'o' &&
10068 return -KEY_endhostent;
10074 if (name[4] == 'e' &&
10081 return -KEY_endservent;
10094 if (name[1] == 'e' &&
10100 if (name[4] == 'o' &&
10107 return -KEY_gethostent;
10116 if (name[5] == 'r' &&
10122 return -KEY_getservent;
10128 if (name[5] == 'c' &&
10134 return -KEY_getsockopt;
10154 if (name[2] == 't')
10159 if (name[4] == 'o' &&
10166 return -KEY_sethostent;
10175 if (name[5] == 'r' &&
10181 return -KEY_setservent;
10187 if (name[5] == 'c' &&
10193 return -KEY_setsockopt;
10210 if (name[2] == 'c' &&
10219 return -KEY_socketpair;
10232 case 11: /* 8 tokens of length 11 */
10236 if (name[1] == '_' &&
10246 { /* __PACKAGE__ */
10247 return -KEY___PACKAGE__;
10253 if (name[1] == 'n' &&
10263 { /* endprotoent */
10264 return -KEY_endprotoent;
10270 if (name[1] == 'e' &&
10279 if (name[5] == 'e' &&
10285 { /* getpeername */
10286 return -KEY_getpeername;
10295 if (name[6] == 'o' &&
10300 { /* getpriority */
10301 return -KEY_getpriority;
10307 if (name[6] == 't' &&
10312 { /* getprotoent */
10313 return -KEY_getprotoent;
10327 if (name[4] == 'o' &&
10334 { /* getsockname */
10335 return -KEY_getsockname;
10348 if (name[1] == 'e' &&
10356 if (name[6] == 'o' &&
10361 { /* setpriority */
10362 return -KEY_setpriority;
10368 if (name[6] == 't' &&
10373 { /* setprotoent */
10374 return -KEY_setprotoent;
10390 case 12: /* 2 tokens of length 12 */
10391 if (name[0] == 'g' &&
10403 if (name[9] == 'd' &&
10406 { /* getnetbyaddr */
10407 return -KEY_getnetbyaddr;
10413 if (name[9] == 'a' &&
10416 { /* getnetbyname */
10417 return -KEY_getnetbyname;
10429 case 13: /* 4 tokens of length 13 */
10430 if (name[0] == 'g' &&
10437 if (name[4] == 'o' &&
10446 if (name[10] == 'd' &&
10449 { /* gethostbyaddr */
10450 return -KEY_gethostbyaddr;
10456 if (name[10] == 'a' &&
10459 { /* gethostbyname */
10460 return -KEY_gethostbyname;
10473 if (name[4] == 'e' &&
10482 if (name[10] == 'a' &&
10485 { /* getservbyname */
10486 return -KEY_getservbyname;
10492 if (name[10] == 'o' &&
10495 { /* getservbyport */
10496 return -KEY_getservbyport;
10515 case 14: /* 1 tokens of length 14 */
10516 if (name[0] == 'g' &&
10530 { /* getprotobyname */
10531 return -KEY_getprotobyname;
10536 case 16: /* 1 tokens of length 16 */
10537 if (name[0] == 'g' &&
10553 { /* getprotobynumber */
10554 return -KEY_getprotobynumber;
10568 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10572 PERL_ARGS_ASSERT_CHECKCOMMA;
10574 if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
10575 if (ckWARN(WARN_SYNTAX)) {
10578 for (w = s+2; *w && level; w++) {
10581 else if (*w == ')')
10584 while (isSPACE(*w))
10586 /* the list of chars below is for end of statements or
10587 * block / parens, boolean operators (&&, ||, //) and branch
10588 * constructs (or, and, if, until, unless, while, err, for).
10589 * Not a very solid hack... */
10590 if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
10591 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10592 "%s (...) interpreted as function",name);
10595 while (s < PL_bufend && isSPACE(*s))
10599 while (s < PL_bufend && isSPACE(*s))
10601 if (isIDFIRST_lazy_if(s,UTF)) {
10602 const char * const w = s++;
10603 while (isALNUM_lazy_if(s,UTF))
10605 while (s < PL_bufend && isSPACE(*s))
10609 if (keyword(w, s - w, 0))
10612 gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10613 if (gv && GvCVu(gv))
10615 Perl_croak(aTHX_ "No comma allowed after %s", what);
10620 /* Either returns sv, or mortalizes sv and returns a new SV*.
10621 Best used as sv=new_constant(..., sv, ...).
10622 If s, pv are NULL, calls subroutine with one argument,
10623 and type is used with error messages only. */
10626 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
10627 SV *sv, SV *pv, const char *type, STRLEN typelen)
10630 HV * const table = GvHV(PL_hintgv); /* ^H */
10634 const char *why1 = "", *why2 = "", *why3 = "";
10636 PERL_ARGS_ASSERT_NEW_CONSTANT;
10638 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10641 why2 = (const char *)
10642 (strEQ(key,"charnames")
10643 ? "(possibly a missing \"use charnames ...\")"
10645 msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10646 (type ? type: "undef"), why2);
10648 /* This is convoluted and evil ("goto considered harmful")
10649 * but I do not understand the intricacies of all the different
10650 * failure modes of %^H in here. The goal here is to make
10651 * the most probable error message user-friendly. --jhi */
10656 msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10657 (type ? type: "undef"), why1, why2, why3);
10659 yyerror(SvPVX_const(msg));
10663 cvp = hv_fetch(table, key, keylen, FALSE);
10664 if (!cvp || !SvOK(*cvp)) {
10667 why3 = "} is not defined";
10670 sv_2mortal(sv); /* Parent created it permanently */
10673 pv = newSVpvn_flags(s, len, SVs_TEMP);
10675 typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
10677 typesv = &PL_sv_undef;
10679 PUSHSTACKi(PERLSI_OVERLOAD);
10691 call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10695 /* Check the eval first */
10696 if (!PL_in_eval && SvTRUE(ERRSV)) {
10697 sv_catpvs(ERRSV, "Propagated");
10698 yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10700 res = SvREFCNT_inc_simple(sv);
10704 SvREFCNT_inc_simple_void(res);
10713 why1 = "Call to &{$^H{";
10715 why3 = "}} did not return a defined value";
10723 /* Returns a NUL terminated string, with the length of the string written to
10727 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10730 register char *d = dest;
10731 register char * const e = d + destlen - 3; /* two-character token, ending NUL */
10733 PERL_ARGS_ASSERT_SCAN_WORD;
10737 Perl_croak(aTHX_ ident_too_long);
10738 if (isALNUM(*s)) /* UTF handled below */
10740 else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10745 else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10749 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10750 char *t = s + UTF8SKIP(s);
10752 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10756 Perl_croak(aTHX_ ident_too_long);
10757 Copy(s, d, len, char);
10770 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10773 char *bracket = NULL;
10775 register char *d = dest;
10776 register char * const e = d + destlen + 3; /* two-character token, ending NUL */
10778 PERL_ARGS_ASSERT_SCAN_IDENT;
10783 while (isDIGIT(*s)) {
10785 Perl_croak(aTHX_ ident_too_long);
10792 Perl_croak(aTHX_ ident_too_long);
10793 if (isALNUM(*s)) /* UTF handled below */
10795 else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10800 else if (*s == ':' && s[1] == ':') {
10804 else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10805 char *t = s + UTF8SKIP(s);
10806 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10808 if (d + (t - s) > e)
10809 Perl_croak(aTHX_ ident_too_long);
10810 Copy(s, d, t - s, char);
10821 if (PL_lex_state != LEX_NORMAL)
10822 PL_lex_state = LEX_INTERPENDMAYBE;
10825 if (*s == '$' && s[1] &&
10826 (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10839 if (*d == '^' && *s && isCONTROLVAR(*s)) {
10844 if (isSPACE(s[-1])) {
10846 const char ch = *s++;
10847 if (!SPACE_OR_TAB(ch)) {
10853 if (isIDFIRST_lazy_if(d,UTF)) {
10857 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10858 end += UTF8SKIP(end);
10859 while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10860 end += UTF8SKIP(end);
10862 Copy(s, d, end - s, char);
10867 while ((isALNUM(*s) || *s == ':') && d < e)
10870 Perl_croak(aTHX_ ident_too_long);
10873 while (s < send && SPACE_OR_TAB(*s))
10875 if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10876 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10877 const char * const brack =
10879 ((*s == '[') ? "[...]" : "{...}");
10880 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10881 "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10882 funny, dest, brack, funny, dest, brack);
10885 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10889 /* Handle extended ${^Foo} variables
10890 * 1999-02-27 mjd-perl-patch@plover.com */
10891 else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10895 while (isALNUM(*s) && d < e) {
10899 Perl_croak(aTHX_ ident_too_long);
10904 if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10905 PL_lex_state = LEX_INTERPEND;
10908 if (PL_lex_state == LEX_NORMAL) {
10909 if (ckWARN(WARN_AMBIGUOUS) &&
10910 (keyword(dest, d - dest, 0)
10911 || get_cvn_flags(dest, d - dest, 0)))
10915 Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10916 "Ambiguous use of %c{%s} resolved to %c%s",
10917 funny, dest, funny, dest);
10922 s = bracket; /* let the parser handle it */
10926 else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10927 PL_lex_state = LEX_INTERPEND;
10932 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10934 PERL_ARGS_ASSERT_PMFLAG;
10936 PERL_UNUSED_CONTEXT;
10938 const char c = (char)ch;
10940 CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
10941 case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
10942 case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
10943 case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
10944 case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break;
10950 S_scan_pat(pTHX_ char *start, I32 type)
10954 char *s = scan_str(start,!!PL_madskills,FALSE);
10955 const char * const valid_flags =
10956 (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
10961 PERL_ARGS_ASSERT_SCAN_PAT;
10964 const char * const delimiter = skipspace(start);
10968 ? "Search pattern not terminated or ternary operator parsed as search pattern"
10969 : "Search pattern not terminated" ));
10972 pm = (PMOP*)newPMOP(type, 0);
10973 if (PL_multi_open == '?') {
10974 /* This is the only point in the code that sets PMf_ONCE: */
10975 pm->op_pmflags |= PMf_ONCE;
10977 /* Hence it's safe to do this bit of PMOP book-keeping here, which
10978 allows us to restrict the list needed by reset to just the ??
10980 assert(type != OP_TRANS);
10982 MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
10985 mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
10988 elements = mg->mg_len / sizeof(PMOP**);
10989 Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
10990 ((PMOP**)mg->mg_ptr) [elements++] = pm;
10991 mg->mg_len = elements * sizeof(PMOP**);
10992 PmopSTASH_set(pm,PL_curstash);
10998 while (*s && strchr(valid_flags, *s))
10999 pmflag(&pm->op_pmflags,*s++);
11001 if (PL_madskills && modstart != s) {
11002 SV* tmptoken = newSVpvn(modstart, s - modstart);
11003 append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
11006 /* issue a warning if /c is specified,but /g is not */
11007 if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
11008 && ckWARN(WARN_REGEXP))
11010 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
11011 "Use of /c modifier is meaningless without /g" );
11014 PL_lex_op = (OP*)pm;
11015 pl_yylval.ival = OP_MATCH;
11020 S_scan_subst(pTHX_ char *start)
11031 PERL_ARGS_ASSERT_SCAN_SUBST;
11033 pl_yylval.ival = OP_NULL;
11035 s = scan_str(start,!!PL_madskills,FALSE);
11038 Perl_croak(aTHX_ "Substitution pattern not terminated");
11040 if (s[-1] == PL_multi_open)
11043 if (PL_madskills) {
11044 CURMAD('q', PL_thisopen);
11045 CURMAD('_', PL_thiswhite);
11046 CURMAD('E', PL_thisstuff);
11047 CURMAD('Q', PL_thisclose);
11048 PL_realtokenstart = s - SvPVX(PL_linestr);
11052 first_start = PL_multi_start;
11053 s = scan_str(s,!!PL_madskills,FALSE);
11055 if (PL_lex_stuff) {
11056 SvREFCNT_dec(PL_lex_stuff);
11057 PL_lex_stuff = NULL;
11059 Perl_croak(aTHX_ "Substitution replacement not terminated");
11061 PL_multi_start = first_start; /* so whole substitution is taken together */
11063 pm = (PMOP*)newPMOP(OP_SUBST, 0);
11066 if (PL_madskills) {
11067 CURMAD('z', PL_thisopen);
11068 CURMAD('R', PL_thisstuff);
11069 CURMAD('Z', PL_thisclose);
11075 if (*s == EXEC_PAT_MOD) {
11079 else if (strchr(S_PAT_MODS, *s))
11080 pmflag(&pm->op_pmflags,*s++);
11086 if (PL_madskills) {
11088 curmad('m', newSVpvn(modstart, s - modstart));
11089 append_madprops(PL_thismad, (OP*)pm, 0);
11093 if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
11094 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
11098 SV * const repl = newSVpvs("");
11100 PL_sublex_info.super_bufptr = s;
11101 PL_sublex_info.super_bufend = PL_bufend;
11103 pm->op_pmflags |= PMf_EVAL;
11106 sv_catpvs(repl, "eval ");
11108 sv_catpvs(repl, "do ");
11110 sv_catpvs(repl, "{");
11111 sv_catsv(repl, PL_lex_repl);
11112 if (strchr(SvPVX(PL_lex_repl), '#'))
11113 sv_catpvs(repl, "\n");
11114 sv_catpvs(repl, "}");
11116 SvREFCNT_dec(PL_lex_repl);
11117 PL_lex_repl = repl;
11120 PL_lex_op = (OP*)pm;
11121 pl_yylval.ival = OP_SUBST;
11126 S_scan_trans(pTHX_ char *start)
11139 PERL_ARGS_ASSERT_SCAN_TRANS;
11141 pl_yylval.ival = OP_NULL;
11143 s = scan_str(start,!!PL_madskills,FALSE);
11145 Perl_croak(aTHX_ "Transliteration pattern not terminated");
11147 if (s[-1] == PL_multi_open)
11150 if (PL_madskills) {
11151 CURMAD('q', PL_thisopen);
11152 CURMAD('_', PL_thiswhite);
11153 CURMAD('E', PL_thisstuff);
11154 CURMAD('Q', PL_thisclose);
11155 PL_realtokenstart = s - SvPVX(PL_linestr);
11159 s = scan_str(s,!!PL_madskills,FALSE);
11161 if (PL_lex_stuff) {
11162 SvREFCNT_dec(PL_lex_stuff);
11163 PL_lex_stuff = NULL;
11165 Perl_croak(aTHX_ "Transliteration replacement not terminated");
11167 if (PL_madskills) {
11168 CURMAD('z', PL_thisopen);
11169 CURMAD('R', PL_thisstuff);
11170 CURMAD('Z', PL_thisclose);
11173 complement = del = squash = 0;
11180 complement = OPpTRANS_COMPLEMENT;
11183 del = OPpTRANS_DELETE;
11186 squash = OPpTRANS_SQUASH;
11195 tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11196 o = newPVOP(OP_TRANS, 0, (char*)tbl);
11197 o->op_private &= ~OPpTRANS_ALL;
11198 o->op_private |= del|squash|complement|
11199 (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11200 (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
11203 pl_yylval.ival = OP_TRANS;
11206 if (PL_madskills) {
11208 curmad('m', newSVpvn(modstart, s - modstart));
11209 append_madprops(PL_thismad, o, 0);
11218 S_scan_heredoc(pTHX_ register char *s)
11222 I32 op_type = OP_SCALAR;
11226 const char *found_newline;
11230 const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11232 I32 stuffstart = s - SvPVX(PL_linestr);
11235 PL_realtokenstart = -1;
11238 PERL_ARGS_ASSERT_SCAN_HEREDOC;
11242 e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11246 while (SPACE_OR_TAB(*peek))
11248 if (*peek == '`' || *peek == '\'' || *peek =='"') {
11251 s = delimcpy(d, e, s, PL_bufend, term, &len);
11261 if (!isALNUM_lazy_if(s,UTF))
11262 deprecate_old("bare << to mean <<\"\"");
11263 for (; isALNUM_lazy_if(s,UTF); s++) {
11268 if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11269 Perl_croak(aTHX_ "Delimiter for here document is too long");
11272 len = d - PL_tokenbuf;
11275 if (PL_madskills) {
11276 tstart = PL_tokenbuf + !outer;
11277 PL_thisclose = newSVpvn(tstart, len - !outer);
11278 tstart = SvPVX(PL_linestr) + stuffstart;
11279 PL_thisopen = newSVpvn(tstart, s - tstart);
11280 stuffstart = s - SvPVX(PL_linestr);
11283 #ifndef PERL_STRICT_CR
11284 d = strchr(s, '\r');
11286 char * const olds = s;
11288 while (s < PL_bufend) {
11294 else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
11303 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11310 if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11311 herewas = newSVpvn(s,PL_bufend-s);
11315 herewas = newSVpvn(s-1,found_newline-s+1);
11318 herewas = newSVpvn(s,found_newline-s);
11322 if (PL_madskills) {
11323 tstart = SvPVX(PL_linestr) + stuffstart;
11325 sv_catpvn(PL_thisstuff, tstart, s - tstart);
11327 PL_thisstuff = newSVpvn(tstart, s - tstart);
11330 s += SvCUR(herewas);
11333 stuffstart = s - SvPVX(PL_linestr);
11339 tmpstr = newSV_type(SVt_PVIV);
11340 SvGROW(tmpstr, 80);
11341 if (term == '\'') {
11342 op_type = OP_CONST;
11343 SvIV_set(tmpstr, -1);
11345 else if (term == '`') {
11346 op_type = OP_BACKTICK;
11347 SvIV_set(tmpstr, '\\');
11351 PL_multi_start = CopLINE(PL_curcop);
11352 PL_multi_open = PL_multi_close = '<';
11353 term = *PL_tokenbuf;
11354 if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11355 char * const bufptr = PL_sublex_info.super_bufptr;
11356 char * const bufend = PL_sublex_info.super_bufend;
11357 char * const olds = s - SvCUR(herewas);
11358 s = strchr(bufptr, '\n');
11362 while (s < bufend &&
11363 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11365 CopLINE_inc(PL_curcop);
11368 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11369 missingterm(PL_tokenbuf);
11371 sv_setpvn(herewas,bufptr,d-bufptr+1);
11372 sv_setpvn(tmpstr,d+1,s-d);
11374 sv_catpvn(herewas,s,bufend-s);
11375 Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11382 while (s < PL_bufend &&
11383 (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11385 CopLINE_inc(PL_curcop);
11387 if (s >= PL_bufend) {
11388 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11389 missingterm(PL_tokenbuf);
11391 sv_setpvn(tmpstr,d+1,s-d);
11393 if (PL_madskills) {
11395 sv_catpvn(PL_thisstuff, d + 1, s - d);
11397 PL_thisstuff = newSVpvn(d + 1, s - d);
11398 stuffstart = s - SvPVX(PL_linestr);
11402 CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11404 sv_catpvn(herewas,s,PL_bufend-s);
11405 sv_setsv(PL_linestr,herewas);
11406 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11407 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11408 PL_last_lop = PL_last_uni = NULL;
11411 sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
11412 while (s >= PL_bufend) { /* multiple line string? */
11414 if (PL_madskills) {
11415 tstart = SvPVX(PL_linestr) + stuffstart;
11417 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11419 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11423 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11424 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11425 missingterm(PL_tokenbuf);
11428 stuffstart = s - SvPVX(PL_linestr);
11430 CopLINE_inc(PL_curcop);
11431 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11432 PL_last_lop = PL_last_uni = NULL;
11433 #ifndef PERL_STRICT_CR
11434 if (PL_bufend - PL_linestart >= 2) {
11435 if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11436 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11438 PL_bufend[-2] = '\n';
11440 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11442 else if (PL_bufend[-1] == '\r')
11443 PL_bufend[-1] = '\n';
11445 else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11446 PL_bufend[-1] = '\n';
11448 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11449 update_debugger_info(PL_linestr, NULL, 0);
11450 if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11451 STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11452 *(SvPVX(PL_linestr) + off ) = ' ';
11453 sv_catsv(PL_linestr,herewas);
11454 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11455 s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11459 sv_catsv(tmpstr,PL_linestr);
11464 PL_multi_end = CopLINE(PL_curcop);
11465 if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11466 SvPV_shrink_to_cur(tmpstr);
11468 SvREFCNT_dec(herewas);
11470 if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11472 else if (PL_encoding)
11473 sv_recode_to_utf8(tmpstr, PL_encoding);
11475 PL_lex_stuff = tmpstr;
11476 pl_yylval.ival = op_type;
11480 /* scan_inputsymbol
11481 takes: current position in input buffer
11482 returns: new position in input buffer
11483 side-effects: pl_yylval and lex_op are set.
11488 <FH> read from filehandle
11489 <pkg::FH> read from package qualified filehandle
11490 <pkg'FH> read from package qualified filehandle
11491 <$fh> read from filehandle in $fh
11492 <*.h> filename glob
11497 S_scan_inputsymbol(pTHX_ char *start)
11500 register char *s = start; /* current position in buffer */
11503 char *d = PL_tokenbuf; /* start of temp holding space */
11504 const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
11506 PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
11508 end = strchr(s, '\n');
11511 s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
11513 /* die if we didn't have space for the contents of the <>,
11514 or if it didn't end, or if we see a newline
11517 if (len >= (I32)sizeof PL_tokenbuf)
11518 Perl_croak(aTHX_ "Excessively long <> operator");
11520 Perl_croak(aTHX_ "Unterminated <> operator");
11525 Remember, only scalar variables are interpreted as filehandles by
11526 this code. Anything more complex (e.g., <$fh{$num}>) will be
11527 treated as a glob() call.
11528 This code makes use of the fact that except for the $ at the front,
11529 a scalar variable and a filehandle look the same.
11531 if (*d == '$' && d[1]) d++;
11533 /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11534 while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11537 /* If we've tried to read what we allow filehandles to look like, and
11538 there's still text left, then it must be a glob() and not a getline.
11539 Use scan_str to pull out the stuff between the <> and treat it
11540 as nothing more than a string.
11543 if (d - PL_tokenbuf != len) {
11544 pl_yylval.ival = OP_GLOB;
11545 s = scan_str(start,!!PL_madskills,FALSE);
11547 Perl_croak(aTHX_ "Glob not terminated");
11551 bool readline_overriden = FALSE;
11554 /* we're in a filehandle read situation */
11557 /* turn <> into <ARGV> */
11559 Copy("ARGV",d,5,char);
11561 /* Check whether readline() is overriden */
11562 gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11564 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11566 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11567 && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
11568 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11569 readline_overriden = TRUE;
11571 /* if <$fh>, create the ops to turn the variable into a
11575 /* try to find it in the pad for this block, otherwise find
11576 add symbol table ops
11578 const PADOFFSET tmp = pad_findmy(d);
11579 if (tmp != NOT_IN_PAD) {
11580 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11581 HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11582 HEK * const stashname = HvNAME_HEK(stash);
11583 SV * const sym = sv_2mortal(newSVhek(stashname));
11584 sv_catpvs(sym, "::");
11585 sv_catpv(sym, d+1);
11590 OP * const o = newOP(OP_PADSV, 0);
11592 PL_lex_op = readline_overriden
11593 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11594 append_elem(OP_LIST, o,
11595 newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11596 : (OP*)newUNOP(OP_READLINE, 0, o);
11605 ? (GV_ADDMULTI | GV_ADDINEVAL)
11608 PL_lex_op = readline_overriden
11609 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11610 append_elem(OP_LIST,
11611 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11612 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11613 : (OP*)newUNOP(OP_READLINE, 0,
11614 newUNOP(OP_RV2SV, 0,
11615 newGVOP(OP_GV, 0, gv)));
11617 if (!readline_overriden)
11618 PL_lex_op->op_flags |= OPf_SPECIAL;
11619 /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
11620 pl_yylval.ival = OP_NULL;
11623 /* If it's none of the above, it must be a literal filehandle
11624 (<Foo::BAR> or <FOO>) so build a simple readline OP */
11626 GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11627 PL_lex_op = readline_overriden
11628 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11629 append_elem(OP_LIST,
11630 newGVOP(OP_GV, 0, gv),
11631 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11632 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11633 pl_yylval.ival = OP_NULL;
11642 takes: start position in buffer
11643 keep_quoted preserve \ on the embedded delimiter(s)
11644 keep_delims preserve the delimiters around the string
11645 returns: position to continue reading from buffer
11646 side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11647 updates the read buffer.
11649 This subroutine pulls a string out of the input. It is called for:
11650 q single quotes q(literal text)
11651 ' single quotes 'literal text'
11652 qq double quotes qq(interpolate $here please)
11653 " double quotes "interpolate $here please"
11654 qx backticks qx(/bin/ls -l)
11655 ` backticks `/bin/ls -l`
11656 qw quote words @EXPORT_OK = qw( func() $spam )
11657 m// regexp match m/this/
11658 s/// regexp substitute s/this/that/
11659 tr/// string transliterate tr/this/that/
11660 y/// string transliterate y/this/that/
11661 ($*@) sub prototypes sub foo ($)
11662 (stuff) sub attr parameters sub foo : attr(stuff)
11663 <> readline or globs <FOO>, <>, <$fh>, or <*.c>
11665 In most of these cases (all but <>, patterns and transliterate)
11666 yylex() calls scan_str(). m// makes yylex() call scan_pat() which
11667 calls scan_str(). s/// makes yylex() call scan_subst() which calls
11668 scan_str(). tr/// and y/// make yylex() call scan_trans() which
11671 It skips whitespace before the string starts, and treats the first
11672 character as the delimiter. If the delimiter is one of ([{< then
11673 the corresponding "close" character )]}> is used as the closing
11674 delimiter. It allows quoting of delimiters, and if the string has
11675 balanced delimiters ([{<>}]) it allows nesting.
11677 On success, the SV with the resulting string is put into lex_stuff or,
11678 if that is already non-NULL, into lex_repl. The second case occurs only
11679 when parsing the RHS of the special constructs s/// and tr/// (y///).
11680 For convenience, the terminating delimiter character is stuffed into
11685 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11688 SV *sv; /* scalar value: string */
11689 const char *tmps; /* temp string, used for delimiter matching */
11690 register char *s = start; /* current position in the buffer */
11691 register char term; /* terminating character */
11692 register char *to; /* current position in the sv's data */
11693 I32 brackets = 1; /* bracket nesting level */
11694 bool has_utf8 = FALSE; /* is there any utf8 content? */
11695 I32 termcode; /* terminating char. code */
11696 U8 termstr[UTF8_MAXBYTES]; /* terminating string */
11697 STRLEN termlen; /* length of terminating string */
11698 int last_off = 0; /* last position for nesting bracket */
11704 PERL_ARGS_ASSERT_SCAN_STR;
11706 /* skip space before the delimiter */
11712 if (PL_realtokenstart >= 0) {
11713 stuffstart = PL_realtokenstart;
11714 PL_realtokenstart = -1;
11717 stuffstart = start - SvPVX(PL_linestr);
11719 /* mark where we are, in case we need to report errors */
11722 /* after skipping whitespace, the next character is the terminator */
11725 termcode = termstr[0] = term;
11729 termcode = utf8_to_uvchr((U8*)s, &termlen);
11730 Copy(s, termstr, termlen, U8);
11731 if (!UTF8_IS_INVARIANT(term))
11735 /* mark where we are */
11736 PL_multi_start = CopLINE(PL_curcop);
11737 PL_multi_open = term;
11739 /* find corresponding closing delimiter */
11740 if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11741 termcode = termstr[0] = term = tmps[5];
11743 PL_multi_close = term;
11745 /* create a new SV to hold the contents. 79 is the SV's initial length.
11746 What a random number. */
11747 sv = newSV_type(SVt_PVIV);
11749 SvIV_set(sv, termcode);
11750 (void)SvPOK_only(sv); /* validate pointer */
11752 /* move past delimiter and try to read a complete string */
11754 sv_catpvn(sv, s, termlen);
11757 tstart = SvPVX(PL_linestr) + stuffstart;
11758 if (!PL_thisopen && !keep_delims) {
11759 PL_thisopen = newSVpvn(tstart, s - tstart);
11760 stuffstart = s - SvPVX(PL_linestr);
11764 if (PL_encoding && !UTF) {
11768 int offset = s - SvPVX_const(PL_linestr);
11769 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11770 &offset, (char*)termstr, termlen);
11771 const char * const ns = SvPVX_const(PL_linestr) + offset;
11772 char * const svlast = SvEND(sv) - 1;
11774 for (; s < ns; s++) {
11775 if (*s == '\n' && !PL_rsfp)
11776 CopLINE_inc(PL_curcop);
11779 goto read_more_line;
11781 /* handle quoted delimiters */
11782 if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11784 for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11786 if ((svlast-1 - t) % 2) {
11787 if (!keep_quoted) {
11788 *(svlast-1) = term;
11790 SvCUR_set(sv, SvCUR(sv) - 1);
11795 if (PL_multi_open == PL_multi_close) {
11801 for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11802 /* At here, all closes are "was quoted" one,
11803 so we don't check PL_multi_close. */
11805 if (!keep_quoted && *(t+1) == PL_multi_open)
11810 else if (*t == PL_multi_open)
11818 SvCUR_set(sv, w - SvPVX_const(sv));
11820 last_off = w - SvPVX(sv);
11821 if (--brackets <= 0)
11826 if (!keep_delims) {
11827 SvCUR_set(sv, SvCUR(sv) - 1);
11833 /* extend sv if need be */
11834 SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11835 /* set 'to' to the next character in the sv's string */
11836 to = SvPVX(sv)+SvCUR(sv);
11838 /* if open delimiter is the close delimiter read unbridle */
11839 if (PL_multi_open == PL_multi_close) {
11840 for (; s < PL_bufend; s++,to++) {
11841 /* embedded newlines increment the current line number */
11842 if (*s == '\n' && !PL_rsfp)
11843 CopLINE_inc(PL_curcop);
11844 /* handle quoted delimiters */
11845 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11846 if (!keep_quoted && s[1] == term)
11848 /* any other quotes are simply copied straight through */
11852 /* terminate when run out of buffer (the for() condition), or
11853 have found the terminator */
11854 else if (*s == term) {
11857 if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11860 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11866 /* if the terminator isn't the same as the start character (e.g.,
11867 matched brackets), we have to allow more in the quoting, and
11868 be prepared for nested brackets.
11871 /* read until we run out of string, or we find the terminator */
11872 for (; s < PL_bufend; s++,to++) {
11873 /* embedded newlines increment the line count */
11874 if (*s == '\n' && !PL_rsfp)
11875 CopLINE_inc(PL_curcop);
11876 /* backslashes can escape the open or closing characters */
11877 if (*s == '\\' && s+1 < PL_bufend) {
11878 if (!keep_quoted &&
11879 ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11884 /* allow nested opens and closes */
11885 else if (*s == PL_multi_close && --brackets <= 0)
11887 else if (*s == PL_multi_open)
11889 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11894 /* terminate the copied string and update the sv's end-of-string */
11896 SvCUR_set(sv, to - SvPVX_const(sv));
11899 * this next chunk reads more into the buffer if we're not done yet
11903 break; /* handle case where we are done yet :-) */
11905 #ifndef PERL_STRICT_CR
11906 if (to - SvPVX_const(sv) >= 2) {
11907 if ((to[-2] == '\r' && to[-1] == '\n') ||
11908 (to[-2] == '\n' && to[-1] == '\r'))
11912 SvCUR_set(sv, to - SvPVX_const(sv));
11914 else if (to[-1] == '\r')
11917 else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11922 /* if we're out of file, or a read fails, bail and reset the current
11923 line marker so we can report where the unterminated string began
11926 if (PL_madskills) {
11927 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11929 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11931 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11935 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11937 CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11943 /* we read a line, so increment our line counter */
11944 CopLINE_inc(PL_curcop);
11946 /* update debugger info */
11947 if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
11948 update_debugger_info(PL_linestr, NULL, 0);
11950 /* having changed the buffer, we must update PL_bufend */
11951 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11952 PL_last_lop = PL_last_uni = NULL;
11955 /* at this point, we have successfully read the delimited string */
11957 if (!PL_encoding || UTF) {
11959 if (PL_madskills) {
11960 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11961 const int len = s - tstart;
11963 sv_catpvn(PL_thisstuff, tstart, len);
11965 PL_thisstuff = newSVpvn(tstart, len);
11966 if (!PL_thisclose && !keep_delims)
11967 PL_thisclose = newSVpvn(s,termlen);
11972 sv_catpvn(sv, s, termlen);
11977 if (PL_madskills) {
11978 char * const tstart = SvPVX(PL_linestr) + stuffstart;
11979 const int len = s - tstart - termlen;
11981 sv_catpvn(PL_thisstuff, tstart, len);
11983 PL_thisstuff = newSVpvn(tstart, len);
11984 if (!PL_thisclose && !keep_delims)
11985 PL_thisclose = newSVpvn(s - termlen,termlen);
11989 if (has_utf8 || PL_encoding)
11992 PL_multi_end = CopLINE(PL_curcop);
11994 /* if we allocated too much space, give some back */
11995 if (SvCUR(sv) + 5 < SvLEN(sv)) {
11996 SvLEN_set(sv, SvCUR(sv) + 1);
11997 SvPV_renew(sv, SvLEN(sv));
12000 /* decide whether this is the first or second quoted string we've read
12013 takes: pointer to position in buffer
12014 returns: pointer to new position in buffer
12015 side-effects: builds ops for the constant in pl_yylval.op
12017 Read a number in any of the formats that Perl accepts:
12019 \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
12020 \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
12023 0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
12025 Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
12028 If it reads a number without a decimal point or an exponent, it will
12029 try converting the number to an integer and see if it can do so
12030 without loss of precision.
12034 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
12037 register const char *s = start; /* current position in buffer */
12038 register char *d; /* destination in temp buffer */
12039 register char *e; /* end of temp buffer */
12040 NV nv; /* number read, as a double */
12041 SV *sv = NULL; /* place to put the converted number */
12042 bool floatit; /* boolean: int or float? */
12043 const char *lastub = NULL; /* position of last underbar */
12044 static char const number_too_long[] = "Number too long";
12046 PERL_ARGS_ASSERT_SCAN_NUM;
12048 /* We use the first character to decide what type of number this is */
12052 Perl_croak(aTHX_ "panic: scan_num");
12054 /* if it starts with a 0, it could be an octal number, a decimal in
12055 0.13 disguise, or a hexadecimal number, or a binary number. */
12059 u holds the "number so far"
12060 shift the power of 2 of the base
12061 (hex == 4, octal == 3, binary == 1)
12062 overflowed was the number more than we can hold?
12064 Shift is used when we add a digit. It also serves as an "are
12065 we in octal/hex/binary?" indicator to disallow hex characters
12066 when in octal mode.
12071 bool overflowed = FALSE;
12072 bool just_zero = TRUE; /* just plain 0 or binary number? */
12073 static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
12074 static const char* const bases[5] =
12075 { "", "binary", "", "octal", "hexadecimal" };
12076 static const char* const Bases[5] =
12077 { "", "Binary", "", "Octal", "Hexadecimal" };
12078 static const char* const maxima[5] =
12080 "0b11111111111111111111111111111111",
12084 const char *base, *Base, *max;
12086 /* check for hex */
12091 } else if (s[1] == 'b') {
12096 /* check for a decimal in disguise */
12097 else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
12099 /* so it must be octal */
12106 if (ckWARN(WARN_SYNTAX))
12107 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12108 "Misplaced _ in number");
12112 base = bases[shift];
12113 Base = Bases[shift];
12114 max = maxima[shift];
12116 /* read the rest of the number */
12118 /* x is used in the overflow test,
12119 b is the digit we're adding on. */
12124 /* if we don't mention it, we're done */
12128 /* _ are ignored -- but warned about if consecutive */
12130 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12131 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12132 "Misplaced _ in number");
12136 /* 8 and 9 are not octal */
12137 case '8': case '9':
12139 yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
12143 case '2': case '3': case '4':
12144 case '5': case '6': case '7':
12146 yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
12149 case '0': case '1':
12150 b = *s++ & 15; /* ASCII digit -> value of digit */
12154 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
12155 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
12156 /* make sure they said 0x */
12159 b = (*s++ & 7) + 9;
12161 /* Prepare to put the digit we have onto the end
12162 of the number so far. We check for overflows.
12168 x = u << shift; /* make room for the digit */
12170 if ((x >> shift) != u
12171 && !(PL_hints & HINT_NEW_BINARY)) {
12174 if (ckWARN_d(WARN_OVERFLOW))
12175 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12176 "Integer overflow in %s number",
12179 u = x | b; /* add the digit to the end */
12182 n *= nvshift[shift];
12183 /* If an NV has not enough bits in its
12184 * mantissa to represent an UV this summing of
12185 * small low-order numbers is a waste of time
12186 * (because the NV cannot preserve the
12187 * low-order bits anyway): we could just
12188 * remember when did we overflow and in the
12189 * end just multiply n by the right
12197 /* if we get here, we had success: make a scalar value from
12202 /* final misplaced underbar check */
12203 if (s[-1] == '_') {
12204 if (ckWARN(WARN_SYNTAX))
12205 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12210 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12211 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12212 "%s number > %s non-portable",
12218 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12219 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12220 "%s number > %s non-portable",
12225 if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12226 sv = new_constant(start, s - start, "integer",
12227 sv, NULL, NULL, 0);
12228 else if (PL_hints & HINT_NEW_BINARY)
12229 sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
12234 handle decimal numbers.
12235 we're also sent here when we read a 0 as the first digit
12237 case '1': case '2': case '3': case '4': case '5':
12238 case '6': case '7': case '8': case '9': case '.':
12241 e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12244 /* read next group of digits and _ and copy into d */
12245 while (isDIGIT(*s) || *s == '_') {
12246 /* skip underscores, checking for misplaced ones
12250 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12251 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12252 "Misplaced _ in number");
12256 /* check for end of fixed-length buffer */
12258 Perl_croak(aTHX_ number_too_long);
12259 /* if we're ok, copy the character */
12264 /* final misplaced underbar check */
12265 if (lastub && s == lastub + 1) {
12266 if (ckWARN(WARN_SYNTAX))
12267 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12270 /* read a decimal portion if there is one. avoid
12271 3..5 being interpreted as the number 3. followed
12274 if (*s == '.' && s[1] != '.') {
12279 if (ckWARN(WARN_SYNTAX))
12280 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12281 "Misplaced _ in number");
12285 /* copy, ignoring underbars, until we run out of digits.
12287 for (; isDIGIT(*s) || *s == '_'; s++) {
12288 /* fixed length buffer check */
12290 Perl_croak(aTHX_ number_too_long);
12292 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12293 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12294 "Misplaced _ in number");
12300 /* fractional part ending in underbar? */
12301 if (s[-1] == '_') {
12302 if (ckWARN(WARN_SYNTAX))
12303 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12304 "Misplaced _ in number");
12306 if (*s == '.' && isDIGIT(s[1])) {
12307 /* oops, it's really a v-string, but without the "v" */
12313 /* read exponent part, if present */
12314 if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12318 /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12319 *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
12321 /* stray preinitial _ */
12323 if (ckWARN(WARN_SYNTAX))
12324 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12325 "Misplaced _ in number");
12329 /* allow positive or negative exponent */
12330 if (*s == '+' || *s == '-')
12333 /* stray initial _ */
12335 if (ckWARN(WARN_SYNTAX))
12336 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12337 "Misplaced _ in number");
12341 /* read digits of exponent */
12342 while (isDIGIT(*s) || *s == '_') {
12345 Perl_croak(aTHX_ number_too_long);
12349 if (((lastub && s == lastub + 1) ||
12350 (!isDIGIT(s[1]) && s[1] != '_'))
12351 && ckWARN(WARN_SYNTAX))
12352 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12353 "Misplaced _ in number");
12360 /* make an sv from the string */
12364 We try to do an integer conversion first if no characters
12365 indicating "float" have been found.
12370 const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12372 if (flags == IS_NUMBER_IN_UV) {
12374 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12377 } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12378 if (uv <= (UV) IV_MIN)
12379 sv_setiv(sv, -(IV)uv);
12386 /* terminate the string */
12388 nv = Atof(PL_tokenbuf);
12393 ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
12394 const char *const key = floatit ? "float" : "integer";
12395 const STRLEN keylen = floatit ? 5 : 7;
12396 sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
12397 key, keylen, sv, NULL, NULL, 0);
12401 /* if it starts with a v, it could be a v-string */
12404 sv = newSV(5); /* preallocate storage space */
12405 s = scan_vstring(s, PL_bufend, sv);
12409 /* make the op for the constant and return */
12412 lvalp->opval = newSVOP(OP_CONST, 0, sv);
12414 lvalp->opval = NULL;
12420 S_scan_formline(pTHX_ register char *s)
12423 register char *eol;
12425 SV * const stuff = newSVpvs("");
12426 bool needargs = FALSE;
12427 bool eofmt = FALSE;
12429 char *tokenstart = s;
12430 SV* savewhite = NULL;
12432 if (PL_madskills) {
12433 savewhite = PL_thiswhite;
12438 PERL_ARGS_ASSERT_SCAN_FORMLINE;
12440 while (!needargs) {
12443 #ifdef PERL_STRICT_CR
12444 while (SPACE_OR_TAB(*t))
12447 while (SPACE_OR_TAB(*t) || *t == '\r')
12450 if (*t == '\n' || t == PL_bufend) {
12455 if (PL_in_eval && !PL_rsfp) {
12456 eol = (char *) memchr(s,'\n',PL_bufend-s);
12461 eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12463 for (t = s; t < eol; t++) {
12464 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12466 goto enough; /* ~~ must be first line in formline */
12468 if (*t == '@' || *t == '^')
12472 sv_catpvn(stuff, s, eol-s);
12473 #ifndef PERL_STRICT_CR
12474 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12475 char *end = SvPVX(stuff) + SvCUR(stuff);
12478 SvCUR_set(stuff, SvCUR(stuff) - 1);
12488 if (PL_madskills) {
12490 sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12492 PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12495 s = filter_gets(PL_linestr, PL_rsfp, 0);
12497 tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12499 PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12501 PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12502 PL_last_lop = PL_last_uni = NULL;
12511 if (SvCUR(stuff)) {
12514 PL_lex_state = LEX_NORMAL;
12515 start_force(PL_curforce);
12516 NEXTVAL_NEXTTOKE.ival = 0;
12520 PL_lex_state = LEX_FORMLINE;
12522 if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12524 else if (PL_encoding)
12525 sv_recode_to_utf8(stuff, PL_encoding);
12527 start_force(PL_curforce);
12528 NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12530 start_force(PL_curforce);
12531 NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12535 SvREFCNT_dec(stuff);
12537 PL_lex_formbrack = 0;
12541 if (PL_madskills) {
12543 sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12545 PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12546 PL_thiswhite = savewhite;
12553 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12556 const I32 oldsavestack_ix = PL_savestack_ix;
12557 CV* const outsidecv = PL_compcv;
12560 assert(SvTYPE(PL_compcv) == SVt_PVCV);
12562 SAVEI32(PL_subline);
12563 save_item(PL_subname);
12564 SAVESPTR(PL_compcv);
12566 PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
12567 CvFLAGS(PL_compcv) |= flags;
12569 PL_subline = CopLINE(PL_curcop);
12570 CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12571 CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
12572 CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12574 return oldsavestack_ix;
12578 #pragma segment Perl_yylex
12581 S_yywarn(pTHX_ const char *const s)
12585 PERL_ARGS_ASSERT_YYWARN;
12587 PL_in_eval |= EVAL_WARNONLY;
12589 PL_in_eval &= ~EVAL_WARNONLY;
12594 Perl_yyerror(pTHX_ const char *const s)
12597 const char *where = NULL;
12598 const char *context = NULL;
12601 int yychar = PL_parser->yychar;
12603 PERL_ARGS_ASSERT_YYERROR;
12605 if (!yychar || (yychar == ';' && !PL_rsfp))
12607 else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12608 PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12609 PL_oldbufptr != PL_bufptr) {
12612 The code below is removed for NetWare because it abends/crashes on NetWare
12613 when the script has error such as not having the closing quotes like:
12614 if ($var eq "value)
12615 Checking of white spaces is anyway done in NetWare code.
12618 while (isSPACE(*PL_oldoldbufptr))
12621 context = PL_oldoldbufptr;
12622 contlen = PL_bufptr - PL_oldoldbufptr;
12624 else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12625 PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12628 The code below is removed for NetWare because it abends/crashes on NetWare
12629 when the script has error such as not having the closing quotes like:
12630 if ($var eq "value)
12631 Checking of white spaces is anyway done in NetWare code.
12634 while (isSPACE(*PL_oldbufptr))
12637 context = PL_oldbufptr;
12638 contlen = PL_bufptr - PL_oldbufptr;
12640 else if (yychar > 255)
12641 where = "next token ???";
12642 else if (yychar == -2) { /* YYEMPTY */
12643 if (PL_lex_state == LEX_NORMAL ||
12644 (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12645 where = "at end of line";
12646 else if (PL_lex_inpat)
12647 where = "within pattern";
12649 where = "within string";
12652 SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
12654 Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12655 else if (isPRINT_LC(yychar)) {
12656 const char string = yychar;
12657 sv_catpvn(where_sv, &string, 1);
12660 Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12661 where = SvPVX_const(where_sv);
12663 msg = sv_2mortal(newSVpv(s, 0));
12664 Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12665 OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12667 Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12669 Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12670 if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12671 Perl_sv_catpvf(aTHX_ msg,
12672 " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12673 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12676 if (PL_in_eval & EVAL_WARNONLY) {
12677 if (ckWARN_d(WARN_SYNTAX))
12678 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12682 if (PL_error_count >= 10) {
12683 if (PL_in_eval && SvCUR(ERRSV))
12684 Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12685 SVfARG(ERRSV), OutCopFILE(PL_curcop));
12687 Perl_croak(aTHX_ "%s has too many errors.\n",
12688 OutCopFILE(PL_curcop));
12691 PL_in_my_stash = NULL;
12695 #pragma segment Main
12699 S_swallow_bom(pTHX_ U8 *s)
12702 const STRLEN slen = SvCUR(PL_linestr);
12704 PERL_ARGS_ASSERT_SWALLOW_BOM;
12708 if (s[1] == 0xFE) {
12709 /* UTF-16 little-endian? (or UTF32-LE?) */
12710 if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
12711 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12712 #ifndef PERL_NO_UTF16_FILTER
12713 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12716 if (PL_bufend > (char*)s) {
12720 filter_add(utf16rev_textfilter, NULL);
12721 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12722 utf16_to_utf8_reversed(s, news,
12723 PL_bufend - (char*)s - 1,
12725 sv_setpvn(PL_linestr, (const char*)news, newlen);
12727 s = (U8*)SvPVX(PL_linestr);
12728 Copy(news, s, newlen, U8);
12732 SvUTF8_on(PL_linestr);
12733 s = (U8*)SvPVX(PL_linestr);
12735 /* FIXME - is this a general bug fix? */
12738 PL_bufend = SvPVX(PL_linestr) + newlen;
12741 Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12746 if (s[1] == 0xFF) { /* UTF-16 big-endian? */
12747 #ifndef PERL_NO_UTF16_FILTER
12748 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12751 if (PL_bufend > (char *)s) {
12755 filter_add(utf16_textfilter, NULL);
12756 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12757 utf16_to_utf8(s, news,
12758 PL_bufend - (char*)s,
12760 sv_setpvn(PL_linestr, (const char*)news, newlen);
12762 SvUTF8_on(PL_linestr);
12763 s = (U8*)SvPVX(PL_linestr);
12764 PL_bufend = SvPVX(PL_linestr) + newlen;
12767 Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12772 if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12773 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12774 s += 3; /* UTF-8 */
12780 if (s[2] == 0xFE && s[3] == 0xFF) {
12781 /* UTF-32 big-endian */
12782 Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12785 else if (s[2] == 0 && s[3] != 0) {
12788 * are a good indicator of UTF-16BE. */
12789 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12795 if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12796 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12797 s += 4; /* UTF-8 */
12803 if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12806 * are a good indicator of UTF-16LE. */
12807 if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12815 #ifndef PERL_NO_UTF16_FILTER
12817 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12820 const STRLEN old = SvCUR(sv);
12821 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12822 DEBUG_P(PerlIO_printf(Perl_debug_log,
12823 "utf16_textfilter(%p): %d %d (%d)\n",
12824 FPTR2DPTR(void *, utf16_textfilter),
12825 idx, maxlen, (int) count));
12829 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12830 Copy(SvPVX_const(sv), tmps, old, char);
12831 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12832 SvCUR(sv) - old, &newlen);
12833 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12835 DEBUG_P({sv_dump(sv);});
12840 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12843 const STRLEN old = SvCUR(sv);
12844 const I32 count = FILTER_READ(idx+1, sv, maxlen);
12845 DEBUG_P(PerlIO_printf(Perl_debug_log,
12846 "utf16rev_textfilter(%p): %d %d (%d)\n",
12847 FPTR2DPTR(void *, utf16rev_textfilter),
12848 idx, maxlen, (int) count));
12852 Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12853 Copy(SvPVX_const(sv), tmps, old, char);
12854 utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12855 SvCUR(sv) - old, &newlen);
12856 sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12858 DEBUG_P({ sv_dump(sv); });
12864 Returns a pointer to the next character after the parsed
12865 vstring, as well as updating the passed in sv.
12867 Function must be called like
12870 s = scan_vstring(s,e,sv);
12872 where s and e are the start and end of the string.
12873 The sv should already be large enough to store the vstring
12874 passed in, for performance reasons.
12879 Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
12882 const char *pos = s;
12883 const char *start = s;
12885 PERL_ARGS_ASSERT_SCAN_VSTRING;
12887 if (*pos == 'v') pos++; /* get past 'v' */
12888 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12890 if ( *pos != '.') {
12891 /* this may not be a v-string if followed by => */
12892 const char *next = pos;
12893 while (next < e && isSPACE(*next))
12895 if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
12896 /* return string not v-string */
12897 sv_setpvn(sv,(char *)s,pos-s);
12898 return (char *)pos;
12902 if (!isALPHA(*pos)) {
12903 U8 tmpbuf[UTF8_MAXBYTES+1];
12906 s++; /* get past 'v' */
12911 /* this is atoi() that tolerates underscores */
12914 const char *end = pos;
12916 while (--end >= s) {
12918 const UV orev = rev;
12919 rev += (*end - '0') * mult;
12921 if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12922 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12923 "Integer overflow in decimal number");
12927 if (rev > 0x7FFFFFFF)
12928 Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12930 /* Append native character for the rev point */
12931 tmpend = uvchr_to_utf8(tmpbuf, rev);
12932 sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12933 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12935 if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
12941 while (pos < e && (isDIGIT(*pos) || *pos == '_'))
12945 sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12953 * c-indentation-style: bsd
12954 * c-basic-offset: 4
12955 * indent-tabs-mode: t
12958 * ex: set ts=8 sts=4 sw=4 noet: