File Coverage

toke.c
Criterion Covered Total %
statement 4203 4568 92.0
branch 5015 6734 74.5
condition n/a
subroutine n/a
total 9218 11302 81.6


line stmt bran cond sub time code
1           /* toke.c
2           *
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
5           *
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.
8           *
9           */
10            
11           /*
12           * 'It all comes from here, the stench and the peril.' --Frodo
13           *
14           * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
15           */
16            
17           /*
18           * This file is the lexer for Perl. It's closely linked to the
19           * parser, perly.y.
20           *
21           * The main routine is yylex(), which returns the next token.
22           */
23            
24           /*
25           =head1 Lexer interface
26            
27           This is the lower layer of the Perl parser, managing characters and tokens.
28            
29           =for apidoc AmU|yy_parser *|PL_parser
30            
31           Pointer to a structure encapsulating the state of the parsing operation
32           currently in progress. The pointer can be locally changed to perform
33           a nested parse without interfering with the state of an outer parse.
34           Individual members of C have their own documentation.
35            
36           =cut
37           */
38            
39           #include "EXTERN.h"
40           #define PERL_IN_TOKE_C
41           #include "perl.h"
42           #include "dquote_static.c"
43            
44           #define new_constant(a,b,c,d,e,f,g) \
45           S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
46            
47           #define pl_yylval (PL_parser->yylval)
48            
49           /* XXX temporary backwards compatibility */
50           #define PL_lex_brackets (PL_parser->lex_brackets)
51           #define PL_lex_allbrackets (PL_parser->lex_allbrackets)
52           #define PL_lex_fakeeof (PL_parser->lex_fakeeof)
53           #define PL_lex_brackstack (PL_parser->lex_brackstack)
54           #define PL_lex_casemods (PL_parser->lex_casemods)
55           #define PL_lex_casestack (PL_parser->lex_casestack)
56           #define PL_lex_defer (PL_parser->lex_defer)
57           #define PL_lex_dojoin (PL_parser->lex_dojoin)
58           #define PL_lex_expect (PL_parser->lex_expect)
59           #define PL_lex_formbrack (PL_parser->lex_formbrack)
60           #define PL_lex_inpat (PL_parser->lex_inpat)
61           #define PL_lex_inwhat (PL_parser->lex_inwhat)
62           #define PL_lex_op (PL_parser->lex_op)
63           #define PL_lex_repl (PL_parser->lex_repl)
64           #define PL_lex_starts (PL_parser->lex_starts)
65           #define PL_lex_stuff (PL_parser->lex_stuff)
66           #define PL_multi_start (PL_parser->multi_start)
67           #define PL_multi_open (PL_parser->multi_open)
68           #define PL_multi_close (PL_parser->multi_close)
69           #define PL_preambled (PL_parser->preambled)
70           #define PL_sublex_info (PL_parser->sublex_info)
71           #define PL_linestr (PL_parser->linestr)
72           #define PL_expect (PL_parser->expect)
73           #define PL_copline (PL_parser->copline)
74           #define PL_bufptr (PL_parser->bufptr)
75           #define PL_oldbufptr (PL_parser->oldbufptr)
76           #define PL_oldoldbufptr (PL_parser->oldoldbufptr)
77           #define PL_linestart (PL_parser->linestart)
78           #define PL_bufend (PL_parser->bufend)
79           #define PL_last_uni (PL_parser->last_uni)
80           #define PL_last_lop (PL_parser->last_lop)
81           #define PL_last_lop_op (PL_parser->last_lop_op)
82           #define PL_lex_state (PL_parser->lex_state)
83           #define PL_rsfp (PL_parser->rsfp)
84           #define PL_rsfp_filters (PL_parser->rsfp_filters)
85           #define PL_in_my (PL_parser->in_my)
86           #define PL_in_my_stash (PL_parser->in_my_stash)
87           #define PL_tokenbuf (PL_parser->tokenbuf)
88           #define PL_multi_end (PL_parser->multi_end)
89           #define PL_error_count (PL_parser->error_count)
90            
91           #ifdef PERL_MAD
92           # define PL_endwhite (PL_parser->endwhite)
93           # define PL_faketokens (PL_parser->faketokens)
94           # define PL_lasttoke (PL_parser->lasttoke)
95           # define PL_nextwhite (PL_parser->nextwhite)
96           # define PL_realtokenstart (PL_parser->realtokenstart)
97           # define PL_skipwhite (PL_parser->skipwhite)
98           # define PL_thisclose (PL_parser->thisclose)
99           # define PL_thismad (PL_parser->thismad)
100           # define PL_thisopen (PL_parser->thisopen)
101           # define PL_thisstuff (PL_parser->thisstuff)
102           # define PL_thistoken (PL_parser->thistoken)
103           # define PL_thiswhite (PL_parser->thiswhite)
104           # define PL_thiswhite (PL_parser->thiswhite)
105           # define PL_nexttoke (PL_parser->nexttoke)
106           # define PL_curforce (PL_parser->curforce)
107           #else
108           # define PL_nexttoke (PL_parser->nexttoke)
109           # define PL_nexttype (PL_parser->nexttype)
110           # define PL_nextval (PL_parser->nextval)
111           #endif
112            
113           static const char* const ident_too_long = "Identifier too long";
114            
115           #ifdef PERL_MAD
116           # define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
117           # define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
118           #else
119           # define CURMAD(slot,sv)
120           # define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
121           #endif
122            
123           #define XENUMMASK 0x3f
124           #define XFAKEEOF 0x40
125           #define XFAKEBRACK 0x80
126            
127           #ifdef USE_UTF8_SCRIPTS
128           # define UTF (!IN_BYTES)
129           #else
130           # define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || ( !(PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS) && (PL_hints & HINT_UTF8)))
131           #endif
132            
133           /* The maximum number of characters preceding the unrecognized one to display */
134           #define UNRECOGNIZED_PRECEDE_COUNT 10
135            
136           /* In variables named $^X, these are the legal values for X.
137           * 1999-02-27 mjd-perl-patch@plover.com */
138           #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
139            
140           #define SPACE_OR_TAB(c) isBLANK_A(c)
141            
142           /* LEX_* are values for PL_lex_state, the state of the lexer.
143           * They are arranged oddly so that the guard on the switch statement
144           * can get by with a single comparison (if the compiler is smart enough).
145           *
146           * These values refer to the various states within a sublex parse,
147           * i.e. within a double quotish string
148           */
149            
150           /* #define LEX_NOTPARSING 11 is done in perl.h. */
151            
152           #define LEX_NORMAL 10 /* normal code (ie not within "...") */
153           #define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
154           #define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
155           #define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
156           #define LEX_INTERPSTART 6 /* expecting the start of a $var */
157            
158           /* at end of code, eg "$x" followed by: */
159           #define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
160           #define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
161            
162           #define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
163           string or after \E, $foo, etc */
164           #define LEX_INTERPCONST 2 /* NOT USED */
165           #define LEX_FORMLINE 1 /* expecting a format line */
166           #define LEX_KNOWNEXT 0 /* next token known; just return it */
167            
168            
169           #ifdef DEBUGGING
170           static const char* const lex_state_names[] = {
171           "KNOWNEXT",
172           "FORMLINE",
173           "INTERPCONST",
174           "INTERPCONCAT",
175           "INTERPENDMAYBE",
176           "INTERPEND",
177           "INTERPSTART",
178           "INTERPPUSH",
179           "INTERPCASEMOD",
180           "INTERPNORMAL",
181           "NORMAL"
182           };
183           #endif
184            
185           #ifdef ff_next
186           #undef ff_next
187           #endif
188            
189           #include "keywords.h"
190            
191           /* CLINE is a macro that ensures PL_copline has a sane value */
192            
193           #ifdef CLINE
194           #undef CLINE
195           #endif
196           #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
197            
198           #ifdef PERL_MAD
199           # define SKIPSPACE0(s) skipspace0(s)
200           # define SKIPSPACE1(s) skipspace1(s)
201           # define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
202           # define PEEKSPACE(s) skipspace2(s,0)
203           #else
204           # define SKIPSPACE0(s) skipspace(s)
205           # define SKIPSPACE1(s) skipspace(s)
206           # define SKIPSPACE2(s,tsv) skipspace(s)
207           # define PEEKSPACE(s) skipspace(s)
208           #endif
209            
210           /*
211           * Convenience functions to return different tokens and prime the
212           * lexer for the next token. They all take an argument.
213           *
214           * TOKEN : generic token (used for '(', DOLSHARP, etc)
215           * OPERATOR : generic operator
216           * AOPERATOR : assignment operator
217           * PREBLOCK : beginning the block after an if, while, foreach, ...
218           * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
219           * PREREF : *EXPR where EXPR is not a simple identifier
220           * TERM : expression term
221           * LOOPX : loop exiting command (goto, last, dump, etc)
222           * FTST : file test operator
223           * FUN0 : zero-argument function
224           * FUN0OP : zero-argument function, with its op created in this file
225           * FUN1 : not used, except for not, which isn't a UNIOP
226           * BOop : bitwise or or xor
227           * BAop : bitwise and
228           * SHop : shift operator
229           * PWop : power operator
230           * PMop : pattern-matching operator
231           * Aop : addition-level operator
232           * Mop : multiplication-level operator
233           * Eop : equality-testing operator
234           * Rop : relational operator <= != gt
235           *
236           * Also see LOP and lop() below.
237           */
238            
239           #ifdef DEBUGGING /* Serve -DT. */
240           # define REPORT(retval) tokereport((I32)retval, &pl_yylval)
241           #else
242           # define REPORT(retval) (retval)
243           #endif
244            
245           #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
246           #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
247           #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
248           #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
249           #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
250           #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
251           #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
252           #define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
253           #define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
254           #define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
255           #define FUN0OP(f) return (pl_yylval.opval=f, CLINE, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0OP))
256           #define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
257           #define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
258           #define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
259           #define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
260           #define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
261           #define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
262           #define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
263           #define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
264           #define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
265           #define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
266            
267           /* This bit of chicanery makes a unary function followed by
268           * a parenthesis into a function with one argument, highest precedence.
269           * The UNIDOR macro is for unary functions that can be followed by the //
270           * operator (such as C).
271           */
272           #define UNI3(f,x,have_x) { \
273           pl_yylval.ival = f; \
274           if (have_x) PL_expect = x; \
275           PL_bufptr = s; \
276           PL_last_uni = PL_oldbufptr; \
277           PL_last_lop_op = f; \
278           if (*s == '(') \
279           return REPORT( (int)FUNC1 ); \
280           s = PEEKSPACE(s); \
281           return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
282           }
283           #define UNI(f) UNI3(f,XTERM,1)
284           #define UNIDOR(f) UNI3(f,XTERMORDORDOR,1)
285           #define UNIPROTO(f,optional) { \
286           if (optional) PL_last_uni = PL_oldbufptr; \
287           OPERATOR(f); \
288           }
289            
290           #define UNIBRACK(f) UNI3(f,0,0)
291            
292           /* grandfather return to old style */
293           #define OLDLOP(f) \
294           do { \
295           if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC) \
296           PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC; \
297           pl_yylval.ival = (f); \
298           PL_expect = XTERM; \
299           PL_bufptr = s; \
300           return (int)LSTOP; \
301           } while(0)
302            
303           #define COPLINE_INC_WITH_HERELINES \
304           STMT_START { \
305           CopLINE_inc(PL_curcop); \
306           if (PL_parser->lex_shared->herelines) \
307           CopLINE(PL_curcop) += PL_parser->lex_shared->herelines, \
308           PL_parser->lex_shared->herelines = 0; \
309           } STMT_END
310           /* Called after scan_str to update CopLINE(PL_curcop), but only when there
311           * is no sublex_push to follow. */
312           #define COPLINE_SET_FROM_MULTI_END \
313           STMT_START { \
314           CopLINE_set(PL_curcop, PL_multi_end); \
315           if (PL_multi_end != PL_multi_start) \
316           PL_parser->lex_shared->herelines = 0; \
317           } STMT_END
318            
319            
320           #ifdef DEBUGGING
321            
322           /* how to interpret the pl_yylval associated with the token */
323           enum token_type {
324           TOKENTYPE_NONE,
325           TOKENTYPE_IVAL,
326           TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
327           TOKENTYPE_PVAL,
328           TOKENTYPE_OPVAL
329           };
330            
331           static struct debug_tokens {
332           const int token;
333           enum token_type type;
334           const char *name;
335           } const debug_tokens[] =
336           {
337           { ADDOP, TOKENTYPE_OPNUM, "ADDOP" },
338           { ANDAND, TOKENTYPE_NONE, "ANDAND" },
339           { ANDOP, TOKENTYPE_NONE, "ANDOP" },
340           { ANONSUB, TOKENTYPE_IVAL, "ANONSUB" },
341           { ARROW, TOKENTYPE_NONE, "ARROW" },
342           { ASSIGNOP, TOKENTYPE_OPNUM, "ASSIGNOP" },
343           { BITANDOP, TOKENTYPE_OPNUM, "BITANDOP" },
344           { BITOROP, TOKENTYPE_OPNUM, "BITOROP" },
345           { COLONATTR, TOKENTYPE_NONE, "COLONATTR" },
346           { CONTINUE, TOKENTYPE_NONE, "CONTINUE" },
347           { DEFAULT, TOKENTYPE_NONE, "DEFAULT" },
348           { DO, TOKENTYPE_NONE, "DO" },
349           { DOLSHARP, TOKENTYPE_NONE, "DOLSHARP" },
350           { DORDOR, TOKENTYPE_NONE, "DORDOR" },
351           { DOROP, TOKENTYPE_OPNUM, "DOROP" },
352           { DOTDOT, TOKENTYPE_IVAL, "DOTDOT" },
353           { ELSE, TOKENTYPE_NONE, "ELSE" },
354           { ELSIF, TOKENTYPE_IVAL, "ELSIF" },
355           { EQOP, TOKENTYPE_OPNUM, "EQOP" },
356           { FOR, TOKENTYPE_IVAL, "FOR" },
357           { FORMAT, TOKENTYPE_NONE, "FORMAT" },
358           { FORMLBRACK, TOKENTYPE_NONE, "FORMLBRACK" },
359           { FORMRBRACK, TOKENTYPE_NONE, "FORMRBRACK" },
360           { FUNC, TOKENTYPE_OPNUM, "FUNC" },
361           { FUNC0, TOKENTYPE_OPNUM, "FUNC0" },
362           { FUNC0OP, TOKENTYPE_OPVAL, "FUNC0OP" },
363           { FUNC0SUB, TOKENTYPE_OPVAL, "FUNC0SUB" },
364           { FUNC1, TOKENTYPE_OPNUM, "FUNC1" },
365           { FUNCMETH, TOKENTYPE_OPVAL, "FUNCMETH" },
366           { GIVEN, TOKENTYPE_IVAL, "GIVEN" },
367           { HASHBRACK, TOKENTYPE_NONE, "HASHBRACK" },
368           { IF, TOKENTYPE_IVAL, "IF" },
369           { LABEL, TOKENTYPE_PVAL, "LABEL" },
370           { LOCAL, TOKENTYPE_IVAL, "LOCAL" },
371           { LOOPEX, TOKENTYPE_OPNUM, "LOOPEX" },
372           { LSTOP, TOKENTYPE_OPNUM, "LSTOP" },
373           { LSTOPSUB, TOKENTYPE_OPVAL, "LSTOPSUB" },
374           { MATCHOP, TOKENTYPE_OPNUM, "MATCHOP" },
375           { METHOD, TOKENTYPE_OPVAL, "METHOD" },
376           { MULOP, TOKENTYPE_OPNUM, "MULOP" },
377           { MY, TOKENTYPE_IVAL, "MY" },
378           { NOAMP, TOKENTYPE_NONE, "NOAMP" },
379           { NOTOP, TOKENTYPE_NONE, "NOTOP" },
380           { OROP, TOKENTYPE_IVAL, "OROP" },
381           { OROR, TOKENTYPE_NONE, "OROR" },
382           { PACKAGE, TOKENTYPE_NONE, "PACKAGE" },
383           { PEG, TOKENTYPE_NONE, "PEG" },
384           { PLUGEXPR, TOKENTYPE_OPVAL, "PLUGEXPR" },
385           { PLUGSTMT, TOKENTYPE_OPVAL, "PLUGSTMT" },
386           { PMFUNC, TOKENTYPE_OPVAL, "PMFUNC" },
387           { POSTDEC, TOKENTYPE_NONE, "POSTDEC" },
388           { POSTINC, TOKENTYPE_NONE, "POSTINC" },
389           { POWOP, TOKENTYPE_OPNUM, "POWOP" },
390           { PREDEC, TOKENTYPE_NONE, "PREDEC" },
391           { PREINC, TOKENTYPE_NONE, "PREINC" },
392           { PRIVATEREF, TOKENTYPE_OPVAL, "PRIVATEREF" },
393           { QWLIST, TOKENTYPE_OPVAL, "QWLIST" },
394           { REFGEN, TOKENTYPE_NONE, "REFGEN" },
395           { RELOP, TOKENTYPE_OPNUM, "RELOP" },
396           { REQUIRE, TOKENTYPE_NONE, "REQUIRE" },
397           { SHIFTOP, TOKENTYPE_OPNUM, "SHIFTOP" },
398           { SUB, TOKENTYPE_NONE, "SUB" },
399           { THING, TOKENTYPE_OPVAL, "THING" },
400           { UMINUS, TOKENTYPE_NONE, "UMINUS" },
401           { UNIOP, TOKENTYPE_OPNUM, "UNIOP" },
402           { UNIOPSUB, TOKENTYPE_OPVAL, "UNIOPSUB" },
403           { UNLESS, TOKENTYPE_IVAL, "UNLESS" },
404           { UNTIL, TOKENTYPE_IVAL, "UNTIL" },
405           { USE, TOKENTYPE_IVAL, "USE" },
406           { WHEN, TOKENTYPE_IVAL, "WHEN" },
407           { WHILE, TOKENTYPE_IVAL, "WHILE" },
408           { WORD, TOKENTYPE_OPVAL, "WORD" },
409           { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
410           { 0, TOKENTYPE_NONE, NULL }
411           };
412            
413           /* dump the returned token in rv, plus any optional arg in pl_yylval */
414            
415           STATIC int
416           S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
417           {
418           dVAR;
419            
420           PERL_ARGS_ASSERT_TOKEREPORT;
421            
422           if (DEBUG_T_TEST) {
423           const char *name = NULL;
424           enum token_type type = TOKENTYPE_NONE;
425           const struct debug_tokens *p;
426           SV* const report = newSVpvs("<== ");
427            
428           for (p = debug_tokens; p->token; p++) {
429           if (p->token == (int)rv) {
430           name = p->name;
431           type = p->type;
432           break;
433           }
434           }
435           if (name)
436           Perl_sv_catpv(aTHX_ report, name);
437           else if ((char)rv > ' ' && (char)rv <= '~')
438           {
439           Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
440           if ((char)rv == 'p')
441           sv_catpvs(report, " (pending identifier)");
442           }
443           else if (!rv)
444           sv_catpvs(report, "EOF");
445           else
446           Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
447           switch (type) {
448           case TOKENTYPE_NONE:
449           break;
450           case TOKENTYPE_IVAL:
451           Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
452           break;
453           case TOKENTYPE_OPNUM:
454           Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
455           PL_op_name[lvalp->ival]);
456           break;
457           case TOKENTYPE_PVAL:
458           Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
459           break;
460           case TOKENTYPE_OPVAL:
461           if (lvalp->opval) {
462           Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
463           PL_op_name[lvalp->opval->op_type]);
464           if (lvalp->opval->op_type == OP_CONST) {
465           Perl_sv_catpvf(aTHX_ report, " %s",
466           SvPEEK(cSVOPx_sv(lvalp->opval)));
467           }
468            
469           }
470           else
471           sv_catpvs(report, "(opval=null)");
472           break;
473           }
474           PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
475           };
476           return (int)rv;
477           }
478            
479            
480           /* print the buffer with suitable escapes */
481            
482           STATIC void
483           S_printbuf(pTHX_ const char *const fmt, const char *const s)
484           {
485           SV* const tmp = newSVpvs("");
486            
487           PERL_ARGS_ASSERT_PRINTBUF;
488            
489           PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
490           SvREFCNT_dec(tmp);
491           }
492            
493           #endif
494            
495           static int
496 12         S_deprecate_commaless_var_list(pTHX) {
497 12         PL_expect = XTERM;
498 12         deprecate("comma-less variable list");
499 12         return REPORT(','); /* grandfather non-comma-format format */
500           }
501            
502           /*
503           * S_ao
504           *
505           * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
506           * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
507           */
508            
509           STATIC int
510 25594627         S_ao(pTHX_ int toketype)
511           {
512           dVAR;
513 25594627 100       if (*PL_bufptr == '=') {
514 2374478         PL_bufptr++;
515 2374478 100       if (toketype == ANDAND)
516 54         pl_yylval.ival = OP_ANDASSIGN;
517 2374424 100       else if (toketype == OROR)
518 533831         pl_yylval.ival = OP_ORASSIGN;
519 1840593 100       else if (toketype == DORDOR)
520 1010         pl_yylval.ival = OP_DORASSIGN;
521           toketype = ASSIGNOP;
522           }
523 25594627         return toketype;
524           }
525            
526           /*
527           * S_no_op
528           * When Perl expects an operator and finds something else, no_op
529           * prints the warning. It always prints " found where
530           * operator expected. It prints "Missing semicolon on previous line?"
531           * if the surprise occurs at the start of the line. "do you need to
532           * predeclare ..." is printed out for code like "sub bar; foo bar $x"
533           * where the compiler doesn't know if foo is a method call or a function.
534           * It prints "Missing operator before end of line" if there's nothing
535           * after the missing operator, or "... before <...>" if there is something
536           * after the missing operator.
537           */
538            
539           STATIC void
540 108         S_no_op(pTHX_ const char *const what, char *s)
541           {
542           dVAR;
543 108         char * const oldbp = PL_bufptr;
544 108         const bool is_first = (PL_oldbufptr == PL_linestart);
545            
546           PERL_ARGS_ASSERT_NO_OP;
547            
548 108 50       if (!s)
549           s = oldbp;
550           else
551 108         PL_bufptr = s;
552 108 50       yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
    100        
    50        
    100        
    100        
553 108 100       if (ckWARN_d(WARN_SYNTAX)) {
554 62 50       if (is_first)
555 0         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
556           "\t(Missing semicolon on previous line?)\n");
557 62 50       else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
    50        
    50        
    50        
    0        
    50        
    100        
    100        
    100        
    50        
    50        
    0        
    0        
    0        
    50        
558           const char *t;
559 297 50       for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
    50        
    50        
    0        
    50        
    100        
    100        
    100        
    100        
    100        
    50        
    50        
    50        
    50        
    100        
560 240 50       t += UTF ? UTF8SKIP(t) : 1)
    50        
    0        
    50        
    100        
561           NOOP;
562 38 100       if (t < PL_bufptr && isSPACE(*t))
    100        
563 70 50       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
    50        
564           "\t(Do you need to predeclare %"UTF8f"?)\n",
565 60 50       UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
    0        
    100        
566           }
567           else {
568           assert(s >= oldbp);
569 84 50       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
    50        
570           "\t(Missing operator before %"UTF8f"?)\n",
571 72 50       UTF8fARG(UTF, s - oldbp, oldbp));
    0        
    50        
572           }
573           }
574 108         PL_bufptr = oldbp;
575 108         }
576            
577           /*
578           * S_missingterm
579           * Complain about missing quote/regexp/heredoc terminator.
580           * If it's called with NULL then it cauterizes the line buffer.
581           * If we're in a delimited string and the delimiter is a control
582           * character, it's reformatted into a two-char sequence like ^C.
583           * This is fatal.
584           */
585            
586           STATIC void
587 98         S_missingterm(pTHX_ char *s)
588           {
589           dVAR;
590           char tmpbuf[3];
591           char q;
592 98 100       if (s) {
593 86         char * const nl = strrchr(s,'\n');
594 86 50       if (nl)
595 86         *nl = '\0';
596           }
597 12 50       else if ((U8) PL_multi_close < 32) {
598 0         *tmpbuf = '^';
599 0 0       tmpbuf[1] = (char)toCTRL(PL_multi_close);
600 0         tmpbuf[2] = '\0';
601           s = tmpbuf;
602           }
603           else {
604 12         *tmpbuf = (char)PL_multi_close;
605 12         tmpbuf[1] = '\0';
606           s = tmpbuf;
607           }
608 98 50       q = strchr(s,'"') ? '\'' : '"';
609 98         Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
610           }
611            
612           #include "feature.h"
613            
614           /*
615           * Check whether the named feature is enabled.
616           */
617           bool
618 3312         Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
619           {
620           dVAR;
621 3312         char he_name[8 + MAX_FEATURE_LEN] = "feature_";
622            
623           PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
624            
625           assert(CURRENT_FEATURE_BUNDLE == FEATURE_BUNDLE_CUSTOM);
626            
627 3312 50       if (namelen > MAX_FEATURE_LEN)
628           return FALSE;
629 3312         memcpy(&he_name[8], name, namelen);
630            
631 3312         return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
632           REFCOUNTED_HE_EXISTS));
633           }
634            
635           /*
636           * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
637           * utf16-to-utf8-reversed.
638           */
639            
640           #ifdef PERL_CR_FILTER
641           static void
642           strip_return(SV *sv)
643           {
644           const char *s = SvPVX_const(sv);
645           const char * const e = s + SvCUR(sv);
646            
647           PERL_ARGS_ASSERT_STRIP_RETURN;
648            
649           /* outer loop optimized to do nothing if there are no CR-LFs */
650           while (s < e) {
651           if (*s++ == '\r' && *s == '\n') {
652           /* hit a CR-LF, need to copy the rest */
653           char *d = s - 1;
654           *d++ = *s++;
655           while (s < e) {
656           if (*s == '\r' && s[1] == '\n')
657           s++;
658           *d++ = *s++;
659           }
660           SvCUR(sv) -= s - d;
661           return;
662           }
663           }
664           }
665            
666           STATIC I32
667           S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
668           {
669           const I32 count = FILTER_READ(idx+1, sv, maxlen);
670           if (count > 0 && !maxlen)
671           strip_return(sv);
672           return count;
673           }
674           #endif
675            
676           /*
677           =for apidoc Amx|void|lex_start|SV *line|PerlIO *rsfp|U32 flags
678            
679           Creates and initialises a new lexer/parser state object, supplying
680           a context in which to lex and parse from a new source of Perl code.
681           A pointer to the new state object is placed in L. An entry
682           is made on the save stack so that upon unwinding the new state object
683           will be destroyed and the former value of L will be restored.
684           Nothing else need be done to clean up the parsing context.
685            
686           The code to be parsed comes from I and I. I, if
687           non-null, provides a string (in SV form) containing code to be parsed.
688           A copy of the string is made, so subsequent modification of I
689           does not affect parsing. I, if non-null, provides an input stream
690           from which code will be read to be parsed. If both are non-null, the
691           code in I comes first and must consist of complete lines of input,
692           and I supplies the remainder of the source.
693            
694           The I parameter is reserved for future use. Currently it is only
695           used by perl internally, so extensions should always pass zero.
696            
697           =cut
698           */
699            
700           /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
701           can share filters with the current parser.
702           LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
703           caller, hence isn't owned by the parser, so shouldn't be closed on parser
704           destruction. This is used to handle the case of defaulting to reading the
705           script from the standard input because no filename was given on the command
706           line (without getting confused by situation where STDIN has been closed, so
707           the script handle is opened on fd 0) */
708            
709           void
710 4388977         Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
711           {
712           dVAR;
713           const char *s = NULL;
714           yy_parser *parser, *oparser;
715 4388977 100       if (flags && flags & ~LEX_START_FLAGS)
    50        
716 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
717            
718           /* create and initialise a parser */
719            
720 4388977         Newxz(parser, 1, yy_parser);
721 4388977         parser->old_parser = oparser = PL_parser;
722 4388977         PL_parser = parser;
723            
724 4388977         parser->stack = NULL;
725 4388977         parser->ps = NULL;
726 4388977         parser->stack_size = 0;
727            
728           /* on scope exit, free this parser and restore any outer one */
729 4388977         SAVEPARSER(parser);
730 4388977         parser->saved_curcop = PL_curcop;
731            
732           /* initialise lexer state */
733            
734           #ifdef PERL_MAD
735           parser->curforce = -1;
736           #else
737 4388977         parser->nexttoke = 0;
738           #endif
739 4388977 100       parser->error_count = oparser ? oparser->error_count : 0;
740 4388977         parser->copline = NOLINE;
741 4388977         parser->lex_state = LEX_NORMAL;
742 4388977         parser->expect = XSTATE;
743 4388977         parser->rsfp = rsfp;
744 4388977         parser->rsfp_filters =
745 4388977         !(flags & LEX_START_SAME_FILTER) || !oparser
746           ? NULL
747 4388977 100       : MUTABLE_AV(SvREFCNT_inc(
    100        
748           oparser->rsfp_filters
749           ? oparser->rsfp_filters
750           : (oparser->rsfp_filters = newAV())
751           ));
752            
753 4388977         Newx(parser->lex_brackstack, 120, char);
754 4388977         Newx(parser->lex_casestack, 12, char);
755 4388977         *parser->lex_casestack = '\0';
756 4388977         Newxz(parser->lex_shared, 1, LEXSHARED);
757            
758 4388977 100       if (line) {
759           STRLEN len;
760 3759876 100       s = SvPV_const(line, len);
761 7519752         parser->linestr = flags & LEX_START_COPIED
762 318         ? SvREFCNT_inc_simple_NN(line)
763 5628496 100       : newSVpvn_flags(s, len, SvUTF8(line));
764 3759876 100       sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
765           } else {
766 629101 100       parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
767           }
768 4388977         parser->oldoldbufptr =
769 4388977         parser->oldbufptr =
770 4388977         parser->bufptr =
771 4388977         parser->linestart = SvPVX(parser->linestr);
772 4388977         parser->bufend = parser->bufptr + SvCUR(parser->linestr);
773 4388977         parser->last_lop = parser->last_uni = NULL;
774 4388977         parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
775           |LEX_DONT_CLOSE_RSFP);
776            
777 4388977         parser->in_pod = parser->filtered = 0;
778 4388977         }
779            
780            
781           /* delete a parser object */
782            
783           void
784 4388977         Perl_parser_free(pTHX_ const yy_parser *parser)
785           {
786           PERL_ARGS_ASSERT_PARSER_FREE;
787            
788 4388977         PL_curcop = parser->saved_curcop;
789 4388977         SvREFCNT_dec(parser->linestr);
790            
791 4388977 100       if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
792 44         PerlIO_clearerr(parser->rsfp);
793 4389224 100       else if (parser->rsfp && (!parser->old_parser ||
    100        
    50        
794 582         (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
795 1454         PerlIO_close(parser->rsfp);
796 4388977         SvREFCNT_dec(parser->rsfp_filters);
797 4388977         SvREFCNT_dec(parser->lex_stuff);
798 4388977         SvREFCNT_dec(parser->sublex_info.repl);
799            
800 4388977         Safefree(parser->lex_brackstack);
801 4388977         Safefree(parser->lex_casestack);
802 4388977         Safefree(parser->lex_shared);
803 4388977         PL_parser = parser->old_parser;
804 4388977         Safefree(parser);
805 4388977         }
806            
807           void
808 237692         Perl_parser_free_nexttoke_ops(pTHX_ yy_parser *parser, OPSLAB *slab)
809           {
810           #ifdef PERL_MAD
811           I32 nexttoke = parser->lasttoke;
812           #else
813 237692         I32 nexttoke = parser->nexttoke;
814           #endif
815           PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
816 352762 100       while (nexttoke--) {
817           #ifdef PERL_MAD
818           if (S_is_opval_token(parser->nexttoke[nexttoke].next_type
819           & 0xffff)
820           && parser->nexttoke[nexttoke].next_val.opval
821           && parser->nexttoke[nexttoke].next_val.opval->op_slabbed
822           && OpSLAB(parser->nexttoke[nexttoke].next_val.opval) == slab) {
823           op_free(parser->nexttoke[nexttoke].next_val.opval);
824           parser->nexttoke[nexttoke].next_val.opval = NULL;
825           }
826           #else
827 6 50       if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
828 4 50       && parser->nextval[nexttoke].opval
829 4 50       && parser->nextval[nexttoke].opval->op_slabbed
830 4 50       && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
831 4         op_free(parser->nextval[nexttoke].opval);
832 4         parser->nextval[nexttoke].opval = NULL;
833           }
834           #endif
835           }
836 237692         }
837            
838            
839           /*
840           =for apidoc AmxU|SV *|PL_parser-Elinestr
841            
842           Buffer scalar containing the chunk currently under consideration of the
843           text currently being lexed. This is always a plain string scalar (for
844           which C is true). It is not intended to be used as a scalar by
845           normal scalar means; instead refer to the buffer directly by the pointer
846           variables described below.
847            
848           The lexer maintains various C pointers to things in the
849           Clinestr> buffer. If Clinestr> is ever
850           reallocated, all of these pointers must be updated. Don't attempt to
851           do this manually, but rather use L if you need to
852           reallocate the buffer.
853            
854           The content of the text chunk in the buffer is commonly exactly one
855           complete line of input, up to and including a newline terminator,
856           but there are situations where it is otherwise. The octets of the
857           buffer may be intended to be interpreted as either UTF-8 or Latin-1.
858           The function L tells you which. Do not use the C
859           flag on this scalar, which may disagree with it.
860            
861           For direct examination of the buffer, the variable
862           Lbufend> points to the end of the buffer. The current
863           lexing position is pointed to by Lbufptr>. Direct use
864           of these pointers is usually preferable to examination of the scalar
865           through normal scalar means.
866            
867           =for apidoc AmxU|char *|PL_parser-Ebufend
868            
869           Direct pointer to the end of the chunk of text currently being lexed, the
870           end of the lexer buffer. This is equal to Clinestr)
871           + SvCUR(PL_parser-Elinestr)>. A NUL character (zero octet) is
872           always located at the end of the buffer, and does not count as part of
873           the buffer's contents.
874            
875           =for apidoc AmxU|char *|PL_parser-Ebufptr
876            
877           Points to the current position of lexing inside the lexer buffer.
878           Characters around this point may be freely examined, within
879           the range delimited by Clinestr>)> and
880           Lbufend>. The octets of the buffer may be intended to be
881           interpreted as either UTF-8 or Latin-1, as indicated by L.
882            
883           Lexing code (whether in the Perl core or not) moves this pointer past
884           the characters that it consumes. It is also expected to perform some
885           bookkeeping whenever a newline character is consumed. This movement
886           can be more conveniently performed by the function L,
887           which handles newlines appropriately.
888            
889           Interpretation of the buffer's octets can be abstracted out by
890           using the slightly higher-level functions L and
891           L.
892            
893           =for apidoc AmxU|char *|PL_parser-Elinestart
894            
895           Points to the start of the current line inside the lexer buffer.
896           This is useful for indicating at which column an error occurred, and
897           not much else. This must be updated by any lexing code that consumes
898           a newline; the function L handles this detail.
899            
900           =cut
901           */
902            
903           /*
904           =for apidoc Amx|bool|lex_bufutf8
905            
906           Indicates whether the octets in the lexer buffer
907           (Llinestr>) should be interpreted as the UTF-8 encoding
908           of Unicode characters. If not, they should be interpreted as Latin-1
909           characters. This is analogous to the C flag for scalars.
910            
911           In UTF-8 mode, it is not guaranteed that the lexer buffer actually
912           contains valid UTF-8. Lexing code must be robust in the face of invalid
913           encoding.
914            
915           The actual C flag of the Llinestr> scalar
916           is significant, but not the whole story regarding the input character
917           encoding. Normally, when a file is being read, the scalar contains octets
918           and its C flag is off, but the octets should be interpreted as
919           UTF-8 if the C pragma is in effect. During a string eval,
920           however, the scalar may have the C flag on, and in this case its
921           octets should be interpreted as UTF-8 unless the C pragma
922           is in effect. This logic may change in the future; use this function
923           instead of implementing the logic yourself.
924            
925           =cut
926           */
927            
928           bool
929 0         Perl_lex_bufutf8(pTHX)
930           {
931 0 0       return UTF;
    0        
    0        
    0        
    0        
932           }
933            
934           /*
935           =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
936            
937           Reallocates the lexer buffer (Llinestr>) to accommodate
938           at least I octets (including terminating NUL). Returns a
939           pointer to the reallocated buffer. This is necessary before making
940           any direct modification of the buffer that would increase its length.
941           L provides a more convenient way to insert text into
942           the buffer.
943            
944           Do not use C or C directly on Clinestr>;
945           this function updates all of the lexer's variables that point directly
946           into the buffer.
947            
948           =cut
949           */
950            
951           char *
952 76         Perl_lex_grow_linestr(pTHX_ STRLEN len)
953           {
954           SV *linestr;
955           char *buf;
956           STRLEN bufend_pos, bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
957           STRLEN linestart_pos, last_uni_pos, last_lop_pos, re_eval_start_pos;
958 76         linestr = PL_parser->linestr;
959 76         buf = SvPVX(linestr);
960 76 100       if (len <= SvLEN(linestr))
961           return buf;
962 72         bufend_pos = PL_parser->bufend - buf;
963 72         bufptr_pos = PL_parser->bufptr - buf;
964 72         oldbufptr_pos = PL_parser->oldbufptr - buf;
965 72         oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
966 72         linestart_pos = PL_parser->linestart - buf;
967 72 50       last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
968 72 50       last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
969 72 50       re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
970 0         PL_parser->lex_shared->re_eval_start - buf : 0;
971            
972 72         buf = sv_grow(linestr, len);
973            
974 72         PL_parser->bufend = buf + bufend_pos;
975 72         PL_parser->bufptr = buf + bufptr_pos;
976 72         PL_parser->oldbufptr = buf + oldbufptr_pos;
977 72         PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
978 72         PL_parser->linestart = buf + linestart_pos;
979 72 50       if (PL_parser->last_uni)
980 0         PL_parser->last_uni = buf + last_uni_pos;
981 72 50       if (PL_parser->last_lop)
982 0         PL_parser->last_lop = buf + last_lop_pos;
983 72 50       if (PL_parser->lex_shared->re_eval_start)
984 38         PL_parser->lex_shared->re_eval_start = buf + re_eval_start_pos;
985           return buf;
986           }
987            
988           /*
989           =for apidoc Amx|void|lex_stuff_pvn|const char *pv|STRLEN len|U32 flags
990            
991           Insert characters into the lexer buffer (Llinestr>),
992           immediately after the current lexing point (Lbufptr>),
993           reallocating the buffer if necessary. This means that lexing code that
994           runs later will see the characters as if they had appeared in the input.
995           It is not recommended to do this as part of normal parsing, and most
996           uses of this facility run the risk of the inserted characters being
997           interpreted in an unintended manner.
998            
999           The string to be inserted is represented by I octets starting
1000           at I. These octets are interpreted as either UTF-8 or Latin-1,
1001           according to whether the C flag is set in I.
1002           The characters are recoded for the lexer buffer, according to how the
1003           buffer is currently being interpreted (L). If a string
1004           to be inserted is available as a Perl scalar, the L
1005           function is more convenient.
1006            
1007           =cut
1008           */
1009            
1010           void
1011 4         Perl_lex_stuff_pvn(pTHX_ const char *pv, STRLEN len, U32 flags)
1012           {
1013           dVAR;
1014           char *bufptr;
1015           PERL_ARGS_ASSERT_LEX_STUFF_PVN;
1016 4 50       if (flags & ~(LEX_STUFF_UTF8))
1017 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1018 4 50       if (UTF) {
    50        
    0        
    50        
    50        
1019 0 0       if (flags & LEX_STUFF_UTF8) {
1020           goto plain_copy;
1021           } else {
1022           STRLEN highhalf = 0; /* Count of variants */
1023 0         const char *p, *e = pv+len;
1024 0 0       for (p = pv; p != e; p++) {
1025 0 0       if (! UTF8_IS_INVARIANT(*p)) {
1026 0         highhalf++;
1027           }
1028           }
1029 0 0       if (!highhalf)
1030           goto plain_copy;
1031 0         lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1032 0         bufptr = PL_parser->bufptr;
1033 0         Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1034 0         SvCUR_set(PL_parser->linestr,
1035           SvCUR(PL_parser->linestr) + len+highhalf);
1036 0         PL_parser->bufend += len+highhalf;
1037 0 0       for (p = pv; p != e; p++) {
1038 0         U8 c = (U8)*p;
1039 0 0       if (! UTF8_IS_INVARIANT(c)) {
1040 0         *bufptr++ = UTF8_TWO_BYTE_HI(c);
1041 0         *bufptr++ = UTF8_TWO_BYTE_LO(c);
1042           } else {
1043 0         *bufptr++ = (char)c;
1044           }
1045           }
1046           }
1047           } else {
1048 4 50       if (flags & LEX_STUFF_UTF8) {
1049           STRLEN highhalf = 0;
1050 0         const char *p, *e = pv+len;
1051 0 0       for (p = pv; p != e; p++) {
1052 0         U8 c = (U8)*p;
1053 0 0       if (UTF8_IS_ABOVE_LATIN1(c)) {
1054 0         Perl_croak(aTHX_ "Lexing code attempted to stuff "
1055           "non-Latin-1 character into Latin-1 input");
1056 0 0       } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
    0        
    0        
1057 0         p++;
1058 0         highhalf++;
1059 0 0       } else if (! UTF8_IS_INVARIANT(c)) {
1060           /* malformed UTF-8 */
1061 0         ENTER;
1062 0         SAVESPTR(PL_warnhook);
1063 0         PL_warnhook = PERL_WARNHOOK_FATAL;
1064 0         utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1065 0         LEAVE;
1066           }
1067           }
1068 0 0       if (!highhalf)
1069           goto plain_copy;
1070 0         lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1071 0         bufptr = PL_parser->bufptr;
1072 0         Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1073 0         SvCUR_set(PL_parser->linestr,
1074           SvCUR(PL_parser->linestr) + len-highhalf);
1075 0         PL_parser->bufend += len-highhalf;
1076           p = pv;
1077 0 0       while (p < e) {
1078 0 0       if (UTF8_IS_INVARIANT(*p)) {
1079 0         *bufptr++ = *p;
1080 0         p++;
1081           }
1082           else {
1083           assert(p < e -1 );
1084 0         *bufptr++ = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
1085 0         p += 2;
1086           }
1087           }
1088           } else {
1089           plain_copy:
1090 4         lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1091 4         bufptr = PL_parser->bufptr;
1092 4         Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1093 4         SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1094 4         PL_parser->bufend += len;
1095 4         Copy(pv, bufptr, len, char);
1096           }
1097           }
1098 4         }
1099            
1100           /*
1101           =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1102            
1103           Insert characters into the lexer buffer (Llinestr>),
1104           immediately after the current lexing point (Lbufptr>),
1105           reallocating the buffer if necessary. This means that lexing code that
1106           runs later will see the characters as if they had appeared in the input.
1107           It is not recommended to do this as part of normal parsing, and most
1108           uses of this facility run the risk of the inserted characters being
1109           interpreted in an unintended manner.
1110            
1111           The string to be inserted is represented by octets starting at I
1112           and continuing to the first nul. These octets are interpreted as either
1113           UTF-8 or Latin-1, according to whether the C flag is set
1114           in I. The characters are recoded for the lexer buffer, according
1115           to how the buffer is currently being interpreted (L).
1116           If it is not convenient to nul-terminate a string to be inserted, the
1117           L function is more appropriate.
1118            
1119           =cut
1120           */
1121            
1122           void
1123 0         Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1124           {
1125           PERL_ARGS_ASSERT_LEX_STUFF_PV;
1126 0         lex_stuff_pvn(pv, strlen(pv), flags);
1127 0         }
1128            
1129           /*
1130           =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1131            
1132           Insert characters into the lexer buffer (Llinestr>),
1133           immediately after the current lexing point (Lbufptr>),
1134           reallocating the buffer if necessary. This means that lexing code that
1135           runs later will see the characters as if they had appeared in the input.
1136           It is not recommended to do this as part of normal parsing, and most
1137           uses of this facility run the risk of the inserted characters being
1138           interpreted in an unintended manner.
1139            
1140           The string to be inserted is the string value of I. The characters
1141           are recoded for the lexer buffer, according to how the buffer is currently
1142           being interpreted (L). If a string to be inserted is
1143           not already a Perl scalar, the L function avoids the
1144           need to construct a scalar.
1145            
1146           =cut
1147           */
1148            
1149           void
1150 0         Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1151           {
1152           char *pv;
1153           STRLEN len;
1154           PERL_ARGS_ASSERT_LEX_STUFF_SV;
1155 0 0       if (flags)
1156 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1157 0 0       pv = SvPV(sv, len);
1158 0 0       lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1159 0         }
1160            
1161           /*
1162           =for apidoc Amx|void|lex_unstuff|char *ptr
1163            
1164           Discards text about to be lexed, from Lbufptr> up to
1165           I. Text following I will be moved, and the buffer shortened.
1166           This hides the discarded text from any lexing code that runs later,
1167           as if the text had never appeared.
1168            
1169           This is not the normal way to consume lexed text. For that, use
1170           L.
1171            
1172           =cut
1173           */
1174            
1175           void
1176 0         Perl_lex_unstuff(pTHX_ char *ptr)
1177           {
1178           char *buf, *bufend;
1179           STRLEN unstuff_len;
1180           PERL_ARGS_ASSERT_LEX_UNSTUFF;
1181 0         buf = PL_parser->bufptr;
1182 0 0       if (ptr < buf)
1183 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1184 0 0       if (ptr == buf)
1185 0         return;
1186 0         bufend = PL_parser->bufend;
1187 0 0       if (ptr > bufend)
1188 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1189 0         unstuff_len = ptr - buf;
1190 0         Move(ptr, buf, bufend+1-ptr, char);
1191 0         SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1192 0         PL_parser->bufend = bufend - unstuff_len;
1193           }
1194            
1195           /*
1196           =for apidoc Amx|void|lex_read_to|char *ptr
1197            
1198           Consume text in the lexer buffer, from Lbufptr> up
1199           to I. This advances Lbufptr> to match I,
1200           performing the correct bookkeeping whenever a newline character is passed.
1201           This is the normal way to consume lexed text.
1202            
1203           Interpretation of the buffer's octets can be abstracted out by
1204           using the slightly higher-level functions L and
1205           L.
1206            
1207           =cut
1208           */
1209            
1210           void
1211 40         Perl_lex_read_to(pTHX_ char *ptr)
1212           {
1213           char *s;
1214           PERL_ARGS_ASSERT_LEX_READ_TO;
1215 40         s = PL_parser->bufptr;
1216 40 50       if (ptr < s || ptr > PL_parser->bufend)
    50        
1217 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1218 184 100       for (; s != ptr; s++)
1219 164 50       if (*s == '\n') {
1220 0 0       COPLINE_INC_WITH_HERELINES;
1221 0         PL_parser->linestart = s+1;
1222           }
1223 40         PL_parser->bufptr = ptr;
1224 40         }
1225            
1226           /*
1227           =for apidoc Amx|void|lex_discard_to|char *ptr
1228            
1229           Discards the first part of the Llinestr> buffer,
1230           up to I. The remaining content of the buffer will be moved, and
1231           all pointers into the buffer updated appropriately. I must not
1232           be later in the buffer than the position of Lbufptr>:
1233           it is not permitted to discard text that has yet to be lexed.
1234            
1235           Normally it is not necessarily to do this directly, because it suffices to
1236           use the implicit discarding behaviour of L and things
1237           based on it. However, if a token stretches across multiple lines,
1238           and the lexing code has kept multiple lines of text in the buffer for
1239           that purpose, then after completion of the token it would be wise to
1240           explicitly discard the now-unneeded earlier lines, to avoid future
1241           multi-line tokens growing the buffer without bound.
1242            
1243           =cut
1244           */
1245            
1246           void
1247 0         Perl_lex_discard_to(pTHX_ char *ptr)
1248           {
1249           char *buf;
1250           STRLEN discard_len;
1251           PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1252 0         buf = SvPVX(PL_parser->linestr);
1253 0 0       if (ptr < buf)
1254 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1255 0 0       if (ptr == buf)
1256 0         return;
1257 0 0       if (ptr > PL_parser->bufptr)
1258 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1259 0         discard_len = ptr - buf;
1260 0 0       if (PL_parser->oldbufptr < ptr)
1261 0         PL_parser->oldbufptr = ptr;
1262 0 0       if (PL_parser->oldoldbufptr < ptr)
1263 0         PL_parser->oldoldbufptr = ptr;
1264 0 0       if (PL_parser->last_uni && PL_parser->last_uni < ptr)
    0        
1265 0         PL_parser->last_uni = NULL;
1266 0 0       if (PL_parser->last_lop && PL_parser->last_lop < ptr)
    0        
1267 0         PL_parser->last_lop = NULL;
1268 0         Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1269 0         SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1270 0         PL_parser->bufend -= discard_len;
1271 0         PL_parser->bufptr -= discard_len;
1272 0         PL_parser->oldbufptr -= discard_len;
1273 0         PL_parser->oldoldbufptr -= discard_len;
1274 0 0       if (PL_parser->last_uni)
1275 0         PL_parser->last_uni -= discard_len;
1276 0 0       if (PL_parser->last_lop)
1277 0         PL_parser->last_lop -= discard_len;
1278           }
1279            
1280           /*
1281           =for apidoc Amx|bool|lex_next_chunk|U32 flags
1282            
1283           Reads in the next chunk of text to be lexed, appending it to
1284           Llinestr>. This should be called when lexing code has
1285           looked to the end of the current chunk and wants to know more. It is
1286           usual, but not necessary, for lexing to have consumed the entirety of
1287           the current chunk at this time.
1288            
1289           If Lbufptr> is pointing to the very end of the current
1290           chunk (i.e., the current chunk has been entirely consumed), normally the
1291           current chunk will be discarded at the same time that the new chunk is
1292           read in. If I includes C, the current chunk
1293           will not be discarded. If the current chunk has not been entirely
1294           consumed, then it will not be discarded regardless of the flag.
1295            
1296           Returns true if some new text was added to the buffer, or false if the
1297           buffer has reached the end of the input text.
1298            
1299           =cut
1300           */
1301            
1302           #define LEX_FAKE_EOF 0x80000000
1303           #define LEX_NO_TERM 0x40000000
1304            
1305           bool
1306 215833189         Perl_lex_next_chunk(pTHX_ U32 flags)
1307           {
1308           SV *linestr;
1309           char *buf;
1310           STRLEN old_bufend_pos, new_bufend_pos;
1311           STRLEN bufptr_pos, oldbufptr_pos, oldoldbufptr_pos;
1312           STRLEN linestart_pos, last_uni_pos, last_lop_pos;
1313           bool got_some_for_debugger = 0;
1314           bool got_some;
1315 215833189 50       if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1316 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1317 215833189         linestr = PL_parser->linestr;
1318 215833189         buf = SvPVX(linestr);
1319 317086085 100       if (!(flags & LEX_KEEP_PREVIOUS) &&
    50        
1320 209530253         PL_parser->bufptr == PL_parser->bufend) {
1321           old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1322           linestart_pos = 0;
1323 209530253 50       if (PL_parser->last_uni != PL_parser->bufend)
1324 209530253         PL_parser->last_uni = NULL;
1325 209530253 50       if (PL_parser->last_lop != PL_parser->bufend)
1326 209530253         PL_parser->last_lop = NULL;
1327           last_uni_pos = last_lop_pos = 0;
1328 209530253         *buf = 0;
1329 209530253         SvCUR(linestr) = 0;
1330           } else {
1331 6302936         old_bufend_pos = PL_parser->bufend - buf;
1332 6302936         bufptr_pos = PL_parser->bufptr - buf;
1333 6302936         oldbufptr_pos = PL_parser->oldbufptr - buf;
1334 6302936         oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1335 6302936         linestart_pos = PL_parser->linestart - buf;
1336 6302936 100       last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1337 6302936 100       last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1338           }
1339 215833189 100       if (flags & LEX_FAKE_EOF) {
1340           goto eof;
1341 215443259 100       } else if (!PL_parser->rsfp && !PL_parser->filtered) {
    100        
1342           got_some = 0;
1343 215443149 100       } else if (filter_gets(linestr, old_bufend_pos)) {
1344           got_some = 1;
1345           got_some_for_debugger = 1;
1346 224157 100       } else if (flags & LEX_NO_TERM) {
1347           got_some = 0;
1348           } else {
1349 223977 100       if (!SvPOK(linestr)) /* can get undefined by filter_gets */
1350 14         sv_setpvs(linestr, "");
1351           eof:
1352           /* End of real input. Close filehandle (unless it was STDIN),
1353           * then add implicit termination.
1354           */
1355 613907 100       if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1356 40         PerlIO_clearerr(PL_parser->rsfp);
1357 613867 100       else if (PL_parser->rsfp)
1358 611619         (void)PerlIO_close(PL_parser->rsfp);
1359 613907         PL_parser->rsfp = NULL;
1360 613907         PL_parser->in_pod = PL_parser->filtered = 0;
1361           #ifdef PERL_MAD
1362           if (PL_madskills && !PL_in_eval && (PL_minus_p || PL_minus_n))
1363           PL_faketokens = 1;
1364           #endif
1365 613907 100       if (!PL_in_eval && PL_minus_p) {
    100        
1366 26         sv_catpvs(linestr,
1367           /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1368 26         PL_minus_n = PL_minus_p = 0;
1369 613881 100       } else if (!PL_in_eval && PL_minus_n) {
    100        
1370 90         sv_catpvs(linestr, /*{*/";}");
1371 90         PL_minus_n = 0;
1372           } else
1373 613791         sv_catpvs(linestr, ";");
1374           got_some = 1;
1375           }
1376 215833179         buf = SvPVX(linestr);
1377 215833179         new_bufend_pos = SvCUR(linestr);
1378 215833179         PL_parser->bufend = buf + new_bufend_pos;
1379 215833179         PL_parser->bufptr = buf + bufptr_pos;
1380 215833179         PL_parser->oldbufptr = buf + oldbufptr_pos;
1381 215833179         PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1382 215833179         PL_parser->linestart = buf + linestart_pos;
1383 215833179 100       if (PL_parser->last_uni)
1384 825798         PL_parser->last_uni = buf + last_uni_pos;
1385 215833179 100       if (PL_parser->last_lop)
1386 571803         PL_parser->last_lop = buf + last_lop_pos;
1387 217243210 100       if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
    100        
    100        
    100        
1388 2820062         PL_curstash != PL_debstash) {
1389           /* debugger active and we're not compiling the debugger code,
1390           * so store the line into the debugger's array of lines
1391           */
1392 1041768         update_debugger_info(NULL, buf+old_bufend_pos,
1393           new_bufend_pos-old_bufend_pos);
1394           }
1395 215833179         return got_some;
1396           }
1397            
1398           /*
1399           =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1400            
1401           Looks ahead one (Unicode) character in the text currently being lexed.
1402           Returns the codepoint (unsigned integer value) of the next character,
1403           or -1 if lexing has reached the end of the input text. To consume the
1404           peeked character, use L.
1405            
1406           If the next character is in (or extends into) the next chunk of input
1407           text, the next chunk will be read in. Normally the current chunk will be
1408           discarded at the same time, but if I includes C
1409           then the current chunk will not be discarded.
1410            
1411           If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1412           is encountered, an exception is generated.
1413            
1414           =cut
1415           */
1416            
1417           I32
1418 536         Perl_lex_peek_unichar(pTHX_ U32 flags)
1419           {
1420           dVAR;
1421           char *s, *bufend;
1422 536 50       if (flags & ~(LEX_KEEP_PREVIOUS))
1423 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1424 536         s = PL_parser->bufptr;
1425 536         bufend = PL_parser->bufend;
1426 536 50       if (UTF) {
    50        
    0        
    50        
    50        
1427           U8 head;
1428           I32 unichar;
1429           STRLEN len, retlen;
1430 0 0       if (s == bufend) {
1431 0 0       if (!lex_next_chunk(flags))
1432           return -1;
1433 0         s = PL_parser->bufptr;
1434 0         bufend = PL_parser->bufend;
1435           }
1436 0         head = (U8)*s;
1437 0 0       if (UTF8_IS_INVARIANT(head))
1438 0         return head;
1439 0 0       if (UTF8_IS_START(head)) {
1440 0         len = UTF8SKIP(&head);
1441 0 0       while ((STRLEN)(bufend-s) < len) {
1442 0 0       if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1443           break;
1444 0         s = PL_parser->bufptr;
1445 0         bufend = PL_parser->bufend;
1446           }
1447           }
1448 0         unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1449 0 0       if (retlen == (STRLEN)-1) {
1450           /* malformed UTF-8 */
1451 0         ENTER;
1452 0         SAVESPTR(PL_warnhook);
1453 0         PL_warnhook = PERL_WARNHOOK_FATAL;
1454 0         utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1455 0         LEAVE;
1456           }
1457           return unichar;
1458           } else {
1459 536 100       if (s == bufend) {
1460 6 50       if (!lex_next_chunk(flags))
1461           return -1;
1462 0         s = PL_parser->bufptr;
1463           }
1464 533         return (U8)*s;
1465           }
1466           }
1467            
1468           /*
1469           =for apidoc Amx|I32|lex_read_unichar|U32 flags
1470            
1471           Reads the next (Unicode) character in the text currently being lexed.
1472           Returns the codepoint (unsigned integer value) of the character read,
1473           and moves Lbufptr> past the character, or returns -1
1474           if lexing has reached the end of the input text. To non-destructively
1475           examine the next character, use L instead.
1476            
1477           If the next character is in (or extends into) the next chunk of input
1478           text, the next chunk will be read in. Normally the current chunk will be
1479           discarded at the same time, but if I includes C
1480           then the current chunk will not be discarded.
1481            
1482           If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1483           is encountered, an exception is generated.
1484            
1485           =cut
1486           */
1487            
1488           I32
1489 202         Perl_lex_read_unichar(pTHX_ U32 flags)
1490           {
1491           I32 c;
1492 202 50       if (flags & ~(LEX_KEEP_PREVIOUS))
1493 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1494 202         c = lex_peek_unichar(flags);
1495 202 50       if (c != -1) {
1496 202 50       if (c == '\n')
1497 0 0       COPLINE_INC_WITH_HERELINES;
1498 202 50       if (UTF)
    50        
    0        
    50        
    50        
1499 0         PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1500           else
1501 202         ++(PL_parser->bufptr);
1502           }
1503 202         return c;
1504           }
1505            
1506           /*
1507           =for apidoc Amx|void|lex_read_space|U32 flags
1508            
1509           Reads optional spaces, in Perl style, in the text currently being
1510           lexed. The spaces may include ordinary whitespace characters and
1511           Perl-style comments. C<#line> directives are processed if encountered.
1512           Lbufptr> is moved past the spaces, so that it points
1513           at a non-space character (or the end of the input text).
1514            
1515           If spaces extend into the next chunk of input text, the next chunk will
1516           be read in. Normally the current chunk will be discarded at the same
1517           time, but if I includes C then the current
1518           chunk will not be discarded.
1519            
1520           =cut
1521           */
1522            
1523           #define LEX_NO_INCLINE 0x40000000
1524           #define LEX_NO_NEXT_CHUNK 0x80000000
1525            
1526           void
1527 470855641         Perl_lex_read_space(pTHX_ U32 flags)
1528           {
1529           char *s, *bufend;
1530 470855641         const bool can_incline = !(flags & LEX_NO_INCLINE);
1531           bool need_incline = 0;
1532 470855641 50       if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1533 0         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1534           #ifdef PERL_MAD
1535           if (PL_skipwhite) {
1536           sv_free(PL_skipwhite);
1537           PL_skipwhite = NULL;
1538           }
1539           if (PL_madskills)
1540           PL_skipwhite = newSVpvs("");
1541           #endif /* PERL_MAD */
1542 470855641         s = PL_parser->bufptr;
1543 616830542         bufend = PL_parser->bufend;
1544           while (1) {
1545 753100338         char c = *s;
1546 753100338 100       if (c == '#') {
1547           do {
1548 15208990         c = *++s;
1549 15208990 100       } while (!(c == '\n' || (c == 0 && s == bufend)));
    100        
1550 752663352 100       } else if (c == '\n') {
1551 6828186         s++;
1552 6828186 100       if (can_incline) {
1553 6015990         PL_parser->linestart = s;
1554 6015990 100       if (s == bufend)
1555           need_incline = 1;
1556           else
1557 523464         incline(s);
1558           }
1559 745835166 100       } else if (isSPACE(c)) {
1560 268676675         s++;
1561 477158491 100       } else if (c == 0 && s == bufend) {
1562           bool got_more;
1563           #ifdef PERL_MAD
1564           if (PL_madskills)
1565           sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1566           #endif /* PERL_MAD */
1567 6302958 100       if (flags & LEX_NO_NEXT_CHUNK)
1568           break;
1569 6302956         PL_parser->bufptr = s;
1570 6302956 100       if (can_incline) COPLINE_INC_WITH_HERELINES;
    100        
1571 6302956         got_more = lex_next_chunk(flags);
1572 6302956 100       if (can_incline) CopLINE_dec(PL_curcop);
1573 6302956         s = PL_parser->bufptr;
1574 6302956         bufend = PL_parser->bufend;
1575 6302956 100       if (!got_more)
1576           break;
1577 6302850 100       if (can_incline && need_incline && PL_parser->rsfp) {
    100        
    100        
1578 5483412         incline(s);
1579           need_incline = 0;
1580           }
1581           } else {
1582           break;
1583           }
1584           }
1585           #ifdef PERL_MAD
1586           if (PL_madskills)
1587           sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1588           #endif /* PERL_MAD */
1589 470855641         PL_parser->bufptr = s;
1590 470855641         }
1591            
1592           /*
1593            
1594           =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1595            
1596           This function performs syntax checking on a prototype, C.
1597           If C is true, any illegal characters or mismatched brackets
1598           will trigger illegalproto warnings, declaring that they were
1599           detected in the prototype for C.
1600            
1601           The return value is C if this is a valid prototype, and
1602           C if it is not, regardless of whether C was C or
1603           C.
1604            
1605           Note that C is a valid C and will always return C.
1606            
1607           =cut
1608            
1609           */
1610            
1611           bool
1612 519944         Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1613           {
1614           STRLEN len, origlen;
1615 519944 50       char *p = proto ? SvPV(proto, len) : NULL;
    50        
1616           bool bad_proto = FALSE;
1617           bool in_brackets = FALSE;
1618           bool after_slash = FALSE;
1619           char greedy_proto = ' ';
1620           bool proto_after_greedy_proto = FALSE;
1621           bool must_be_last = FALSE;
1622           bool underscore = FALSE;
1623           bool bad_proto_after_underscore = FALSE;
1624            
1625           PERL_ARGS_ASSERT_VALIDATE_PROTO;
1626            
1627 519944 50       if (!proto)
1628           return TRUE;
1629            
1630 519944         origlen = len;
1631 1014054 100       for (; len--; p++) {
1632 494110 100       if (!isSPACE(*p)) {
1633 494058 100       if (must_be_last)
1634           proto_after_greedy_proto = TRUE;
1635 494058 100       if (underscore) {
1636 78 100       if (!strchr(";@%", *p))
1637           bad_proto_after_underscore = TRUE;
1638           underscore = FALSE;
1639           }
1640 494058 100       if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
    100        
1641           bad_proto = TRUE;
1642           }
1643           else {
1644 493976 100       if (*p == '[')
1645           in_brackets = TRUE;
1646 491036 100       else if (*p == ']')
1647           in_brackets = FALSE;
1648 488098 100       else if ((*p == '@' || *p == '%') &&
    100        
1649 34816 100       !after_slash &&
1650           !in_brackets ) {
1651           must_be_last = TRUE;
1652 28962         greedy_proto = *p;
1653           }
1654 459136 100       else if (*p == '_')
1655           underscore = TRUE;
1656           }
1657 494058 100       if (*p == '\\')
1658           after_slash = TRUE;
1659           else
1660           after_slash = FALSE;
1661           }
1662           }
1663            
1664 519944 100       if (warn) {
1665 147014         SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1666 147014         p -= origlen;
1667 147014         p = SvUTF8(proto)
1668 4         ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1669           origlen, UNI_DISPLAY_ISPRINT)
1670 147018 100       : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1671            
1672 147014 100       if (proto_after_greedy_proto)
1673 38         Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1674           "Prototype after '%c' for %"SVf" : %s",
1675           greedy_proto, SVfARG(name), p);
1676 147014 100       if (in_brackets)
1677 2         Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1678           "Missing ']' in prototype for %"SVf" : %s",
1679           SVfARG(name), p);
1680 147014 100       if (bad_proto)
1681 30         Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1682           "Illegal character in prototype for %"SVf" : %s",
1683           SVfARG(name), p);
1684 147014 100       if (bad_proto_after_underscore)
1685 8         Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1686           "Illegal character after '_' in prototype for %"SVf" : %s",
1687           SVfARG(name), p);
1688           }
1689            
1690 519944 100       return (! (proto_after_greedy_proto || bad_proto) );
    100        
1691           }
1692            
1693           /*
1694           * S_incline
1695           * This subroutine has nothing to do with tilting, whether at windmills
1696           * or pinball tables. Its name is short for "increment line". It
1697           * increments the current line number in CopLINE(PL_curcop) and checks
1698           * to see whether the line starts with a comment of the form
1699           * # line 500 "foo.pm"
1700           * If so, it sets the current line number and file to the values in the comment.
1701           */
1702            
1703           STATIC void
1704 202428658         S_incline(pTHX_ const char *s)
1705           {
1706           dVAR;
1707           const char *t;
1708           const char *n;
1709           const char *e;
1710           line_t line_num;
1711            
1712           PERL_ARGS_ASSERT_INCLINE;
1713            
1714 202428658 100       COPLINE_INC_WITH_HERELINES;
1715 202428658 100       if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
    100        
    100        
1716 7378420 100       && s+1 == PL_bufend && *s == ';') {
    50        
1717           /* fake newline in string eval */
1718 3626370         CopLINE_dec(PL_curcop);
1719 3626370         return;
1720           }
1721 198802288 100       if (*s++ != '#')
1722           return;
1723 17709658 100       while (SPACE_OR_TAB(*s))
1724 9237789         s++;
1725 8471869 100       if (strnEQ(s, "line", 4))
1726           s += 4;
1727           else
1728           return;
1729 315040 100       if (SPACE_OR_TAB(*s))
1730 310300         s++;
1731           else
1732           return;
1733 465592 100       while (SPACE_OR_TAB(*s))
1734 142         s++;
1735 310300 100       if (!isDIGIT(*s))
1736           return;
1737            
1738           n = s;
1739 1153442 100       while (isDIGIT(*s))
1740 844318         s++;
1741 309124 100       if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
    50        
    100        
    50        
1742           return;
1743 615496 100       while (SPACE_OR_TAB(*s))
1744 306374         s++;
1745 309122 100       if (*s == '"' && (t = strchr(s+1, '"'))) {
    100        
1746 291766         s++;
1747 300444         e = t + 1;
1748           }
1749           else {
1750           t = s;
1751 259114 100       while (!isSPACE(*t))
1752 241758         t++;
1753           e = t;
1754           }
1755 309130 100       while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
    50        
    50        
1756 8         e++;
1757 309122 100       if (*e != '\n' && *e != '\0')
1758           return; /* false alarm */
1759            
1760 309116         line_num = atoi(n)-1;
1761            
1762 309116 100       if (t - s > 0) {
1763 306364         const STRLEN len = t - s;
1764            
1765 306364 100       if (!PL_rsfp && !PL_parser->filtered) {
    50        
1766           /* must copy *{"::_<(eval N)[oldfilename:L]"}
1767           * to *{"::_
1768           /* However, the long form of evals is only turned on by the
1769           debugger - usually they're "(eval %lu)" */
1770 284802         GV * const cfgv = CopFILEGV(PL_curcop);
1771 284802 50       if (cfgv) {
1772           char smallbuf[128];
1773           STRLEN tmplen2 = len;
1774           char *tmpbuf2;
1775           GV *gv2;
1776            
1777 284802 100       if (tmplen2 + 2 <= sizeof smallbuf)
1778           tmpbuf2 = smallbuf;
1779           else
1780 4         Newx(tmpbuf2, tmplen2 + 2, char);
1781            
1782 284802         tmpbuf2[0] = '_';
1783 284802         tmpbuf2[1] = '<';
1784            
1785 284802         memcpy(tmpbuf2 + 2, s, tmplen2);
1786 284802         tmplen2 += 2;
1787            
1788 284802         gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1789 284802 100       if (!isGV(gv2)) {
1790 2146         gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1791           /* adjust ${"::_
1792 2146         GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1793           /* The line number may differ. If that is the case,
1794           alias the saved lines that are in the array.
1795           Otherwise alias the whole array. */
1796 2146 100       if (CopLINE(PL_curcop) == line_num) {
1797 20         GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1798 15         GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1799           }
1800 2136 100       else if (GvAV(cfgv)) {
1801 22         AV * const av = GvAV(cfgv);
1802 22         const I32 start = CopLINE(PL_curcop)+1;
1803 22         I32 items = AvFILLp(av) - start;
1804 22 50       if (items > 0) {
1805 22 50       AV * const av2 = GvAVn(gv2);
1806 22         SV **svp = AvARRAY(av) + start;
1807 22         I32 l = (I32)line_num+1;
1808 79 100       while (items--)
1809 69         av_store(av2, l++, SvREFCNT_inc(*svp++));
1810           }
1811           }
1812           }
1813            
1814 284802 100       if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1815           }
1816           }
1817 306364         CopFILE_free(PL_curcop);
1818 612728         CopFILE_setn(PL_curcop, s, len);
1819           }
1820 104779884         CopLINE_set(PL_curcop, line_num);
1821           }
1822            
1823           #define skipspace(s) skipspace_flags(s, 0)
1824            
1825           #ifdef PERL_MAD
1826           /* skip space before PL_thistoken */
1827            
1828           STATIC char *
1829           S_skipspace0(pTHX_ char *s)
1830           {
1831           PERL_ARGS_ASSERT_SKIPSPACE0;
1832            
1833           s = skipspace(s);
1834           if (!PL_madskills)
1835           return s;
1836           if (PL_skipwhite) {
1837           if (!PL_thiswhite)
1838           PL_thiswhite = newSVpvs("");
1839           sv_catsv(PL_thiswhite, PL_skipwhite);
1840           sv_free(PL_skipwhite);
1841           PL_skipwhite = 0;
1842           }
1843           PL_realtokenstart = s - SvPVX(PL_linestr);
1844           return s;
1845           }
1846            
1847           /* skip space after PL_thistoken */
1848            
1849           STATIC char *
1850           S_skipspace1(pTHX_ char *s)
1851           {
1852           const char *start = s;
1853           I32 startoff = start - SvPVX(PL_linestr);
1854            
1855           PERL_ARGS_ASSERT_SKIPSPACE1;
1856            
1857           s = skipspace(s);
1858           if (!PL_madskills)
1859           return s;
1860           start = SvPVX(PL_linestr) + startoff;
1861           if (!PL_thistoken && PL_realtokenstart >= 0) {
1862           const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1863           PL_thistoken = newSVpvn(tstart, start - tstart);
1864           }
1865           PL_realtokenstart = -1;
1866           if (PL_skipwhite) {
1867           if (!PL_nextwhite)
1868           PL_nextwhite = newSVpvs("");
1869           sv_catsv(PL_nextwhite, PL_skipwhite);
1870           sv_free(PL_skipwhite);
1871           PL_skipwhite = 0;
1872           }
1873           return s;
1874           }
1875            
1876           STATIC char *
1877           S_skipspace2(pTHX_ char *s, SV **svp)
1878           {
1879           char *start;
1880           const I32 startoff = s - SvPVX(PL_linestr);
1881            
1882           PERL_ARGS_ASSERT_SKIPSPACE2;
1883            
1884           s = skipspace(s);
1885           if (!PL_madskills || !svp)
1886           return s;
1887           start = SvPVX(PL_linestr) + startoff;
1888           if (!PL_thistoken && PL_realtokenstart >= 0) {
1889           char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1890           PL_thistoken = newSVpvn(tstart, start - tstart);
1891           PL_realtokenstart = -1;
1892           }
1893           if (PL_skipwhite) {
1894           if (!*svp)
1895           *svp = newSVpvs("");
1896           sv_setsv(*svp, PL_skipwhite);
1897           sv_free(PL_skipwhite);
1898           PL_skipwhite = 0;
1899           }
1900          
1901           return s;
1902           }
1903           #endif
1904            
1905           STATIC void
1906 1041982         S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1907           {
1908 1041982         AV *av = CopFILEAVx(PL_curcop);
1909 1041982 100       if (av) {
1910 1041900         SV * const sv = newSV_type(SVt_PVMG);
1911 1041900 100       if (orig_sv)
1912 214         sv_setsv_flags(sv, orig_sv, 0); /* no cow */
1913           else
1914 1041686         sv_setpvn(sv, buf, len);
1915 1041900         (void)SvIOK_on(sv);
1916 1041900         SvIV_set(sv, 0);
1917 1041900         av_store(av, CopLINE(PL_curcop), sv);
1918           }
1919 1041982         }
1920            
1921           /*
1922           * S_skipspace
1923           * Called to gobble the appropriate amount and type of whitespace.
1924           * Skips comments as well.
1925           */
1926            
1927           STATIC char *
1928 470855659         S_skipspace_flags(pTHX_ char *s, U32 flags)
1929           {
1930           #ifdef PERL_MAD
1931           char *start = s;
1932           #endif /* PERL_MAD */
1933           PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1934           #ifdef PERL_MAD
1935           if (PL_skipwhite) {
1936           sv_free(PL_skipwhite);
1937           PL_skipwhite = NULL;
1938           }
1939           #endif /* PERL_MAD */
1940 470855659 100       if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
    100        
1941 562 50       while (s < PL_bufend && SPACE_OR_TAB(*s))
    100        
1942 144         s++;
1943           } else {
1944 470855241         STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1945 470855241         PL_bufptr = s;
1946 470855241 100       lex_read_space(flags | LEX_KEEP_PREVIOUS |
    50        
1947           (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1948           LEX_NO_NEXT_CHUNK : 0));
1949 470855241         s = PL_bufptr;
1950 470855241         PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1951 470855241 100       if (PL_linestart > PL_bufptr)
1952 245610822         PL_bufptr = PL_linestart;
1953           return s;
1954           }
1955           #ifdef PERL_MAD
1956           if (PL_madskills)
1957           PL_skipwhite = newSVpvn(start, s-start);
1958           #endif /* PERL_MAD */
1959           return s;
1960           }
1961            
1962           /*
1963           * S_check_uni
1964           * Check the unary operators to ensure there's no ambiguity in how they're
1965           * used. An ambiguous piece of code would be:
1966           * rand + 5
1967           * This doesn't mean rand() + 5. Because rand() is a unary operator,
1968           * the +5 is its argument.
1969           */
1970            
1971           STATIC void
1972 304762         S_check_uni(pTHX)
1973           {
1974           dVAR;
1975           const char *s;
1976           const char *t;
1977            
1978 304762 100       if (PL_oldoldbufptr != PL_last_uni)
1979           return;
1980 162 100       while (isSPACE(*PL_last_uni))
1981 66         PL_last_uni++;
1982 96         s = PL_last_uni;
1983 492 100       while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
    50        
    50        
    0        
    50        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    50        
1984 348         s++;
1985 96 100       if ((t = strchr(s, '(')) && t < PL_bufptr)
    50        
1986           return;
1987            
1988 173087         Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
1989           "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1990 12         (int)(s - PL_last_uni), PL_last_uni);
1991           }
1992            
1993           /*
1994           * LOP : macro to build a list operator. Its behaviour has been replaced
1995           * with a subroutine, S_lop() for which LOP is just another name.
1996           */
1997            
1998           #define LOP(f,x) return lop(f,x,s)
1999            
2000           /*
2001           * S_lop
2002           * Build a list operator (or something that might be one). The rules:
2003           * - if we have a next token, then it's a list operator [why?]
2004           * - if the next thing is an opening paren, then it's a function
2005           * - else it's a list operator
2006           */
2007            
2008           STATIC I32
2009 8624847         S_lop(pTHX_ I32 f, int x, char *s)
2010           {
2011           dVAR;
2012            
2013           PERL_ARGS_ASSERT_LOP;
2014            
2015 8624847         pl_yylval.ival = f;
2016 8624847         CLINE;
2017 8624847         PL_expect = x;
2018 8624847         PL_bufptr = s;
2019 8624847         PL_last_lop = PL_oldbufptr;
2020 8624847         PL_last_lop_op = (OPCODE)f;
2021           #ifdef PERL_MAD
2022           if (PL_lasttoke)
2023           goto lstop;
2024           #else
2025 8624847 100       if (PL_nexttoke)
2026           goto lstop;
2027           #endif
2028 8624385 100       if (*s == '(')
2029           return REPORT(FUNC);
2030 5827704         s = PEEKSPACE(s);
2031 5827704 100       if (*s == '(')
2032           return REPORT(FUNC);
2033           else {
2034           lstop:
2035 5737004 100       if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
    100        
2036 4507879         PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
2037           return REPORT(LSTOP);
2038           }
2039           }
2040            
2041           #ifdef PERL_MAD
2042           /*
2043           * S_start_force
2044           * Sets up for an eventual force_next(). start_force(0) basically does
2045           * an unshift, while start_force(-1) does a push. yylex removes items
2046           * on the "pop" end.
2047           */
2048            
2049           STATIC void
2050           S_start_force(pTHX_ int where)
2051           {
2052           int i;
2053            
2054           if (where < 0) /* so people can duplicate start_force(PL_curforce) */
2055           where = PL_lasttoke;
2056           assert(PL_curforce < 0 || PL_curforce == where);
2057           if (PL_curforce != where) {
2058           for (i = PL_lasttoke; i > where; --i) {
2059           PL_nexttoke[i] = PL_nexttoke[i-1];
2060           }
2061           PL_lasttoke++;
2062           }
2063           if (PL_curforce < 0) /* in case of duplicate start_force() */
2064           Zero(&PL_nexttoke[where], 1, NEXTTOKE);
2065           PL_curforce = where;
2066           if (PL_nextwhite) {
2067           if (PL_madskills)
2068           curmad('^', newSVpvs(""));
2069           CURMAD('_', PL_nextwhite);
2070           }
2071           }
2072            
2073           STATIC void
2074           S_curmad(pTHX_ char slot, SV *sv)
2075           {
2076           MADPROP **where;
2077            
2078           if (!sv)
2079           return;
2080           if (PL_curforce < 0)
2081           where = &PL_thismad;
2082           else
2083           where = &PL_nexttoke[PL_curforce].next_mad;
2084            
2085           if (PL_faketokens)
2086           sv_setpvs(sv, "");
2087           else {
2088           if (!IN_BYTES) {
2089           if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2090           SvUTF8_on(sv);
2091           else if (PL_encoding) {
2092           sv_recode_to_utf8(sv, PL_encoding);
2093           }
2094           }
2095           }
2096            
2097           /* keep a slot open for the head of the list? */
2098           if (slot != '_' && *where && (*where)->mad_key == '^') {
2099           (*where)->mad_key = slot;
2100           sv_free(MUTABLE_SV(((*where)->mad_val)));
2101           (*where)->mad_val = (void*)sv;
2102           }
2103           else
2104           addmad(newMADsv(slot, sv), where, 0);
2105           }
2106           #else
2107           # define start_force(where) NOOP
2108           # define curmad(slot, sv) NOOP
2109           #endif
2110            
2111           /*
2112           * S_force_next
2113           * When the lexer realizes it knows the next token (for instance,
2114           * it is reordering tokens for the parser) then it can call S_force_next
2115           * to know what token to return the next time the lexer is called. Caller
2116           * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2117           * and possibly PL_expect to ensure the lexer handles the token correctly.
2118           */
2119            
2120           STATIC void
2121 253471872         S_force_next(pTHX_ I32 type)
2122           {
2123           dVAR;
2124           #ifdef DEBUGGING
2125           if (DEBUG_T_TEST) {
2126           PerlIO_printf(Perl_debug_log, "### forced token:\n");
2127           tokereport(type, &NEXTVAL_NEXTTOKE);
2128           }
2129           #endif
2130           #ifdef PERL_MAD
2131           if (PL_curforce < 0)
2132           start_force(PL_lasttoke);
2133           PL_nexttoke[PL_curforce].next_type = type;
2134           if (PL_lex_state != LEX_KNOWNEXT)
2135           PL_lex_defer = PL_lex_state;
2136           PL_lex_state = LEX_KNOWNEXT;
2137           PL_lex_expect = PL_expect;
2138           PL_curforce = -1;
2139           #else
2140 253471872         PL_nexttype[PL_nexttoke] = type;
2141 253471872         PL_nexttoke++;
2142 253471872 100       if (PL_lex_state != LEX_KNOWNEXT) {
2143 246791240         PL_lex_defer = PL_lex_state;
2144 246791240         PL_lex_expect = PL_expect;
2145 246791240         PL_lex_state = LEX_KNOWNEXT;
2146           }
2147           #endif
2148 253471872         }
2149            
2150           void
2151 214         Perl_yyunlex(pTHX)
2152           {
2153 214         int yyc = PL_parser->yychar;
2154 214 100       if (yyc != YYEMPTY) {
2155 78 50       if (yyc) {
2156           start_force(-1);
2157 78         NEXTVAL_NEXTTOKE = PL_parser->yylval;
2158 78 100       if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
    100        
2159 8         PL_lex_allbrackets--;
2160 8         PL_lex_brackets--;
2161 8         yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2162 70 50       } else if (yyc == '('/*)*/) {
2163 0         PL_lex_allbrackets--;
2164 0         yyc |= (2<<24);
2165           }
2166 78         force_next(yyc);
2167           }
2168 78         PL_parser->yychar = YYEMPTY;
2169           }
2170 214         }
2171            
2172           STATIC SV *
2173 46609495         S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2174           {
2175           dVAR;
2176 46609495 100       SV * const sv = newSVpvn_utf8(start, len,
    50        
    100        
    50        
    100        
    100        
    100        
    50        
2177           !IN_BYTES
2178           && UTF
2179           && !is_ascii_string((const U8*)start, len)
2180           && is_utf8_string((const U8*)start, len));
2181 46609495         return sv;
2182           }
2183            
2184           /*
2185           * S_force_word
2186           * When the lexer knows the next thing is a word (for instance, it has
2187           * just seen -> and it knows that the next char is a word char, then
2188           * it calls S_force_word to stick the next word into the PL_nexttoke/val
2189           * lookahead.
2190           *
2191           * Arguments:
2192           * char *start : buffer position (must be within PL_linestr)
2193           * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2194           * int check_keyword : if true, Perl checks to make sure the word isn't
2195           * a keyword (do this if the word is a label, e.g. goto FOO)
2196           * int allow_pack : if true, : characters will also be allowed (require,
2197           * use, etc. do this)
2198           * int allow_initial_tick : used by the "sub" lexer only.
2199           */
2200            
2201           STATIC char *
2202 29956093         S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2203           {
2204           dVAR;
2205           char *s;
2206           STRLEN len;
2207            
2208           PERL_ARGS_ASSERT_FORCE_WORD;
2209            
2210 29956093         start = SKIPSPACE1(start);
2211           s = start;
2212 29956093 100       if (isIDFIRST_lazy_if(s,UTF) ||
    50        
    100        
    50        
    100        
    100        
    100        
    100        
    100        
    100        
    50        
    50        
    50        
    50        
    100        
2213 125237 100       (allow_pack && *s == ':') )
2214           {
2215 28983389         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2216 28983389 100       if (check_keyword) {
2217 2490986         char *s2 = PL_tokenbuf;
2218 2490986 100       if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
    100        
    100        
2219 4         s2 += 6, len -= 6;
2220 2490986 100       if (keyword(s2, len, 0))
2221           return start;
2222           }
2223           start_force(PL_curforce);
2224           if (PL_madskills)
2225           curmad('X', newSVpvn(start,s-start));
2226 28004531 100       if (token == METHOD) {
2227 12627485         s = SKIPSPACE1(s);
2228 12627485 100       if (*s == '(')
2229 6208113         PL_expect = XTERM;
2230           else {
2231 6419372         PL_expect = XOPERATOR;
2232           }
2233           }
2234           if (PL_madskills)
2235           curmad('g', newSVpvs( "forced" ));
2236 28004531         NEXTVAL_NEXTTOKE.opval
2237 28004531         = (OP*)newSVOP(OP_CONST,0,
2238           S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2239 28004531         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2240 28004531         force_next(token);
2241           }
2242 29484303         return s;
2243           }
2244            
2245           /*
2246           * S_force_ident
2247           * Called when the lexer wants $foo *foo &foo etc, but the program
2248           * text only contains the "foo" portion. The first argument is a pointer
2249           * to the "foo", and the second argument is the type symbol to prefix.
2250           * Forces the next token to be a "WORD".
2251           * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2252           */
2253            
2254           STATIC void
2255 1802178         S_force_ident(pTHX_ const char *s, int kind)
2256           {
2257           dVAR;
2258            
2259           PERL_ARGS_ASSERT_FORCE_IDENT;
2260            
2261 1802178 100       if (s[0]) {
2262 1080726 100       const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2263 1080726 50       OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
    100        
    50        
    50        
    100        
2264           UTF ? SVf_UTF8 : 0));
2265           start_force(PL_curforce);
2266 1080726         NEXTVAL_NEXTTOKE.opval = o;
2267 1080726         force_next(WORD);
2268 1080726 50       if (kind) {
2269 1080726         o->op_private = OPpCONST_ENTERED;
2270           /* XXX see note in pp_entereval() for why we forgo typo
2271           warnings if the symbol must be introduced in an eval.
2272           GSAR 96-10-12 */
2273 1080726 100       gv_fetchpvn_flags(s, len,
    50        
    50        
    100        
    50        
    100        
    50        
    50        
    100        
2274           (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2275           : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2276           kind == '$' ? SVt_PV :
2277           kind == '@' ? SVt_PVAV :
2278           kind == '%' ? SVt_PVHV :
2279           SVt_PVGV
2280           );
2281           }
2282           }
2283 1802178         }
2284            
2285           static void
2286 142444391         S_force_ident_maybe_lex(pTHX_ char pit)
2287           {
2288           start_force(PL_curforce);
2289 142444391         NEXTVAL_NEXTTOKE.ival = pit;
2290 142444391         force_next('p');
2291 142444391         }
2292            
2293           NV
2294 552         Perl_str_to_version(pTHX_ SV *sv)
2295           {
2296           NV retval = 0.0;
2297           NV nshift = 1.0;
2298           STRLEN len;
2299 552 50       const char *start = SvPV_const(sv,len);
2300 552         const char * const end = start + len;
2301 552         const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2302            
2303           PERL_ARGS_ASSERT_STR_TO_VERSION;
2304            
2305 2270 100       while (start < end) {
2306           STRLEN skip;
2307           UV n;
2308 1622 100       if (utf)
2309 36         n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2310           else {
2311 1586         n = *(U8*)start;
2312 1586         skip = 1;
2313           }
2314 1622         retval += ((NV)n)/nshift;
2315 1622         start += skip;
2316 1622         nshift *= 1000;
2317           }
2318 552         return retval;
2319           }
2320            
2321           /*
2322           * S_force_version
2323           * Forces the next token to be a version number.
2324           * If the next token appears to be an invalid version number, (e.g. "v2b"),
2325           * and if "guessing" is TRUE, then no new token is created (and the caller
2326           * must use an alternative parsing method).
2327           */
2328            
2329           STATIC char *
2330 4697200         S_force_version(pTHX_ char *s, int guessing)
2331           {
2332           dVAR;
2333           OP *version = NULL;
2334           char *d;
2335           #ifdef PERL_MAD
2336           I32 startoff = s - SvPVX(PL_linestr);
2337           #endif
2338            
2339           PERL_ARGS_ASSERT_FORCE_VERSION;
2340            
2341 4697200         s = SKIPSPACE1(s);
2342            
2343           d = s;
2344 4697200 100       if (*d == 'v')
2345 148         d++;
2346 4697200 100       if (isDIGIT(*d)) {
2347 1218624 100       while (isDIGIT(*d) || *d == '_' || *d == '.')
    100        
    100        
2348 1030870         d++;
2349           #ifdef PERL_MAD
2350           if (PL_madskills) {
2351           start_force(PL_curforce);
2352           curmad('X', newSVpvn(s,d-s));
2353           }
2354           #endif
2355 187754 100       if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
    100        
    50        
    100        
    50        
2356           SV *ver;
2357           #ifdef USE_LOCALE_NUMERIC
2358 187720         char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2359 187720         setlocale(LC_NUMERIC, "C");
2360           #endif
2361 187720         s = scan_num(s, &pl_yylval);
2362           #ifdef USE_LOCALE_NUMERIC
2363 187720         setlocale(LC_NUMERIC, loc);
2364 187720         Safefree(loc);
2365           #endif
2366 187720         version = pl_yylval.opval;
2367 187720         ver = cSVOPx(version)->op_sv;
2368 187816 100       if (SvPOK(ver) && !SvNIOK(ver)) {
    50        
2369 96         SvUPGRADE(ver, SVt_PVNV);
2370 552         SvNV_set(ver, str_to_version(ver));
2371 552         SvNOK_on(ver); /* hint that it is a version */
2372           }
2373           }
2374 34 50       else if (guessing) {
2375           #ifdef PERL_MAD
2376           if (PL_madskills) {
2377           sv_free(PL_nextwhite); /* let next token collect whitespace */
2378           PL_nextwhite = 0;
2379           s = SvPVX(PL_linestr) + startoff;
2380           }
2381           #endif
2382           return s;
2383           }
2384           }
2385            
2386           #ifdef PERL_MAD
2387           if (PL_madskills && !version) {
2388           sv_free(PL_nextwhite); /* let next token collect whitespace */
2389           PL_nextwhite = 0;
2390           s = SvPVX(PL_linestr) + startoff;
2391           }
2392           #endif
2393           /* NOTE: The parser sees the package name and the VERSION swapped */
2394           start_force(PL_curforce);
2395 4697200         NEXTVAL_NEXTTOKE.opval = version;
2396 4697200         force_next(WORD);
2397            
2398 4697200         return s;
2399           }
2400            
2401           /*
2402           * S_force_strict_version
2403           * Forces the next token to be a version number using strict syntax rules.
2404           */
2405            
2406           STATIC char *
2407 700686         S_force_strict_version(pTHX_ char *s)
2408           {
2409           dVAR;
2410           OP *version = NULL;
2411           #ifdef PERL_MAD
2412           I32 startoff = s - SvPVX(PL_linestr);
2413           #endif
2414 700686         const char *errstr = NULL;
2415            
2416           PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2417            
2418 1037351 50       while (isSPACE(*s)) /* leading whitespace */
2419 0         s++;
2420            
2421 700686 100       if (is_STRICT_VERSION(s,&errstr)) {
2422 88         SV *ver = newSV(0);
2423 88         s = (char *)scan_version(s, ver, 0);
2424 88         version = newSVOP(OP_CONST, 0, ver);
2425           }
2426 700854 100       else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
    50        
2427 256 50       (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2428           {
2429 128         PL_bufptr = s;
2430 128 50       if (errstr)
2431 128         yyerror(errstr); /* version required */
2432           return s;
2433           }
2434            
2435           #ifdef PERL_MAD
2436           if (PL_madskills && !version) {
2437           sv_free(PL_nextwhite); /* let next token collect whitespace */
2438           PL_nextwhite = 0;
2439           s = SvPVX(PL_linestr) + startoff;
2440           }
2441           #endif
2442           /* NOTE: The parser sees the package name and the VERSION swapped */
2443           start_force(PL_curforce);
2444 700558         NEXTVAL_NEXTTOKE.opval = version;
2445 700558         force_next(WORD);
2446            
2447 700622         return s;
2448           }
2449            
2450           /*
2451           * S_tokeq
2452           * Tokenize a quoted string passed in as an SV. It finds the next
2453           * chunk, up to end of string or a backslash. It may make a new
2454           * SV containing that chunk (if HINT_NEW_STRING is on). It also
2455           * turns \\ into \.
2456           */
2457            
2458           STATIC SV *
2459 46589553         S_tokeq(pTHX_ SV *sv)
2460           {
2461           dVAR;
2462           char *s;
2463           char *send;
2464           char *d;
2465 46589553         STRLEN len = 0;
2466           SV *pv = sv;
2467            
2468           PERL_ARGS_ASSERT_TOKEQ;
2469            
2470 46589553 50       if (!SvLEN(sv))
2471           goto finish;
2472            
2473 46589553 50       s = SvPV_force(sv, len);
2474 46589553 100       if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
    100        
2475           goto finish;
2476 46367387         send = s + len;
2477           /* This is relying on the SV being "well formed" with a trailing '\0' */
2478 443066293 100       while (s < send && !(*s == '\\' && s[1] == '\\'))
    100        
    100        
2479 374216179         s++;
2480 46367387 100       if (s == send)
2481           goto finish;
2482           d = s;
2483 208390 50       if ( PL_hints & HINT_NEW_STRING ) {
2484 107255         pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2485           }
2486 1425704 100       while (s < send) {
2487 1217314 100       if (*s == '\\') {
2488 253070 50       if (s + 1 < send && (s[1] == '\\'))
    100        
2489 231280         s++; /* all that, just for this */
2490           }
2491 1217314         *d++ = *s++;
2492           }
2493 208390         *d = '\0';
2494 208390         SvCUR_set(sv, d - SvPVX_const(sv));
2495           finish:
2496 46589553 100       if ( PL_hints & HINT_NEW_STRING )
2497 23996463         return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2498           return sv;
2499           }
2500            
2501           /*
2502           * Now come three functions related to double-quote context,
2503           * S_sublex_start, S_sublex_push, and S_sublex_done. They're used when
2504           * converting things like "\u\Lgnat" into ucfirst(lc("gnat")). They
2505           * interact with PL_lex_state, and create fake ( ... ) argument lists
2506           * to handle functions and concatenation.
2507           * For example,
2508           * "foo\lbar"
2509           * is tokenised as
2510           * stringify ( const[foo] concat lcfirst ( const[bar] ) )
2511           */
2512            
2513           /*
2514           * S_sublex_start
2515           * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2516           *
2517           * Pattern matching will set PL_lex_op to the pattern-matching op to
2518           * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2519           *
2520           * OP_CONST and OP_READLINE are easy--just make the new op and return.
2521           *
2522           * Everything else becomes a FUNC.
2523           *
2524           * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2525           * had an OP_CONST or OP_READLINE). This just sets us up for a
2526           * call to S_sublex_push().
2527           */
2528            
2529           STATIC I32
2530 53038691         S_sublex_start(pTHX)
2531           {
2532           dVAR;
2533 53038691         const I32 op_type = pl_yylval.ival;
2534            
2535 53038691 100       if (op_type == OP_NULL) {
2536 90680         pl_yylval.opval = PL_lex_op;
2537 90680         PL_lex_op = NULL;
2538 90680         return THING;
2539           }
2540 52948011 100       if (op_type == OP_CONST || op_type == OP_READLINE) {
2541 37751218         SV *sv = tokeq(PL_lex_stuff);
2542            
2543 37751218 100       if (SvTYPE(sv) == SVt_PVIV) {
2544           /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2545           STRLEN len;
2546 37751216 50       const char * const p = SvPV_const(sv, len);
2547 37751216         SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2548 37751216         SvREFCNT_dec(sv);
2549           sv = nsv;
2550           }
2551 37751218         pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2552 37751218         PL_lex_stuff = NULL;
2553           /* Allow // "foo" */
2554 37751218 50       if (op_type == OP_READLINE)
2555 0         PL_expect = XTERMORDORDOR;
2556           return THING;
2557           }
2558 15196793 100       else if (op_type == OP_BACKTICK && PL_lex_op) {
    100        
2559           /* readpipe() was overridden */
2560 8         cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2561 8         pl_yylval.opval = PL_lex_op;
2562 8         PL_lex_op = NULL;
2563 8         PL_lex_stuff = NULL;
2564 8         return THING;
2565           }
2566            
2567 15196785         PL_sublex_info.super_state = PL_lex_state;
2568 15196785         PL_sublex_info.sub_inwhat = (U16)op_type;
2569 15196785         PL_sublex_info.sub_op = PL_lex_op;
2570 15196785         PL_lex_state = LEX_INTERPPUSH;
2571            
2572 15196785         PL_expect = XTERM;
2573 15196785 100       if (PL_lex_op) {
2574 4846039         pl_yylval.opval = PL_lex_op;
2575 4846039         PL_lex_op = NULL;
2576 29691837         return PMFUNC;
2577           }
2578           else
2579           return FUNC;
2580           }
2581            
2582           /*
2583           * S_sublex_push
2584           * Create a new scope to save the lexing state. The scope will be
2585           * ended in S_sublex_done. Returns a '(', starting the function arguments
2586           * to the uc, lc, etc. found before.
2587           * Sets PL_lex_state to LEX_INTERPCONCAT.
2588           */
2589            
2590           STATIC I32
2591 15196785         S_sublex_push(pTHX)
2592           {
2593           dVAR;
2594           LEXSHARED *shared;
2595 15196785         const bool is_heredoc =
2596 15196785         CopLINE(PL_curcop) == (line_t)PL_multi_start - 1;
2597 15196785         ENTER;
2598            
2599           assert(CopLINE(PL_curcop) == (line_t)PL_multi_start
2600           || CopLINE(PL_curcop) == (line_t)PL_multi_start - 1);
2601            
2602 15196785         PL_lex_state = PL_sublex_info.super_state;
2603 15196785         SAVEBOOL(PL_lex_dojoin);
2604 15196785         SAVEI32(PL_lex_brackets);
2605 15196785         SAVEI32(PL_lex_allbrackets);
2606 15196785         SAVEI32(PL_lex_formbrack);
2607 15196785         SAVEI8(PL_lex_fakeeof);
2608 15196785         SAVEI32(PL_lex_casemods);
2609 15196785         SAVEI32(PL_lex_starts);
2610 15196785         SAVEI8(PL_lex_state);
2611 15196785         SAVESPTR(PL_lex_repl);
2612 15196785         SAVEVPTR(PL_lex_inpat);
2613 15196785         SAVEI16(PL_lex_inwhat);
2614 15196785 100       if (is_heredoc)
2615 134157         SAVECOPLINE(PL_curcop);
2616 15196785         SAVEPPTR(PL_bufptr);
2617 15196785         SAVEPPTR(PL_bufend);
2618 15196785         SAVEPPTR(PL_oldbufptr);
2619 15196785         SAVEPPTR(PL_oldoldbufptr);
2620 15196785         SAVEPPTR(PL_last_lop);
2621 15196785         SAVEPPTR(PL_last_uni);
2622 15196785         SAVEPPTR(PL_linestart);
2623 15196785         SAVESPTR(PL_linestr);
2624 15196785         SAVEGENERICPV(PL_lex_brackstack);
2625 15196785         SAVEGENERICPV(PL_lex_casestack);
2626 15196785         SAVEGENERICPV(PL_parser->lex_shared);
2627 15196785         SAVEBOOL(PL_parser->lex_re_reparsing);
2628 15196785         SAVEI32(PL_copline);
2629            
2630           /* The here-doc parser needs to be able to peek into outer lexing
2631           scopes to find the body of the here-doc. So we put PL_linestr and
2632           PL_bufptr into lex_shared, to ‘share’ those values.
2633           */
2634 15196785         PL_parser->lex_shared->ls_linestr = PL_linestr;
2635 15196785         PL_parser->lex_shared->ls_bufptr = PL_bufptr;
2636            
2637 15196785         PL_linestr = PL_lex_stuff;
2638 15196785         PL_lex_repl = PL_sublex_info.repl;
2639 15196785         PL_lex_stuff = NULL;
2640 15196785         PL_sublex_info.repl = NULL;
2641            
2642 15196785         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2643 15196785         = SvPVX(PL_linestr);
2644 15196785         PL_bufend += SvCUR(PL_linestr);
2645 15196785         PL_last_lop = PL_last_uni = NULL;
2646 15196785         SAVEFREESV(PL_linestr);
2647 15196785 100       if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2648            
2649 15196785         PL_lex_dojoin = FALSE;
2650 15196785         PL_lex_brackets = PL_lex_formbrack = 0;
2651 15196785         PL_lex_allbrackets = 0;
2652 15196785         PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2653 15196785         Newx(PL_lex_brackstack, 120, char);
2654 15196785         Newx(PL_lex_casestack, 12, char);
2655 15196785         PL_lex_casemods = 0;
2656 15196785         *PL_lex_casestack = '\0';
2657 15196785         PL_lex_starts = 0;
2658 15196785         PL_lex_state = LEX_INTERPCONCAT;
2659 15196785 100       if (is_heredoc)
2660 134157         CopLINE_inc(PL_curcop);
2661 15196785         PL_copline = NOLINE;
2662          
2663 15196785         Newxz(shared, 1, LEXSHARED);
2664 15196785         shared->ls_prev = PL_parser->lex_shared;
2665 15196785         PL_parser->lex_shared = shared;
2666 15196785 100       if (!is_heredoc && PL_multi_start != PL_multi_end) {
    100        
2667 282217         shared->herelines = shared->ls_prev->herelines;
2668 282217         shared->ls_prev->herelines = 0;
2669           }
2670            
2671 15196785         PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2672 15196785 100       if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2673 15196785 100       if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2674 4736789         PL_lex_inpat = PL_sublex_info.sub_op;
2675           else
2676 10459996         PL_lex_inpat = NULL;
2677            
2678 15196785         PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2679 15196785         PL_in_eval &= ~EVAL_RE_REPARSING;
2680            
2681 15196785         return '(';
2682           }
2683            
2684           /*
2685           * S_sublex_done
2686           * Restores lexer state after a S_sublex_push.
2687           */
2688            
2689           STATIC I32
2690 17555602         S_sublex_done(pTHX)
2691           {
2692           dVAR;
2693 17555602 100       if (!PL_lex_starts++) {
2694 730414         SV * const sv = newSVpvs("");
2695 730414 100       if (SvUTF8(PL_linestr))
2696 2         SvUTF8_on(sv);
2697 730414         PL_expect = XOPERATOR;
2698 730414         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2699 730414         return THING;
2700           }
2701            
2702 16825188 100       if (PL_lex_casemods) { /* oops, we've got some unbalanced parens */
2703 31382         PL_lex_state = LEX_INTERPCASEMOD;
2704 31382         return yylex();
2705           }
2706            
2707           /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2708           assert(PL_lex_inwhat != OP_TRANSR);
2709 16793806 100       if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
    50        
2710 1597241         PL_linestr = PL_lex_repl;
2711 1597241         PL_lex_inpat = 0;
2712 1597241         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2713 1597241         PL_bufend += SvCUR(PL_linestr);
2714 1597241         PL_last_lop = PL_last_uni = NULL;
2715 1597241         PL_lex_dojoin = FALSE;
2716 1597241         PL_lex_brackets = 0;
2717 1597241         PL_lex_allbrackets = 0;
2718 1597241         PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2719 1597241         PL_lex_casemods = 0;
2720 1597241         *PL_lex_casestack = '\0';
2721 1597241         PL_lex_starts = 0;
2722 1597241 100       if (SvEVALED(PL_lex_repl)) {
2723 175369         PL_lex_state = LEX_INTERPNORMAL;
2724 175369         PL_lex_starts++;
2725           /* we don't clear PL_lex_repl here, so that we can check later
2726           whether this is an evalled subst; that means we rely on the
2727           logic to ensure sublex_done() is called again only via the
2728           branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2729           }
2730           else {
2731 1421872         PL_lex_state = LEX_INTERPCONCAT;
2732 1421872         PL_lex_repl = NULL;
2733           }
2734 1597241 100       if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2735 56570         CopLINE(PL_curcop) +=
2736 28285         ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2737 28285         + PL_parser->lex_shared->herelines;
2738 28285         PL_parser->lex_shared->herelines = 0;
2739           }
2740           return ',';
2741           }
2742           else {
2743           #ifdef PERL_MAD
2744           if (PL_madskills) {
2745           if (PL_thiswhite) {
2746           if (!PL_endwhite)
2747           PL_endwhite = newSVpvs("");
2748           sv_catsv(PL_endwhite, PL_thiswhite);
2749           PL_thiswhite = 0;
2750           }
2751           if (PL_thistoken)
2752           sv_setpvs(PL_thistoken,"");
2753           else
2754           PL_realtokenstart = -1;
2755           }
2756           #endif
2757 15196565         LEAVE;
2758 15196565         PL_bufend = SvPVX(PL_linestr);
2759 15196565         PL_bufend += SvCUR(PL_linestr);
2760 15196565         PL_expect = XOPERATOR;
2761 15196565         PL_sublex_info.sub_inwhat = 0;
2762 16420353         return ')';
2763           }
2764           }
2765            
2766           PERL_STATIC_INLINE SV*
2767 2578         S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2768           {
2769           /* points to first character of interior of \N{}, to one beyond the
2770           * interior, hence to the "}". Finds what the name resolves to, returning
2771           * an SV* containing it; NULL if no valid one found */
2772            
2773 2578 50       SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
    100        
    50        
    50        
    100        
2774            
2775           HV * table;
2776           SV **cvp;
2777           SV *cv;
2778           SV *rv;
2779           HV *stash;
2780           const U8* first_bad_char_loc;
2781 2578         const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2782            
2783           PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2784            
2785 2578 50       if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
    100        
    50        
    50        
    100        
    100        
2786           e - backslash_ptr,
2787           &first_bad_char_loc))
2788           {
2789           /* If warnings are on, this will print a more detailed analysis of what
2790           * is wrong than the error message below */
2791 2         utf8n_to_uvchr(first_bad_char_loc,
2792           e - ((char *) first_bad_char_loc),
2793           NULL, 0);
2794            
2795           /* We deliberately don't try to print the malformed character, which
2796           * might not print very well; it also may be just the first of many
2797           * malformations, so don't print what comes after it */
2798 2         yyerror(Perl_form(aTHX_
2799           "Malformed UTF-8 character immediately after '%.*s'",
2800           (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2801 2         return NULL;
2802           }
2803            
2804 2576         res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2805           /* include the <}> */
2806           e - backslash_ptr + 1);
2807 2572 100       if (! SvPOK(res)) {
2808           SvREFCNT_dec_NN(res);
2809           return NULL;
2810           }
2811            
2812           /* See if the charnames handler is the Perl core's, and if so, we can skip
2813           * the validation needed for a user-supplied one, as Perl's does its own
2814           * validation. */
2815 2462         table = GvHV(PL_hintgv); /* ^H */
2816 2462         cvp = hv_fetchs(table, "charnames", FALSE);
2817 2462 100       if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
    50        
    100        
    50        
2818 2456 100       && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
    50        
2819           {
2820 2454 50       const char * const name = HvNAME(stash);
    50        
    50        
    0        
    50        
    50        
2821 2454 100       if strEQ(name, "_charnames") {
2822           return res;
2823           }
2824           }
2825            
2826           /* Here, it isn't Perl's charname handler. We can't rely on a
2827           * user-supplied handler to validate the input name. For non-ut8 input,
2828           * look to see that the first character is legal. Then loop through the
2829           * rest checking that each is a continuation */
2830            
2831           /* This code needs to be sync'ed with a regex in _charnames.pm which does
2832           * the same thing */
2833            
2834 100 50       if (! UTF) {
    100        
    50        
    50        
    100        
2835 72 100       if (! isALPHAU(*s)) {
2836           goto bad_charname;
2837           }
2838 70         s++;
2839 561 100       while (s < e) {
2840 462 100       if (! isCHARNAME_CONT(*s)) {
2841           goto bad_charname;
2842           }
2843 458 100       if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
    100        
    100        
2844 6         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2845           "A sequence of multiple spaces in a charnames "
2846           "alias definition is deprecated");
2847           }
2848 456         s++;
2849           }
2850 64 100       if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
    100        
2851 6         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2852           "Trailing white-space in a charnames alias "
2853           "definition is deprecated");
2854           }
2855           }
2856           else {
2857           /* Similarly for utf8. For invariants can check directly; for other
2858           * Latin1, can calculate their code point and check; otherwise use a
2859           * swash */
2860 28 100       if (UTF8_IS_INVARIANT(*s)) {
2861 24 100       if (! isALPHAU(*s)) {
2862           goto bad_charname;
2863           }
2864 23         s++;
2865 4 50       } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2866 0 0       if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
    0        
2867           goto bad_charname;
2868           }
2869 0         s += 2;
2870           }
2871           else {
2872 4 100       if (! PL_utf8_charname_begin) {
2873 2         U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2874 2         PL_utf8_charname_begin = _core_swash_init("utf8",
2875           "_Perl_Charname_Begin",
2876           &PL_sv_undef,
2877           1, 0, NULL, &flags);
2878           }
2879 4 100       if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2880           goto bad_charname;
2881           }
2882 2         s += UTF8SKIP(s);
2883           }
2884            
2885 260 100       while (s < e) {
2886 244 100       if (UTF8_IS_INVARIANT(*s)) {
2887 238 100       if (! isCHARNAME_CONT(*s)) {
2888           goto bad_charname;
2889           }
2890 236 100       if (*s == ' ' && *(s-1) == ' '
    100        
2891 8 100       && ckWARN_d(WARN_DEPRECATED)) {
2892 6         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2893           "A sequence of multiple spaces in a charnam"
2894           "es alias definition is deprecated");
2895           }
2896 234         s++;
2897           }
2898 6 100       else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2899 2 50       if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
    50        
2900           {
2901           goto bad_charname;
2902           }
2903 0         s += 2;
2904           }
2905           else {
2906 4 100       if (! PL_utf8_charname_continue) {
2907 2         U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2908 2         PL_utf8_charname_continue = _core_swash_init("utf8",
2909           "_Perl_Charname_Continue",
2910           &PL_sv_undef,
2911           1, 0, NULL, &flags);
2912           }
2913 4 100       if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2914           goto bad_charname;
2915           }
2916 119         s += UTF8SKIP(s);
2917           }
2918           }
2919 16 100       if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
    100        
2920 6         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2921           "Trailing white-space in a charnames alias "
2922           "definition is deprecated");
2923           }
2924           }
2925            
2926 76 100       if (SvUTF8(res)) { /* Don't accept malformed input */
2927           const U8* first_bad_char_loc;
2928           STRLEN len;
2929 16 50       const char* const str = SvPV_const(res, len);
2930 16 100       if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2931           /* If warnings are on, this will print a more detailed analysis of
2932           * what is wrong than the error message below */
2933 2         utf8n_to_uvchr(first_bad_char_loc,
2934           (char *) first_bad_char_loc - str,
2935           NULL, 0);
2936            
2937           /* We deliberately don't try to print the malformed character,
2938           * which might not print very well; it also may be just the first
2939           * of many malformations, so don't print what comes after it */
2940 2         yyerror_pv(
2941           Perl_form(aTHX_
2942           "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2943           (int) (e - backslash_ptr + 1), backslash_ptr,
2944           (int) ((char *) first_bad_char_loc - str), str
2945           ),
2946           SVf_UTF8);
2947 2         return NULL;
2948           }
2949           }
2950            
2951           return res;
2952            
2953           bad_charname: {
2954 16 50       int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
    100        
    50        
    50        
    100        
2955            
2956           /* The final %.*s makes sure that should the trailing NUL be missing
2957           * that this print won't run off the end of the string */
2958 16 50       yyerror_pv(
    100        
    50        
    50        
    100        
2959           Perl_form(aTHX_
2960           "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2961           (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2962           (int)(e - s + bad_char_size), s + bad_char_size
2963           ),
2964           UTF ? SVf_UTF8 : 0);
2965 1291         return NULL;
2966           }
2967           }
2968            
2969           /*
2970           scan_const
2971            
2972           Extracts the next constant part of a pattern, double-quoted string,
2973           or transliteration. This is terrifying code.
2974            
2975           For example, in parsing the double-quoted string "ab\x63$d", it would
2976           stop at the '$' and return an OP_CONST containing 'abc'.
2977            
2978           It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2979           processing a pattern (PL_lex_inpat is true), a transliteration
2980           (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2981            
2982           Returns a pointer to the character scanned up to. If this is
2983           advanced from the start pointer supplied (i.e. if anything was
2984           successfully parsed), will leave an OP_CONST for the substring scanned
2985           in pl_yylval. Caller must intuit reason for not parsing further
2986           by looking at the next characters herself.
2987            
2988           In patterns:
2989           expand:
2990           \N{FOO} => \N{U+hex_for_character_FOO}
2991           (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2992            
2993           pass through:
2994           all other \-char, including \N and \N{ apart from \N{ABC}
2995            
2996           stops on:
2997           @ and $ where it appears to be a var, but not for $ as tail anchor
2998           \l \L \u \U \Q \E
2999           (?{ or (??{
3000            
3001            
3002           In transliterations:
3003           characters are VERY literal, except for - not at the start or end
3004           of the string, which indicates a range. If the range is in bytes,
3005           scan_const expands the range to the full set of intermediate
3006           characters. If the range is in utf8, the hyphen is replaced with
3007           a certain range mark which will be handled by pmtrans() in op.c.
3008            
3009           In double-quoted strings:
3010           backslashes:
3011           double-quoted style: \r and \n
3012           constants: \x31, etc.
3013           deprecated backrefs: \1 (in substitution replacements)
3014           case and quoting: \U \Q \E
3015           stops on @ and $
3016            
3017           scan_const does *not* construct ops to handle interpolated strings.
3018           It stops processing as soon as it finds an embedded $ or @ variable
3019           and leaves it to the caller to work out what's going on.
3020            
3021           embedded arrays (whether in pattern or not) could be:
3022           @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
3023            
3024           $ in double-quoted strings must be the symbol of an embedded scalar.
3025            
3026           $ in pattern could be $foo or could be tail anchor. Assumption:
3027           it's a tail anchor if $ is the last thing in the string, or if it's
3028           followed by one of "()| \r\n\t"
3029            
3030           \1 (backreferences) are turned into $1 in substitutions
3031            
3032           The structure of the code is
3033           while (there's a character to process) {
3034           handle transliteration ranges
3035           skip regexp comments /(?#comment)/ and codes /(?{code})/
3036           skip #-initiated comments in //x patterns
3037           check for embedded arrays
3038           check for embedded scalars
3039           if (backslash) {
3040           deprecate \1 in substitution replacements
3041           handle string-changing backslashes \l \U \Q \E, etc.
3042           switch (what was escaped) {
3043           handle \- in a transliteration (becomes a literal -)
3044           if a pattern and not \N{, go treat as regular character
3045           handle \132 (octal characters)
3046           handle \x15 and \x{1234} (hex characters)
3047           handle \N{name} (named characters, also \N{3,5} in a pattern)
3048           handle \cV (control characters)
3049           handle printf-style backslashes (\f, \r, \n, etc)
3050           } (end switch)
3051           continue
3052           } (end if backslash)
3053           handle regular character
3054           } (end while character to read)
3055          
3056           */
3057            
3058           STATIC char *
3059 22710265         S_scan_const(pTHX_ char *start)
3060           {
3061           dVAR;
3062 22710265         char *send = PL_bufend; /* end of the constant */
3063 22710265         SV *sv = newSV(send - start); /* sv for the constant. See
3064           note below on sizing. */
3065 22710265         char *s = start; /* start of the constant */
3066 22710265         char *d = SvPVX(sv); /* destination for copies */
3067           bool dorange = FALSE; /* are we in a translit range? */
3068           bool didrange = FALSE; /* did we just finish a range? */
3069           bool in_charclass = FALSE; /* within /[...]/ */
3070           bool has_utf8 = FALSE; /* Output constant is UTF8 */
3071 22710265 50       bool this_utf8 = cBOOL(UTF); /* Is the source string assumed
    100        
    50        
    100        
    100        
3072           to be UTF8? But, this can
3073           show as true when the source
3074           isn't utf8, as for example
3075           when it is entirely composed
3076           of hex constants */
3077           SV *res; /* result from charnames */
3078            
3079           /* Note on sizing: The scanned constant is placed into sv, which is
3080           * initialized by newSV() assuming one byte of output for every byte of
3081           * input. This routine expects newSV() to allocate an extra byte for a
3082           * trailing NUL, which this routine will append if it gets to the end of
3083           * the input. There may be more bytes of input than output (eg., \N{LATIN
3084           * CAPITAL LETTER A}), or more output than input if the constant ends up
3085           * recoded to utf8, but each time a construct is found that might increase
3086           * the needed size, SvGROW() is called. Its size parameter each time is
3087           * based on the best guess estimate at the time, namely the length used so
3088           * far, plus the length the current construct will occupy, plus room for
3089           * the trailing NUL, plus one byte for every input byte still unscanned */
3090            
3091 22710265         UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
3092           before set */
3093           #ifdef EBCDIC
3094           UV literal_endpoint = 0;
3095           bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
3096           #endif
3097            
3098           PERL_ARGS_ASSERT_SCAN_CONST;
3099            
3100           assert(PL_lex_inwhat != OP_TRANSR);
3101 22710265 100       if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
    50        
3102           /* If we are doing a trans and we know we want UTF8 set expectation */
3103 135970         has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
3104 135970 100       this_utf8 = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3105           }
3106            
3107           /* Protect sv from errors and fatal warnings. */
3108 22710265         ENTER_with_name("scan_const");
3109 22710265         SAVEFREESV(sv);
3110            
3111 258448946 100       while (s < send || dorange) {
    100        
3112            
3113           /* get transliterations out of the way (they're most literal) */
3114 234247528 100       if (PL_lex_inwhat == OP_TRANS) {
3115           /* expand a range A-Z to the full set of characters. AIE! */
3116 327926 100       if (dorange) {
3117           I32 i; /* current expanded character */
3118           I32 min; /* first character in range */
3119           I32 max; /* last character in range */
3120            
3121           #ifdef EBCDIC
3122           UV uvmax = 0;
3123           #endif
3124            
3125 58448 100       if (has_utf8
3126           #ifdef EBCDIC
3127           && !native_range
3128           #endif
3129           ) {
3130 8         char * const c = (char*)utf8_hop((U8*)d, -1);
3131 8         char *e = d++;
3132 30 100       while (e-- > c)
3133 18         *(e + 1) = *e;
3134 8         *c = (char) ILLEGAL_UTF8_BYTE;
3135           /* mark the range as done, and continue */
3136           dorange = FALSE;
3137           didrange = TRUE;
3138 8         continue;
3139           }
3140            
3141 58440         i = d - SvPVX_const(sv); /* remember current offset */
3142           #ifdef EBCDIC
3143           SvGROW(sv,
3144           SvLEN(sv) + (has_utf8 ?
3145           (512 - UTF_CONTINUATION_MARK +
3146           UNISKIP(0x100))
3147           : 256));
3148           /* How many two-byte within 0..255: 128 in UTF-8,
3149           * 96 in UTF-8-mod. */
3150           #else
3151 58440 50       SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */
    50        
3152           #endif
3153 58440         d = SvPVX(sv) + i; /* refresh d after realloc */
3154           #ifdef EBCDIC
3155           if (has_utf8) {
3156           int j;
3157           for (j = 0; j <= 1; j++) {
3158           char * const c = (char*)utf8_hop((U8*)d, -1);
3159           const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3160           if (j)
3161           min = (U8)uv;
3162           else if (uv < 256)
3163           max = (U8)uv;
3164           else {
3165           max = (U8)0xff; /* only to \xff */
3166           uvmax = uv; /* \x{100} to uvmax */
3167           }
3168           d = c; /* eat endpoint chars */
3169           }
3170           }
3171           else {
3172           #endif
3173 58440         d -= 2; /* eat the first char and the - */
3174 58440         min = (U8)*d; /* first char in range */
3175 58440         max = (U8)d[1]; /* last char in range */
3176           #ifdef EBCDIC
3177           }
3178           #endif
3179            
3180 58440 100       if (min > max) {
3181 9         Perl_croak(aTHX_
3182           "Invalid range \"%c-%c\" in transliteration operator",
3183 12         (char)min, (char)max);
3184           }
3185            
3186           #ifdef EBCDIC
3187           if (literal_endpoint == 2 &&
3188           ((isLOWER_A(min) && isLOWER_A(max)) ||
3189           (isUPPER_A(min) && isUPPER_A(max))))
3190           {
3191           for (i = min; i <= max; i++) {
3192           if (isALPHA_A(i))
3193           *d++ = i;
3194           }
3195           }
3196           else
3197           #endif
3198 2732291 100       for (i = min; i <= max; i++)
3199           #ifdef EBCDIC
3200           if (has_utf8) {
3201           append_utf8_from_native_byte(i, &d);
3202           }
3203           else
3204           #endif
3205 2701994         *d++ = (char)i;
3206          
3207           #ifdef EBCDIC
3208           if (uvmax) {
3209           d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3210           if (uvmax > 0x101)
3211           *d++ = (char) ILLEGAL_UTF8_BYTE;
3212           if (uvmax > 0x100)
3213           d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3214           }
3215           #endif
3216            
3217           /* mark the range as done, and continue */
3218           dorange = FALSE;
3219           didrange = TRUE;
3220           #ifdef EBCDIC
3221           literal_endpoint = 0;
3222           #endif
3223 58434         continue;
3224           }
3225            
3226           /* range begins (ignore - as first or last char) */
3227 269478 100       else if (*s == '-' && s+1 < send && s != start) {
    100        
3228 58540 100       if (didrange) {
3229 6         Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3230           }
3231 58534 100       if (has_utf8
3232           #ifdef EBCDIC
3233           && !native_range
3234           #endif
3235           ) {
3236 86         *d++ = (char) ILLEGAL_UTF8_BYTE; /* use illegal utf8 byte--see pmtrans */
3237 86         s++;
3238 86         continue;
3239           }
3240           dorange = TRUE;
3241 58448         s++;
3242           }
3243           else {
3244           didrange = FALSE;
3245           #ifdef EBCDIC
3246           literal_endpoint = 0;
3247           native_range = TRUE;
3248           #endif
3249           }
3250           }
3251            
3252           /* if we get here, we're not doing a transliteration */
3253            
3254 233919602 100       else if (*s == '[' && PL_lex_inpat && !in_charclass) {
    100        
    100        
3255 1812839         char *s1 = s-1;
3256           int esc = 0;
3257 2721771 100       while (s1 >= start && *s1-- == '\\')
    100        
3258 41752         esc = !esc;
3259 1812839 100       if (!esc)
3260           in_charclass = TRUE;
3261           }
3262            
3263 232106763 100       else if (*s == ']' && PL_lex_inpat && in_charclass) {
    100        
    100        
3264 1807945         char *s1 = s-1;
3265           int esc = 0;
3266 2882018 50       while (s1 >= start && *s1-- == '\\')
    100        
3267 209340         esc = !esc;
3268 1807945 100       if (!esc)
3269           in_charclass = FALSE;
3270           }
3271            
3272           /* skip for regexp comments /(?#comment)/, except for the last
3273           * char, which will be done separately.
3274           * Stop on (?{..}) and friends */
3275            
3276 230298818 100       else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
    100        
    100        
    100        
3277 791588 100       if (s[2] == '#') {
3278 3048 100       while (s+1 < send && *s != ')')
    100        
3279 2608         *d++ = *s++;
3280           }
3281 1173025 100       else if (!PL_lex_casemods &&
    100        
3282 791112         ( s[2] == '{' /* This should match regcomp.c */
3283 788696 100       || (s[2] == '?' && s[3] == '{')))
    50        
3284           {
3285           break;
3286           }
3287           }
3288            
3289           /* likewise skip #-initiated comments in //x patterns */
3290 229616858 100       else if (*s == '#' && PL_lex_inpat && !in_charclass &&
    100        
    100        
    100        
3291 232936         ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3292 4351078 100       while (s+1 < send && *s != '\n')
    100        
3293 4146494         *d++ = *s++;
3294           }
3295            
3296           /* no further processing of single-quoted regex */
3297 229302646 100       else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
    100        
3298           goto default_action;
3299            
3300           /* check for embedded arrays
3301           (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3302           */
3303 228531966 100       else if (*s == '@' && s[1]) {
    100        
3304 248862 100       if (isWORDCHAR_lazy_if(s+1,UTF))
    50        
    100        
    50        
    50        
    100        
    50        
    0        
    0        
    0        
    100        
3305           break;
3306 64220 100       if (strchr(":'{$", s[1]))
3307           break;
3308 37642 100       if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
    100        
3309           break; /* in regexp, neither @+ nor @- are interpolated */
3310           }
3311            
3312           /* check for embedded scalars. only stop if we're sure it's a
3313           variable.
3314           */
3315 228283104 100       else if (*s == '$') {
3316 10113463 100       if (!PL_lex_inpat) /* not a regexp, so $ must be var */
3317           break;
3318 1486465 100       if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
    100        
3319 405558 100       if (s[1] == '\\') {
3320 12         Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3321           "Possible unintended interpolation of $\\ in regex");
3322           }
3323           break; /* in regexp, $ might be tail anchor */
3324           }
3325           }
3326            
3327           /* End of else if chain - OP_TRANS rejoin rest */
3328            
3329           /* backslashes */
3330 224163272 100       if (*s == '\\' && s+1 < send) {
    100        
3331           char* e; /* Can be used for ending '}', etc. */
3332            
3333 44060493         s++;
3334            
3335           /* warn on \1 - \9 in substitution replacements, but note that \11
3336           * is an octal; and \19 is \1 followed by '9' */
3337 44255036 100       if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
    100        
    100        
3338 198671 100       isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
    100        
3339           {
3340 10         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3341 6         *--s = '$';
3342 6         break;
3343           }
3344            
3345           /* string-change backslash escapes */
3346 44060483 100       if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
    100        
    100        
3347 200626         --s;
3348 200626         break;
3349           }
3350           /* In a pattern, process \N, but skip any other backslash escapes.
3351           * This is because we don't want to translate an escape sequence
3352           * into a meta symbol and have the regex compiler use the meta
3353           * symbol meaning, e.g. \x{2E} would be confused with a dot. But
3354           * in spite of this, we do have to process \N here while the proper
3355           * charnames handler is in scope. See bugs #56444 and #62056.
3356           * There is a complication because \N in a pattern may also stand
3357           * for 'match a non-nl', and not mean a charname, in which case its
3358           * processing should be deferred to the regex compiler. To be a
3359           * charname it must be followed immediately by a '{', and not look
3360           * like \N followed by a curly quantifier, i.e., not something like
3361           * \N{3,}. regcurly returns a boolean indicating if it is a legal
3362           * quantifier */
3363 43859857 100       else if (PL_lex_inpat
3364 5740825 100       && (*s != 'N'
3365 1068 100       || s[1] != '{'
3366 590 100       || regcurly(s + 1, FALSE)))
3367           {
3368 5740239         *d++ = '\\';
3369 5740239         goto default_action;
3370           }
3371            
3372 38119618         switch (*s) {
3373            
3374           /* quoted - in transliterations */
3375           case '-':
3376 5306 100       if (PL_lex_inwhat == OP_TRANS) {
3377 532         *d++ = *s++;
3378 532         continue;
3379           }
3380           /* FALL THROUGH */
3381           default:
3382           {
3383 1678285 100       if ((isALPHANUMERIC(*s)))
3384 10         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3385           "Unrecognized escape \\%c passed through",
3386 10         *s);
3387           /* default action is to copy the quoted character */
3388           goto default_action;
3389           }
3390            
3391           /* eg. \132 indicates the octal constant 0132 */
3392           case '0': case '1': case '2': case '3':
3393           case '4': case '5': case '6': case '7':
3394           {
3395 317094         I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3396 317094         STRLEN len = 3;
3397 317094         uv = grok_oct(s, &len, &flags, NULL);
3398 317094         s += len;
3399 317094 100       if (len < 3 && s < send && isDIGIT(*s)
    50        
3400 0 0       && ckWARN(WARN_MISC))
3401           {
3402 0         Perl_warner(aTHX_ packWARN(WARN_MISC),
3403           "%s", form_short_octal_warning(s, len));
3404           }
3405           }
3406           goto NUM_ESCAPE_INSERT;
3407            
3408           /* eg. \o{24} indicates the octal constant \024 */
3409           case 'o':
3410           {
3411           const char* error;
3412            
3413 64 50       bool valid = grok_bslash_o(&s, &uv, &error,
    50        
    0        
    50        
    50        
3414           TRUE, /* Output warning */
3415           FALSE, /* Not strict */
3416           TRUE, /* Output warnings for
3417           non-portables */
3418           UTF);
3419 60 100       if (! valid) {
3420 50         yyerror(error);
3421 46         continue;
3422           }
3423           goto NUM_ESCAPE_INSERT;
3424           }
3425            
3426           /* eg. \x24 indicates the hex constant 0x24 */
3427           case 'x':
3428           {
3429           const char* error;
3430            
3431           bool valid = grok_bslash_x(&s, &uv, &error,
3432           TRUE, /* Output warning */
3433           FALSE, /* Not strict */
3434           TRUE, /* Output warnings for
3435           non-portables */
3436           UTF);
3437 32465268 100       if (! valid) {
3438 42         yyerror(error);
3439 38         continue;
3440           }
3441           }
3442            
3443           NUM_ESCAPE_INSERT:
3444           /* Insert oct or hex escaped character. There will always be
3445           * enough room in sv since such escapes will be longer than any
3446           * UTF-8 sequence they can end up as, except if they force us
3447           * to recode the rest of the string into utf8 */
3448          
3449           /* Here uv is the ordinal of the next character being added */
3450 32782330 100       if (!NATIVE_IS_INVARIANT(uv)) {
3451 1122234 100       if (!has_utf8 && uv > 255) {
    100        
3452           /* Might need to recode whatever we have accumulated so
3453           * far if it contains any chars variant in utf8 or
3454           * utf-ebcdic. */
3455          
3456 264432         SvCUR_set(sv, d - SvPVX_const(sv));
3457 264432         SvPOK_on(sv);
3458 264432         *d = '\0';
3459           /* See Note on sizing above. */
3460 264432 50       sv_utf8_upgrade_flags_grow(sv,
    100        
    100        
    100        
    100        
    50        
    100        
3461           SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3462           UNISKIP(uv) + (STRLEN)(send - s) + 1);
3463 264432         d = SvPVX(sv) + SvCUR(sv);
3464           has_utf8 = TRUE;
3465           }
3466            
3467 1122234 100       if (has_utf8) {
3468 300990         d = (char*)uvchr_to_utf8((U8*)d, uv);
3469 301066 100       if (PL_lex_inwhat == OP_TRANS &&
    50        
3470 152         PL_sublex_info.sub_op) {
3471 228 100       PL_sublex_info.sub_op->op_private |=
3472 152         (PL_lex_repl ? OPpTRANS_FROM_UTF
3473           : OPpTRANS_TO_UTF);
3474           }
3475           #ifdef EBCDIC
3476           if (uv > 255 && !dorange)
3477           native_range = FALSE;
3478           #endif
3479           }
3480           else {
3481 821244         *d++ = (char)uv;
3482           }
3483           }
3484           else {
3485 31660096         *d++ = (char) uv;
3486           }
3487 32782330         continue;
3488            
3489           case 'N':
3490           /* In a non-pattern \N must be a named character, like \N{LATIN
3491           * SMALL LETTER A} or \N{U+0041}. For patterns, it also can
3492           * mean to match a non-newline. For non-patterns, named
3493           * characters are converted to their string equivalents. In
3494           * patterns, named characters are not converted to their
3495           * ultimate forms for the same reasons that other escapes
3496           * aren't. Instead, they are converted to the \N{U+...} form
3497           * to get the value from the charnames that is in effect right
3498           * now, while preserving the fact that it was a named character
3499           * so that the regex compiler knows this */
3500            
3501           /* The structure of this section of code (besides checking for
3502           * errors and upgrading to utf8) is:
3503           * Further disambiguate between the two meanings of \N, and if
3504           * not a charname, go process it elsewhere
3505           * If of form \N{U+...}, pass it through if a pattern;
3506           * otherwise convert to utf8
3507           * Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3508           * pattern; otherwise convert to utf8 */
3509            
3510           /* Here, s points to the 'N'; the test below is guaranteed to
3511           * succeed if we are being called on a pattern as we already
3512           * know from a test above that the next character is a '{'.
3513           * On a non-pattern \N must mean 'named sequence, which
3514           * requires braces */
3515 3180         s++;
3516 3180 100       if (*s != '{') {
3517 42         yyerror("Missing braces on \\N{}");
3518 38         continue;
3519           }
3520 3138         s++;
3521            
3522           /* If there is no matching '}', it is an error. */
3523 3138 100       if (! (e = strchr(s, '}'))) {
3524 56 100       if (! PL_lex_inpat) {
3525 42         yyerror("Missing right brace on \\N{}");
3526           } else {
3527 14         yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3528           }
3529 52         continue;
3530           }
3531            
3532           /* Here it looks like a named character */
3533            
3534 3082 100       if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
    100        
3535 504         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3536           | PERL_SCAN_DISALLOW_PREFIX;
3537           STRLEN len;
3538            
3539           /* For \N{U+...}, the '...' is a unicode value even on
3540           * EBCDIC machines */
3541 504         s += 2; /* Skip to next char after the 'U+' */
3542 504         len = e - s;
3543 504         uv = grok_hex(s, &len, &flags, NULL);
3544 448 100       if (len == 0 || len != (STRLEN)(e - s)) {
    50        
3545 82         yyerror("Invalid hexadecimal number in \\N{U+...}");
3546 78         s = e + 1;
3547 78         continue;
3548           }
3549            
3550 366 100       if (PL_lex_inpat) {
3551            
3552           /* On non-EBCDIC platforms, pass through to the regex
3553           * compiler unchanged. The reason we evaluated the
3554           * number above is to make sure there wasn't a syntax
3555           * error. But on EBCDIC we convert to native so
3556           * downstream code can continue to assume it's native
3557           */
3558 284         s -= 5; /* Include the '\N{U+' */
3559           #ifdef EBCDIC
3560           d += my_snprintf(d, e - s + 1 + 1, /* includes the }
3561           and the \0 */
3562           "\\N{U+%X}",
3563           (unsigned int) UNI_TO_NATIVE(uv));
3564           #else
3565 284         Copy(s, d, e - s + 1, char); /* 1 = include the } */
3566 284         d += e - s + 1;
3567           #endif
3568           }
3569           else { /* Not a pattern: convert the hex to string */
3570            
3571           /* If destination is not in utf8, unconditionally
3572           * recode it to be so. This is because \N{} implies
3573           * Unicode semantics, and scalars have to be in utf8
3574           * to guarantee those semantics */
3575 82 100       if (! has_utf8) {
3576 56         SvCUR_set(sv, d - SvPVX_const(sv));
3577 56         SvPOK_on(sv);
3578 56         *d = '\0';
3579           /* See Note on sizing above. */
3580 56 50       sv_utf8_upgrade_flags_grow(
    100        
    100        
    50        
    0        
    0        
    0        
3581           sv,
3582           SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3583           UNISKIP(uv) + (STRLEN)(send - e) + 1);
3584 56         d = SvPVX(sv) + SvCUR(sv);
3585           has_utf8 = TRUE;
3586           }
3587            
3588           /* Add the (Unicode) code point to the output. */
3589 82 100       if (UNI_IS_INVARIANT(uv)) {
3590 8         *d++ = (char) LATIN1_TO_NATIVE(uv);
3591           }
3592           else {
3593 74         d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3594           }
3595           }
3596           }
3597           else /* Here is \N{NAME} but not \N{U+...}. */
3598 2578 100       if ((res = get_and_check_backslash_N_name(s, e)))
3599           {
3600           STRLEN len;
3601 2436 50       const char *str = SvPV_const(res, len);
3602 2436 100       if (PL_lex_inpat) {
3603            
3604 172 100       if (! len) { /* The name resolved to an empty string */
3605 12         Copy("\\N{}", d, 4, char);
3606 12         d += 4;
3607           }
3608           else {
3609           /* In order to not lose information for the regex
3610           * compiler, pass the result in the specially made
3611           * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3612           * the code points in hex of each character
3613           * returned by charnames */
3614            
3615 160         const char *str_end = str + len;
3616 160         const STRLEN off = d - SvPVX_const(sv);
3617            
3618 160 100       if (! SvUTF8(res)) {
3619           /* For the non-UTF-8 case, we can determine the
3620           * exact length needed without having to parse
3621           * through the string. Each character takes up
3622           * 2 hex digits plus either a trailing dot or
3623           * the "}" */
3624 22 50       d = off + SvGROW(sv, off
    100        
3625           + 3 * len
3626           + 6 /* For the "\N{U+", and
3627           trailing NUL */
3628           + (STRLEN)(send - e));
3629 22         Copy("\\N{U+", d, 5, char);
3630 22         d += 5;
3631 1603 100       while (str < str_end) {
3632           char hex_string[4];
3633 2355 50       my_snprintf(hex_string, sizeof(hex_string),
3634           "%02X.", (U8) *str);
3635 1570         Copy(hex_string, d, 3, char);
3636 1570         d += 3;
3637 1570         str++;
3638           }
3639 22         d--; /* We will overwrite below the final
3640           dot with a right brace */
3641           }
3642           else {
3643           STRLEN char_length; /* cur char's byte length */
3644            
3645           /* and the number of bytes after this is
3646           * translated into hex digits */
3647           STRLEN output_length;
3648            
3649           /* 2 hex per byte; 2 chars for '\N'; 2 chars
3650           * for max('U+', '.'); and 1 for NUL */
3651           char hex_string[2 * UTF8_MAXBYTES + 5];
3652            
3653           /* Get the first character of the result. */
3654 138         U32 uv = utf8n_to_uvchr((U8 *) str,
3655           len,
3656           &char_length,
3657           UTF8_ALLOW_ANYUV);
3658           /* Convert first code point to hex, including
3659           * the boiler plate before it. */
3660 138         output_length =
3661 138 50       my_snprintf(hex_string, sizeof(hex_string),
3662           "\\N{U+%X",
3663           (unsigned int) uv);
3664            
3665           /* Make sure there is enough space to hold it */
3666 138 50       d = off + SvGROW(sv, off
    50        
3667           + output_length
3668           + (STRLEN)(send - e)
3669           + 2); /* '}' + NUL */
3670           /* And output it */
3671 138         Copy(hex_string, d, output_length, char);
3672 138         d += output_length;
3673            
3674           /* For each subsequent character, append dot and
3675           * its ordinal in hex */
3676 211 100       while ((str += char_length) < str_end) {
3677 4         const STRLEN off = d - SvPVX_const(sv);
3678 4         U32 uv = utf8n_to_uvchr((U8 *) str,
3679           str_end - str,
3680           &char_length,
3681           UTF8_ALLOW_ANYUV);
3682 4         output_length =
3683 4 50       my_snprintf(hex_string,
3684           sizeof(hex_string),
3685           ".%X",
3686           (unsigned int) uv);
3687            
3688 4 50       d = off + SvGROW(sv, off
    50        
3689           + output_length
3690           + (STRLEN)(send - e)
3691           + 2); /* '}' + NUL */
3692 4         Copy(hex_string, d, output_length, char);
3693 4         d += output_length;
3694           }
3695           }
3696            
3697 160         *d++ = '}'; /* Done. Add the trailing brace */
3698           }
3699           }
3700           else { /* Here, not in a pattern. Convert the name to a
3701           * string. */
3702            
3703           /* If destination is not in utf8, unconditionally
3704           * recode it to be so. This is because \N{} implies
3705           * Unicode semantics, and scalars have to be in utf8
3706           * to guarantee those semantics */
3707 2264 100       if (! has_utf8) {
3708 2232         SvCUR_set(sv, d - SvPVX_const(sv));
3709 2232         SvPOK_on(sv);
3710 2232         *d = '\0';
3711           /* See Note on sizing above. */
3712 2232         sv_utf8_upgrade_flags_grow(sv,
3713           SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3714           len + (STRLEN)(send - s) + 1);
3715 2232         d = SvPVX(sv) + SvCUR(sv);
3716           has_utf8 = TRUE;
3717 32 50       } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3718            
3719           /* See Note on sizing above. (NOTE: SvCUR() is not
3720           * set correctly here). */
3721 0         const STRLEN off = d - SvPVX_const(sv);
3722 0 0       d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
    0        
3723           }
3724 2264         Copy(str, d, len, char);
3725 2264         d += len;
3726           }
3727            
3728 2436         SvREFCNT_dec(res);
3729            
3730           } /* End \N{NAME} */
3731           #ifdef EBCDIC
3732           if (!dorange)
3733           native_range = FALSE; /* \N{} is defined to be Unicode */
3734           #endif
3735 2932         s = e + 1; /* Point to just after the '}' */
3736 2932         continue;
3737            
3738           /* \c is a control character */
3739           case 'c':
3740 231466         s++;
3741 231466 100       if (s < send) {
3742 231424         *d++ = grok_bslash_c(*s++, has_utf8, 1);
3743           }
3744           else {
3745 42         yyerror("Missing control char name in \\c");
3746           }
3747 231454         continue;
3748            
3749           /* printf-style backslashes, formfeeds, newlines, etc */
3750           case 'b':
3751 77326         *d++ = '\b';
3752 77326         break;
3753           case 'n':
3754 2602192         *d++ = '\n';
3755 2602192         break;
3756           case 'r':
3757 25598         *d++ = '\r';
3758 25598         break;
3759           case 'f':
3760 59390         *d++ = '\f';
3761 59390         break;
3762           case 't':
3763 632333         *d++ = '\t';
3764 632333         break;
3765           case 'e':
3766 11906         *d++ = ASCII_TO_NATIVE('\033');
3767 11906         break;
3768           case 'a':
3769 14984         *d++ = '\a';
3770 14984         break;
3771           } /* end switch */
3772            
3773 3423729         s++;
3774 3423729         continue;
3775           } /* end if (backslash) */
3776           #ifdef EBCDIC
3777           else
3778           literal_endpoint++;
3779           #endif
3780            
3781           default_action:
3782           /* If we started with encoded form, or already know we want it,
3783           then encode the next character */
3784 188335713 100       if (! NATIVE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
    100        
    100        
3785 43734         STRLEN len = 1;
3786            
3787            
3788           /* One might think that it is wasted effort in the case of the
3789           * source being utf8 (this_utf8 == TRUE) to take the next character
3790           * in the source, convert it to an unsigned value, and then convert
3791           * it back again. But the source has not been validated here. The
3792           * routine that does the conversion checks for errors like
3793           * malformed utf8 */
3794            
3795           const UV nextuv = (this_utf8)
3796 43730         ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3797 65599 100       : (UV) ((U8) *s);
3798 43734 100       const STRLEN need = UNISKIP(nextuv);
    100        
    100        
    50        
    0        
    0        
    0        
3799 43734 100       if (!has_utf8) {
3800 38318         SvCUR_set(sv, d - SvPVX_const(sv));
3801 38318         SvPOK_on(sv);
3802 38318         *d = '\0';
3803           /* See Note on sizing above. */
3804 38318         sv_utf8_upgrade_flags_grow(sv,
3805           SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3806           need + (STRLEN)(send - s) + 1);
3807 38318         d = SvPVX(sv) + SvCUR(sv);
3808           has_utf8 = TRUE;
3809 5416 100       } else if (need > len) {
3810           /* encoded value larger than old, may need extra space (NOTE:
3811           * SvCUR() is not set correctly here). See Note on sizing
3812           * above. */
3813 4         const STRLEN off = d - SvPVX_const(sv);
3814 4 50       d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
    50        
3815           }
3816 43734         s += len;
3817            
3818 43734         d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3819           #ifdef EBCDIC
3820           if (uv > 255 && !dorange)
3821           native_range = FALSE;
3822           #endif
3823           }
3824           else {
3825 206923360         *d++ = *s++;
3826           }
3827           } /* while loop to process each character */
3828            
3829           /* terminate the string and set up the sv */
3830 22710137         *d = '\0';
3831 22710137         SvCUR_set(sv, d - SvPVX_const(sv));
3832 22710137 50       if (SvCUR(sv) >= SvLEN(sv))
3833 0         Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3834 0         " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3835            
3836 22710137         SvPOK_on(sv);
3837 22710137 100       if (PL_encoding && !has_utf8) {
    100        
3838 732         sv_recode_to_utf8(sv, PL_encoding);
3839 732 50       if (SvUTF8(sv))
3840           has_utf8 = TRUE;
3841           }
3842 22710137 100       if (has_utf8) {
3843 305900         SvUTF8_on(sv);
3844 305900 100       if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
    50        
3845 324 100       PL_sublex_info.sub_op->op_private |=
3846 216         (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3847           }
3848           }
3849            
3850           /* shrink the sv if we allocated more than we used */
3851 22710137 100       if (SvCUR(sv) + 5 < SvLEN(sv)) {
3852 20928118         SvPV_shrink_to_cur(sv);
3853           }
3854            
3855           /* return the substring (via pl_yylval) only if we parsed anything */
3856 22710137 100       if (s > PL_bufptr) {
3857 19981035         char *s2 = PL_bufptr;
3858 359563858 100       for (; s2 < s; s2++) {
3859 339582823 100       if (*s2 == '\n')
3860 1632227 100       COPLINE_INC_WITH_HERELINES;
3861           }
3862 19981035         SvREFCNT_inc_simple_void_NN(sv);
3863 19981035 100       if ( (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
    100        
3864 118 100       && ! PL_parser->lex_re_reparsing)
3865           {
3866 86 100       const char *const key = PL_lex_inpat ? "qr" : "q";
3867 86 100       const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3868           const char *type;
3869           STRLEN typelen;
3870            
3871 86 100       if (PL_lex_inwhat == OP_TRANS) {
3872           type = "tr";
3873           typelen = 2;
3874 82 100       } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
    50        
3875           type = "s";
3876           typelen = 1;
3877 78 100       } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
    100        
3878           type = "q";
3879           typelen = 1;
3880           } else {
3881           type = "qq";
3882           typelen = 2;
3883           }
3884            
3885 86         sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3886           type, typelen);
3887           }
3888 19981035         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3889           }
3890 22710137         LEAVE_with_name("scan_const");
3891 22710137         return s;
3892           }
3893            
3894           /* S_intuit_more
3895           * Returns TRUE if there's more to the expression (e.g., a subscript),
3896           * FALSE otherwise.
3897           *
3898           * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3899           *
3900           * ->[ and ->{ return TRUE
3901           * { and [ outside a pattern are always subscripts, so return TRUE
3902           * if we're outside a pattern and it's not { or [, then return FALSE
3903           * if we're in a pattern and the first char is a {
3904           * {4,5} (any digits around the comma) returns FALSE
3905           * if we're in a pattern and the first char is a [
3906           * [] returns FALSE
3907           * [SOMETHING] has a funky algorithm to decide whether it's a
3908           * character class or not. It has to deal with things like
3909           * /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3910           * anything else returns TRUE
3911           */
3912            
3913           /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3914            
3915           STATIC int
3916 136239962         S_intuit_more(pTHX_ char *s)
3917           {
3918           dVAR;
3919            
3920           PERL_ARGS_ASSERT_INTUIT_MORE;
3921            
3922 136239962 100       if (PL_lex_brackets)
3923           return TRUE;
3924 23666468 100       if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
    100        
    100        
3925           return TRUE;
3926 22970064 100       if (*s != '{' && *s != '[')
3927           return FALSE;
3928 1521148 100       if (!PL_lex_inpat)
3929           return TRUE;
3930            
3931           /* In a pattern, so maybe we have {n,m}. */
3932 20826 100       if (*s == '{') {
3933 13974 100       if (regcurly(s, FALSE)) {
3934           return FALSE;
3935           }
3936 7942         return TRUE;
3937           }
3938            
3939           /* On the other hand, maybe we have a character class */
3940            
3941 6852         s++;
3942 6852 100       if (*s == ']' || *s == '^')
3943           return FALSE;
3944           else {
3945           /* this is terrifying, and it works */
3946           int weight;
3947           char seen[256];
3948 6792         const char * const send = strchr(s,']');
3949           unsigned char un_char, last_un_char;
3950           char tmpbuf[sizeof PL_tokenbuf * 4];
3951            
3952 6792 50       if (!send) /* has to be an expression */
3953           return TRUE;
3954           weight = 2; /* let's weigh the evidence */
3955            
3956 6792 100       if (*s == '$')
3957           weight -= 3;
3958 6452 100       else if (isDIGIT(*s)) {
3959 5916 50       if (s[1] != ']') {
3960 0 0       if (isDIGIT(s[1]) && s[2] == ']')
    0        
3961           weight -= 10;
3962           }
3963           else
3964           weight -= 100;
3965           }
3966           Zero(seen,256,char);
3967           un_char = 255;
3968 16812 100       for (; s < send; s++) {
3969           last_un_char = un_char;
3970 10020         un_char = (unsigned char)*s;
3971 10020         switch (*s) {
3972           case '@':
3973           case '&':
3974           case '$':
3975 340         weight -= seen[un_char] * 10;
3976 340 50       if (isWORDCHAR_lazy_if(s+1,UTF)) {
    50        
    50        
    0        
    50        
    50        
    0        
    0        
    0        
    0        
    50        
3977           int len;
3978 340         scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3979 340         len = (int)strlen(tmpbuf);
3980 340 100       if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
    50        
    50        
    0        
    50        
    50        
    50        
3981           UTF ? SVf_UTF8 : 0, SVt_PV))
3982 0         weight -= 100;
3983           else
3984 340         weight -= 10;
3985           }
3986 0 0       else if (*s == '$' && s[1] &&
    0        
    0        
3987 0         strchr("[#!%*<>()-=",s[1])) {
3988 0 0       if (/*{*/ strchr("])} =",s[2]))
3989 0         weight -= 10;
3990           else
3991 0         weight -= 1;
3992           }
3993           break;
3994           case '\\':
3995           un_char = 254;
3996 1044 50       if (s[1]) {
3997 1044 100       if (strchr("wds]",s[1]))
3998 4         weight += 100;
3999 1040 50       else if (seen[(U8)'\''] || seen[(U8)'"'])
    50        
4000 0         weight += 1;
4001 1040 50       else if (strchr("rnftbxcav",s[1]))
4002 0         weight += 40;
4003 1040 50       else if (isDIGIT(s[1])) {
4004 0         weight += 40;
4005 0 0       while (s[1] && isDIGIT(s[1]))
    0        
4006 0         s++;
4007           }
4008           }
4009           else
4010 0         weight += 100;
4011           break;
4012           case '-':
4013 12 50       if (s[1] == '\\')
4014 0         weight += 50;
4015 12 100       if (strchr("aA01! ",last_un_char))
4016 4         weight += 30;
4017 12 100       if (strchr("zZ79~",s[1]))
4018 4         weight += 30;
4019 12 100       if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
    50        
    0        
4020 8         weight -= 5; /* cope with negative subscript */
4021           break;
4022           default:
4023 8624 100       if (!isWORDCHAR(last_un_char)
4024 7308 100       && !(last_un_char == '$' || last_un_char == '@'
    50        
4025           || last_un_char == '&')
4026 6968 100       && isALPHA(*s) && s[1] && isALPHA(s[1])) {
    50        
    50        
4027           char *d = tmpbuf;
4028 0 0       while (isALPHA(*s))
4029 0         *d++ = *s++;
4030 0         *d = '\0';
4031 0 0       if (keyword(tmpbuf, d - tmpbuf, 0))
4032 0         weight -= 150;
4033           }
4034 8624 50       if (un_char == last_un_char + 1)
4035 0         weight += 5;
4036 8624         weight -= seen[un_char];
4037 8624         break;
4038           }
4039 10020         seen[un_char]++;
4040           }
4041 6792 100       if (weight >= 0) /* probably a character class */
4042           return FALSE;
4043           }
4044            
4045 70304664         return TRUE;
4046           }
4047            
4048           /*
4049           * S_intuit_method
4050           *
4051           * Does all the checking to disambiguate
4052           * foo bar
4053           * between foo(bar) and bar->foo. Returns 0 if not a method, otherwise
4054           * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4055           *
4056           * First argument is the stuff after the first token, e.g. "bar".
4057           *
4058           * Not a method if foo is a filehandle.
4059           * Not a method if foo is a subroutine prototyped to take a filehandle.
4060           * Not a method if it's really "Foo $bar"
4061           * Method if it's "foo $bar"
4062           * Not a method if it's really "print foo $bar"
4063           * Method if it's really "foo package::" (interpreted as package->foo)
4064           * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4065           * Not a method if bar is a filehandle or package, but is quoted with
4066           * =>
4067           */
4068            
4069           STATIC int
4070 765059         S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
4071           {
4072           dVAR;
4073 765059         char *s = start + (*start == '$');
4074           char tmpbuf[sizeof PL_tokenbuf];
4075           STRLEN len;
4076           GV* indirgv;
4077           #ifdef PERL_MAD
4078           int soff;
4079           #endif
4080            
4081           PERL_ARGS_ASSERT_INTUIT_METHOD;
4082            
4083 765059 100       if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
    50        
    50        
    50        
    50        
    100        
4084           return 0;
4085 683315 100       if (cv && SvPOK(cv)) {
    100        
4086 164088 50       const char *proto = CvPROTO(cv);
    50        
    100        
4087 164088 50       if (proto) {
4088 164212 100       while (*proto && (isSPACE(*proto) || *proto == ';'))
    100        
    100        
4089 124         proto++;
4090 164088 100       if (*proto == '*')
4091           return 0;
4092           }
4093           }
4094            
4095 682693 100       if (*start == '$') {
4096 347732 100       if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
    50        
    0        
    0        
4097 0         isUPPER(*PL_tokenbuf))
4098           return 0;
4099           #ifdef PERL_MAD
4100           len = start - SvPVX(PL_linestr);
4101           #endif
4102 0         s = PEEKSPACE(s);
4103           #ifdef PERL_MAD
4104           start = SvPVX(PL_linestr) + len;
4105           #endif
4106 0         PL_bufptr = start;
4107 0         PL_expect = XREF;
4108 0 0       return *s == '(' ? FUNCMETH : METHOD;
4109           }
4110            
4111 334961         s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4112           /* start is the beginning of the possible filehandle/object,
4113           * and s is the end of it
4114           * tmpbuf is a copy of it (but with single quotes as double colons)
4115           */
4116            
4117 334961 100       if (!keyword(tmpbuf, len, 0)) {
4118 177227 100       if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
    100        
    100        
4119 4         len -= 2;
4120 4         tmpbuf[len] = '\0';
4121           #ifdef PERL_MAD
4122           soff = s - SvPVX(PL_linestr);
4123           #endif
4124 4         goto bare_package;
4125           }
4126 177223 50       indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
    100        
    50        
    50        
    100        
4127 177223 100       if (indirgv && GvCVu(indirgv))
    50        
    100        
4128           return 0;
4129           /* filehandle or package name makes it a method */
4130 165865 100       if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
    100        
    50        
    50        
    50        
    50        
    100        
    50        
    50        
    100        
    100        
4131           #ifdef PERL_MAD
4132           soff = s - SvPVX(PL_linestr);
4133           #endif
4134 92615         s = PEEKSPACE(s);
4135 92615 100       if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
    100        
    50        
4136           return 0; /* no assumptions -- "=>" quotes bareword */
4137           bare_package:
4138           start_force(PL_curforce);
4139 62949         NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4140           S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4141 62949         NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4142           if (PL_madskills)
4143           curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4144           ( UTF ? SVf_UTF8 : 0 )));
4145 62949         PL_expect = XTERM;
4146 62949         force_next(WORD);
4147 62949         PL_bufptr = s;
4148           #ifdef PERL_MAD
4149           PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4150           #endif
4151 433261 100       return *s == '(' ? FUNCMETH : METHOD;
4152           }
4153           }
4154           return 0;
4155           }
4156            
4157           /* Encoded script support. filter_add() effectively inserts a
4158           * 'pre-processing' function into the current source input stream.
4159           * Note that the filter function only applies to the current source file
4160           * (e.g., it will not affect files 'require'd or 'use'd by this one).
4161           *
4162           * The datasv parameter (which may be NULL) can be used to pass
4163           * private data to this instance of the filter. The filter function
4164           * can recover the SV using the FILTER_DATA macro and use it to
4165           * store private buffers and state information.
4166           *
4167           * The supplied datasv parameter is upgraded to a PVIO type
4168           * and the IoDIRP/IoANY field is used to store the function pointer,
4169           * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4170           * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4171           * private use must be set using malloc'd pointers.
4172           */
4173            
4174           SV *
4175 19730         Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4176 19728 50       {
4177           dVAR;
4178 19730 50       if (!funcp)
4179           return NULL;
4180            
4181 19730 50       if (!PL_parser)
4182           return NULL;
4183            
4184 19730 100       if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4185 2         Perl_croak(aTHX_ "Source filters apply only to byte streams");
4186            
4187 19728 100       if (!PL_rsfp_filters)
4188 19690         PL_rsfp_filters = newAV();
4189 19728 100       if (!datasv)
4190 19640         datasv = newSV(0);
4191 29592         SvUPGRADE(datasv, SVt_PVIO);
4192 19728         IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4193 19728         IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4194           DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4195           FPTR2DPTR(void *, IoANY(datasv)),
4196           SvPV_nolen(datasv)));
4197 19728         av_unshift(PL_rsfp_filters, 1);
4198 19728         av_store(PL_rsfp_filters, 0, datasv) ;
4199 19728 50       if (
4200 19728         !PL_parser->filtered
4201 19728 100       && PL_parser->lex_flags & LEX_EVALBYTES
4202 2 50       && PL_bufptr < PL_bufend
4203           ) {
4204 2         const char *s = PL_bufptr;
4205 9867 50       while (s < PL_bufend) {
4206 2 50       if (*s == '\n') {
4207 2         SV *linestr = PL_parser->linestr;
4208 2         char *buf = SvPVX(linestr);
4209 2         STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4210 2         STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4211 2         STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4212 2         STRLEN const linestart_pos = PL_parser->linestart - buf;
4213 2 50       STRLEN const last_uni_pos =
4214 2         PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4215 2 50       STRLEN const last_lop_pos =
4216 2         PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4217 2         av_push(PL_rsfp_filters, linestr);
4218 4         PL_parser->linestr =
4219 2         newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4220 2         buf = SvPVX(PL_parser->linestr);
4221 2         PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4222 2         PL_parser->bufptr = buf + bufptr_pos;
4223 2         PL_parser->oldbufptr = buf + oldbufptr_pos;
4224 2         PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4225 2         PL_parser->linestart = buf + linestart_pos;
4226 2 50       if (PL_parser->last_uni)
4227 0         PL_parser->last_uni = buf + last_uni_pos;
4228 2 50       if (PL_parser->last_lop)
4229 0         PL_parser->last_lop = buf + last_lop_pos;
4230 2         SvLEN(linestr) = SvCUR(linestr);
4231 2         SvCUR(linestr) = s-SvPVX(linestr);
4232 2         PL_parser->filtered = 1;
4233 2         break;
4234           }
4235 0         s++;
4236           }
4237           }
4238           return(datasv);
4239           }
4240            
4241            
4242           /* Delete most recently added instance of this filter function. */
4243           void
4244 11630         Perl_filter_del(pTHX_ filter_t funcp)
4245           {
4246           dVAR;
4247           SV *datasv;
4248            
4249           PERL_ARGS_ASSERT_FILTER_DEL;
4250            
4251           #ifdef DEBUGGING
4252           DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4253           FPTR2DPTR(void*, funcp)));
4254           #endif
4255 11630 50       if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
    50        
    50        
4256           return;
4257           /* if filter is on top of stack (usual case) just pop it off */
4258 11630 50       datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4259 11630 50       if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4260 11630         sv_free(av_pop(PL_rsfp_filters));
4261            
4262 11630         return;
4263           }
4264           /* we need to search for the correct entry and clear it */
4265 5815         Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4266           }
4267            
4268            
4269           /* Invoke the idxth filter function for the current rsfp. */
4270           /* maxlen 0 = read one text line */
4271           I32
4272 42469402         Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4273           {
4274           dVAR;
4275           filter_t funcp;
4276           SV *datasv = NULL;
4277           /* This API is bad. It should have been using unsigned int for maxlen.
4278           Not sure if we want to change the API, but if not we should sanity
4279           check the value here. */
4280 42469402 50       unsigned int correct_length
4281           = maxlen < 0 ?
4282           #ifdef PERL_MICRO
4283           0x7FFFFFFF
4284           #else
4285           INT_MAX
4286           #endif
4287           : maxlen;
4288            
4289           PERL_ARGS_ASSERT_FILTER_READ;
4290            
4291 42469402 50       if (!PL_parser || !PL_rsfp_filters)
    50        
4292           return -1;
4293 42469402 100       if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
4294           /* Provide a default input filter to make life easy. */
4295           /* Note that we append to the line. This is handy. */
4296           DEBUG_P(PerlIO_printf(Perl_debug_log,
4297           "filter_read %d: from rsfp\n", idx));
4298 42420660 100       if (correct_length) {
4299           /* Want a block */
4300           int len ;
4301 20326         const int old_len = SvCUR(buf_sv);
4302            
4303           /* ensure buf_sv is large enough */
4304 20326 50       SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
    100        
4305 20326 100       if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4306           correct_length)) <= 0) {
4307 7998 50       if (PerlIO_error(PL_rsfp))
4308           return -1; /* error */
4309           else
4310 7998         return 0 ; /* end of file */
4311           }
4312 12328         SvCUR_set(buf_sv, old_len + len) ;
4313 12328         SvPVX(buf_sv)[old_len + len] = '\0';
4314           } else {
4315           /* Want a line */
4316 42400334 100       if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4317 5706 50       if (PerlIO_error(PL_rsfp))
4318           return -1; /* error */
4319           else
4320 5706         return 0 ; /* end of file */
4321           }
4322           }
4323 42406956         return SvCUR(buf_sv);
4324           }
4325           /* Skip this filter slot if filter has been deleted */
4326 48742 50       if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
    50        
4327           DEBUG_P(PerlIO_printf(Perl_debug_log,
4328           "filter_read %d: skipped (filter deleted)\n",
4329           idx));
4330 0         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4331           }
4332 48742 100       if (SvTYPE(datasv) != SVt_PVIO) {
4333 4 50       if (correct_length) {
4334           /* Want a block */
4335 0         const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4336 0 0       if (!remainder) return 0; /* eof */
4337 0 0       if (correct_length > remainder) correct_length = remainder;
4338 0         sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4339 0         SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4340           } else {
4341           /* Want a line */
4342 4         const char *s = SvEND(datasv);
4343 4         const char *send = SvPVX(datasv) + SvLEN(datasv);
4344 38 100       while (s < send) {
4345 34 100       if (*s == '\n') {
4346 2         s++;
4347 2         break;
4348           }
4349 32         s++;
4350           }
4351 4 100       if (s == send) return 0; /* eof */
4352 2         sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4353 2         SvCUR_set(datasv, s-SvPVX(datasv));
4354           }
4355 2         return SvCUR(buf_sv);
4356           }
4357           /* Get function pointer hidden within datasv */
4358 48738         funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4359           DEBUG_P(PerlIO_printf(Perl_debug_log,
4360           "filter_read %d: via function %p (%s)\n",
4361           idx, (void*)datasv, SvPV_nolen_const(datasv)));
4362           /* Call function. The function is expected to */
4363           /* call "FILTER_READ(idx+1, buf_sv)" first. */
4364           /* Return: <0:error, =0:eof, >0:not eof */
4365 21921650         return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4366           }
4367            
4368           STATIC char *
4369           S_filter_gets(pTHX_ SV *sv, STRLEN append)
4370           {
4371           dVAR;
4372            
4373           PERL_ARGS_ASSERT_FILTER_GETS;
4374            
4375           #ifdef PERL_CR_FILTER
4376           if (!PL_rsfp_filters) {
4377           filter_add(S_cr_textfilter,NULL);
4378           }
4379           #endif
4380 215443159 100       if (PL_rsfp_filters) {
4381 42440262 100       if (!append)
4382 40267224         SvCUR_set(sv, 0); /* start with empty line */
4383 42440262 100       if (FILTER_READ(0, sv, 0) > 0)
4384 42415054         return ( SvPVX(sv) ) ;
4385           else
4386           return NULL ;
4387           }
4388           else
4389 173002897         return (sv_gets(sv, PL_rsfp, append));
4390           }
4391            
4392           STATIC HV *
4393 90         S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4394           {
4395           dVAR;
4396           GV *gv;
4397            
4398           PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4399            
4400 90 100       if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
    100        
    50        
4401 4         return PL_curstash;
4402            
4403 125 100       if (len > 2 &&
    100        
4404 55 50       (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
    100        
4405 8 50       (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
    100        
    50        
    50        
    50        
4406           {
4407 4         return GvHV(gv); /* Foo:: */
4408           }
4409            
4410           /* use constant CLASS => 'MyClass' */
4411 82 50       gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
    100        
    50        
    50        
    50        
4412 82 100       if (gv && GvCV(gv)) {
    50        
4413 8         SV * const sv = cv_const_sv(GvCV(gv));
4414 8 50       if (sv)
4415 8 50       pkgname = SvPV_const(sv, len);
4416           }
4417            
4418 86 50       return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
    100        
    50        
    50        
    50        
4419           }
4420            
4421           /*
4422           * S_readpipe_override
4423           * Check whether readpipe() is overridden, and generates the appropriate
4424           * optree, provided sublex_start() is called afterwards.
4425           */
4426           STATIC void
4427 74864         S_readpipe_override(pTHX)
4428           {
4429           GV **gvp;
4430 74864         GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4431 74864         pl_yylval.ival = OP_BACKTICK;
4432 74864 100       if ((gv_readpipe
4433 4 50       && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
    50        
    50        
4434 74860 100       ||
4435 74860         ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4436 6 50       && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
    100        
    50        
4437 4 50       && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
    50        
    50        
4438           {
4439 8 50       COPLINE_SET_FROM_MULTI_END;
4440 8         PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4441           op_append_elem(OP_LIST,
4442           newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4443           newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4444           }
4445 74864         }
4446            
4447           #ifdef PERL_MAD
4448           /*
4449           * Perl_madlex
4450           * The intent of this yylex wrapper is to minimize the changes to the
4451           * tokener when we aren't interested in collecting madprops. It remains
4452           * to be seen how successful this strategy will be...
4453           */
4454            
4455           int
4456           Perl_madlex(pTHX)
4457           {
4458           int optype;
4459           char *s = PL_bufptr;
4460            
4461           /* make sure PL_thiswhite is initialized */
4462           PL_thiswhite = 0;
4463           PL_thismad = 0;
4464            
4465           /* previous token ate up our whitespace? */
4466           if (!PL_lasttoke && PL_nextwhite) {
4467           PL_thiswhite = PL_nextwhite;
4468           PL_nextwhite = 0;
4469           }
4470            
4471           /* isolate the token, and figure out where it is without whitespace */
4472           PL_realtokenstart = -1;
4473           PL_thistoken = 0;
4474           optype = yylex();
4475           s = PL_bufptr;
4476           assert(PL_curforce < 0);
4477            
4478           if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */
4479           if (!PL_thistoken) {
4480           if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
4481           PL_thistoken = newSVpvs("");
4482           else {
4483           char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
4484           PL_thistoken = newSVpvn(tstart, s - tstart);
4485           }
4486           }
4487           if (PL_thismad) /* install head */
4488           CURMAD('X', PL_thistoken);
4489           }
4490            
4491           /* last whitespace of a sublex? */
4492           if (optype == ')' && PL_endwhite) {
4493           CURMAD('X', PL_endwhite);
4494           }
4495            
4496           if (!PL_thismad) {
4497            
4498           /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
4499           if (!PL_thiswhite && !PL_endwhite && !optype) {
4500           sv_free(PL_thistoken);
4501           PL_thistoken = 0;
4502           return 0;
4503           }
4504            
4505           /* put off final whitespace till peg */
4506           if (optype == ';' && !PL_rsfp && !PL_parser->filtered) {
4507           PL_nextwhite = PL_thiswhite;
4508           PL_thiswhite = 0;
4509           }
4510           else if (PL_thisopen) {
4511           CURMAD('q', PL_thisopen);
4512           if (PL_thistoken)
4513           sv_free(PL_thistoken);
4514           PL_thistoken = 0;
4515           }
4516           else {
4517           /* Store actual token text as madprop X */
4518           CURMAD('X', PL_thistoken);
4519           }
4520            
4521           if (PL_thiswhite) {
4522           /* add preceding whitespace as madprop _ */
4523           CURMAD('_', PL_thiswhite);
4524           }
4525            
4526           if (PL_thisstuff) {
4527           /* add quoted material as madprop = */
4528           CURMAD('=', PL_thisstuff);
4529           }
4530            
4531           if (PL_thisclose) {
4532           /* add terminating quote as madprop Q */
4533           CURMAD('Q', PL_thisclose);
4534           }
4535           }
4536            
4537           /* special processing based on optype */
4538            
4539           switch (optype) {
4540            
4541           /* opval doesn't need a TOKEN since it can already store mp */
4542           case WORD:
4543           case METHOD:
4544           case FUNCMETH:
4545           case THING:
4546           case PMFUNC:
4547           case PRIVATEREF:
4548           case FUNC0SUB:
4549           case UNIOPSUB:
4550           case LSTOPSUB:
4551           if (pl_yylval.opval)
4552           append_madprops(PL_thismad, pl_yylval.opval, 0);
4553           PL_thismad = 0;
4554           return optype;
4555            
4556           /* fake EOF */
4557           case 0:
4558           optype = PEG;
4559           if (PL_endwhite) {
4560           addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
4561           PL_endwhite = 0;
4562           }
4563           break;
4564            
4565           /* pval */
4566           case LABEL:
4567           break;
4568            
4569           case ']':
4570           case '}':
4571           if (PL_faketokens)
4572           break;
4573           /* remember any fake bracket that lexer is about to discard */
4574           if (PL_lex_brackets == 1 &&
4575           ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
4576           {
4577           s = PL_bufptr;
4578           while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4579           s++;
4580           if (*s == '}') {
4581           PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
4582           addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4583           PL_thiswhite = 0;
4584           PL_bufptr = s - 1;
4585           break; /* don't bother looking for trailing comment */
4586           }
4587           else
4588           s = PL_bufptr;
4589           }
4590           if (optype == ']')
4591           break;
4592           /* FALLTHROUGH */
4593            
4594           /* attach a trailing comment to its statement instead of next token */
4595           case ';':
4596           if (PL_faketokens)
4597           break;
4598           if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
4599           s = PL_bufptr;
4600           while (s < PL_bufend && (*s == ' ' || *s == '\t'))
4601           s++;
4602           if (*s == '\n' || *s == '#') {
4603           while (s < PL_bufend && *s != '\n')
4604           s++;
4605           if (s < PL_bufend)
4606           s++;
4607           PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
4608           addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
4609           PL_thiswhite = 0;
4610           PL_bufptr = s;
4611           }
4612           }
4613           break;
4614            
4615           /* ival */
4616           default:
4617           break;
4618            
4619           }
4620            
4621           /* Create new token struct. Note: opvals return early above. */
4622           pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
4623           PL_thismad = 0;
4624           return optype;
4625           }
4626           #endif
4627            
4628           STATIC char *
4629 4646544         S_tokenize_use(pTHX_ int is_use, char *s) {
4630           dVAR;
4631            
4632           PERL_ARGS_ASSERT_TOKENIZE_USE;
4633            
4634 4646544 50       if (PL_expect != XSTATE)
4635 0 0       yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4636           is_use ? "use" : "no"));
4637 4646544         PL_expect = XTERM;
4638 4646544         s = SKIPSPACE1(s);
4639 4646544 100       if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
    100        
    100        
4640 108030         s = force_version(s, TRUE);
4641 108030 100       if (*s == ';' || *s == '}'
4642 70 50       || (s = SKIPSPACE1(s), (*s == ';' || *s == '}'))) {
4643           start_force(PL_curforce);
4644 108030         NEXTVAL_NEXTTOKE.opval = NULL;
4645 108030         force_next(WORD);
4646           }
4647 0 0       else if (*s == 'v') {
4648 0         s = force_word(s,WORD,FALSE,TRUE);
4649 0         s = force_version(s, FALSE);
4650           }
4651           }
4652           else {
4653 4538514         s = force_word(s,WORD,FALSE,TRUE);
4654 4538514         s = force_version(s, FALSE);
4655           }
4656 4646544         pl_yylval.ival = is_use;
4657 4646544         return s;
4658           }
4659           #ifdef DEBUGGING
4660           static const char* const exp_name[] =
4661           { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4662           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
4663           };
4664           #endif
4665            
4666           #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4667           STATIC bool
4668 125145386         S_word_takes_any_delimeter(char *p, STRLEN len)
4669           {
4670 248620785 100       return (len == 1 && strchr("msyq", p[0])) ||
    100        
    100        
4671 39684773 100       (len == 2 && (
4672 58898642 100       (p[0] == 't' && p[1] == 'r') ||
    100        
4673 83125873 100       (p[0] == 'q' && strchr("qwxr", p[1]))));
4674           }
4675            
4676           /*
4677           yylex
4678            
4679           Works out what to call the token just pulled out of the input
4680           stream. The yacc parser takes care of taking the ops we return and
4681           stitching them into a tree.
4682            
4683           Returns:
4684           The type of the next token
4685            
4686           Structure:
4687           Switch based on the current state:
4688           - if we already built the token before, use it
4689           - if we have a case modifier in a string, deal with that
4690           - handle other cases of interpolation inside a string
4691           - scan the next line if we are inside a format
4692           In the normal state switch on the next character:
4693           - default:
4694           if alphabetic, go to key lookup
4695           unrecoginized character - croak
4696           - 0/4/26: handle end-of-line or EOF
4697           - cases for whitespace
4698           - \n and #: handle comments and line numbers
4699           - various operators, brackets and sigils
4700           - numbers
4701           - quotes
4702           - 'v': vstrings (or go to key lookup)
4703           - 'x' repetition operator (or go to key lookup)
4704           - other ASCII alphanumerics (key lookup begins here):
4705           word before => ?
4706           keyword plugin
4707           scan built-in keyword (but do nothing with it yet)
4708           check for statement label
4709           check for lexical subs
4710           goto just_a_word if there is one
4711           see whether built-in keyword is overridden
4712           switch on keyword number:
4713           - default: just_a_word:
4714           not a built-in keyword; handle bareword lookup
4715           disambiguate between method and sub call
4716           fall back to bareword
4717           - cases for built-in keywords
4718           */
4719            
4720            
4721           #ifdef __SC__
4722           #pragma segment Perl_yylex
4723           #endif
4724           int
4725 1060137204         Perl_yylex(pTHX)
4726           {
4727           dVAR;
4728           char *s = PL_bufptr;
4729           char *d;
4730           STRLEN len;
4731           bool bof = FALSE;
4732 1060137204         const bool saw_infix_sigil = PL_parser->saw_infix_sigil;
4733           U8 formbrack = 0;
4734           U32 fake_eof = 0;
4735            
4736           /* orig_keyword, gvp, and gv are initialized here because
4737           * jump to the label just_a_word_zero can bypass their
4738           * initialization later. */
4739           I32 orig_keyword = 0;
4740           GV *gv = NULL;
4741           GV **gvp = NULL;
4742            
4743           DEBUG_T( {
4744           SV* tmp = newSVpvs("");
4745           PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4746           (IV)CopLINE(PL_curcop),
4747           lex_state_names[PL_lex_state],
4748           exp_name[PL_expect],
4749           pv_display(tmp, s, strlen(s), 0, 60));
4750           SvREFCNT_dec(tmp);
4751           } );
4752            
4753 1060137204         switch (PL_lex_state) {
4754           #ifdef COMMENTARY
4755           case LEX_NORMAL: /* Some compilers will produce faster */
4756           case LEX_INTERPNORMAL: /* code if we comment these out. */
4757           break;
4758           #endif
4759            
4760           /* when we've already built the next token, just pull it out of the queue */
4761           case LEX_KNOWNEXT:
4762           #ifdef PERL_MAD
4763           PL_lasttoke--;
4764           pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
4765           if (PL_madskills) {
4766           PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
4767           PL_nexttoke[PL_lasttoke].next_mad = 0;
4768           if (PL_thismad && PL_thismad->mad_key == '_') {
4769           PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
4770           PL_thismad->mad_val = 0;
4771           mad_free(PL_thismad);
4772           PL_thismad = 0;
4773           }
4774           }
4775           if (!PL_lasttoke) {
4776           PL_lex_state = PL_lex_defer;
4777           PL_expect = PL_lex_expect;
4778           PL_lex_defer = LEX_NORMAL;
4779           if (!PL_nexttoke[PL_lasttoke].next_type)
4780           return yylex();
4781           }
4782           #else
4783 253471868         PL_nexttoke--;
4784 253471868         pl_yylval = PL_nextval[PL_nexttoke];
4785 253471868 100       if (!PL_nexttoke) {
4786 246791236         PL_lex_state = PL_lex_defer;
4787 246791236         PL_expect = PL_lex_expect;
4788 246791236         PL_lex_defer = LEX_NORMAL;
4789           }
4790           #endif
4791           {
4792           I32 next_type;
4793           #ifdef PERL_MAD
4794           next_type = PL_nexttoke[PL_lasttoke].next_type;
4795           #else
4796 253471868         next_type = PL_nexttype[PL_nexttoke];
4797           #endif
4798 253471868 100       if (next_type & (7<<24)) {
4799 327386 100       if (next_type & (1<<24)) {
4800 8 50       if (PL_lex_brackets > 100)
4801 0         Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4802 12         PL_lex_brackstack[PL_lex_brackets++] =
4803 8         (char) ((next_type >> 16) & 0xff);
4804           }
4805 327386 50       if (next_type & (2<<24))
4806 327386         PL_lex_allbrackets++;
4807 327386 50       if (next_type & (4<<24))
4808 0         PL_lex_allbrackets--;
4809 327386         next_type &= 0xffff;
4810           }
4811 253471868 100       return REPORT(next_type == 'p' ? pending_ident() : next_type);
4812           }
4813            
4814           /* interpolated case modifiers like \L \U, including \Q and \E.
4815           when we get here, PL_bufptr is at the \
4816           */
4817           case LEX_INTERPCASEMOD:
4818           #ifdef DEBUGGING
4819           if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4820           Perl_croak(aTHX_
4821           "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4822           PL_bufptr, PL_bufend, *PL_bufptr);
4823           #endif
4824           /* handle \E or end of string */
4825 263572 100       if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
    100        
4826           /* if at a \E */
4827 147474 100       if (PL_lex_casemods) {
4828 116076         const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4829 116076         PL_lex_casestack[PL_lex_casemods] = '\0';
4830            
4831 116076 100       if (PL_bufptr != PL_bufend
4832 84526 100       && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4833 80692 100       || oldmod == 'F')) {
4834 84518         PL_bufptr += 2;
4835 84518         PL_lex_state = LEX_INTERPCONCAT;
4836           #ifdef PERL_MAD
4837           if (PL_madskills)
4838           PL_thistoken = newSVpvs("\\E");
4839           #endif
4840           }
4841 116076         PL_lex_allbrackets--;
4842 116076         return REPORT(')');
4843           }
4844 31398 100       else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
    50        
4845           /* Got an unpaired \E */
4846 16         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4847           "Useless use of \\E");
4848           }
4849           #ifdef PERL_MAD
4850           while (PL_bufptr != PL_bufend &&
4851           PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
4852           if (PL_madskills) {
4853           if (!PL_thiswhite)
4854           PL_thiswhite = newSVpvs("");
4855           sv_catpvn(PL_thiswhite, PL_bufptr, 2);
4856           }
4857           PL_bufptr += 2;
4858           }
4859           #else
4860 31398 100       if (PL_bufptr != PL_bufend)
4861 16         PL_bufptr += 2;
4862           #endif
4863 31398         PL_lex_state = LEX_INTERPCONCAT;
4864 31398         return yylex();
4865           }
4866           else {
4867           DEBUG_T({ PerlIO_printf(Perl_debug_log,
4868           "### Saw case modifier\n"); });
4869 116098         s = PL_bufptr + 1;
4870 116098 100       if (s[1] == '\\' && s[2] == 'E') {
    100        
4871           #ifdef PERL_MAD
4872           if (PL_madskills) {
4873           if (!PL_thiswhite)
4874           PL_thiswhite = newSVpvs("");
4875           sv_catpvn(PL_thiswhite, PL_bufptr, 4);
4876           }
4877           #endif
4878 10         PL_bufptr = s + 3;
4879 10         PL_lex_state = LEX_INTERPCONCAT;
4880 10         return yylex();
4881           }
4882           else {
4883           I32 tmp;
4884           if (!PL_madskills) /* when just compiling don't need correct */
4885 116088 100       if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
    100        
4886 8         tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */
4887 120836 100       if ((*s == 'L' || *s == 'U' || *s == 'F') &&
    100        
    100        
4888 9496         (strchr(PL_lex_casestack, 'L')
4889 9492 100       || strchr(PL_lex_casestack, 'U')
4890 9490 50       || strchr(PL_lex_casestack, 'F'))) {
4891 6         PL_lex_casestack[--PL_lex_casemods] = '\0';
4892 6         PL_lex_allbrackets--;
4893 6         return REPORT(')');
4894           }
4895 116082 100       if (PL_lex_casemods > 10)
4896 4         Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4897 116082         PL_lex_casestack[PL_lex_casemods++] = *s;
4898 116082         PL_lex_casestack[PL_lex_casemods] = '\0';
4899 116082         PL_lex_state = LEX_INTERPCONCAT;
4900           start_force(PL_curforce);
4901 116082         NEXTVAL_NEXTTOKE.ival = 0;
4902 116082         force_next((2<<24)|'(');
4903           start_force(PL_curforce);
4904 116082 100       if (*s == 'l')
4905 26         NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4906 116056 100       else if (*s == 'u')
4907 10288         NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4908 105768 100       else if (*s == 'L')
4909 1048         NEXTVAL_NEXTTOKE.ival = OP_LC;
4910 104720 100       else if (*s == 'U')
4911 8416         NEXTVAL_NEXTTOKE.ival = OP_UC;
4912 96304 100       else if (*s == 'Q')
4913 96278         NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4914 26 50       else if (*s == 'F')
4915 26         NEXTVAL_NEXTTOKE.ival = OP_FC;
4916           else
4917 0         Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4918           if (PL_madskills) {
4919           SV* const tmpsv = newSVpvs("\\ ");
4920           /* replace the space with the character we want to escape
4921           */
4922           SvPVX(tmpsv)[1] = *s;
4923           curmad('_', tmpsv);
4924           }
4925 116082         PL_bufptr = s + 1;
4926           }
4927 116082         force_next(FUNC);
4928 116082 100       if (PL_lex_starts) {
4929 95594         s = PL_bufptr;
4930 95594         PL_lex_starts = 0;
4931           #ifdef PERL_MAD
4932           if (PL_madskills) {
4933           if (PL_thistoken)
4934           sv_free(PL_thistoken);
4935           PL_thistoken = newSVpvs("");
4936           }
4937           #endif
4938           /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4939 95594 100       if (PL_lex_casemods == 1 && PL_lex_inpat)
    100        
4940 76092         OPERATOR(',');
4941           else
4942 19502         Aop(OP_CONCAT);
4943           }
4944           else
4945 20488         return yylex();
4946           }
4947            
4948           case LEX_INTERPPUSH:
4949 15196785         return REPORT(sublex_push());
4950            
4951           case LEX_INTERPSTART:
4952 22509507 100       if (PL_bufptr == PL_bufend)
4953 13254469         return REPORT(sublex_done());
4954           DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4955           "### Interpolated variable\n"); });
4956 9255038         PL_expect = XTERM;
4957           /* for /@a/, we leave the joining for the regex engine to do
4958           * (unless we're within \Q etc) */
4959 18510076         PL_lex_dojoin = (*PL_bufptr == '@'
4960 9255038 100       && (!PL_lex_inpat || PL_lex_casemods));
    100        
    100        
4961 9255038         PL_lex_state = LEX_INTERPNORMAL;
4962 9255038 100       if (PL_lex_dojoin) {
4963           start_force(PL_curforce);
4964 211296         NEXTVAL_NEXTTOKE.ival = 0;
4965 211296         force_next(',');
4966           start_force(PL_curforce);
4967 211296         force_ident("\"", '$');
4968           start_force(PL_curforce);
4969 211296         NEXTVAL_NEXTTOKE.ival = 0;
4970 211296         force_next('$');
4971           start_force(PL_curforce);
4972 211296         NEXTVAL_NEXTTOKE.ival = 0;
4973 211296         force_next((2<<24)|'(');
4974           start_force(PL_curforce);
4975 211296         NEXTVAL_NEXTTOKE.ival = OP_JOIN; /* emulate join($", ...) */
4976 211296         force_next(FUNC);
4977           }
4978           /* Convert (?{...}) and friends to 'do {...}' */
4979 9255038 100       if (PL_lex_inpat && *PL_bufptr == '(') {
    100        
4980 11150         PL_parser->lex_shared->re_eval_start = PL_bufptr;
4981 11150         PL_bufptr += 2;
4982 11150 100       if (*PL_bufptr != '{')
4983 8734         PL_bufptr++;
4984           start_force(PL_curforce);
4985           /* XXX probably need a CURMAD(something) here */
4986 11150         PL_expect = XTERMBLOCK;
4987 11150         force_next(DO);
4988           }
4989            
4990 9255038 100       if (PL_lex_starts++) {
4991 6967193         s = PL_bufptr;
4992           #ifdef PERL_MAD
4993           if (PL_madskills) {
4994           if (PL_thistoken)
4995           sv_free(PL_thistoken);
4996           PL_thistoken = newSVpvs("");
4997           }
4998           #endif
4999           /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5000 6967193 100       if (!PL_lex_casemods && PL_lex_inpat)
    100        
5001 219736         OPERATOR(',');
5002           else
5003 6747457         Aop(OP_CONCAT);
5004           }
5005 2287845         return yylex();
5006            
5007           case LEX_INTERPENDMAYBE:
5008 8464695 100       if (intuit_more(PL_bufptr)) {
5009 1314496         PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
5010 1314496         break;
5011           }
5012           /* FALL THROUGH */
5013            
5014           case LEX_INTERPEND:
5015 9441451 100       if (PL_lex_dojoin) {
5016 211296         PL_lex_dojoin = FALSE;
5017 211296         PL_lex_state = LEX_INTERPCONCAT;
5018           #ifdef PERL_MAD
5019           if (PL_madskills) {
5020           if (PL_thistoken)
5021           sv_free(PL_thistoken);
5022           PL_thistoken = newSVpvs("");
5023           }
5024           #endif
5025 211296         PL_lex_allbrackets--;
5026 211296         return REPORT(')');
5027           }
5028 9230155 100       if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
    100        
5029 175367 50       && SvEVALED(PL_lex_repl))
5030           {
5031 175367 100       if (PL_bufptr != PL_bufend)
5032 6         Perl_croak(aTHX_ "Bad evalled substitution pattern");
5033 175361         PL_lex_repl = NULL;
5034           }
5035           /* Paranoia. re_eval_start is adjusted when S_scan_heredoc sets
5036           re_eval_str. If the here-doc body’s length equals the previous
5037           value of re_eval_start, re_eval_start will now be null. So
5038           check re_eval_str as well. */
5039 9230149 100       if (PL_parser->lex_shared->re_eval_start
5040 9219029 50       || PL_parser->lex_shared->re_eval_str) {
5041           SV *sv;
5042 11120 100       if (*PL_bufptr != ')')
5043 30         Perl_croak(aTHX_ "Sequence (?{...}) not terminated with ')'");
5044 11090         PL_bufptr++;
5045           /* having compiled a (?{..}) expression, return the original
5046           * text too, as a const */
5047 11090 100       if (PL_parser->lex_shared->re_eval_str) {
5048 6         sv = PL_parser->lex_shared->re_eval_str;
5049 6         PL_parser->lex_shared->re_eval_str = NULL;
5050 6         SvCUR_set(sv,
5051           PL_bufptr - PL_parser->lex_shared->re_eval_start);
5052 6         SvPV_shrink_to_cur(sv);
5053           }
5054 11084         else sv = newSVpvn(PL_parser->lex_shared->re_eval_start,
5055           PL_bufptr - PL_parser->lex_shared->re_eval_start);
5056           start_force(PL_curforce);
5057           /* XXX probably need a CURMAD(something) here */
5058 22180         NEXTVAL_NEXTTOKE.opval =
5059 11090         (OP*)newSVOP(OP_CONST, 0,
5060           sv);
5061 11090         force_next(THING);
5062 11090         PL_parser->lex_shared->re_eval_start = NULL;
5063 11090         PL_expect = XTERM;
5064 11090         return REPORT(',');
5065           }
5066            
5067           /* FALLTHROUGH */
5068           case LEX_INTERPCONCAT:
5069           #ifdef DEBUGGING
5070           if (PL_lex_brackets)
5071           Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
5072           (long) PL_lex_brackets);
5073           #endif
5074 27011408 100       if (PL_bufptr == PL_bufend)
5075 4301133         return REPORT(sublex_done());
5076            
5077           /* m'foo' still needs to be parsed for possible (?{...}) */
5078 22710285 100       if (SvIVX(PL_linestr) == '\'' && !PL_lex_inpat) {
    100        
5079 10         SV *sv = newSVsv(PL_linestr);
5080 10         sv = tokeq(sv);
5081 10         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5082 10         s = PL_bufend;
5083           }
5084           else {
5085 22710265         s = scan_const(PL_bufptr);
5086 22710137 100       if (*s == '\\')
5087 200626         PL_lex_state = LEX_INTERPCASEMOD;
5088           else
5089 22509511         PL_lex_state = LEX_INTERPSTART;
5090           }
5091            
5092 22710147 100       if (s != PL_bufptr) {
5093           start_force(PL_curforce);
5094           if (PL_madskills) {
5095           curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
5096           }
5097 19981045         NEXTVAL_NEXTTOKE = pl_yylval;
5098 19981045         PL_expect = XTERM;
5099 19981045         force_next(THING);
5100 19981045 100       if (PL_lex_starts++) {
5101           #ifdef PERL_MAD
5102           if (PL_madskills) {
5103           if (PL_thistoken)
5104           sv_free(PL_thistoken);
5105           PL_thistoken = newSVpvs("");
5106           }
5107           #endif
5108           /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
5109 6285187 100       if (!PL_lex_casemods && PL_lex_inpat)
    100        
5110 268320         OPERATOR(',');
5111           else
5112 6016867         Aop(OP_CONCAT);
5113           }
5114           else {
5115 13695858         PL_bufptr = s;
5116 13695858         return yylex();
5117           }
5118           }
5119            
5120 2729102         return yylex();
5121           case LEX_FORMLINE:
5122 666         s = scan_formline(PL_bufptr);
5123 666 100       if (!PL_lex_formbrack)
5124           {
5125           formbrack = 1;
5126           goto rightbracket;
5127           }
5128 384         PL_bufptr = s;
5129 384         return yylex();
5130           }
5131            
5132           /* We really do *not* want PL_linestr ever becoming a COW. */
5133           assert (!SvIsCOW(PL_linestr));
5134 741460976         s = PL_bufptr;
5135 741460976         PL_oldoldbufptr = PL_oldbufptr;
5136 741460976         PL_oldbufptr = s;
5137 741460976         PL_parser->saw_infix_sigil = 0;
5138            
5139           retry:
5140           #ifdef PERL_MAD
5141           if (PL_thistoken) {
5142           sv_free(PL_thistoken);
5143           PL_thistoken = 0;
5144           }
5145           PL_realtokenstart = s - SvPVX(PL_linestr); /* assume but undo on ws */
5146           #endif
5147 1931271773         switch (*s) {
5148           default:
5149 34708 50       if (UTF ? isIDFIRST_utf8((U8*)s) : isALNUMC(*s))
    100        
    50        
    100        
    100        
    50        
    100        
    50        
    100        
    100        
5150           goto keylookup;
5151           {
5152 34208         SV *dsv = newSVpvs_flags("", SVs_TEMP);
5153 34342 50       const char *c = UTF ? savepv(sv_uni_display(dsv, newSVpvn_flags(s,
    100        
    50        
    100        
    100        
5154           UTF8SKIP(s),
5155           SVs_TEMP | SVf_UTF8),
5156           10, UNI_DISPLAY_ISPRINT))
5157 268         : Perl_form(aTHX_ "\\x%02X", (unsigned char)*s);
5158 34208 50       len = UTF ? Perl_utf8_length(aTHX_ (U8 *) PL_linestart, (U8 *) s) : (STRLEN) (s - PL_linestart);
    100        
    50        
    100        
    100        
5159 34208 100       if (len > UNRECOGNIZED_PRECEDE_COUNT) {
5160 132 50       d = UTF ? (char *) Perl_utf8_hop(aTHX_ (U8 *) s, -UNRECOGNIZED_PRECEDE_COUNT) : s - UNRECOGNIZED_PRECEDE_COUNT;
    100        
    50        
    50        
    50        
5161           } else {
5162 34076         d = PL_linestart;
5163           }
5164 34208         *s = '\0';
5165 34208         sv_setpv(dsv, d);
5166 34208 50       if (UTF)
    100        
    50        
    100        
    100        
5167 33940         SvUTF8_on(dsv);
5168 34208         Perl_croak(aTHX_ "Unrecognized character %s; marked by <-- HERE after %"SVf"<-- HERE near column %d", c, SVfARG(dsv), (int) len + 1);
5169           }
5170           case 4:
5171           case 26:
5172           goto fake_eof; /* emulate EOF on ^D or ^Z */
5173           case 0:
5174           #ifdef PERL_MAD
5175           if (PL_madskills)
5176           PL_faketokens = 0;
5177           #endif
5178 169828796 100       if (!PL_rsfp && (!PL_parser->filtered || s+1 < PL_bufend)) {
    100        
    50        
5179 4312505         PL_last_uni = 0;
5180 4312505         PL_last_lop = 0;
5181 4312539 100       if (PL_lex_brackets &&
    100        
5182 68         PL_lex_brackstack[PL_lex_brackets-1] != XFAKEEOF) {
5183 60 100       yyerror((const char *)
5184           (PL_lex_formbrack
5185           ? "Format not terminated"
5186           : "Missing right curly or square bracket"));
5187           }
5188           DEBUG_T( { PerlIO_printf(Perl_debug_log,
5189           "### Tokener got EOF\n");
5190           } );
5191 4312505         TOKEN(0);
5192           }
5193 165516291 50       if (s++ < PL_bufend)
5194           goto retry; /* ignore stray nulls */
5195 165516291         PL_last_uni = 0;
5196 165516291         PL_last_lop = 0;
5197 165516291 100       if (!PL_in_eval && !PL_preambled) {
    100        
5198 24242         PL_preambled = TRUE;
5199           #ifdef PERL_MAD
5200           if (PL_madskills)
5201           PL_faketokens = 1;
5202           #endif
5203 24242 100       if (PL_perldb) {
5204           /* Generate a string of Perl code to load the debugger.
5205           * If PERL5DB is set, it will return the contents of that,
5206           * otherwise a compile-time require of perl5db.pl. */
5207            
5208 222         const char * const pdb = PerlEnv_getenv("PERL5DB");
5209            
5210 222 100       if (pdb) {
5211 18         sv_setpv(PL_linestr, pdb);
5212 18         sv_catpvs(PL_linestr,";");
5213           } else {
5214 204         SETERRNO(0,SS_NORMAL);
5215 204         sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
5216           }
5217           } else
5218 24020         sv_setpvs(PL_linestr,"");
5219 24242 100       if (PL_preambleav) {
5220 14642         SV **svp = AvARRAY(PL_preambleav);
5221 14642         SV **const end = svp + AvFILLp(PL_preambleav);
5222 43335 100       while(svp <= end) {
5223 21372         sv_catsv(PL_linestr, *svp);
5224 21372         ++svp;
5225 21372         sv_catpvs(PL_linestr, ";");
5226           }
5227 14642         sv_free(MUTABLE_SV(PL_preambleav));
5228 14642         PL_preambleav = NULL;
5229           }
5230 24242 100       if (PL_minus_E)
5231 10         sv_catpvs(PL_linestr,
5232           "use feature ':5." STRINGIFY(PERL_VERSION) "';");
5233 24242 100       if (PL_minus_n || PL_minus_p) {
    100        
5234 118         sv_catpvs(PL_linestr, "LINE: while (<>) {"/*}*/);
5235 118 100       if (PL_minus_l)
5236 4         sv_catpvs(PL_linestr,"chomp;");
5237 118 100       if (PL_minus_a) {
5238 18 100       if (PL_minus_F) {
5239 8 50       if ((*PL_splitstr == '/' || *PL_splitstr == '\''
    0        
5240 8 50       || *PL_splitstr == '"')
5241 0 0       && strchr(PL_splitstr + 1, *PL_splitstr))
    0        
    0        
5242 0         Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
5243           else {
5244           /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
5245           bytes can be used as quoting characters. :-) */
5246 8         const char *splits = PL_splitstr;
5247 8         sv_catpvs(PL_linestr, "our @F=split(q\0");
5248           do {
5249           /* Need to \ \s */
5250 38 100       if (*splits == '\\')
5251 4         sv_catpvn(PL_linestr, splits, 1);
5252 38         sv_catpvn(PL_linestr, splits, 1);
5253 38 100       } while (*splits++);
5254           /* This loop will embed the trailing NUL of
5255           PL_linestr as the last thing it does before
5256           terminating. */
5257 8         sv_catpvs(PL_linestr, ");");
5258           }
5259           }
5260           else
5261 10         sv_catpvs(PL_linestr,"our @F=split(' ');");
5262           }
5263           }
5264 24242         sv_catpvs(PL_linestr, "\n");
5265 24242         PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5266 24242         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5267 24242         PL_last_lop = PL_last_uni = NULL;
5268 24242 100       if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
    100        
    50        
5269 214         update_debugger_info(PL_linestr, NULL, 0);
5270           goto retry;
5271           }
5272           do {
5273           fake_eof = 0;
5274 188730235         bof = PL_rsfp ? TRUE : FALSE;
5275           if (0) {
5276           fake_eof:
5277           fake_eof = LEX_FAKE_EOF;
5278           }
5279 189120165         PL_bufptr = PL_bufend;
5280 189120165 100       COPLINE_INC_WITH_HERELINES;
5281 189120165 50       if (!lex_next_chunk(fake_eof)) {
5282 0         CopLINE_dec(PL_curcop);
5283 0         s = PL_bufptr;
5284 0         TOKEN(';'); /* not infinite loop because rsfp is NULL now */
5285           }
5286 189120155         CopLINE_dec(PL_curcop);
5287           #ifdef PERL_MAD
5288           if (!PL_rsfp)
5289           PL_realtokenstart = -1;
5290           #endif
5291 189120155         s = PL_bufptr;
5292           /* If it looks like the start of a BOM or raw UTF-16,
5293           * check if it in fact is. */
5294 280157196 100       if (bof && PL_rsfp &&
    100        
    100        
5295 279550619 100       (*s == 0 ||
5296 279549585 100       *(U8*)s == BOM_UTF8_FIRST_BYTE ||
5297 279545572 100       *(U8*)s >= 0xFE ||
5298 188509548         s[1] == 0)) {
5299 34061281         Off_t offset = (IV)PerlIO_tell(PL_rsfp);
5300 34061281         bof = (offset == (Off_t)SvCUR(PL_linestr));
5301           #if defined(PERLIO_USING_CRLF) && defined(PERL_TEXTMODE_SCRIPTS)
5302           /* offset may include swallowed CR */
5303           if (!bof)
5304           bof = (offset == (Off_t)SvCUR(PL_linestr)+1);
5305           #endif
5306 34061281 100       if (bof) {
5307 24674         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5308 24674         s = swallow_bom((U8*)s);
5309           }
5310           }
5311 189120155 100       if (PL_parser->in_pod) {
5312           /* Incest with pod. */
5313           #ifdef PERL_MAD
5314           if (PL_madskills)
5315           sv_catsv(PL_thiswhite, PL_linestr);
5316           #endif
5317 24113065 100       if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
    100        
    50        
5318 874879         sv_setpvs(PL_linestr, "");
5319 874879         PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5320 874879         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5321 874879         PL_last_lop = PL_last_uni = NULL;
5322 874879         PL_parser->in_pod = 0;
5323           }
5324           }
5325 189120155 100       if (PL_rsfp || PL_parser->filtered)
    100        
5326 188515580         incline(s);
5327 189120155 100       } while (PL_parser->in_pod);
5328 165881969         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
5329 165881969         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5330 165881969         PL_last_lop = PL_last_uni = NULL;
5331 165881969 100       if (CopLINE(PL_curcop) == 1) {
5332 661843 100       while (s < PL_bufend && isSPACE(*s))
    100        
5333 41236         s++;
5334 620607 50       if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
    0        
5335 0         s++;
5336           #ifdef PERL_MAD
5337           if (PL_madskills)
5338           PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
5339           #endif
5340           d = NULL;
5341 620607 100       if (!PL_in_eval) {
5342 29140 100       if (*s == '#' && *(s+1) == '!')
    100        
5343 5568         d = s + 2;
5344           #ifdef ALTERNATE_SHEBANG
5345           else {
5346           static char const as[] = ALTERNATE_SHEBANG;
5347           if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
5348           d = s + (sizeof(as) - 1);
5349           }
5350           #endif /* ALTERNATE_SHEBANG */
5351           }
5352 620607 100       if (d) {
5353           char *ipath;
5354           char *ipathend;
5355            
5356 5734 100       while (isSPACE(*d))
5357 166         d++;
5358           ipath = d;
5359 87494 50       while (*d && !isSPACE(*d))
    100        
5360 81926         d++;
5361           ipathend = d;
5362            
5363           #ifdef ARG_ZERO_IS_SCRIPT
5364           if (ipathend > ipath) {
5365           /*
5366           * HP-UX (at least) sets argv[0] to the script name,
5367           * which makes $^X incorrect. And Digital UNIX and Linux,
5368           * at least, set argv[0] to the basename of the Perl
5369           * interpreter. So, having found "#!", we'll set it right.
5370           */
5371           SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
5372           SVt_PV)); /* $^X */
5373           assert(SvPOK(x) || SvGMAGICAL(x));
5374           if (sv_eq(x, CopFILESV(PL_curcop))) {
5375           sv_setpvn(x, ipath, ipathend - ipath);
5376           SvSETMAGIC(x);
5377           }
5378           else {
5379           STRLEN blen;
5380           STRLEN llen;
5381           const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
5382           const char * const lstart = SvPV_const(x,llen);
5383           if (llen < blen) {
5384           bstart += blen - llen;
5385           if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
5386           sv_setpvn(x, ipath, ipathend - ipath);
5387           SvSETMAGIC(x);
5388           }
5389           }
5390           }
5391           TAINT_NOT; /* $^X is always tainted, but that's OK */
5392           }
5393           #endif /* ARG_ZERO_IS_SCRIPT */
5394            
5395           /*
5396           * Look for options.
5397           */
5398 5568         d = instr(s,"perl -");
5399 5568 100       if (!d) {
5400 3790         d = instr(s,"perl");
5401           #if defined(DOSISH)
5402           /* avoid getting into infinite loops when shebang
5403           * line contains "Perl" rather than "perl" */
5404           if (!d) {
5405           for (d = ipathend-4; d >= ipath; --d) {
5406           if ((*d == 'p' || *d == 'P')
5407           && !ibcmp(d, "perl", 4))
5408           {
5409           break;
5410           }
5411           }
5412           if (d < ipath)
5413           d = NULL;
5414           }
5415           #endif
5416           }
5417           #ifdef ALTERNATE_SHEBANG
5418           /*
5419           * If the ALTERNATE_SHEBANG on this system starts with a
5420           * character that can be part of a Perl expression, then if
5421           * we see it but not "perl", we're probably looking at the
5422           * start of Perl code, not a request to hand off to some
5423           * other interpreter. Similarly, if "perl" is there, but
5424           * not in the first 'word' of the line, we assume the line
5425           * contains the start of the Perl program.
5426           */
5427           if (d && *s != '#') {
5428           const char *c = ipath;
5429           while (*c && !strchr("; \t\r\n\f\v#", *c))
5430           c++;
5431           if (c < d)
5432           d = NULL; /* "perl" not in first word; ignore */
5433           else
5434           *s = '#'; /* Don't try to parse shebang line */
5435           }
5436           #endif /* ALTERNATE_SHEBANG */
5437 5568 50       if (!d &&
5438 0 0       *s == '#' &&
5439 0 0       ipathend > ipath &&
5440 0 0       !PL_minus_c &&
5441 0 0       !instr(s,"indir") &&
5442 0         instr(PL_origargv[0],"perl"))
5443           {
5444           dVAR;
5445           char **newargv;
5446            
5447 0         *ipathend = '\0';
5448 0         s = ipathend + 1;
5449 0 0       while (s < PL_bufend && isSPACE(*s))
    0        
5450 0         s++;
5451 0 0       if (s < PL_bufend) {
5452 0 0       Newx(newargv,PL_origargc+3,char*);
5453 0         newargv[1] = s;
5454 0 0       while (s < PL_bufend && !isSPACE(*s))
    0        
5455 0         s++;
5456 0         *s = '\0';
5457 0 0       Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
5458           }
5459           else
5460 0         newargv = PL_origargv;
5461 0         newargv[0] = ipath;
5462 0         PERL_FPU_PRE_EXEC
5463 0         PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
5464 0         PERL_FPU_POST_EXEC
5465 0         Perl_croak(aTHX_ "Can't exec %s", ipath);
5466           }
5467 5568 50       if (d) {
5468 46136 50       while (*d && !isSPACE(*d))
    100        
5469 40568         d++;
5470 7434 100       while (SPACE_OR_TAB(*d))
5471 1866         d++;
5472            
5473 5568 100       if (*d++ == '-') {
5474 1856         const bool switches_done = PL_doswitches;
5475 1856         const U32 oldpdb = PL_perldb;
5476 1856         const bool oldn = PL_minus_n;
5477 1856         const bool oldp = PL_minus_p;
5478 1856         const char *d1 = d;
5479            
5480           do {
5481           bool baduni = FALSE;
5482 3692 100       if (*d1 == 'C') {
5483 10         const char *d2 = d1 + 1;
5484 15 100       if (parse_unicode_opts((const char **)&d2)
5485 10         != PL_unicode)
5486           baduni = TRUE;
5487           }
5488 3692 100       if (baduni || *d1 == 'M' || *d1 == 'm') {
    100        
    100        
5489           const char * const m = d1;
5490 20 50       while (*d1 && !isSPACE(*d1))
    100        
5491 12         d1++;
5492 8         Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
5493 8         (int)(d1 - m), m);
5494           }
5495 3684         d1 = moreswitches(d1);
5496 3606 100       } while (d1);
5497 1770 100       if (PL_doswitches && !switches_done) {
    50        
5498 6         int argc = PL_origargc;
5499 6         char **argv = PL_origargv;
5500           do {
5501 18         argc--,argv++;
5502 18 50       } while (argc && argv[0][0] == '-' && argv[0][1]);
    100        
    50        
5503 6         init_argv_symbols(argc,argv);
5504           }
5505 1770 100       if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
    100        
    100        
5506 1763 100       ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
    50        
    50        
5507           /* if we have already added "LINE: while (<>) {",
5508           we must not do it again */
5509           {
5510 14         sv_setpvs(PL_linestr, "");
5511 14         PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
5512 14         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5513 14         PL_last_lop = PL_last_uni = NULL;
5514 14         PL_preambled = FALSE;
5515 14 100       if (PERLDB_LINE || PERLDB_SAVESRC)
    100        
5516 2         (void)gv_fetchfile(PL_origfilename);
5517           goto retry;
5518           }
5519           }
5520           }
5521           }
5522           }
5523 165881869 100       if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
    100        
5524 468         PL_lex_state = LEX_FORMLINE;
5525           start_force(PL_curforce);
5526 468         NEXTVAL_NEXTTOKE.ival = 0;
5527 468         force_next(FORMRBRACK);
5528 468         TOKEN(';');
5529           }
5530           goto retry;
5531           case '\r':
5532           #ifdef PERL_STRICT_CR
5533           Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
5534           Perl_croak(aTHX_
5535           "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
5536           #endif
5537           case ' ': case '\t': case '\f': case 013:
5538           #ifdef PERL_MAD
5539           PL_realtokenstart = -1;
5540           if (PL_madskills) {
5541           if (!PL_thiswhite)
5542           PL_thiswhite = newSVpvs("");
5543           sv_catpvn(PL_thiswhite, s, 1);
5544           }
5545           #endif
5546 851402688         s++;
5547 851402688         goto retry;
5548           case '#':
5549           case '\n':
5550           #ifdef PERL_MAD
5551           PL_realtokenstart = -1;
5552           if (PL_madskills)
5553           PL_faketokens = 0;
5554           #endif
5555 338651585 100       if (PL_lex_state != LEX_NORMAL ||
    100        
5556 252776030 100       (PL_in_eval && !PL_rsfp && !PL_parser->filtered)) {
    100        
5557 7333874 100       if (*s == '#' && s == PL_linestart && PL_in_eval
    100        
    50        
5558 15010 50       && !PL_rsfp && !PL_parser->filtered) {
    50        
5559           /* handle eval qq[#line 1 "foo"\n ...] */
5560 15010         CopLINE_dec(PL_curcop);
5561 15010         incline(s);
5562           }
5563           if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
5564           s = SKIPSPACE0(s);
5565           if (!PL_in_eval || PL_rsfp || PL_parser->filtered)
5566           incline(s);
5567           }
5568           else {
5569 7333874         const bool in_comment = *s == '#';
5570           d = s;
5571 24585596 100       while (d < PL_bufend && *d != '\n')
    100        
5572 13655338         d++;
5573 7333874 100       if (d < PL_bufend)
5574 7333870         d++;
5575 4 50       else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5576 0         Perl_croak(aTHX_ "panic: input overflow, %p > %p",
5577 0         d, PL_bufend);
5578           #ifdef PERL_MAD
5579           if (PL_madskills)
5580           PL_thiswhite = newSVpvn(s, d - s);
5581           #endif
5582           s = d;
5583 7333874 100       if (in_comment && d == PL_bufend
    100        
5584 4 50       && PL_lex_state == LEX_INTERPNORMAL
5585 4 50       && PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
    50        
5586 4 50       && SvEVALED(PL_lex_repl) && d[-1] == '}') s--;
    50        
5587 7333870         else incline(s);
5588           }
5589 7333874 100       if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
    50        
5590 138         PL_lex_state = LEX_FORMLINE;
5591           start_force(PL_curforce);
5592 138         NEXTVAL_NEXTTOKE.ival = 0;
5593 138         force_next(FORMRBRACK);
5594 138         TOKEN(';');
5595           }
5596           }
5597           else {
5598           #ifdef PERL_MAD
5599           if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
5600           if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
5601           PL_faketokens = 0;
5602           s = SKIPSPACE0(s);
5603           TOKEN(PEG); /* make sure any #! line is accessible */
5604           }
5605           s = SKIPSPACE0(s);
5606           }
5607           else {
5608           #endif
5609           if (PL_madskills) d = s;
5610 1119912821 50       while (s < PL_bufend && *s != '\n')
    100        
5611 955628616         s++;
5612 164284205 50       if (s < PL_bufend)
5613           {
5614 164284205         s++;
5615 164284205 100       if (s < PL_bufend)
5616 556890         incline(s);
5617           }
5618 0 0       else if (s > PL_bufend) /* Found by Ilya: feed random input to Perl. */
5619 0         Perl_croak(aTHX_ "panic: input overflow");
5620           #ifdef PERL_MAD
5621           if (PL_madskills && CopLINE(PL_curcop) >= 1) {
5622           if (!PL_thiswhite)
5623           PL_thiswhite = newSVpvs("");
5624           if (CopLINE(PL_curcop) == 1) {
5625           sv_setpvs(PL_thiswhite, "");
5626           PL_faketokens = 0;
5627           }
5628           sv_catpvn(PL_thiswhite, d, s - d);
5629           }
5630           }
5631           #endif
5632           }
5633           goto retry;
5634           case '-':
5635 24288174 50       if (s[1] && isALPHA(s[1]) && !isWORDCHAR(s[2])) {
    100        
    100        
5636           I32 ftst = 0;
5637           char tmp;
5638            
5639 751256         s++;
5640 751256         PL_bufptr = s;
5641 751256         tmp = *s++;
5642            
5643 1865678 50       while (s < PL_bufend && SPACE_OR_TAB(*s))
    100        
5644 745454         s++;
5645            
5646 751256 100       if (strnEQ(s,"=>",2)) {
5647 50         s = force_word(PL_bufptr,WORD,FALSE,FALSE);
5648           DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
5649 50         OPERATOR('-'); /* unary minus */
5650           }
5651 751206         PL_last_uni = PL_oldbufptr;
5652 751206         switch (tmp) {
5653 9586         case 'r': ftst = OP_FTEREAD; break;
5654 32234         case 'w': ftst = OP_FTEWRITE; break;
5655 23804         case 'x': ftst = OP_FTEEXEC; break;
5656 174         case 'o': ftst = OP_FTEOWNED; break;
5657 172         case 'R': ftst = OP_FTRREAD; break;
5658 176         case 'W': ftst = OP_FTRWRITE; break;
5659 172         case 'X': ftst = OP_FTREXEC; break;
5660 172         case 'O': ftst = OP_FTROWNED; break;
5661 100986         case 'e': ftst = OP_FTIS; break;
5662 556         case 'z': ftst = OP_FTZERO; break;
5663 55950         case 's': ftst = OP_FTSIZE; break;
5664 157360         case 'f': ftst = OP_FTFILE; break;
5665 300870         case 'd': ftst = OP_FTDIR; break;
5666 51196         case 'l': ftst = OP_FTLINK; break;
5667 3340         case 'p': ftst = OP_FTPIPE; break;
5668 206         case 'S': ftst = OP_FTSOCK; break;
5669 328         case 'u': ftst = OP_FTSUID; break;
5670 326         case 'g': ftst = OP_FTSGID; break;
5671 1096         case 'k': ftst = OP_FTSVTX; break;
5672 200         case 'b': ftst = OP_FTBLK; break;
5673 1980         case 'c': ftst = OP_FTCHR; break;
5674 3870         case 't': ftst = OP_FTTTY; break;
5675 1140         case 'T': ftst = OP_FTTEXT; break;
5676 2290         case 'B': ftst = OP_FTBINARY; break;
5677           case 'M': case 'A': case 'C':
5678 3018         gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
5679 3018         switch (tmp) {
5680 2672         case 'M': ftst = OP_FTMTIME; break;
5681 170         case 'A': ftst = OP_FTATIME; break;
5682 176         case 'C': ftst = OP_FTCTIME; break;
5683           default: break;
5684           }
5685           break;
5686           default:
5687           break;
5688           }
5689 751206 100       if (ftst) {
5690 751202         PL_last_lop_op = (OPCODE)ftst;
5691           DEBUG_T( { PerlIO_printf(Perl_debug_log,
5692           "### Saw file test %c\n", (int)tmp);
5693           } );
5694 751202         FTST(ftst);
5695           }
5696           else {
5697           /* Assume it was a minus followed by a one-letter named
5698           * subroutine call (or a -bareword), then. */
5699           DEBUG_T( { PerlIO_printf(Perl_debug_log,
5700           "### '-%c' looked like a file test but was not\n",
5701           (int) tmp);
5702           } );
5703 4         s = --PL_bufptr;
5704           }
5705           }
5706           {
5707 23536922         const char tmp = *s++;
5708 23536922 100       if (*s == tmp) {
5709 330884         s++;
5710 330884 100       if (PL_expect == XOPERATOR)
5711 211848         TERM(POSTDEC);
5712           else
5713 119036         OPERATOR(PREDEC);
5714           }
5715 23206038 100       else if (*s == '>') {
5716 22223575         s++;
5717 22223575         s = SKIPSPACE1(s);
5718 22223575 100       if (isIDFIRST_lazy_if(s,UTF)) {
    50        
    100        
    50        
    100        
    100        
    100        
    50        
    0        
    0        
    100        
5719 12627485         s = force_word(s,METHOD,FALSE,TRUE);
5720 12627485         TOKEN(ARROW);
5721           }
5722 9596090 100       else if (*s == '$')
5723 75294         OPERATOR(ARROW);
5724           else
5725 9520796         TERM(ARROW);
5726           }
5727 982463 100       if (PL_expect == XOPERATOR) {
5728 468446 100       if (*s == '=' && !PL_lex_allbrackets &&
    100        
    50        
5729 142         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5730           s--;
5731 0         TOKEN(0);
5732           }
5733 468375         Aop(OP_SUBTRACT);
5734           }
5735           else {
5736 514088 100       if (isSPACE(*s) || !isSPACE(*PL_bufptr))
    100        
5737 282930         check_uni();
5738 514088         OPERATOR('-'); /* unary minus */
5739           }
5740           }
5741            
5742           case '+':
5743           {
5744 1638650         const char tmp = *s++;
5745 1638650 100       if (*s == tmp) {
5746 794104         s++;
5747 794104 100       if (PL_expect == XOPERATOR)
5748 646928         TERM(POSTINC);
5749           else
5750 147176         OPERATOR(PREINC);
5751           }
5752 844546 100       if (PL_expect == XOPERATOR) {
5753 777394 100       if (*s == '=' && !PL_lex_allbrackets &&
    100        
    50        
5754 332         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5755           s--;
5756 0         TOKEN(0);
5757           }
5758 777228         Aop(OP_ADD);
5759           }
5760           else {
5761 67318 100       if (isSPACE(*s) || !isSPACE(*PL_bufptr))
    100        
5762 21708         check_uni();
5763 67318         OPERATOR('+');
5764           }
5765           }
5766            
5767           case '*':
5768 1747060 100       if (PL_expect != XOPERATOR) {
5769 1590884         s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5770 1590882         PL_expect = XOPERATOR;
5771 1590882         force_ident(PL_tokenbuf, '*');
5772 1590882 100       if (!*PL_tokenbuf)
5773 721452         PREREF('*');
5774 869430         TERM('*');
5775           }
5776 156176         s++;
5777 156176 100       if (*s == '*') {
5778 51716         s++;
5779 51726 100       if (*s == '=' && !PL_lex_allbrackets &&
    100        
    50        
5780 20         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5781           s -= 2;
5782 0         TOKEN(0);
5783           }
5784 51716         PWop(OP_POW);
5785           }
5786 104500 100       if (*s == '=' && !PL_lex_allbrackets &&
    100        
    50        
5787 80         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
5788           s--;
5789 0         TOKEN(0);
5790           }
5791 104460         PL_parser->saw_infix_sigil = 1;
5792 104460         Mop(OP_MULTIPLY);
5793            
5794           case '%':
5795 2408954 100       if (PL_expect == XOPERATOR) {
5796 38535 100       if (s[1] == '=' && !PL_lex_allbrackets &&
    100        
    50        
5797 50         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
5798 0         TOKEN(0);
5799 38510         ++s;
5800 38510         PL_parser->saw_infix_sigil = 1;
5801 38510         Mop(OP_MODULO);
5802           }
5803 2370444         PL_tokenbuf[0] = '%';
5804 2370444         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
5805           sizeof PL_tokenbuf - 1, FALSE);
5806 2370442 100       if (!PL_tokenbuf[1]) {
5807 696098         PREREF('%');
5808           }
5809 1674344         PL_expect = XOPERATOR;
5810 1674344         force_ident_maybe_lex('%');
5811 1674344         TERM('%');
5812            
5813           case '^':
5814 7736 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >=
    50        
5815 450 100       (s[1] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE))
5816 0         TOKEN(0);
5817 7286         s++;
5818 7286         BOop(OP_BIT_XOR);
5819           case '[':
5820 7417146 50       if (PL_lex_brackets > 100)
5821 0         Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
5822 7417146         PL_lex_brackstack[PL_lex_brackets++] = 0;
5823 7417146         PL_lex_allbrackets++;
5824           {
5825 7417146         const char tmp = *s++;
5826 7417146         OPERATOR(tmp);
5827           }
5828           case '~':
5829 188588 100       if (s[1] == '~'
5830 740 100       && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
5831           {
5832 724 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
    50        
5833 0         TOKEN(0);
5834 724         s += 2;
5835 724         Perl_ck_warner_d(aTHX_
5836           packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
5837           "Smartmatch is experimental");
5838 724         Eop(OP_SMARTMATCH);
5839           }
5840 187864         s++;
5841 187864         OPERATOR('~');
5842           case ',':
5843 39933773 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMMA)
    100        
5844 48         TOKEN(0);
5845 39933725         s++;
5846 39933725         OPERATOR(',');
5847           case ':':
5848 3006161 100       if (s[1] == ':') {
5849 832         len = 0;
5850 832         goto just_a_word_zero_gv;
5851           }
5852 3005329         s++;
5853 3005329         switch (PL_expect) {
5854           OP *attrs;
5855           #ifdef PERL_MAD
5856           I32 stuffstart;
5857           #endif
5858           case XOPERATOR:
5859 2939012 100       if (!PL_in_my || PL_lex_state != LEX_NORMAL)
    50        
5860           break;
5861 108         PL_bufptr = s; /* update in case we back off */
5862 108 50       if (*s == '=') {
5863 0         Perl_croak(aTHX_
5864           "Use of := for an empty attribute list is not allowed");
5865           }
5866           goto grabattrs;
5867           case XATTRBLOCK:
5868 5856         PL_expect = XBLOCK;
5869 5856         goto grabattrs;
5870           case XATTRTERM:
5871 64         PL_expect = XTERMBLOCK;
5872           grabattrs:
5873           #ifdef PERL_MAD
5874           stuffstart = s - SvPVX(PL_linestr) - 1;
5875           #endif
5876 6028         s = PEEKSPACE(s);
5877           attrs = NULL;
5878 14772 100       while (isIDFIRST_lazy_if(s,UTF)) {
    50        
    50        
    0        
    50        
    100        
    50        
    0        
    0        
    0        
    100        
5879           I32 tmp;
5880           SV *sv;
5881 6034         d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5882 6034 100       if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
    50        
5883 0 0       if (tmp < 0) tmp = -tmp;
5884 0 0       switch (tmp) {
5885           case KEY_or:
5886           case KEY_and:
5887           case KEY_for:
5888           case KEY_foreach:
5889           case KEY_unless:
5890           case KEY_if:
5891           case KEY_while:
5892           case KEY_until:
5893           goto got_attrs;
5894           default:
5895           break;
5896           }
5897           }
5898 6034 50       sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
    50        
    0        
    50        
    100        
5899 6034 100       if (*d == '(') {
5900 146         d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
5901 146 100       COPLINE_SET_FROM_MULTI_END;
5902 146 50       if (!d) {
5903           /* MUST advance bufptr here to avoid bogus
5904           "at end of line" context messages from yyerror().
5905           */
5906 0         PL_bufptr = s + len;
5907 0         yyerror("Unterminated attribute parameter in attribute list");
5908 0 0       if (attrs)
5909 0         op_free(attrs);
5910 0         sv_free(sv);
5911 0         return REPORT(0); /* EOF indicator */
5912           }
5913           }
5914 6034 100       if (PL_lex_stuff) {
5915 146         sv_catsv(sv, PL_lex_stuff);
5916 146         attrs = op_append_elem(OP_LIST, attrs,
5917           newSVOP(OP_CONST, 0, sv));
5918 146         SvREFCNT_dec(PL_lex_stuff);
5919 146         PL_lex_stuff = NULL;
5920           }
5921           else {
5922 5888 100       if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
    50        
    50        
    0        
    100        
5923 4         sv_free(sv);
5924 8 50       if (PL_in_my == KEY_our) {
5925 4         deprecate(":unique");
5926           }
5927           else
5928 0         Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
5929           }
5930            
5931           /* NOTE: any CV attrs applied here need to be part of
5932           the CVf_BUILTIN_ATTRS define in cv.h! */
5933 5884 100       else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
    100        
    50        
    50        
    0        
    100        
5934 5794         sv_free(sv);
5935 5794         CvLVALUE_on(PL_compcv);
5936           }
5937 90 100       else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
    100        
    50        
    50        
    0        
    100        
5938 12         sv_free(sv);
5939 12         deprecate(":locked");
5940           }
5941 78 100       else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
    100        
    50        
    50        
    0        
    100        
5942 6         sv_free(sv);
5943 6         CvMETHOD_on(PL_compcv);
5944           }
5945           /* After we've set the flags, it could be argued that
5946           we don't need to do the attributes.pm-based setting
5947           process, and shouldn't bother appending recognized
5948           flags. To experiment with that, uncomment the
5949           following "else". (Note that's already been
5950           uncommented. That keeps the above-applied built-in
5951           attributes from being intercepted (and possibly
5952           rejected) by a package's attribute routines, but is
5953           justified by the performance win for the common case
5954           of applying only built-in attributes.) */
5955           else
5956 72         attrs = op_append_elem(OP_LIST, attrs,
5957           newSVOP(OP_CONST, 0,
5958           sv));
5959           }
5960 6034         s = PEEKSPACE(d);
5961 6034 100       if (*s == ':' && s[1] != ':')
    50        
5962 6         s = PEEKSPACE(s+1);
5963 6031 100       else if (s == d)
5964           break; /* require real whitespace or :'s */
5965           /* XXX losing whitespace on sequential attributes here */
5966           }
5967           {
5968 6028 100       const char tmp
5969 6028         = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
5970 6028 100       if (*s != ';' && *s != '}' && *s != tmp
    50        
5971 0 0       && (tmp != '=' || *s != ')')) {
    0        
5972 0 0       const char q = ((*s == '\'') ? '"' : '\'');
5973           /* If here for an expression, and parsed no attrs, back
5974           off. */
5975 0 0       if (tmp == '=' && !attrs) {
5976 0         s = PL_bufptr;
5977 0         break;
5978           }
5979           /* MUST advance bufptr here to avoid bogus "at end of line"
5980           context messages from yyerror().
5981           */
5982 0         PL_bufptr = s;
5983 0 0       yyerror( (const char *)
5984           (*s
5985           ? Perl_form(aTHX_ "Invalid separator character "
5986           "%c%c%c in attribute list", q, *s, q)
5987           : "Unterminated attribute list" ) );
5988 0 0       if (attrs)
5989 0         op_free(attrs);
5990 0         OPERATOR(':');
5991           }
5992           }
5993           got_attrs:
5994 6028 100       if (attrs) {
5995           start_force(PL_curforce);
5996 216         NEXTVAL_NEXTTOKE.opval = attrs;
5997           CURMAD('_', PL_nextwhite);
5998 216         force_next(THING);
5999           }
6000           #ifdef PERL_MAD
6001           if (PL_madskills) {
6002           PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
6003           (s - SvPVX(PL_linestr)) - stuffstart);
6004           }
6005           #endif
6006 6028         TOKEN(COLONATTR);
6007           }
6008 2999301 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING) {
    100        
6009 8         s--;
6010 8         TOKEN(0);
6011           }
6012 2999293         PL_lex_allbrackets--;
6013 2999293         OPERATOR(':');
6014           case '(':
6015 44303010         s++;
6016 44303010 100       if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
    100        
6017 6203999         PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */
6018           else
6019 38099011         PL_expect = XTERM;
6020 44303010         s = SKIPSPACE1(s);
6021 44303010         PL_lex_allbrackets++;
6022 44303010         TOKEN('(');
6023           case ';':
6024 68586414 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
    100        
6025 142         TOKEN(0);
6026 68586272         CLINE;
6027 68586272         s++;
6028 68586272         OPERATOR(';');
6029           case ')':
6030 44301832 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_CLOSING)
    100        
6031 6         TOKEN(0);
6032 44301826         s++;
6033 44301826         PL_lex_allbrackets--;
6034 44301826         s = SKIPSPACE1(s);
6035 44301826 100       if (*s == '{')
6036 11885131         PREBLOCK(')');
6037 32416695         TERM(')');
6038           case ']':
6039 7417142 50       if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
    100        
6040 2         TOKEN(0);
6041 7417140         s++;
6042 7417140 50       if (PL_lex_brackets <= 0)
6043 0         yyerror("Unmatched right square bracket");
6044           else
6045 7417140         --PL_lex_brackets;
6046 7417140         PL_lex_allbrackets--;
6047 7417140 100       if (PL_lex_state == LEX_INTERPNORMAL) {
6048 280477 100       if (PL_lex_brackets == 0) {
6049 266279 100       if (*s == '-' && s[1] == '>')
    100        
6050 68         PL_lex_state = LEX_INTERPENDMAYBE;
6051 266211 100       else if (*s != '[' && *s != '{')
6052 225515         PL_lex_state = LEX_INTERPEND;
6053           }
6054           }
6055 7417140         TERM(']');
6056           case '{':
6057 44297193         s++;
6058           leftbracket:
6059 44297483 100       if (PL_lex_brackets > 100) {
6060 100         Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
6061           }
6062 44297483         switch (PL_expect) {
6063           case XTERM:
6064 947271         PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6065 947271         PL_lex_allbrackets++;
6066 947271         OPERATOR(HASHBRACK);
6067           case XOPERATOR:
6068 15415541 50       while (s < PL_bufend && SPACE_OR_TAB(*s))
    100        
6069 198570         s++;
6070           d = s;
6071 15216971         PL_tokenbuf[0] = '\0';
6072 15216971 50       if (d < PL_bufend && *d == '-') {
    100        
6073 30328         PL_tokenbuf[0] = '-';
6074 30328         d++;
6075 40812 50       while (d < PL_bufend && SPACE_OR_TAB(*d))
    50        
6076 0         d++;
6077           }
6078 15216971 50       if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
    100        
    50        
    100        
    50        
    50        
    100        
    100        
    100        
    50        
    50        
    100        
6079 8894595         d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
6080           FALSE, &len);
6081 13409946 50       while (d < PL_bufend && SPACE_OR_TAB(*d))
    100        
6082 210242         d++;
6083 8894595 100       if (*d == '}') {
6084 8625674         const char minus = (PL_tokenbuf[0] == '-');
6085 8625674         s = force_word(s + minus, WORD, FALSE, TRUE);
6086 8625674 100       if (minus)
6087 15232         force_next('-');
6088           }
6089           }
6090           /* FALL THROUGH */
6091           case XATTRBLOCK:
6092           case XBLOCK:
6093 38609797         PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
6094 38609797         PL_lex_allbrackets++;
6095 38609797         PL_expect = XSTATE;
6096 38609797         break;
6097           case XATTRTERM:
6098           case XTERMBLOCK:
6099 1557423         PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6100 1557423         PL_lex_allbrackets++;
6101 1557423         PL_expect = XSTATE;
6102 1557423         break;
6103           default: {
6104           const char *t;
6105 3182992 100       if (PL_oldoldbufptr == PL_last_lop)
6106 545633         PL_lex_brackstack[PL_lex_brackets++] = XTERM;
6107           else
6108 2637359         PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
6109 3182992         PL_lex_allbrackets++;
6110 3182992         s = SKIPSPACE1(s);
6111 3182992 100       if (*s == '}') {
6112 984 100       if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
    100        
6113 2         PL_expect = XTERM;
6114           /* This hack is to get the ${} in the message. */
6115 2         PL_bufptr = s+1;
6116 2         yyerror("syntax error");
6117 2         break;
6118           }
6119 982         OPERATOR(HASHBRACK);
6120           }
6121           /* This hack serves to disambiguate a pair of curlies
6122           * as being a block or an anon hash. Normally, expectation
6123           * determines that, but in cases where we're not in a
6124           * position to expect anything in particular (like inside
6125           * eval"") we have to resolve the ambiguity. This code
6126           * covers the case where the first term in the curlies is a
6127           * quoted string. Most other cases need to be explicitly
6128           * disambiguated by prepending a "+" before the opening
6129           * curly in order to force resolution as an anon hash.
6130           *
6131           * XXX should probably propagate the outer expectation
6132           * into eval"" to rely less on this hack, but that could
6133           * potentially break current behavior of eval"".
6134           * GSAR 97-07-21
6135           */
6136           t = s;
6137 3182008 100       if (*s == '\'' || *s == '"' || *s == '`') {
    100        
6138           /* common case: get past first string, handling escapes */
6139 8083916 50       for (t++; t < PL_bufend && *t != *s;)
    100        
6140 7292361 100       if (*t++ == '\\' && (*t == '\\' || *t == *s))
    100        
    100        
6141 3768251         t++;
6142 533223         t++;
6143           }
6144 2648785 100       else if (*s == 'q') {
6145 11330 50       if (++t < PL_bufend
6146 11330 100       && (!isWORDCHAR(*t)
6147 11314 100       || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
    50        
6148 7102 50       && !isWORDCHAR(*t))))
6149 1652151         {
6150           /* skip q//-like construct */
6151           const char *tmps;
6152           char open, close, term;
6153           I32 brackets = 1;
6154            
6155 7120 50       while (t < PL_bufend && isSPACE(*t))
    100        
6156 10         t++;
6157           /* check for q => */
6158 7110 50       if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
    100        
    100        
6159 4         OPERATOR(HASHBRACK);
6160           }
6161 7106         term = *t;
6162           open = term;
6163 7106 50       if (term && (tmps = strchr("([{< )]}> )]}>",term)))
    100        
6164 7072         term = tmps[5];
6165           close = term;
6166 7106 100       if (open == close)
6167 500 50       for (t++; t < PL_bufend; t++) {
6168 500 50       if (*t == '\\' && t+1 < PL_bufend && open != '\\')
    0        
6169 0         t++;
6170 500 100       else if (*t == open)
6171           break;
6172           }
6173           else {
6174 50082 50       for (t++; t < PL_bufend; t++) {
6175 50082 50       if (*t == '\\' && t+1 < PL_bufend)
    0        
6176 0         t++;
6177 50082 100       else if (*t == close && --brackets <= 0)
    100        
6178           break;
6179 43010 100       else if (*t == open)
6180 2         brackets++;
6181           }
6182           }
6183 7106         t++;
6184           }
6185           else
6186           /* skip plain q word */
6187 30812 50       while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
    50        
    50        
    50        
    0        
    50        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
6188 26592         t += UTF8SKIP(t);
6189           }
6190 2637455 100       else if (isWORDCHAR_lazy_if(t,UTF)) {
    50        
    100        
    50        
    100        
    100        
    100        
    50        
    0        
    0        
    100        
6191 516718         t += UTF8SKIP(t);
6192 2655014 50       while (t < PL_bufend && isWORDCHAR_lazy_if(t,UTF))
    100        
    50        
    100        
    50        
    100        
    100        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
6193 1886776         t += UTF8SKIP(t);
6194           }
6195 3596107 100       while (t < PL_bufend && isSPACE(*t))
    100        
6196 414103         t++;
6197           /* if comma follows first term, call it an anon hash */
6198           /* XXX it could be a comma expression with loop modifiers */
6199 3182004 100       if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
    100        
    100        
    100        
6200 3181000 100       || (*t == '=' && t[1] == '>')))
    100        
6201 11114         OPERATOR(HASHBRACK);
6202 3170890 100       if (PL_expect == XREF)
6203 2834128         PL_expect = XTERM;
6204           else {
6205 336762         PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
6206 336762         PL_expect = XSTATE;
6207           }
6208           }
6209           break;
6210           }
6211 43338112         pl_yylval.ival = CopLINE(PL_curcop);
6212 43338112 100       if (isSPACE(*s) || *s == '#')
    100        
6213 24677071         PL_copline = NOLINE; /* invalidate current command line number */
6214 43338112 100       TOKEN(formbrack ? '=' : '{');
6215           case '}':
6216 44297161 100       if (PL_lex_brackets && PL_lex_brackstack[PL_lex_brackets-1] == XFAKEEOF)
    100        
6217 48         TOKEN(0);
6218           rightbracket:
6219 44297395         s++;
6220 44297395 100       if (PL_lex_brackets <= 0)
6221 12         yyerror("Unmatched right curly bracket");
6222           else
6223 44297383         PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
6224 44297395         PL_lex_allbrackets--;
6225 44297395 100       if (PL_lex_state == LEX_INTERPNORMAL) {
6226 963037 100       if (PL_lex_brackets == 0) {
6227 883309 100       if (PL_expect & XFAKEBRACK) {
6228 2         PL_expect &= XENUMMASK;
6229 2         PL_lex_state = LEX_INTERPEND;
6230 2         PL_bufptr = s;
6231           #if 0
6232           if (PL_madskills) {
6233           if (!PL_thiswhite)
6234           PL_thiswhite = newSVpvs("");
6235           sv_catpvs(PL_thiswhite,"}");
6236           }
6237           #endif
6238 2         return yylex(); /* ignore fake brackets */
6239           }
6240 883307 100       if (PL_lex_inwhat == OP_SUBST && PL_lex_repl == PL_linestr
    100        
6241 175367 50       && SvEVALED(PL_lex_repl))
6242 175367         PL_lex_state = LEX_INTERPEND;
6243 707940 100       else if (*s == '-' && s[1] == '>')
    100        
6244 504         PL_lex_state = LEX_INTERPENDMAYBE;
6245 707436 100       else if (*s != '[' && *s != '{')
6246 690748         PL_lex_state = LEX_INTERPEND;
6247           }
6248           }
6249 44297393 100       if (PL_expect & XFAKEBRACK) {
6250 12         PL_expect &= XENUMMASK;
6251 12         PL_bufptr = s;
6252 12         return yylex(); /* ignore fake brackets */
6253           }
6254           start_force(PL_curforce);
6255           if (PL_madskills) {
6256           curmad('X', newSVpvn(s-1,1));
6257           CURMAD('_', PL_thiswhite);
6258           }
6259 44297381 100       force_next(formbrack ? '.' : '}');
6260 44297381 100       if (formbrack) LEAVE;
6261           #ifdef PERL_MAD
6262           if (PL_madskills && !PL_thistoken)
6263           PL_thistoken = newSVpvs("");
6264           #endif
6265 44297381 50       if (formbrack == 2) { /* means . where arguments were expected */
6266           start_force(PL_curforce);
6267 0         force_next(';');
6268 0         TOKEN(FORMRBRACK);
6269           }
6270 44297381         TOKEN(';');
6271           case '&':
6272           s++;
6273 5862521 100       if (*s++ == '&') {
6274 2544850 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >=
    50        
6275 28234 50       (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6276           s -= 2;
6277 0         TOKEN(0);
6278           }
6279 2516616         AOPERATOR(ANDAND);
6280           }
6281 3345905         s--;
6282 3345905 100       if (PL_expect == XOPERATOR) {
6283 1082861 100       if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
    100        
6284 2 50       && isIDFIRST_lazy_if(s,UTF))
    50        
    50        
    0        
    50        
    50        
    0        
    0        
    0        
    0        
    50        
6285           {
6286 2         CopLINE_dec(PL_curcop);
6287 2         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
6288 2         CopLINE_inc(PL_curcop);
6289           }
6290 1088469 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >=
    50        
6291 5608 100       (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6292           s--;
6293 0         TOKEN(0);
6294           }
6295 1082861         PL_parser->saw_infix_sigil = 1;
6296 1082861         BAop(OP_BIT_AND);
6297           }
6298            
6299 2263044         PL_tokenbuf[0] = '&';
6300 2263044         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1,
6301           sizeof PL_tokenbuf - 1, TRUE);
6302 2263042 100       if (PL_tokenbuf[1]) {
6303 1753210         PL_expect = XOPERATOR;
6304 1753210         force_ident_maybe_lex('&');
6305           }
6306           else
6307 509832         PREREF('&');
6308 1753210         pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
6309 1753210         TERM('&');
6310            
6311           case '|':
6312           s++;
6313 3027944 100       if (*s++ == '|') {
6314 2429593 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >=
    100        
6315 55598 100       (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC)) {
6316           s -= 2;
6317 8         TOKEN(0);
6318           }
6319 2373987         AOPERATOR(OROR);
6320           }
6321 653949         s--;
6322 709223 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >=
    50        
6323 55274 100       (*s == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_BITWISE)) {
6324           s--;
6325 0         TOKEN(0);
6326           }
6327 653949         BOop(OP_BIT_OR);
6328           case '=':
6329           s++;
6330           {
6331 49147590         const char tmp = *s++;
6332 49147590 100       if (tmp == '=') {
6333 1028644 100       if (!PL_lex_allbrackets &&
    50        
6334 8026         PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6335           s -= 2;
6336 0         TOKEN(0);
6337           }
6338 1024631         Eop(OP_EQ);
6339           }
6340 48122959 100       if (tmp == '>') {
6341 14221703 100       if (!PL_lex_allbrackets &&
    100        
6342 279902         PL_lex_fakeeof >= LEX_FAKEEOF_COMMA) {
6343           s -= 2;
6344 4         TOKEN(0);
6345           }
6346 14090568         OPERATOR(',');
6347           }
6348 34032387 100       if (tmp == '~')
6349 3598441         PMop(OP_MATCH);
6350 30433946 50       if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
    100        
    100        
6351 27158 100       && strchr("+-*/%.^&|<",tmp))
6352 106         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6353           "Reversed %c= operator",(int)tmp);
6354 30433928         s--;
6355 30870424 100       if (PL_expect == XSTATE && isALPHA(tmp) &&
    50        
    100        
6356 436500 50       (s == PL_linestart+1 || s[-2] == '\n') )
6357           {
6358 884511 100       if ((PL_in_eval && !PL_rsfp && !PL_parser->filtered)
    100        
    50        
6359 884509 100       || PL_lex_state != LEX_NORMAL) {
6360 4         d = PL_bufend;
6361 22 50       while (s < d) {
6362 20 100       if (*s++ == '\n') {
6363 8         incline(s);
6364 8 100       if (strnEQ(s,"=cut",4)) {
6365 4         s = strchr(s,'\n');
6366 4 50       if (s)
6367 4         s++;
6368           else
6369           s = d;
6370 12         incline(s);
6371 616692275         goto retry;
6372           }
6373           }
6374           }
6375           goto retry;
6376           }
6377           #ifdef PERL_MAD
6378           if (PL_madskills) {
6379           if (!PL_thiswhite)
6380           PL_thiswhite = newSVpvs("");
6381           sv_catpvn(PL_thiswhite, PL_linestart,
6382           PL_bufend - PL_linestart);
6383           }
6384           #endif
6385 884507         s = PL_bufend;
6386 884507         PL_parser->in_pod = 1;
6387 884507         goto retry;
6388           }
6389           }
6390 29549417 100       if (PL_expect == XBLOCK) {
6391           const char *t = s;
6392           #ifdef PERL_STRICT_CR
6393           while (SPACE_OR_TAB(*t))
6394           #else
6395 302 100       while (SPACE_OR_TAB(*t) || *t == '\r')
    50        
6396           #endif
6397 12         t++;
6398 290 50       if (*t == '\n' || *t == '#') {
6399           formbrack = 1;
6400 290         ENTER;
6401 290         SAVEI8(PL_parser->form_lex_state);
6402 290         SAVEI32(PL_lex_formbrack);
6403 290         PL_parser->form_lex_state = PL_lex_state;
6404 290         PL_lex_formbrack = PL_lex_brackets + 1;
6405 290         goto leftbracket;
6406           }
6407           }
6408 29549127 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
    50        
6409           s--;
6410 0         TOKEN(0);
6411           }
6412 29549127         pl_yylval.ival = 0;
6413 29549127         OPERATOR(ASSIGNOP);
6414           case '!':
6415           s++;
6416           {
6417 2749151         const char tmp = *s++;
6418 2749151 100       if (tmp == '=') {
6419           /* was this !=~ where !~ was meant?
6420           * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
6421            
6422 370193 100       if (*s == '~' && ckWARN(WARN_SYNTAX)) {
    100        
6423 14         const char *t = s+1;
6424            
6425 35 50       while (t < PL_bufend && isSPACE(*t))
    100        
6426 14         ++t;
6427            
6428 18 100       if (*t == '/' || *t == '?' ||
    100        
6429 8 100       ((*t == 'm' || *t == 's' || *t == 'y')
6430 8 50       && !isWORDCHAR(t[1])) ||
    50        
6431 3 50       (*t == 't' && t[1] == 'r' && !isWORDCHAR(t[2])))
    50        
6432 14         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6433           "!=~ should be !~");
6434           }
6435 370247 100       if (!PL_lex_allbrackets &&
    50        
6436 108         PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6437           s -= 2;
6438 0         TOKEN(0);
6439           }
6440 370193         Eop(OP_NE);
6441           }
6442 2378958 100       if (tmp == '~')
6443 297088         PMop(OP_NOT);
6444           }
6445 2081870         s--;
6446 2081870         OPERATOR('!');
6447           case '<':
6448 1327904 100       if (PL_expect != XOPERATOR) {
6449 447311 100       if (s[1] != '<' && !strchr(s,'>'))
    100        
6450 4         check_uni();
6451 447311 100       if (s[1] == '<')
6452 356411         s = scan_heredoc(s);
6453           else
6454 90900         s = scan_inputsymbol(s);
6455 447219         PL_expect = XOPERATOR;
6456 447219         TOKEN(sublex_start());
6457           }
6458           s++;
6459           {
6460 880593         char tmp = *s++;
6461 880593 100       if (tmp == '<') {
6462 39788 100       if (*s == '=' && !PL_lex_allbrackets &&
    100        
    50        
6463 10         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6464           s -= 2;
6465 0         TOKEN(0);
6466           }
6467 39783         SHop(OP_LEFT_SHIFT);
6468           }
6469 840810 100       if (tmp == '=') {
6470 155336         tmp = *s++;
6471 155336 100       if (tmp == '>') {
6472 30514 100       if (!PL_lex_allbrackets &&
    50        
6473 28         PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6474           s -= 3;
6475 0         TOKEN(0);
6476           }
6477 30500         Eop(OP_NCMP);
6478           }
6479 124836         s--;
6480 130184 100       if (!PL_lex_allbrackets &&
    50        
6481 10696         PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6482           s -= 2;
6483 0         TOKEN(0);
6484           }
6485 124836         Rop(OP_LE);
6486           }
6487           }
6488 685474         s--;
6489 685474 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
    100        
6490           s--;
6491 2         TOKEN(0);
6492           }
6493 685472         Rop(OP_LT);
6494           case '>':
6495           s++;
6496           {
6497 1152857         const char tmp = *s++;
6498 1152857 100       if (tmp == '>') {
6499 31481 100       if (*s == '=' && !PL_lex_allbrackets &&
    100        
    50        
6500 4         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6501           s -= 2;
6502 0         TOKEN(0);
6503           }
6504 31479         SHop(OP_RIGHT_SHIFT);
6505           }
6506 1121378 100       else if (tmp == '=') {
6507 356644 100       if (!PL_lex_allbrackets &&
    50        
6508 18160         PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
6509           s -= 2;
6510 0         TOKEN(0);
6511           }
6512 348104         Rop(OP_GE);
6513           }
6514           }
6515 773274         s--;
6516 773274 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE) {
    50        
6517           s--;
6518 0         TOKEN(0);
6519           }
6520 773274         Rop(OP_GT);
6521            
6522           case '$':
6523 117171704         CLINE;
6524            
6525 117171704 100       if (PL_expect == XOPERATOR) {
6526 8 100       if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
    50        
6527 4         return deprecate_commaless_var_list();
6528           }
6529           }
6530            
6531 117171700 100       if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
    50        
    50        
    50        
    0        
    50        
    100        
    100        
    50        
    50        
    0        
    0        
    0        
    0        
    0        
    100        
6532 219482         PL_tokenbuf[0] = '@';
6533 219482         s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
6534           sizeof PL_tokenbuf - 1, FALSE);
6535 219480 50       if (PL_expect == XOPERATOR)
6536 0         no_op("Array length", s);
6537 219480 100       if (!PL_tokenbuf[1])
6538 92314         PREREF(DOLSHARP);
6539 127166         PL_expect = XOPERATOR;
6540 127166         force_ident_maybe_lex('#');
6541 127166         TOKEN(DOLSHARP);
6542           }
6543            
6544 116952218         PL_tokenbuf[0] = '$';
6545 116952218         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
6546           sizeof PL_tokenbuf - 1, FALSE);
6547 116952216 100       if (PL_expect == XOPERATOR)
6548 4         no_op("Scalar", s);
6549 116952216 100       if (!PL_tokenbuf[1]) {
6550 1139352 100       if (s == PL_bufend)
6551 2         yyerror("Final $ should be \\$ or $name");
6552 1139352         PREREF('$');
6553           }
6554            
6555           d = s;
6556           {
6557 115812864         const char tmp = *s;
6558 115812864 100       if (PL_lex_state == LEX_NORMAL || PL_lex_brackets)
    100        
6559 106850594         s = SKIPSPACE1(s);
6560            
6561 115812864 100       if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
    100        
6562 112840219 100       && intuit_more(s)) {
6563 100458234 100       if (*s == '[') {
6564 3802163         PL_tokenbuf[0] = '@';
6565 3802163 100       if (ckWARN(WARN_SYNTAX)) {
6566 1192381         char *t = s+1;
6567            
6568 3108548 100       while (isSPACE(*t) || isWORDCHAR_lazy_if(t,UTF) || *t == '$')
    100        
    50        
    100        
    50        
    50        
    100        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    100        
6569 1335095         t++;
6570 1192381 100       if (*t++ == ',') {
6571 2         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6572 5 50       while (t < PL_bufend && *t != ']')
    100        
6573 2         t++;
6574 2         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6575           "Multidimensional syntax %.*s not supported",
6576 2         (int)((t - PL_bufptr) + 1), PL_bufptr);
6577           }
6578           }
6579           }
6580 96656071 100       else if (*s == '{') {
6581           char *t;
6582 5156890         PL_tokenbuf[0] = '%';
6583 5156890 100       if (strEQ(PL_tokenbuf+1, "SIG") && ckWARN(WARN_SYNTAX)
    100        
    100        
    100        
    100        
6584 81990 50       && (t = strchr(s, '}')) && (t = strchr(t, '=')))
    100        
6585           {
6586           char tmpbuf[sizeof PL_tokenbuf];
6587           do {
6588 80672         t++;
6589 80672 100       } while (isSPACE(*t));
6590 40012 50       if (isIDFIRST_lazy_if(t,UTF)) {
    50        
    50        
    0        
    50        
    100        
    100        
    50        
    0        
    0        
    100        
6591           STRLEN len;
6592 34406         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
6593           &len);
6594 56019 100       while (isSPACE(*t))
6595 4770         t++;
6596 34406 100       if (*t == ';'
6597 110 50       && get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
    50        
    0        
    50        
    100        
    100        
6598 21 50       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
    50        
6599           "You need to quote \"%"UTF8f"\"",
6600 15 50       UTF8fARG(UTF, len, tmpbuf));
    0        
    100        
6601           }
6602           }
6603           }
6604           }
6605            
6606 115812864         PL_expect = XOPERATOR;
6607 115812864 100       if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
    100        
6608 38247285         const bool islop = (PL_last_lop == PL_oldoldbufptr);
6609 38247285 100       if (!islop || PL_last_lop_op == OP_GREPSTART)
    100        
6610 37986938         PL_expect = XOPERATOR;
6611 260347 100       else if (strchr("$@\"'`q", *s))
6612 91017         PL_expect = XTERM; /* e.g. print $fh "foo" */
6613 169330 100       else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
    100        
    50        
    50        
    0        
    50        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
6614 40         PL_expect = XTERM; /* e.g. print $fh &sub */
6615 169290 100       else if (isIDFIRST_lazy_if(s,UTF)) {
    50        
    100        
    50        
    50        
    100        
    50        
    0        
    0        
    0        
    100        
6616           char tmpbuf[sizeof PL_tokenbuf];
6617           int t2;
6618 105508         scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6619 105508 100       if ((t2 = keyword(tmpbuf, len, 0))) {
6620           /* binary operators exclude handle interpretations */
6621 104828 100       switch (t2) {
6622           case -KEY_x:
6623           case -KEY_eq:
6624           case -KEY_ne:
6625           case -KEY_gt:
6626           case -KEY_lt:
6627           case -KEY_ge:
6628           case -KEY_le:
6629           case -KEY_cmp:
6630           break;
6631           default:
6632 103396         PL_expect = XTERM; /* e.g. print $fh length() */
6633 103396         break;
6634           }
6635           }
6636           else {
6637 680         PL_expect = XTERM; /* e.g. print $fh subr() */
6638           }
6639           }
6640 63782 100       else if (isDIGIT(*s))
6641 620         PL_expect = XTERM; /* e.g. print $fh 3 */
6642 63162 100       else if (*s == '.' && isDIGIT(s[1]))
    50        
6643 0         PL_expect = XTERM; /* e.g. print $fh .3 */
6644 63162 100       else if ((*s == '?' || *s == '-' || *s == '+')
    100        
6645 5920 100       && !isSPACE(s[1]) && s[1] != '=')
    50        
6646 4         PL_expect = XTERM; /* e.g. print $fh -1 */
6647 63158 100       else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
    100        
    100        
6648 4 50       && s[1] != '/')
6649 4         PL_expect = XTERM; /* e.g. print $fh /.../
6650           XXX except DORDOR operator
6651           */
6652 63154 100       else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
    100        
    50        
6653 5972 50       && s[2] != '=')
6654 5972         PL_expect = XTERM; /* print $fh <<"EOF" */
6655           }
6656           }
6657 115812864         force_ident_maybe_lex('$');
6658 115812864         TOKEN('$');
6659            
6660           case '@':
6661 15888234 100       if (PL_expect == XOPERATOR)
6662 6         no_op("Array", s);
6663 15888234         PL_tokenbuf[0] = '@';
6664 15888234         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
6665 15888234 100       if (!PL_tokenbuf[1]) {
6666 1759319         PREREF('@');
6667           }
6668 14128915 100       if (PL_lex_state == LEX_NORMAL)
6669 13933861         s = SKIPSPACE1(s);
6670 14128915 100       if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
    100        
    100        
6671 13001318 100       if (*s == '{')
6672 144931         PL_tokenbuf[0] = '%';
6673            
6674           /* Warn about @ where they meant $. */
6675 13001318 100       if (*s == '[' || *s == '{') {
6676 189799 100       if (ckWARN(WARN_SYNTAX)) {
6677 49702         const char *t = s + 1;
6678 128565 50       while (*t && (isWORDCHAR_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
    100        
    50        
    50        
    0        
    50        
    100        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    100        
6679 54372 50       t += UTF ? UTF8SKIP(t) : 1;
    50        
    0        
    50        
    100        
6680 49702 100       if (*t == '}' || *t == ']') {
6681 12         t++;
6682 12         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
6683           /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
6684 78 50       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
    50        
    50        
    50        
6685           "Scalar value %"UTF8f" better written as $%"UTF8f,
6686 36 50       UTF8fARG(UTF, t-PL_bufptr, PL_bufptr),
    0        
    100        
6687 42 50       UTF8fARG(UTF, t-PL_bufptr-1, PL_bufptr+1));
    0        
    100        
6688           }
6689           }
6690           }
6691           }
6692 14128915         PL_expect = XOPERATOR;
6693 14128915         force_ident_maybe_lex('@');
6694 14128915         TERM('@');
6695            
6696           case '/': /* may be division, defined-or, or pattern */
6697 2425577 100       if (PL_expect == XTERMORDORDOR && s[1] == '/') {
    50        
6698 22 50       if (!PL_lex_allbrackets && PL_lex_fakeeof >=
    0        
6699 0 0       (s[2] == '=' ? LEX_FAKEEOF_ASSIGN : LEX_FAKEEOF_LOGIC))
6700 0         TOKEN(0);
6701 22         s += 2;
6702 22         AOPERATOR(DORDOR);
6703           }
6704           case '?': /* may either be conditional or pattern */
6705 5424824 100       if (PL_expect == XOPERATOR) {
6706 3141419         char tmp = *s++;
6707 3141419 100       if(tmp == '?') {
6708 3113078 100       if (!PL_lex_allbrackets &&
    100        
6709 229074         PL_lex_fakeeof >= LEX_FAKEEOF_IFELSE) {
6710           s--;
6711 4         TOKEN(0);
6712           }
6713 2999257         PL_lex_allbrackets++;
6714 2999257         OPERATOR('?');
6715           }
6716           else {
6717 142158         tmp = *s++;
6718 142158 100       if(tmp == '/') {
6719           /* A // operator. */
6720 56866 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >=
    50        
6721 18 100       (*s == '=' ? LEX_FAKEEOF_ASSIGN :
6722           LEX_FAKEEOF_LOGIC)) {
6723           s -= 2;
6724 0         TOKEN(0);
6725           }
6726 56848         AOPERATOR(DORDOR);
6727           }
6728           else {
6729 85310         s--;
6730 85334 100       if (*s == '=' && !PL_lex_allbrackets &&
    100        
    50        
6731 48         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6732           s--;
6733 0         TOKEN(0);
6734           }
6735 85310         Mop(OP_DIVIDE);
6736           }
6737           }
6738           }
6739           else {
6740           /* Disable warning on "study /blah/" */
6741 2283405 100       if (PL_oldoldbufptr == PL_last_uni
    0        
    0        
    0        
6742 2 50       && (*PL_last_uni != 's' || s - PL_last_uni < 5
    0        
6743 0 0       || memNE(PL_last_uni, "study", 5)
6744 0 0       || isWORDCHAR_lazy_if(PL_last_uni+5,UTF)
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
6745           ))
6746 2         check_uni();
6747 2283405 100       if (*s == '?')
6748 8         deprecate("?PATTERN? without explicit operator");
6749 2283405         s = scan_pat(s,OP_MATCH);
6750 2283395         TERM(sublex_start());
6751           }
6752            
6753           case '.':
6754 4493129 100       if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
    100        
6755           #ifdef PERL_STRICT_CR
6756           && s[1] == '\n'
6757           #else
6758 10 50       && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
    50        
    0        
6759           #endif
6760 0 0       && (s == PL_linestart || s[-1] == '\n') )
    0        
6761           {
6762 0         PL_expect = XSTATE;
6763           formbrack = 2; /* dot seen where arguments expected */
6764 0         goto rightbracket;
6765           }
6766 4493129 100       if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
    100        
    50        
6767 2         s += 3;
6768 2         OPERATOR(YADAYADA);
6769           }
6770 4493127 100       if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
    100        
6771 4483125         char tmp = *s++;
6772 4483125 100       if (*s == tmp) {
6773 183189 100       if (!PL_lex_allbrackets &&
    50        
6774 306         PL_lex_fakeeof >= LEX_FAKEEOF_RANGE) {
6775           s--;
6776 0         TOKEN(0);
6777           }
6778 183036         s++;
6779 183036 100       if (*s == tmp) {
6780 344         s++;
6781 344         pl_yylval.ival = OPf_SPECIAL;
6782           }
6783           else
6784 182692         pl_yylval.ival = 0;
6785 183036         OPERATOR(DOTDOT);
6786           }
6787 4300765 100       if (*s == '=' && !PL_lex_allbrackets &&
    100        
    50        
6788 1352         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN) {
6789           s--;
6790 0         TOKEN(0);
6791           }
6792 4300089         Aop(OP_CONCAT);
6793           }
6794           /* FALL THROUGH */
6795           case '0': case '1': case '2': case '3': case '4':
6796           case '5': case '6': case '7': case '8': case '9':
6797 24486895         s = scan_num(s, &pl_yylval);
6798           DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
6799 24486881 100       if (PL_expect == XOPERATOR)
6800 40         no_op("Number",s);
6801 24486881         TERM(THING);
6802            
6803           case '\'':
6804 27135418         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6805 27135418 100       COPLINE_SET_FROM_MULTI_END;
6806           DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6807 27135418 100       if (PL_expect == XOPERATOR) {
6808 8 100       if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
    50        
6809 4         return deprecate_commaless_var_list();
6810           }
6811           else
6812 4         no_op("String",s);
6813           }
6814 27135414 50       if (!s)
6815 0         missingterm(NULL);
6816 27135414         pl_yylval.ival = OP_CONST;
6817 27135414         TERM(sublex_start());
6818            
6819           case '"':
6820 19024121         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6821           DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
6822 19024121 100       if (PL_expect == XOPERATOR) {
6823 12 100       if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
    50        
6824 4         return deprecate_commaless_var_list();
6825           }
6826           else
6827 8         no_op("String",s);
6828           }
6829 19024117 50       if (!s)
6830 0         missingterm(NULL);
6831 19024117         pl_yylval.ival = OP_CONST;
6832           /* FIXME. I think that this can be const if char *d is replaced by
6833           more localised variables. */
6834 151854520 50       for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
    100        
6835 142694465 100       if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
    100        
    100        
6836 9864062         pl_yylval.ival = OP_STRINGIFY;
6837 9864062         break;
6838           }
6839           }
6840 19024117 100       if (pl_yylval.ival == OP_CONST)
6841 9160055 100       COPLINE_SET_FROM_MULTI_END;
6842 19024117         TERM(sublex_start());
6843            
6844           case '`':
6845 74810         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
6846           DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
6847 74810 50       if (PL_expect == XOPERATOR)
6848 0         no_op("Backticks",s);
6849 74810 50       if (!s)
6850 0         missingterm(NULL);
6851 74810         readpipe_override();
6852 74810         TERM(sublex_start());
6853            
6854           case '\\':
6855 2439744         s++;
6856 2439744 100       if (PL_lex_inwhat && isDIGIT(*s))
    100        
6857 4         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
6858 4         *s, *s);
6859 2439744 50       if (PL_expect == XOPERATOR)
6860 0         no_op("Backslash",s);
6861 2439744         OPERATOR(REFGEN);
6862            
6863           case 'v':
6864 547673 100       if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
    50        
6865 6478         char *start = s + 2;
6866 11145 100       while (isDIGIT(*start) || *start == '_')
    50        
6867 1428         start++;
6868 6478 100       if (*start == '.' && isDIGIT(start[1])) {
    100        
6869 1116         s = scan_num(s, &pl_yylval);
6870 1116         TERM(THING);
6871           }
6872 5362 100       else if ((*start == ':' && start[1] == ':')
    100        
6873 5358 100       || (PL_expect == XSTATE && *start == ':'))
    100        
6874           goto keylookup;
6875 5356 100       else if (PL_expect == XSTATE) {
6876           d = start;
6877 27 50       while (d < PL_bufend && isSPACE(*d)) d++;
    100        
6878 18 100       if (*d == ':') goto keylookup;
6879           }
6880           /* avoid v123abc() or $h{v1}, allow C */
6881 8031 50       if (!isALPHA(*start) && (PL_expect == XTERM
    100        
6882           || PL_expect == XREF || PL_expect == XSTATE
6883 5354         || PL_expect == XTERMORDORDOR)) {
6884 5342 50       GV *const gv = gv_fetchpvn_flags(s, start - s,
    50        
    0        
    50        
    100        
6885           UTF ? SVf_UTF8 : 0, SVt_PVCV);
6886 5342 100       if (!gv) {
6887 5340         s = scan_num(s, &pl_yylval);
6888 5336         TERM(THING);
6889           }
6890           }
6891           }
6892           goto keylookup;
6893           case 'x':
6894 282234 100       if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
    100        
6895 834         s++;
6896 834         Mop(OP_REPEAT);
6897           }
6898           goto keylookup;
6899            
6900           case '_':
6901           case 'a': case 'A':
6902           case 'b': case 'B':
6903           case 'c': case 'C':
6904           case 'd': case 'D':
6905           case 'e': case 'E':
6906           case 'f': case 'F':
6907           case 'g': case 'G':
6908           case 'h': case 'H':
6909           case 'i': case 'I':
6910           case 'j': case 'J':
6911           case 'k': case 'K':
6912           case 'l': case 'L':
6913           case 'm': case 'M':
6914           case 'n': case 'N':
6915           case 'o': case 'O':
6916           case 'p': case 'P':
6917           case 'q': case 'Q':
6918           case 'r': case 'R':
6919           case 's': case 'S':
6920           case 't': case 'T':
6921           case 'u': case 'U':
6922           case 'V':
6923           case 'w': case 'W':
6924           case 'X':
6925           case 'y': case 'Y':
6926           case 'z': case 'Z':
6927            
6928           keylookup: {
6929           bool anydelim;
6930           bool lex;
6931           I32 tmp;
6932           SV *sv;
6933           CV *cv;
6934           PADOFFSET off;
6935           OP *rv2cv_op;
6936            
6937           lex = FALSE;
6938           orig_keyword = 0;
6939           off = 0;
6940           sv = NULL;
6941           cv = NULL;
6942           gv = NULL;
6943           gvp = NULL;
6944           rv2cv_op = NULL;
6945            
6946 125145302         PL_bufptr = s;
6947 125145302         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
6948            
6949           /* Some keywords can be followed by any delimiter, including ':' */
6950 125145302         anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
6951            
6952           /* x::* is just a word, unless x is "CORE" */
6953 125145302 100       if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
    100        
    100        
    100        
6954           goto just_a_word;
6955            
6956           d = s;
6957 224269481 100       while (d < PL_bufend && isSPACE(*d))
    100        
6958 102138280         d++; /* no comments skipped here, or s### is misparsed */
6959            
6960           /* Is this a word before a => operator? */
6961 122131201 100       if (*d == '=' && d[1] == '>') {
    100        
6962           fat_arrow:
6963 4159002         CLINE;
6964           pl_yylval.opval
6965 4159002         = (OP*)newSVOP(OP_CONST, 0,
6966           S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
6967 4159002         pl_yylval.opval->op_private = OPpCONST_BARE;
6968 4159002         TERM(WORD);
6969           }
6970            
6971           /* Check for plugged-in keyword */
6972           {
6973           OP *o;
6974           int result;
6975 117972201         char *saved_bufptr = PL_bufptr;
6976 117972201         PL_bufptr = s;
6977 117972201         result = PL_keyword_plugin(aTHX_ PL_tokenbuf, len, &o);
6978 117972197         s = PL_bufptr;
6979 117972197 100       if (result == KEYWORD_PLUGIN_DECLINE) {
6980           /* not a plugged-in keyword */
6981 117971631         PL_bufptr = saved_bufptr;
6982 566 100       } else if (result == KEYWORD_PLUGIN_STMT) {
6983 188         pl_yylval.opval = o;
6984 188         CLINE;
6985 188         PL_expect = XSTATE;
6986 188         return REPORT(PLUGSTMT);
6987 378 50       } else if (result == KEYWORD_PLUGIN_EXPR) {
6988 378         pl_yylval.opval = o;
6989 378         CLINE;
6990 378         PL_expect = XOPERATOR;
6991 378         return REPORT(PLUGEXPR);
6992           } else {
6993 0         Perl_croak(aTHX_ "Bad plugin affecting keyword '%s'",
6994 0         PL_tokenbuf);
6995           }
6996           }
6997            
6998           /* Check for built-in keyword */
6999 117971631         tmp = keyword(PL_tokenbuf, len, 0);
7000            
7001           /* Is this a label? */
7002 172320496 100       if (!anydelim && PL_expect == XSTATE
    100        
7003 69117547 100       && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
    100        
    100        
7004 92362         s = d + 1;
7005 92362         pl_yylval.pval = savepvn(PL_tokenbuf, len+1);
7006 92362         pl_yylval.pval[len] = '\0';
7007 92362 50       pl_yylval.pval[len+1] = UTF ? 1 : 0;
    100        
    50        
    50        
    100        
7008 92362         CLINE;
7009 92362         TOKEN(LABEL);
7010           }
7011            
7012           /* Check for lexical sub */
7013 117879269 100       if (PL_expect != XOPERATOR) {
7014           char tmpbuf[sizeof PL_tokenbuf + 1];
7015 103124075         *tmpbuf = '&';
7016 103124075         Copy(PL_tokenbuf, tmpbuf+1, len, char);
7017 103124075 50       off = pad_findmy_pvn(tmpbuf, len+1, UTF ? SVf_UTF8 : 0);
    100        
    50        
    100        
    100        
7018 103124075 100       if (off != NOT_IN_PAD) {
7019           assert(off); /* we assume this is boolean-true below */
7020 154 100       if (PAD_COMPNAME_FLAGS_isOUR(off)) {
7021 22 50       HV * const stash = PAD_COMPNAME_OURSTASH(off);
7022 22 50       HEK * const stashname = HvNAME_HEK(stash);
    50        
    50        
7023 22         sv = newSVhek(stashname);
7024 22         sv_catpvs(sv, "::");
7025 22 50       sv_catpvn_flags(sv, PL_tokenbuf, len,
    50        
    0        
    50        
    50        
7026           (UTF ? SV_CATUTF8 : SV_CATBYTES));
7027 22         gv = gv_fetchsv(sv, GV_NOADD_NOINIT | SvUTF8(sv),
7028           SVt_PVCV);
7029           off = 0;
7030 22 50       if (!gv) {
7031 0         sv_free(sv);
7032           sv = NULL;
7033 0         goto just_a_word;
7034           }
7035           }
7036           else {
7037 132         rv2cv_op = newOP(OP_PADANY, 0);
7038 132         rv2cv_op->op_targ = off;
7039 132         cv = find_lexical_cv(off);
7040           }
7041           lex = TRUE;
7042           goto just_a_word;
7043           }
7044           off = 0;
7045           }
7046            
7047 117879115 100       if (tmp < 0) { /* second-class keyword? */
7048           GV *ogv = NULL; /* override (winner) */
7049           GV *hgv = NULL; /* hidden (loser) */
7050 23347380 100       if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
    100        
    100        
7051           CV *cv;
7052 14604801 50       if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
    100        
    50        
    100        
    100        
    100        
7053 14186 100       UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
7054 14186 50       (cv = GvCVu(gv)))
7055           {
7056 11770 100       if (GvIMPORTED_CV(gv))
7057           ogv = gv;
7058 10550 50       else if (! CvMETHOD(cv))
7059           hgv = gv;
7060           }
7061 29208382 100       if (!ogv &&
    100        
7062 14603581 50       (gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
    100        
    50        
    100        
    100        
7063 368 50       UTF ? -(I32)len : (I32)len, FALSE)) &&
7064 918 100       (gv = *gvp) && isGV_with_GP(gv) &&
    50        
    50        
    100        
7065 692 50       GvCVu(gv) && GvIMPORTED_CV(gv))
7066           {
7067           ogv = gv;
7068           }
7069           }
7070 23347380 100       if (ogv) {
7071           orig_keyword = tmp;
7072           tmp = 0; /* overridden by import or by GLOBAL */
7073           }
7074 23345834 100       else if (gv && !gvp
7075 12966 100       && -tmp==KEY_lock /* XXX generalizable kludge */
7076 10448 50       && GvCVu(gv))
    50        
7077           {
7078           tmp = 0; /* any sub overrides "weak" keyword */
7079           }
7080           else { /* no override */
7081 23335386         tmp = -tmp;
7082 23335386 100       if (tmp == KEY_dump) {
7083 6         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
7084           "dump() better written as CORE::dump()");
7085           }
7086           gv = NULL;
7087           gvp = 0;
7088 23335386 100       if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
    50        
7089 8         Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
7090           "Ambiguous call resolved as CORE::%s(), "
7091           "qualify as such or use &",
7092 8 50       GvENAME(hgv));
7093           }
7094           }
7095            
7096 117879115 100       if (tmp && tmp != KEY___DATA__ && tmp != KEY___END__
    100        
7097 106121617 100       && (!anydelim || *s != '#')) {
    100        
7098           /* no override, and not s### either; skipspace is safe here
7099           * check for => on following line */
7100 106017995         STRLEN bufoff = PL_bufptr - SvPVX(PL_linestr);
7101 106017995         STRLEN soff = s - SvPVX(PL_linestr);
7102 106017995         s = skipspace_flags(s, LEX_NO_INCLINE);
7103 106017995 100       if (*s == '=' && s[1] == '>') goto fat_arrow;
    100        
7104 106017993         PL_bufptr = SvPVX(PL_linestr) + bufoff;
7105 112190057         s = SvPVX(PL_linestr) + soff;
7106           }
7107            
7108           reserved_word:
7109 117972657         switch (tmp) {
7110            
7111           default: /* not a keyword */
7112           /* Trade off - by using this evil construction we can pull the
7113           variable gv into the block labelled keylookup. If not, then
7114           we have to give it function scope so that the goto from the
7115           earlier ':' case doesn't bypass the initialisation. */
7116           if (0) {
7117           just_a_word_zero_gv:
7118           sv = NULL;
7119           cv = NULL;
7120           gv = NULL;
7121           gvp = NULL;
7122           rv2cv_op = NULL;
7123           orig_keyword = 0;
7124           lex = 0;
7125           off = 0;
7126           }
7127           just_a_word: {
7128           int pkgname = 0;
7129 14382783 100       const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
7130 28004474 100       const char penultchar =
7131 13943339 100       lastchar && PL_bufptr - 2 >= PL_linestart
7132 13621691         ? PL_bufptr[-2]
7133           : 0;
7134           #ifdef PERL_MAD
7135           SV *nextPL_nextwhite = 0;
7136           #endif
7137            
7138            
7139           /* Get the rest if it looks like a package qualifier */
7140            
7141 14382783 100       if (*s == '\'' || (*s == ':' && s[1] == ':')) {
    100        
    100        
7142           STRLEN morelen;
7143 3014955         s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
7144           TRUE, &morelen);
7145 3014955 100       if (!morelen)
7146 28 100       Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
    50        
    50        
7147 20 100       UTF8fARG(UTF, len, PL_tokenbuf),
    50        
    50        
7148 8         *s == '\'' ? "'" : "::");
7149 3014947         len += morelen;
7150           pkgname = 1;
7151           }
7152            
7153 14382775 100       if (PL_expect == XOPERATOR) {
7154 46 50       if (PL_bufptr == PL_linestart) {
7155 0         CopLINE_dec(PL_curcop);
7156 0         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
7157 0         CopLINE_inc(PL_curcop);
7158           }
7159           else
7160 46         no_op("Bareword",s);
7161           }
7162            
7163           /* Look for a subroutine with this name in current package,
7164           unless this is a lexical sub, or name is "Foo::",
7165           in which case Foo is a bareword
7166           (and a package name). */
7167            
7168 21202669 100       if (len > 2 && !PL_madskills &&
    100        
7169 6866345 100       PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
7170           {
7171 4862 100       if (ckWARN(WARN_BAREWORD)
7172 1394 50       && ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
    50        
    0        
    50        
    100        
    100        
7173 21 50       Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
    50        
7174           "Bareword \"%"UTF8f"\" refers to nonexistent package",
7175 18 50       UTF8fARG(UTF, len, PL_tokenbuf));
    0        
    100        
7176 4862         len -= 2;
7177 4862         PL_tokenbuf[len] = '\0';
7178           gv = NULL;
7179 4862         gvp = 0;
7180           }
7181           else {
7182 14377913 100       if (!lex && !gv) {
    100        
7183           /* Mustn't actually add anything to a symbol table.
7184           But also don't want to "initialise" any placeholder
7185           constants that might already be there into full
7186           blown PVGVs with attached PVCV. */
7187 14365765 50       gv = gv_fetchpvn_flags(PL_tokenbuf, len,
    100        
    50        
    100        
    100        
7188           GV_NOADD_NOINIT | ( UTF ? SVf_UTF8 : 0 ),
7189           SVt_PVCV);
7190           }
7191 14377913         len = 0;
7192           }
7193            
7194           /* if we saw a global override before, get the right name */
7195            
7196 14382775 100       if (!sv)
7197 21339353 100       sv = S_newSV_maybe_utf8(aTHX_ PL_tokenbuf,
7198 28760644         len ? len : strlen(PL_tokenbuf));
7199 14382775 100       if (gvp) {
7200           SV * const tmp_sv = sv;
7201 326         sv = newSVpvs("CORE::GLOBAL::");
7202 326         sv_catsv(sv, tmp_sv);
7203 326         SvREFCNT_dec(tmp_sv);
7204           }
7205            
7206           #ifdef PERL_MAD
7207           if (PL_madskills && !PL_thistoken) {
7208           char *start = SvPVX(PL_linestr) + PL_realtokenstart;
7209           PL_thistoken = newSVpvn(start,s - start);
7210           PL_realtokenstart = s - SvPVX(PL_linestr);
7211           }
7212           #endif
7213            
7214           /* Presume this is going to be a bareword of some sort. */
7215 14382775         CLINE;
7216 14382775         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
7217 14382775         pl_yylval.opval->op_private = OPpCONST_BARE;
7218            
7219           /* And if "Foo::", then that's what it certainly is. */
7220 14382775 100       if (len)
7221           goto safe_bareword;
7222            
7223 14377913 100       if (!off)
7224           {
7225 14377781         OP *const_op = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(sv));
7226 14377781         const_op->op_private = OPpCONST_BARE;
7227 14377781         rv2cv_op = newCVREF(0, const_op);
7228 14377781 100       cv = lex ? GvCV(gv) : rv2cv_op_cv(rv2cv_op, 0);
7229           }
7230            
7231           /* See if it's the indirect object for a list operator. */
7232            
7233 21334524 50       if (PL_oldoldbufptr &&
    100        
7234 20895096 100       PL_oldoldbufptr < PL_bufptr &&
7235 13938485         (PL_oldoldbufptr == PL_last_lop
7236 14086911 100       || PL_oldoldbufptr == PL_last_uni) &&
    100        
7237           /* NO SKIPSPACE BEFORE HERE! */
7238 1058589 100       (PL_expect == XREF ||
7239 615658         ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
7240           {
7241 718556         bool immediate_paren = *s == '(';
7242            
7243           /* (Now we can afford to cross potential line boundary.) */
7244 718556         s = SKIPSPACE2(s,nextPL_nextwhite);
7245           #ifdef PERL_MAD
7246           PL_nextwhite = nextPL_nextwhite; /* assume no & deception */
7247           #endif
7248            
7249           /* Two barewords in a row may indicate method call. */
7250            
7251 718556 100       if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
    50        
    100        
    50        
    50        
    100        
    100        
    50        
    100        
    0        
    0        
    0        
    0        
    0        
    100        
    50        
7252           (tmp = intuit_method(s, gv, cv))) {
7253 0         op_free(rv2cv_op);
7254 0 0       if (tmp == METHOD && !PL_lex_allbrackets &&
    0        
    0        
7255 0         PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7256 0         PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7257           return REPORT(tmp);
7258           }
7259            
7260           /* If not a declared subroutine, it's an indirect object. */
7261           /* (But it's an indir obj regardless for sort.) */
7262           /* Also, if "_" follows a filetest operator, it's a bareword */
7263            
7264 718556 100       if (
7265 679063 100       ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
    100        
7266 673641 100       (!cv &&
7267 673641         (PL_last_lop_op != OP_MAPSTART &&
7268           PL_last_lop_op != OP_GREPSTART))))
7269 46039 100       || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
7270 26 50       && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
7271           )
7272           {
7273 672543         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
7274 672543         goto bareword;
7275           }
7276           }
7277            
7278 13705370         PL_expect = XOPERATOR;
7279           #ifdef PERL_MAD
7280           if (isSPACE(*s))
7281           s = SKIPSPACE2(s,nextPL_nextwhite);
7282           PL_nextwhite = nextPL_nextwhite;
7283           #else
7284 13705370         s = skipspace(s);
7285           #endif
7286            
7287           /* Is this a word before a => operator? */
7288 13705370 100       if (*s == '=' && s[1] == '>' && !pkgname) {
    100        
7289 26         op_free(rv2cv_op);
7290 26         CLINE;
7291           /* This is our own scalar, created a few lines above,
7292           so this is safe. */
7293 26         SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv);
7294 26         sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
7295 26 50       if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
    50        
    0        
    50        
    50        
    0        
    0        
7296 0         SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
7297 26         SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv);
7298 26         TERM(WORD);
7299           }
7300            
7301           /* If followed by a paren, it's certainly a subroutine. */
7302 13705344 100       if (*s == '(') {
7303 9278802         CLINE;
7304 9278802 100       if (cv) {
7305 6737349         d = s + 1;
7306 10327308 100       while (SPACE_OR_TAB(*d))
7307 288418         d++;
7308 6737349 100       if (*d == ')' && (sv = cv_const_sv_or_av(cv))) {
    100        
7309 21088         s = d + 1;
7310 21088         goto its_constant;
7311           }
7312           }
7313           #ifdef PERL_MAD
7314           if (PL_madskills) {
7315           PL_nextwhite = PL_thiswhite;
7316           PL_thiswhite = 0;
7317           }
7318           start_force(PL_curforce);
7319           #endif
7320 18515428         NEXTVAL_NEXTTOKE.opval =
7321 9257714 100       off ? rv2cv_op : pl_yylval.opval;
7322 9257714         PL_expect = XOPERATOR;
7323           #ifdef PERL_MAD
7324           if (PL_madskills) {
7325           PL_nextwhite = nextPL_nextwhite;
7326           curmad('X', PL_thistoken);
7327           PL_thistoken = newSVpvs("");
7328           }
7329           #endif
7330 9257714 100       if (off)
7331 38         op_free(pl_yylval.opval), force_next(PRIVATEREF);
7332 9257676         else op_free(rv2cv_op), force_next(WORD);
7333 9257714         pl_yylval.ival = 0;
7334 9257714         TOKEN('&');
7335           }
7336            
7337           /* If followed by var or block, call it a method (unless sub) */
7338            
7339 4426542 100       if ((*s == '$' || *s == '{') && !cv) {
    100        
7340 1442         op_free(rv2cv_op);
7341 1442         PL_last_lop = PL_oldbufptr;
7342 1442         PL_last_lop_op = OP_METHOD;
7343 1469 100       if (!PL_lex_allbrackets &&
    50        
7344 54         PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7345 0         PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7346 1442         PREBLOCK(METHOD);
7347           }
7348            
7349           /* If followed by a bareword, see if it looks like indir obj. */
7350            
7351 6533585 100       if (!orig_keyword
    100        
    100        
    100        
7352 6475096 50       && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
    100        
    50        
    100        
    100        
    100        
    100        
    50        
    50        
    50        
    50        
    100        
7353 685717 100       && (tmp = intuit_method(s, gv, cv))) {
7354 62949         op_free(rv2cv_op);
7355 65018 100       if (tmp == METHOD && !PL_lex_allbrackets &&
    100        
    100        
7356 4138         PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7357 4         PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7358           return REPORT(tmp);
7359           }
7360            
7361           /* Not a method, so call it a subroutine (if defined) */
7362            
7363 4362151 100       if (cv) {
7364 3457161 100       if (lastchar == '-' && penultchar != '-') {
7365 32 50       const STRLEN l = len ? len : strlen(PL_tokenbuf);
7366 160 50       Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
    50        
    50        
    50        
7367           "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()",
7368 80 50       UTF8fARG(UTF, l, PL_tokenbuf),
    0        
    100        
7369 80 50       UTF8fARG(UTF, l, PL_tokenbuf));
    0        
    100        
7370           }
7371           /* Check for a constant sub */
7372 3457161 100       if ((sv = cv_const_sv_or_av(cv))) {
7373           its_constant:
7374 2229594         op_free(rv2cv_op);
7375 2229594         SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
7376 4459188         ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
7377 2229594 100       if (SvTYPE(sv) == SVt_PVAV)
7378 1010         pl_yylval.opval = newUNOP(OP_RV2AV, OPf_PARENS,
7379           pl_yylval.opval);
7380           else {
7381 2228584         pl_yylval.opval->op_private = OPpCONST_FOLDED;
7382 2228584         pl_yylval.opval->op_folded = 1;
7383 2228584         pl_yylval.opval->op_flags |= OPf_SPECIAL;
7384           }
7385 2229594         TOKEN(WORD);
7386           }
7387            
7388 1248655         op_free(pl_yylval.opval);
7389 2497310         pl_yylval.opval =
7390 1248655 100       off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7391 1248655         pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7392 1248655         PL_last_lop = PL_oldbufptr;
7393 1248655         PL_last_lop_op = OP_ENTERSUB;
7394           /* Is there a prototype? */
7395 1248655 100       if (
7396           #ifdef PERL_MAD
7397           cv &&
7398           #endif
7399 1248655         SvPOK(cv))
7400           {
7401 86362 50       STRLEN protolen = CvPROTOLEN(cv);
    50        
    100        
7402 86362 50       const char *proto = CvPROTO(cv);
    50        
    100        
7403           bool optional;
7404           proto = S_strip_spaces(aTHX_ proto, &protolen);
7405 86362 100       if (!protolen)
7406 43058         TERM(FUNC0SUB);
7407 43304 100       if ((optional = *proto == ';'))
7408           do
7409 406         proto++;
7410 406 100       while (*proto == ';');
7411 43304 100       if (
7412           (
7413           (
7414 43304         *proto == '$' || *proto == '_'
7415 7742 100       || *proto == '*' || *proto == '+'
    100        
7416           )
7417 36310 100       && proto[1] == '\0'
7418           )
7419 40990 100       || (
7420 20713 50       *proto == '\\' && proto[1] && proto[2] == '\0'
    100        
7421           )
7422           )
7423 2388 100       UNIPROTO(UNIOPSUB,optional);
7424 40916 100       if (*proto == '\\' && proto[1] == '[') {
    100        
7425 122         const char *p = proto + 2;
7426 561 100       while(*p && *p != ']')
7427 378         ++p;
7428 122 50       if(*p == ']' && !p[1])
    100        
7429 32 100       UNIPROTO(UNIOPSUB,optional);
7430           }
7431 40884 100       if (*proto == '&' && *s == '{') {
    100        
7432 2442 50       if (PL_curstash)
7433 2442         sv_setpvs(PL_subname, "__ANON__");
7434           else
7435 0         sv_setpvs(PL_subname, "__ANON__::__ANON__");
7436 2495 100       if (!PL_lex_allbrackets &&
    100        
7437 106         PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7438 4         PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7439 2442         PREBLOCK(LSTOPSUB);
7440           }
7441           }
7442           #ifdef PERL_MAD
7443           {
7444           if (PL_madskills) {
7445           PL_nextwhite = PL_thiswhite;
7446           PL_thiswhite = 0;
7447           }
7448           start_force(PL_curforce);
7449           NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7450           PL_expect = XTERM;
7451           if (PL_madskills) {
7452           PL_nextwhite = nextPL_nextwhite;
7453           curmad('X', PL_thistoken);
7454           PL_thistoken = newSVpvs("");
7455           }
7456           force_next(off ? PRIVATEREF : WORD);
7457           if (!PL_lex_allbrackets &&
7458           PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7459           PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7460           TOKEN(NOAMP);
7461           }
7462           }
7463            
7464           /* Guess harder when madskills require "best effort". */
7465           if (PL_madskills && (!gv || !GvCVu(gv))) {
7466           int probable_sub = 0;
7467           if (strchr("\"'`$@%0123456789!*+{[<", *s))
7468           probable_sub = 1;
7469           else if (isALPHA(*s)) {
7470           char tmpbuf[1024];
7471           STRLEN tmplen;
7472           d = s;
7473           d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
7474           if (!keyword(tmpbuf, tmplen, 0))
7475           probable_sub = 1;
7476           else {
7477           while (d < PL_bufend && isSPACE(*d))
7478           d++;
7479           if (*d == '=' && d[1] == '>')
7480           probable_sub = 1;
7481           }
7482           }
7483           if (probable_sub) {
7484           gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
7485           SVt_PVCV);
7486           op_free(pl_yylval.opval);
7487           pl_yylval.opval =
7488           off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
7489           pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
7490           PL_last_lop = PL_oldbufptr;
7491           PL_last_lop_op = OP_ENTERSUB;
7492           PL_nextwhite = PL_thiswhite;
7493           PL_thiswhite = 0;
7494           start_force(PL_curforce);
7495           NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7496           PL_expect = XTERM;
7497           PL_nextwhite = nextPL_nextwhite;
7498           curmad('X', PL_thistoken);
7499           PL_thistoken = newSVpvs("");
7500           force_next(off ? PRIVATEREF : WORD);
7501           if (!PL_lex_allbrackets &&
7502           PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7503           PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7504           TOKEN(NOAMP);
7505           }
7506           #else
7507 1200735         NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
7508 1200735         PL_expect = XTERM;
7509 1200735 100       force_next(off ? PRIVATEREF : WORD);
7510 1213490 100       if (!PL_lex_allbrackets &&
    100        
7511 25870         PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
7512 4         PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
7513 1200735         TOKEN(NOAMP);
7514           #endif
7515           }
7516            
7517           /* Call it a bare word */
7518            
7519 904990 100       if (PL_hints & HINT_STRICT_SUBS)
7520 822842         pl_yylval.opval->op_private |= OPpCONST_STRICT;
7521           else {
7522           bareword:
7523           /* after "print" and similar functions (corresponding to
7524           * "F? L" in opcode.pl), whatever wasn't already parsed as
7525           * a filehandle should be subject to "strict subs".
7526           * Likewise for the optional indirect-object argument to system
7527           * or exec, which can't be a bareword */
7528 1114943 100       if ((PL_last_lop_op == OP_PRINT
7529           || PL_last_lop_op == OP_PRTF
7530           || PL_last_lop_op == OP_SAY
7531 754691         || PL_last_lop_op == OP_SYSTEM
7532 486505 50       || PL_last_lop_op == OP_EXEC)
7533 268186 100       && (PL_hints & HINT_STRICT_SUBS))
7534 191612         pl_yylval.opval->op_private |= OPpCONST_STRICT;
7535 754691 100       if (lastchar != '-') {
7536 754675 100       if (ckWARN(WARN_RESERVED)) {
7537 311528         d = PL_tokenbuf;
7538 465528 100       while (isLOWER(*d))
7539 2196         d++;
7540 311528 100       if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
    50        
    50        
    0        
    50        
    50        
    100        
7541 42         Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
7542 42         PL_tokenbuf);
7543           }
7544           }
7545           }
7546 1577533         op_free(rv2cv_op);
7547            
7548           safe_bareword:
7549 1582395 100       if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
    100        
7550 48 100       && saw_infix_sigil) {
7551 112 50       Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
    50        
7552           "Operator or semicolon missing before %c%"UTF8f,
7553           lastchar,
7554 96 50       UTF8fARG(UTF, strlen(PL_tokenbuf),
    0        
    100        
7555           PL_tokenbuf));
7556 32         Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
7557           "Ambiguous use of %c resolved as operator %c",
7558           lastchar, lastchar);
7559           }
7560 1582395         TOKEN(WORD);
7561           }
7562            
7563           case KEY___FILE__:
7564 38364 50       FUN0OP(
7565           (OP*)newSVOP(OP_CONST, 0, newSVpv(CopFILE(PL_curcop),0))
7566           );
7567            
7568           case KEY___LINE__:
7569 25326         FUN0OP(
7570           (OP*)newSVOP(OP_CONST, 0,
7571           Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)))
7572           );
7573            
7574           case KEY___PACKAGE__:
7575 200440 50       FUN0OP(
    50        
    50        
    100        
7576           (OP*)newSVOP(OP_CONST, 0,
7577           (PL_curstash
7578           ? newSVhek(HvNAME_HEK(PL_curstash))
7579           : &PL_sv_undef))
7580           );
7581            
7582           case KEY___DATA__:
7583           case KEY___END__: {
7584           GV *gv;
7585 389930 100       if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
    100        
    100        
7586 2359 50       HV * const stash = PL_tokenbuf[2] == 'D' && PL_curstash
7587           ? PL_curstash
7588 3650 100       : PL_defstash;
7589 2222         gv = (GV *)*hv_fetchs(stash, "DATA", 1);
7590 2222 100       if (!isGV(gv))
7591 734         gv_init(gv,stash,"DATA",4,0);
7592 2222         GvMULTI_on(gv);
7593 2222 50       if (!GvIO(gv))
    50        
    50        
    100        
7594 926         GvIOp(gv) = newIO();
7595 2222         IoIFP(GvIOp(gv)) = PL_rsfp;
7596           #if defined(HAS_FCNTL) && defined(F_SETFD)
7597           {
7598 2222         const int fd = PerlIO_fileno(PL_rsfp);
7599 2222         fcntl(fd,F_SETFD,fd >= 3);
7600           }
7601           #endif
7602           /* Mark this internal pseudo-handle as clean */
7603 2222         IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
7604 2222 50       if ((PerlIO*)PL_rsfp == PerlIO_stdin())
7605 0         IoTYPE(GvIOp(gv)) = IoTYPE_STD;
7606           else
7607 2222         IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
7608           #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
7609           /* if the script was opened in binmode, we need to revert
7610           * it to text mode for compatibility; but only iff it has CRs
7611           * XXX this is a questionable hack at best. */
7612           if (PL_bufend-PL_bufptr > 2
7613           && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
7614           {
7615           Off_t loc = 0;
7616           if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
7617           loc = PerlIO_tell(PL_rsfp);
7618           (void)PerlIO_seek(PL_rsfp, 0L, 0);
7619           }
7620           #ifdef NETWARE
7621           if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
7622           #else
7623           if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
7624           #endif /* NETWARE */
7625           if (loc > 0)
7626           PerlIO_seek(PL_rsfp, loc, 0);
7627           }
7628           }
7629           #endif
7630           #ifdef PERLIO_LAYERS
7631 2222 100       if (!IN_BYTES) {
7632 2220 50       if (UTF)
    50        
    0        
    50        
    100        
7633 16         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
7634 2222 100       else if (PL_encoding) {
    50        
7635           SV *name;
7636 18         dSP;
7637 18         ENTER;
7638 18         SAVETMPS;
7639 18 50       PUSHMARK(sp);
7640 9         EXTEND(SP, 1);
7641 18 50       XPUSHs(PL_encoding);
7642 18         PUTBACK;
7643 18         call_method("name", G_SCALAR);
7644 18         SPAGAIN;
7645 18         name = POPs;
7646 18         PUTBACK;
7647 18         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
7648 18         Perl_form(aTHX_ ":encoding(%"SVf")",
7649           SVfARG(name)));
7650 18 50       FREETMPS;
7651 18         LEAVE;
7652           }
7653           }
7654           #endif
7655           #ifdef PERL_MAD
7656           if (PL_madskills) {
7657           if (PL_realtokenstart >= 0) {
7658           char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
7659           if (!PL_endwhite)
7660           PL_endwhite = newSVpvs("");
7661           sv_catsv(PL_endwhite, PL_thiswhite);
7662           PL_thiswhite = 0;
7663           sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
7664           PL_realtokenstart = -1;
7665           }
7666           while ((s = filter_gets(PL_endwhite, SvCUR(PL_endwhite)))
7667           != NULL) ;
7668           }
7669           #endif
7670 2222         PL_rsfp = NULL;
7671           }
7672           goto fake_eof;
7673           }
7674            
7675           case KEY___SUB__:
7676 32         FUN0OP(newPVOP(OP_RUNCV,0,NULL));
7677            
7678           case KEY_AUTOLOAD:
7679           case KEY_DESTROY:
7680           case KEY_BEGIN:
7681           case KEY_UNITCHECK:
7682           case KEY_CHECK:
7683           case KEY_INIT:
7684           case KEY_END:
7685 346012 100       if (PL_expect == XSTATE) {
7686 346008         s = PL_bufptr;
7687 346008         goto really_sub;
7688           }
7689           goto just_a_word;
7690            
7691           case KEY_CORE:
7692 93556 100       if (*s == ':' && s[1] == ':') {
    50        
7693 93550         STRLEN olen = len;
7694           d = s;
7695 93550         s += 2;
7696 93550         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
7697 93550 100       if ((*s == ':' && s[1] == ':')
    50        
7698 93548 100       || (!(tmp = keyword(PL_tokenbuf, len, 1)) && *s == '\''))
    100        
7699           {
7700           s = d;
7701 4         len = olen;
7702 4         Copy(PL_bufptr, PL_tokenbuf, olen, char);
7703           goto just_a_word;
7704           }
7705 93546 100       if (!tmp)
7706 7 50       Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
    50        
7707 6 50       UTF8fARG(UTF, len, PL_tokenbuf));
    0        
    50        
7708 93544 100       if (tmp < 0)
7709 91982         tmp = -tmp;
7710 1562 100       else if (tmp == KEY_require || tmp == KEY_do
7711 1557 100       || tmp == KEY_glob)
7712           /* that's a way to remember we saw "CORE::" */
7713           orig_keyword = tmp;
7714           goto reserved_word;
7715           }
7716           goto just_a_word;
7717            
7718           case KEY_abs:
7719 7382 100       UNI(OP_ABS);
    100        
7720            
7721           case KEY_alarm:
7722 2372 100       UNI(OP_ALARM);
    50        
7723            
7724           case KEY_accept:
7725 234         LOP(OP_ACCEPT,XTERM);
7726            
7727           case KEY_and:
7728 2012188 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
    100        
7729           return REPORT(0);
7730 2012182         OPERATOR(ANDOP);
7731            
7732           case KEY_atan2:
7733 122         LOP(OP_ATAN2,XTERM);
7734            
7735           case KEY_bind:
7736 336         LOP(OP_BIND,XTERM);
7737            
7738           case KEY_binmode:
7739 46583         LOP(OP_BINMODE,XTERM);
7740            
7741           case KEY_bless:
7742 195603         LOP(OP_BLESS,XTERM);
7743            
7744           case KEY_break:
7745 32         FUN0(OP_BREAK);
7746            
7747           case KEY_chop:
7748 33362 100       UNI(OP_CHOP);
    100        
7749            
7750           case KEY_continue:
7751           /* We have to disambiguate the two senses of
7752           "continue". If the next token is a '{' then
7753           treat it as the start of a continue block;
7754           otherwise treat it as a control operator.
7755           */
7756 6626         s = skipspace(s);
7757 6626 100       if (*s == '{')
7758 6566         PREBLOCK(CONTINUE);
7759           else
7760 60         FUN0(OP_CONTINUE);
7761            
7762           case KEY_chdir:
7763           /* may use HOME */
7764 122836         (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
7765 122836 100       UNI(OP_CHDIR);
    100        
7766            
7767           case KEY_close:
7768 145367 100       UNI(OP_CLOSE);
    100        
7769            
7770           case KEY_closedir:
7771 76954 100       UNI(OP_CLOSEDIR);
    50        
7772            
7773           case KEY_cmp:
7774 24996 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
    50        
7775           return REPORT(0);
7776 24996         Eop(OP_SCMP);
7777            
7778           case KEY_caller:
7779 447978 100       UNI(OP_CALLER);
    100        
7780            
7781           case KEY_crypt:
7782           #ifdef FCRYPT
7783           if (!PL_cryptseen) {
7784           PL_cryptseen = TRUE;
7785           init_des();
7786           }
7787           #endif
7788 20         LOP(OP_CRYPT,XTERM);
7789            
7790           case KEY_chmod:
7791 84278         LOP(OP_CHMOD,XTERM);
7792            
7793           case KEY_chown:
7794 9376         LOP(OP_CHOWN,XTERM);
7795            
7796           case KEY_connect:
7797 472         LOP(OP_CONNECT,XTERM);
7798            
7799           case KEY_chr:
7800 80004 100       UNI(OP_CHR);
    100        
7801            
7802           case KEY_cos:
7803 330 100       UNI(OP_COS);
    50        
7804            
7805           case KEY_chroot:
7806 6 100       UNI(OP_CHROOT);
    50        
7807            
7808           case KEY_default:
7809 70         PREBLOCK(DEFAULT);
7810            
7811           case KEY_do:
7812 537255         s = SKIPSPACE1(s);
7813 537255 100       if (*s == '{')
7814 506471         PRETERMBLOCK(DO);
7815 30784 100       if (*s != '\'') {
7816 28898         *PL_tokenbuf = '&';
7817 28898         d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
7818           1, &len);
7819 28898 100       if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
    100        
7820 60         d = SKIPSPACE1(d);
7821 60 100       if (*d == '(') {
7822 56         force_ident_maybe_lex('&');
7823           s = d;
7824           }
7825           }
7826           }
7827 30784 50       if (orig_keyword == KEY_do) {
7828           orig_keyword = 0;
7829 0         pl_yylval.ival = 1;
7830           }
7831           else
7832 30784         pl_yylval.ival = 0;
7833 30784         OPERATOR(DO);
7834            
7835           case KEY_die:
7836 695120         PL_hints |= HINT_BLOCK_SCOPE;
7837 695120         LOP(OP_DIE,XTERM);
7838            
7839           case KEY_defined:
7840 3193360 100       UNI(OP_DEFINED);
    100        
7841            
7842           case KEY_delete:
7843 400444 100       UNI(OP_DELETE);
    100        
7844            
7845           case KEY_dbmopen:
7846 116         Perl_populate_isa(aTHX_ STR_WITH_LEN("AnyDBM_File::ISA"),
7847           STR_WITH_LEN("NDBM_File::"),
7848           STR_WITH_LEN("DB_File::"),
7849           STR_WITH_LEN("GDBM_File::"),
7850           STR_WITH_LEN("SDBM_File::"),
7851           STR_WITH_LEN("ODBM_File::"),
7852           NULL);
7853 116         LOP(OP_DBMOPEN,XTERM);
7854            
7855           case KEY_dbmclose:
7856 110 100       UNI(OP_DBMCLOSE);
    50        
7857            
7858           case KEY_dump:
7859 8         PL_expect = XOPERATOR;
7860 8         s = force_word(s,WORD,TRUE,FALSE);
7861 8         LOOPX(OP_DUMP);
7862            
7863           case KEY_else:
7864 2940718         PREBLOCK(ELSE);
7865            
7866           case KEY_elsif:
7867 1807244         pl_yylval.ival = CopLINE(PL_curcop);
7868 1807244         OPERATOR(ELSIF);
7869            
7870           case KEY_eq:
7871 4426840 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
    50        
7872           return REPORT(0);
7873 4426840         Eop(OP_SEQ);
7874            
7875           case KEY_exists:
7876 839897 100       UNI(OP_EXISTS);
    100        
7877          
7878           case KEY_exit:
7879           if (PL_madskills)
7880           UNI(OP_INT);
7881 23502 100       UNI(OP_EXIT);
    100        
7882            
7883           case KEY_eval:
7884 711177         s = SKIPSPACE1(s);
7885 711177 100       if (*s == '{') { /* block eval */
7886 422178         PL_expect = XTERMBLOCK;
7887 422178 50       UNIBRACK(OP_ENTERTRY);
    50        
7888           }
7889           else { /* string eval */
7890 288999         PL_expect = XTERM;
7891 288999 100       UNIBRACK(OP_ENTEREVAL);
    50        
7892           }
7893            
7894           case KEY_evalbytes:
7895 42         PL_expect = XTERM;
7896 42 100       UNIBRACK(-OP_ENTEREVAL);
    50        
7897            
7898           case KEY_eof:
7899 4198 100       UNI(OP_EOF);
    50        
7900            
7901           case KEY_exp:
7902 316 100       UNI(OP_EXP);
    50        
7903            
7904           case KEY_each:
7905 103866 100       UNI(OP_EACH);
    100        
7906            
7907           case KEY_exec:
7908 11664         LOP(OP_EXEC,XREF);
7909            
7910           case KEY_endhostent:
7911 6         FUN0(OP_EHOSTENT);
7912            
7913           case KEY_endnetent:
7914 6         FUN0(OP_ENETENT);
7915            
7916           case KEY_endservent:
7917 6         FUN0(OP_ESERVENT);
7918            
7919           case KEY_endprotoent:
7920 6         FUN0(OP_EPROTOENT);
7921            
7922           case KEY_endpwent:
7923 12         FUN0(OP_EPWENT);
7924            
7925           case KEY_endgrent:
7926 12         FUN0(OP_EGRENT);
7927            
7928           case KEY_for:
7929           case KEY_foreach:
7930 1948455 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
    50        
7931           return REPORT(0);
7932 1948455         pl_yylval.ival = CopLINE(PL_curcop);
7933 1948455         s = SKIPSPACE1(s);
7934 1948455 100       if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
    100        
    50        
    100        
    50        
    50        
    100        
    50        
    0        
    0        
    0        
    100        
7935           char *p = s;
7936           #ifdef PERL_MAD
7937           int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
7938           #endif
7939            
7940 1314041 50       if ((PL_bufend - p) >= 3 &&
    100        
7941 1314019 50       strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
7942 886085         p += 2;
7943 33 50       else if ((PL_bufend - p) >= 4 &&
    100        
7944 27 50       strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
7945 16         p += 3;
7946 886107         p = PEEKSPACE(p);
7947 886107 100       if (isIDFIRST_lazy_if(p,UTF)) {
    50        
    50        
    0        
    50        
    100        
    50        
    0        
    0        
    0        
    100        
7948 6         p = scan_ident(p, PL_bufend,
7949           PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
7950 2         p = PEEKSPACE(p);
7951           }
7952 886103 100       if (*p != '$')
7953 2         Perl_croak(aTHX_ "Missing $ on loop variable");
7954           #ifdef PERL_MAD
7955           s = SvPVX(PL_linestr) + soff;
7956           #endif
7957           }
7958 1948449         OPERATOR(FOR);
7959            
7960           case KEY_formline:
7961 1522         LOP(OP_FORMLINE,XTERM);
7962            
7963           case KEY_fork:
7964 3114         FUN0(OP_FORK);
7965            
7966           case KEY_fc:
7967 112 100       UNI(OP_FC);
    50        
7968            
7969           case KEY_fcntl:
7970 6284         LOP(OP_FCNTL,XTERM);
7971            
7972           case KEY_fileno:
7973 25632 100       UNI(OP_FILENO);
    50        
7974            
7975           case KEY_flock:
7976 11012         LOP(OP_FLOCK,XTERM);
7977            
7978           case KEY_gt:
7979 5030 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
    50        
7980           return REPORT(0);
7981 5030         Rop(OP_SGT);
7982            
7983           case KEY_ge:
7984 11272 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
    50        
7985           return REPORT(0);
7986 11272         Rop(OP_SGE);
7987            
7988           case KEY_grep:
7989 425926         LOP(OP_GREPSTART, XREF);
7990            
7991           case KEY_goto:
7992 335173         PL_expect = XOPERATOR;
7993 335173         s = force_word(s,WORD,TRUE,FALSE);
7994 335173         LOOPX(OP_GOTO);
7995            
7996           case KEY_gmtime:
7997 5620 100       UNI(OP_GMTIME);
    50        
7998            
7999           case KEY_getc:
8000 1572 100       UNIDOR(OP_GETC);
    50        
8001            
8002           case KEY_getppid:
8003 1036         FUN0(OP_GETPPID);
8004            
8005           case KEY_getpgrp:
8006 20 100       UNI(OP_GETPGRP);
    50        
8007            
8008           case KEY_getpriority:
8009 12         LOP(OP_GETPRIORITY,XTERM);
8010            
8011           case KEY_getprotobyname:
8012 858 100       UNI(OP_GPBYNAME);
    50        
8013            
8014           case KEY_getprotobynumber:
8015 742         LOP(OP_GPBYNUMBER,XTERM);
8016            
8017           case KEY_getprotoent:
8018 12         FUN0(OP_GPROTOENT);
8019            
8020           case KEY_getpwent:
8021 14         FUN0(OP_GPWENT);
8022            
8023           case KEY_getpwnam:
8024 11312 100       UNI(OP_GPWNAM);
    50        
8025            
8026           case KEY_getpwuid:
8027 1870 100       UNI(OP_GPWUID);
    100        
8028            
8029           case KEY_getpeername:
8030 386 100       UNI(OP_GETPEERNAME);
    50        
8031            
8032           case KEY_gethostbyname:
8033 1420 100       UNI(OP_GHBYNAME);
    50        
8034            
8035           case KEY_gethostbyaddr:
8036 656         LOP(OP_GHBYADDR,XTERM);
8037            
8038           case KEY_gethostent:
8039 10         FUN0(OP_GHOSTENT);
8040            
8041           case KEY_getnetbyname:
8042 14 100       UNI(OP_GNBYNAME);
    50        
8043            
8044           case KEY_getnetbyaddr:
8045 8         LOP(OP_GNBYADDR,XTERM);
8046            
8047           case KEY_getnetent:
8048 10         FUN0(OP_GNETENT);
8049            
8050           case KEY_getservbyname:
8051 1528         LOP(OP_GSBYNAME,XTERM);
8052            
8053           case KEY_getservbyport:
8054 648         LOP(OP_GSBYPORT,XTERM);
8055            
8056           case KEY_getservent:
8057 12         FUN0(OP_GSERVENT);
8058            
8059           case KEY_getsockname:
8060 138 100       UNI(OP_GETSOCKNAME);
    50        
8061            
8062           case KEY_getsockopt:
8063 258         LOP(OP_GSOCKOPT,XTERM);
8064            
8065           case KEY_getgrent:
8066 14         FUN0(OP_GGRENT);
8067            
8068           case KEY_getgrnam:
8069 9302 100       UNI(OP_GGRNAM);
    50        
8070            
8071           case KEY_getgrgid:
8072 78 100       UNI(OP_GGRGID);
    100        
8073            
8074           case KEY_getlogin:
8075 30         FUN0(OP_GETLOGIN);
8076            
8077           case KEY_given:
8078 216         pl_yylval.ival = CopLINE(PL_curcop);
8079 216         Perl_ck_warner_d(aTHX_
8080           packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8081           "given is experimental");
8082 216         OPERATOR(GIVEN);
8083            
8084           case KEY_glob:
8085 10252 100       LOP(
8086           orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
8087           XTERM
8088           );
8089            
8090           case KEY_hex:
8091 55556 100       UNI(OP_HEX);
    50        
8092            
8093           case KEY_if:
8094 11643170 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
    100        
8095           return REPORT(0);
8096 11643162         pl_yylval.ival = CopLINE(PL_curcop);
8097 11643162         OPERATOR(IF);
8098            
8099           case KEY_index:
8100 68398         LOP(OP_INDEX,XTERM);
8101            
8102           case KEY_int:
8103 48366 100       UNI(OP_INT);
    100        
8104            
8105           case KEY_ioctl:
8106 1670         LOP(OP_IOCTL,XTERM);
8107            
8108           case KEY_join:
8109 588286         LOP(OP_JOIN,XTERM);
8110            
8111           case KEY_keys:
8112 554537 100       UNI(OP_KEYS);
    100        
8113            
8114           case KEY_kill:
8115 10296         LOP(OP_KILL,XTERM);
8116            
8117           case KEY_last:
8118 480846         PL_expect = XOPERATOR;
8119 480846         s = force_word(s,WORD,TRUE,FALSE);
8120 480846         LOOPX(OP_LAST);
8121          
8122           case KEY_lc:
8123 73964 100       UNI(OP_LC);
    100        
8124            
8125           case KEY_lcfirst:
8126 376 100       UNI(OP_LCFIRST);
    100        
8127            
8128           case KEY_local:
8129 1214863         pl_yylval.ival = 0;
8130 1214863         OPERATOR(LOCAL);
8131            
8132           case KEY_length:
8133 698007 100       UNI(OP_LENGTH);
    100        
8134            
8135           case KEY_lt:
8136 1872 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
    50        
8137           return REPORT(0);
8138 1872         Rop(OP_SLT);
8139            
8140           case KEY_le:
8141 5684 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
    50        
8142           return REPORT(0);
8143 5684         Rop(OP_SLE);
8144            
8145           case KEY_localtime:
8146 8140 100       UNI(OP_LOCALTIME);
    50        
8147            
8148           case KEY_log:
8149 10402 100       UNI(OP_LOG);
    100        
8150            
8151           case KEY_link:
8152 484         LOP(OP_LINK,XTERM);
8153            
8154           case KEY_listen:
8155 232         LOP(OP_LISTEN,XTERM);
8156            
8157           case KEY_lock:
8158 882 100       UNI(OP_LOCK);
    50        
8159            
8160           case KEY_lstat:
8161 56338 100       UNI(OP_LSTAT);
    100        
8162            
8163           case KEY_m:
8164 493413         s = scan_pat(s,OP_MATCH);
8165 493389         TERM(sublex_start());
8166            
8167           case KEY_map:
8168 545027         LOP(OP_MAPSTART, XREF);
8169            
8170           case KEY_mkdir:
8171 35086         LOP(OP_MKDIR,XTERM);
8172            
8173           case KEY_msgctl:
8174 110         LOP(OP_MSGCTL,XTERM);
8175            
8176           case KEY_msgget:
8177 104         LOP(OP_MSGGET,XTERM);
8178            
8179           case KEY_msgrcv:
8180 104         LOP(OP_MSGRCV,XTERM);
8181            
8182           case KEY_msgsnd:
8183 104         LOP(OP_MSGSND,XTERM);
8184            
8185           case KEY_our:
8186           case KEY_my:
8187           case KEY_state:
8188 19007435         PL_in_my = (U16)tmp;
8189 19007435         s = SKIPSPACE1(s);
8190 19007435 100       if (isIDFIRST_lazy_if(s,UTF)) {
    50        
    100        
    50        
    50        
    100        
    100        
    50        
    0        
    0        
    100        
8191           #ifdef PERL_MAD
8192           char* start = s;
8193           #endif
8194 302         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
8195 302 100       if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
    100        
8196           {
8197 212 50       if (!FEATURE_LEXSUBS_IS_ENABLED)
    100        
    0        
    50        
    50        
    50        
8198 11 100       Perl_croak(aTHX_
8199           "Experimental \"%s\" subs not enabled",
8200           tmp == KEY_my ? "my" :
8201 4 100       tmp == KEY_state ? "state" : "our");
8202 206         Perl_ck_warner_d(aTHX_
8203           packWARN(WARN_EXPERIMENTAL__LEXICAL_SUBS),
8204           "The lexical_subs feature is experimental");
8205 202         goto really_sub;
8206           }
8207 90         PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
8208 90 100       if (!PL_in_my_stash) {
8209           char tmpbuf[1024];
8210 18         PL_bufptr = s;
8211 27 50       my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
8212 18 50       yyerror_pv(tmpbuf, UTF ? SVf_UTF8 : 0);
    100        
    50        
    50        
    50        
8213           }
8214           #ifdef PERL_MAD
8215           if (PL_madskills) { /* just add type to declarator token */
8216           sv_catsv(PL_thistoken, PL_nextwhite);
8217           PL_nextwhite = 0;
8218           sv_catpvn(PL_thistoken, start, s - start);
8219           }
8220           #endif
8221           }
8222 19007223         pl_yylval.ival = 1;
8223 19007223         OPERATOR(MY);
8224            
8225           case KEY_next:
8226 846262         PL_expect = XOPERATOR;
8227 846262         s = force_word(s,WORD,TRUE,FALSE);
8228 846262         LOOPX(OP_NEXT);
8229            
8230           case KEY_ne:
8231 580020 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_COMPARE)
    50        
8232           return REPORT(0);
8233 580020         Eop(OP_SNE);
8234            
8235           case KEY_no:
8236 411504         s = tokenize_use(0, s);
8237 411504         TERM(USE);
8238            
8239           case KEY_not:
8240 324558 100       if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
    100        
8241 1218         FUN1(OP_NOT);
8242           else {
8243 323863 100       if (!PL_lex_allbrackets &&
    100        
8244 1046         PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
8245 4         PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
8246 323340         OPERATOR(NOTOP);
8247           }
8248            
8249           case KEY_open:
8250 171428         s = SKIPSPACE1(s);
8251 171428 100       if (isIDFIRST_lazy_if(s,UTF)) {
    50        
    50        
    0        
    50        
    100        
    100        
    50        
    0        
    0        
    100        
8252           const char *t;
8253 64708         d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE,
8254           &len);
8255 143580 100       for (t=d; isSPACE(*t);)
8256 47958         t++;
8257 64708 100       if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
    100        
    100        
8258           /* [perl #16184] */
8259 36 100       && !(t[0] == '=' && t[1] == '>')
    50        
8260 34 100       && !(t[0] == ':' && t[1] == ':')
    50        
8261 26 100       && !keyword(s, d-s, 0)
8262           ) {
8263 132 50       Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
    50        
    50        
    50        
8264           "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
8265 120 50       UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
    0        
    100        
    50        
    0        
    100        
8266           }
8267           }
8268 171428         LOP(OP_OPEN,XTERM);
8269            
8270           case KEY_or:
8271 1364511 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
    100        
8272           return REPORT(0);
8273 1364481         pl_yylval.ival = OP_OR;
8274 1364481         OPERATOR(OROP);
8275            
8276           case KEY_ord:
8277 371972 100       UNI(OP_ORD);
    100        
8278            
8279           case KEY_oct:
8280 19120 100       UNI(OP_OCT);
    50        
8281            
8282           case KEY_opendir:
8283 57350         LOP(OP_OPEN_DIR,XTERM);
8284            
8285           case KEY_print:
8286 1031900         checkcomma(s,PL_tokenbuf,"filehandle");
8287 1031898         LOP(OP_PRINT,XREF);
8288            
8289           case KEY_printf:
8290 300566         checkcomma(s,PL_tokenbuf,"filehandle");
8291 300566         LOP(OP_PRTF,XREF);
8292            
8293           case KEY_prototype:
8294 24050 100       UNI(OP_PROTOTYPE);
    50        
8295            
8296           case KEY_push:
8297 1413114         LOP(OP_PUSH,XTERM);
8298            
8299           case KEY_pop:
8300 168172 100       UNIDOR(OP_POP);
    100        
8301            
8302           case KEY_pos:
8303 35270 100       UNIDOR(OP_POS);
    100        
8304          
8305           case KEY_pack:
8306 82767         LOP(OP_PACK,XTERM);
8307            
8308           case KEY_package:
8309 700686         s = force_word(s,WORD,FALSE,TRUE);
8310 700686         s = SKIPSPACE1(s);
8311 700686         s = force_strict_version(s);
8312 700686         PL_lex_expect = XBLOCK;
8313 700686         OPERATOR(PACKAGE);
8314            
8315           case KEY_pipe:
8316 1926         LOP(OP_PIPE_OP,XTERM);
8317            
8318           case KEY_q:
8319 1233587         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8320 1233587 100       COPLINE_SET_FROM_MULTI_END;
8321 1233587 100       if (!s)
8322 4         missingterm(NULL);
8323 1233583         pl_yylval.ival = OP_CONST;
8324 1233583         TERM(sublex_start());
8325            
8326           case KEY_quotemeta:
8327 8216 100       UNI(OP_QUOTEMETA);
    100        
8328            
8329           case KEY_qw: {
8330           OP *words = NULL;
8331 1361133         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8332 1361133 100       COPLINE_SET_FROM_MULTI_END;
8333 1361133 100       if (!s)
8334 4         missingterm(NULL);
8335 1361129         PL_expect = XOPERATOR;
8336 1361129 100       if (SvCUR(PL_lex_stuff)) {
8337 1360275         int warned_comma = !ckWARN(WARN_QW);
8338           int warned_comment = warned_comma;
8339 1360275 50       d = SvPV_force(PL_lex_stuff, len);
8340 11881663 100       while (len) {
8341 22727388 100       for (; isSPACE(*d) && len; --len, ++d)
    50        
8342           /**/;
8343 9161113 100       if (len) {
8344           SV *sv;
8345           const char *b = d;
8346 8838317 100       if (!warned_comma || !warned_comment) {
8347 25552910 100       for (; !isSPACE(*d) && len; --len, ++d) {
    100        
8348 23941194 100       if (!warned_comma && *d == ',') {
    100        
8349 4         Perl_warner(aTHX_ packWARN(WARN_QW),
8350           "Possible attempt to separate words with commas");
8351 4         ++warned_comma;
8352           }
8353 23941190 100       else if (!warned_comment && *d == '#') {
    100        
8354 4         Perl_warner(aTHX_ packWARN(WARN_QW),
8355           "Possible attempt to put comments in qw() list");
8356 4         ++warned_comment;
8357           }
8358           }
8359           }
8360           else {
8361 49022790 100       for (; !isSPACE(*d) && len; --len, ++d)
    100        
8362           /**/;
8363           }
8364 8838317 100       sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
    50        
8365 9541668         words = op_append_elem(OP_LIST, words,
8366           newSVOP(OP_CONST, 0, tokeq(sv)));
8367           }
8368           }
8369           }
8370 1361129 100       if (!words)
8371 1724         words = newNULLLIST();
8372 1361129 50       if (PL_lex_stuff) {
8373 1361129         SvREFCNT_dec(PL_lex_stuff);
8374 1361129         PL_lex_stuff = NULL;
8375           }
8376 1361129         PL_expect = XOPERATOR;
8377 1361129         pl_yylval.opval = sawparens(words);
8378 1361129         TOKEN(QWLIST);
8379           }
8380            
8381           case KEY_qq:
8382 277457         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8383 277457 100       if (!s)
8384 2         missingterm(NULL);
8385 277455         pl_yylval.ival = OP_STRINGIFY;
8386 277455 100       if (SvIVX(PL_lex_stuff) == '\'')
8387 46218         SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should interpolate */
8388 277455         TERM(sublex_start());
8389            
8390           case KEY_qr:
8391 472010         s = scan_pat(s,OP_QR);
8392 471994         TERM(sublex_start());
8393            
8394           case KEY_qx:
8395 56         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8396 56 100       if (!s)
8397 2         missingterm(NULL);
8398 54         readpipe_override();
8399 54         TERM(sublex_start());
8400            
8401           case KEY_return:
8402 6899041 100       OLDLOP(OP_RETURN);
    100        
8403            
8404           case KEY_require:
8405 1430907         s = SKIPSPACE1(s);
8406 1430907         PL_expect = XOPERATOR;
8407 1430907 100       if (isDIGIT(*s)) {
8408 50648         s = force_version(s, FALSE);
8409           }
8410 1380259 100       else if (*s != 'v' || !isDIGIT(s[1])
    100        
8411 8 50       || (s = force_version(s, TRUE), *s == 'v'))
8412           {
8413 1380251         *PL_tokenbuf = '\0';
8414 1380251         s = force_word(s,WORD,TRUE,TRUE);
8415 1380251 100       if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
    50        
    100        
    50        
    50        
    100        
    100        
    50        
    0        
    0        
    100        
8416 1321802 50       gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
    100        
    50        
    50        
    100        
8417           GV_ADD | (UTF ? SVf_UTF8 : 0));
8418 58449 100       else if (*s == '<')
8419 2         yyerror("<> should be quotes");
8420           }
8421 1430907 100       if (orig_keyword == KEY_require) {
8422           orig_keyword = 0;
8423 10         pl_yylval.ival = 1;
8424           }
8425           else
8426 1430897         pl_yylval.ival = 0;
8427 1430907         PL_expect = XTERM;
8428 1430907         PL_bufptr = s;
8429 1430907         PL_last_uni = PL_oldbufptr;
8430 1430907         PL_last_lop_op = OP_REQUIRE;
8431 1430907         s = skipspace(s);
8432 1430907         return REPORT( (int)REQUIRE );
8433            
8434           case KEY_reset:
8435 56 100       UNI(OP_RESET);
    50        
8436            
8437           case KEY_redo:
8438 181572         PL_expect = XOPERATOR;
8439 181572         s = force_word(s,WORD,TRUE,FALSE);
8440 181572         LOOPX(OP_REDO);
8441            
8442           case KEY_rename:
8443 15540         LOP(OP_RENAME,XTERM);
8444            
8445           case KEY_rand:
8446 7578 100       UNI(OP_RAND);
    100        
8447            
8448           case KEY_rmdir:
8449 9528 100       UNI(OP_RMDIR);
    50        
8450            
8451           case KEY_rindex:
8452 3606         LOP(OP_RINDEX,XTERM);
8453            
8454           case KEY_read:
8455 18346         LOP(OP_READ,XTERM);
8456            
8457           case KEY_readdir:
8458 66438 100       UNI(OP_READDIR);
    50        
8459            
8460           case KEY_readline:
8461 6674 100       UNIDOR(OP_READLINE);
    50        
8462            
8463           case KEY_readpipe:
8464 6 100       UNIDOR(OP_BACKTICK);
    50        
8465            
8466           case KEY_rewinddir:
8467 1320 100       UNI(OP_REWINDDIR);
    50        
8468            
8469           case KEY_recv:
8470 258         LOP(OP_RECV,XTERM);
8471            
8472           case KEY_reverse:
8473 23688         LOP(OP_REVERSE,XTERM);
8474            
8475           case KEY_readlink:
8476 32920 100       UNIDOR(OP_READLINK);
    50        
8477            
8478           case KEY_ref:
8479 1107855 100       UNI(OP_REF);
    100        
8480            
8481           case KEY_s:
8482 1488023         s = scan_subst(s);
8483 1488011 50       if (pl_yylval.opval)
8484 1488011         TERM(sublex_start());
8485           else
8486 0         TOKEN(1); /* force error */
8487            
8488           case KEY_say:
8489 78         checkcomma(s,PL_tokenbuf,"filehandle");
8490 78         LOP(OP_SAY,XREF);
8491            
8492           case KEY_chomp:
8493 121127 100       UNI(OP_CHOMP);
    100        
8494          
8495           case KEY_scalar:
8496 126618 100       UNI(OP_SCALAR);
    100        
8497            
8498           case KEY_select:
8499 38140         LOP(OP_SELECT,XTERM);
8500            
8501           case KEY_seek:
8502 9220         LOP(OP_SEEK,XTERM);
8503            
8504           case KEY_semctl:
8505 132         LOP(OP_SEMCTL,XTERM);
8506            
8507           case KEY_semget:
8508 104         LOP(OP_SEMGET,XTERM);
8509            
8510           case KEY_semop:
8511 102         LOP(OP_SEMOP,XTERM);
8512            
8513           case KEY_send:
8514 522         LOP(OP_SEND,XTERM);
8515            
8516           case KEY_setpgrp:
8517 8         LOP(OP_SETPGRP,XTERM);
8518            
8519           case KEY_setpriority:
8520 4         LOP(OP_SETPRIORITY,XTERM);
8521            
8522           case KEY_sethostent:
8523 6 100       UNI(OP_SHOSTENT);
    50        
8524            
8525           case KEY_setnetent:
8526 6 100       UNI(OP_SNETENT);
    50        
8527            
8528           case KEY_setservent:
8529 6 100       UNI(OP_SSERVENT);
    50        
8530            
8531           case KEY_setprotoent:
8532 6 100       UNI(OP_SPROTOENT);
    50        
8533            
8534           case KEY_setpwent:
8535 14         FUN0(OP_SPWENT);
8536            
8537           case KEY_setgrent:
8538 12         FUN0(OP_SGRENT);
8539            
8540           case KEY_seekdir:
8541 54         LOP(OP_SEEKDIR,XTERM);
8542            
8543           case KEY_setsockopt:
8544 522         LOP(OP_SSOCKOPT,XTERM);
8545            
8546           case KEY_shift:
8547 3309389 100       UNIDOR(OP_SHIFT);
    100        
8548            
8549           case KEY_shmctl:
8550 108         LOP(OP_SHMCTL,XTERM);
8551            
8552           case KEY_shmget:
8553 106         LOP(OP_SHMGET,XTERM);
8554            
8555           case KEY_shmread:
8556 112         LOP(OP_SHMREAD,XTERM);
8557            
8558           case KEY_shmwrite:
8559 18         LOP(OP_SHMWRITE,XTERM);
8560            
8561           case KEY_shutdown:
8562 1222         LOP(OP_SHUTDOWN,XTERM);
8563            
8564           case KEY_sin:
8565 9668 100       UNI(OP_SIN);
    50        
8566            
8567           case KEY_sleep:
8568 4508 100       UNI(OP_SLEEP);
    100        
8569            
8570           case KEY_socket:
8571 272         LOP(OP_SOCKET,XTERM);
8572            
8573           case KEY_socketpair:
8574 2178         LOP(OP_SOCKPAIR,XTERM);
8575            
8576           case KEY_sort:
8577 239572         checkcomma(s,PL_tokenbuf,"subroutine name");
8578 239572         s = SKIPSPACE1(s);
8579 239572         PL_expect = XTERM;
8580 239572         s = force_word(s,WORD,TRUE,TRUE);
8581 239572         LOP(OP_SORT,XREF);
8582            
8583           case KEY_split:
8584 325600         LOP(OP_SPLIT,XTERM);
8585            
8586           case KEY_sprintf:
8587 405821         LOP(OP_SPRINTF,XTERM);
8588            
8589           case KEY_splice:
8590 87536         LOP(OP_SPLICE,XTERM);
8591            
8592           case KEY_sqrt:
8593 1562 100       UNI(OP_SQRT);
    100        
8594            
8595           case KEY_srand:
8596 70 100       UNI(OP_SRAND);
    50        
8597            
8598           case KEY_stat:
8599 154208 100       UNI(OP_STAT);
    50        
8600            
8601           case KEY_study:
8602 37170 100       UNI(OP_STUDY);
    50        
8603            
8604           case KEY_substr:
8605 575203         LOP(OP_SUBSTR,XTERM);
8606            
8607           case KEY_format:
8608           case KEY_sub:
8609           really_sub:
8610           {
8611 9565790         char * const tmpbuf = PL_tokenbuf + 1;
8612           expectation attrful;
8613           bool have_name, have_proto;
8614           const int key = tmp;
8615           #ifndef PERL_MAD
8616           SV *format_name = NULL;
8617           #endif
8618            
8619           #ifdef PERL_MAD
8620           SV *tmpwhite = 0;
8621            
8622           char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
8623           SV *subtoken = PL_madskills
8624           ? newSVpvn_flags(tstart, s - tstart, SvUTF8(PL_linestr))
8625           : NULL;
8626           PL_thistoken = 0;
8627            
8628           d = s;
8629           s = SKIPSPACE2(s,tmpwhite);
8630           #else
8631           d = s;
8632 9565790         s = skipspace(s);
8633           #endif
8634            
8635 9864377 100       if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
    50        
    100        
    50        
    100        
    100        
    100        
    100        
    100        
    100        
    50        
    50        
    50        
    50        
    100        
    100        
8636 298651 100       (*s == ':' && s[1] == ':'))
8637           {
8638           #ifdef PERL_MAD
8639           SV *nametoke = NULL;
8640           #endif
8641            
8642 8948104         PL_expect = XBLOCK;
8643           attrful = XATTRBLOCK;
8644 8948104         d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
8645           &len);
8646           #ifdef PERL_MAD
8647           if (PL_madskills)
8648           nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
8649           #else
8650 8948104 100       if (key == KEY_format)
8651 260         format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
8652           #endif
8653 8948104         *PL_tokenbuf = '&';
8654 8948104 100       if (memchr(tmpbuf, ':', len) || key != KEY_sub
8655 8411722 50       || pad_findmy_pvn(
    100        
    50        
    50        
    100        
    100        
8656           PL_tokenbuf, len + 1, UTF ? SVf_UTF8 : 0
8657           ) != NOT_IN_PAD)
8658 536446         sv_setpvn(PL_subname, tmpbuf, len);
8659           else {
8660 8411658         sv_setsv(PL_subname,PL_curstname);
8661 8411658         sv_catpvs(PL_subname,"::");
8662 8411658         sv_catpvn(PL_subname,tmpbuf,len);
8663           }
8664 8948104 100       if (SvUTF8(PL_linestr))
8665 74         SvUTF8_on(PL_subname);
8666           have_name = TRUE;
8667            
8668            
8669           #ifdef PERL_MAD
8670           start_force(0);
8671           CURMAD('X', nametoke);
8672           CURMAD('_', tmpwhite);
8673           force_ident_maybe_lex('&');
8674            
8675           s = SKIPSPACE2(d,tmpwhite);
8676           #else
8677 8948104         s = skipspace(d);
8678           #endif
8679           }
8680           else {
8681 617686 100       if (key == KEY_my || key == KEY_our || key==KEY_state)
    100        
8682           {
8683 6         *d = '\0';
8684           /* diag_listed_as: Missing name in "%s sub" */
8685 6         Perl_croak(aTHX_
8686 6         "Missing name in \"%s\"", PL_bufptr);
8687           }
8688 617680         PL_expect = XTERMBLOCK;
8689           attrful = XATTRTERM;
8690 617680         sv_setpvs(PL_subname,"?");
8691           have_name = FALSE;
8692           }
8693            
8694 9565784 100       if (key == KEY_format) {
8695           #ifdef PERL_MAD
8696           PL_thistoken = subtoken;
8697           s = d;
8698           #else
8699 298 100       if (format_name) {
8700           start_force(PL_curforce);
8701 260         NEXTVAL_NEXTTOKE.opval
8702 260         = (OP*)newSVOP(OP_CONST,0, format_name);
8703 260         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
8704 260         force_next(WORD);
8705           }
8706           #endif
8707 298         PREBLOCK(FORMAT);
8708           }
8709            
8710           /* Look for a prototype */
8711 9565486 100       if (*s == '(') {
8712 519948         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
8713 519948 100       COPLINE_SET_FROM_MULTI_END;
8714 519948 100       if (!s)
8715 4         Perl_croak(aTHX_ "Prototype not terminated");
8716 519944         (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
8717           have_proto = TRUE;
8718            
8719           #ifdef PERL_MAD
8720           start_force(0);
8721           CURMAD('q', PL_thisopen);
8722           CURMAD('_', tmpwhite);
8723           CURMAD('=', PL_thisstuff);
8724           CURMAD('Q', PL_thisclose);
8725           NEXTVAL_NEXTTOKE.opval =
8726           (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8727           PL_lex_stuff = NULL;
8728           force_next(THING);
8729            
8730           s = SKIPSPACE2(s,tmpwhite);
8731           #else
8732 519944         s = skipspace(s);
8733           #endif
8734           }
8735           else
8736           have_proto = FALSE;
8737            
8738 9565482 100       if (*s == ':' && s[1] != ':')
    50        
8739 5920         PL_expect = attrful;
8740 9559562 100       else if (*s != '{' && key == KEY_sub) {
8741 390389 100       if (!have_name)
8742 16         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
8743 390373 100       else if (*s != ';' && *s != '}')
8744 4         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
8745           }
8746            
8747           #ifdef PERL_MAD
8748           start_force(0);
8749           if (tmpwhite) {
8750           if (PL_madskills)
8751           curmad('^', newSVpvs(""));
8752           CURMAD('_', tmpwhite);
8753           }
8754           force_next(0);
8755            
8756           PL_thistoken = subtoken;
8757           PERL_UNUSED_VAR(have_proto);
8758           #else
8759 9565462 100       if (have_proto) {
8760 1039880         NEXTVAL_NEXTTOKE.opval =
8761 519940         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
8762 519940         PL_lex_stuff = NULL;
8763 519940         force_next(THING);
8764           }
8765           #endif
8766 9565462 100       if (!have_name) {
8767 617626 50       if (PL_curstash)
8768 617626         sv_setpvs(PL_subname, "__ANON__");
8769           else
8770 0         sv_setpvs(PL_subname, "__ANON__::__ANON__");
8771 617626         TOKEN(ANONSUB);
8772           }
8773           #ifndef PERL_MAD
8774 8947836         force_ident_maybe_lex('&');
8775           #endif
8776 8947836         TOKEN(SUB);
8777           }
8778            
8779           case KEY_system:
8780 12466         LOP(OP_SYSTEM,XREF);
8781            
8782           case KEY_symlink:
8783 154         LOP(OP_SYMLINK,XTERM);
8784            
8785           case KEY_syscall:
8786 32         LOP(OP_SYSCALL,XTERM);
8787            
8788           case KEY_sysopen:
8789 2084         LOP(OP_SYSOPEN,XTERM);
8790            
8791           case KEY_sysseek:
8792 1222         LOP(OP_SYSSEEK,XTERM);
8793            
8794           case KEY_sysread:
8795 11563         LOP(OP_SYSREAD,XTERM);
8796            
8797           case KEY_syswrite:
8798 7720         LOP(OP_SYSWRITE,XTERM);
8799            
8800           case KEY_tr:
8801           case KEY_y:
8802 109274         s = scan_trans(s);
8803 109250         TERM(sublex_start());
8804            
8805           case KEY_tell:
8806 3776 100       UNI(OP_TELL);
    100        
8807            
8808           case KEY_telldir:
8809 60 100       UNI(OP_TELLDIR);
    50        
8810            
8811           case KEY_tie:
8812 21402         LOP(OP_TIE,XTERM);
8813            
8814           case KEY_tied:
8815 8482 100       UNI(OP_TIED);
    50        
8816            
8817           case KEY_time:
8818 20570         FUN0(OP_TIME);
8819            
8820           case KEY_times:
8821 5604         FUN0(OP_TMS);
8822            
8823           case KEY_truncate:
8824 6623         LOP(OP_TRUNCATE,XTERM);
8825            
8826           case KEY_uc:
8827 52508 100       UNI(OP_UC);
    100        
8828            
8829           case KEY_ucfirst:
8830 7380 100       UNI(OP_UCFIRST);
    100        
8831            
8832           case KEY_untie:
8833 2082 100       UNI(OP_UNTIE);
    50        
8834            
8835           case KEY_until:
8836 15192 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
    50        
8837           return REPORT(0);
8838 15192         pl_yylval.ival = CopLINE(PL_curcop);
8839 15192         OPERATOR(UNTIL);
8840            
8841           case KEY_unless:
8842 3346816 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
    50        
8843           return REPORT(0);
8844 3346816         pl_yylval.ival = CopLINE(PL_curcop);
8845 3346816         OPERATOR(UNLESS);
8846            
8847           case KEY_unlink:
8848 61661         LOP(OP_UNLINK,XTERM);
8849            
8850           case KEY_undef:
8851 868280 100       UNIDOR(OP_UNDEF);
    50        
8852            
8853           case KEY_unpack:
8854 90122         LOP(OP_UNPACK,XTERM);
8855            
8856           case KEY_utime:
8857 13112         LOP(OP_UTIME,XTERM);
8858            
8859           case KEY_umask:
8860 3420 100       UNIDOR(OP_UMASK);
    100        
8861            
8862           case KEY_unshift:
8863 156678         LOP(OP_UNSHIFT,XTERM);
8864            
8865           case KEY_use:
8866 4235040         s = tokenize_use(1, s);
8867 4235040         OPERATOR(USE);
8868            
8869           case KEY_values:
8870 58113 100       UNI(OP_VALUES);
    100        
8871            
8872           case KEY_vec:
8873 271486         LOP(OP_VEC,XTERM);
8874            
8875           case KEY_when:
8876 432 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
    50        
8877           return REPORT(0);
8878 432         pl_yylval.ival = CopLINE(PL_curcop);
8879 432         Perl_ck_warner_d(aTHX_
8880           packWARN(WARN_EXPERIMENTAL__SMARTMATCH),
8881           "when is experimental");
8882 432         OPERATOR(WHEN);
8883            
8884           case KEY_while:
8885 689160 100       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_NONEXPR)
    50        
8886           return REPORT(0);
8887 689160         pl_yylval.ival = CopLINE(PL_curcop);
8888 689160         OPERATOR(WHILE);
8889            
8890           case KEY_warn:
8891 405308         PL_hints |= HINT_BLOCK_SCOPE;
8892 405308         LOP(OP_WARN,XTERM);
8893            
8894           case KEY_wait:
8895 120         FUN0(OP_WAIT);
8896            
8897           case KEY_waitpid:
8898 3420         LOP(OP_WAITPID,XTERM);
8899            
8900           case KEY_wantarray:
8901 115848         FUN0(OP_WANTARRAY);
8902            
8903           case KEY_write:
8904           /* Make sure $^L is defined. 0x0C is CTRL-L on ASCII platforms, and
8905           * we use the same number on EBCDIC */
8906 3314         gv_fetchpvs("\x0C", GV_ADD|GV_NOTQUAL, SVt_PV);
8907 3314 100       UNI(OP_ENTERWRITE);
    100        
8908            
8909           case KEY_x:
8910 221558 100       if (PL_expect == XOPERATOR) {
8911 221452 100       if (*s == '=' && !PL_lex_allbrackets &&
    100        
    50        
8912 8         PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
8913           return REPORT(0);
8914 221448         Mop(OP_REPEAT);
8915           }
8916 110         check_uni();
8917 110         goto just_a_word;
8918            
8919           case KEY_xor:
8920 38984 50       if (!PL_lex_allbrackets && PL_lex_fakeeof >= LEX_FAKEEOF_LOWLOGIC)
    0        
8921           return REPORT(0);
8922 38984         pl_yylval.ival = OP_XOR;
8923 547621750         OPERATOR(OROP);
8924           }
8925           }}
8926           }
8927           #ifdef __SC__
8928           #pragma segment Main
8929           #endif
8930            
8931           /*
8932           S_pending_ident
8933            
8934           Looks up an identifier in the pad or in a package
8935            
8936           Returns:
8937           PRIVATEREF if this is a lexical name.
8938           WORD if this belongs to a package.
8939            
8940           Structure:
8941           if we're in a my declaration
8942           croak if they tried to say my($foo::bar)
8943           build the ops for a my() declaration
8944           if it's an access to a my() variable
8945           build ops for access to a my() variable
8946           if in a dq string, and they've said @foo and we can't find @foo
8947           warn
8948           build ops for a bareword
8949           */
8950            
8951           static int
8952 142444391         S_pending_ident(pTHX)
8953           {
8954           dVAR;
8955           PADOFFSET tmp = 0;
8956 142444391         const char pit = (char)pl_yylval.ival;
8957 142444391         const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
8958           /* All routes through this function want to know if there is a colon. */
8959 142444391         const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
8960            
8961           DEBUG_T({ PerlIO_printf(Perl_debug_log,
8962           "### Pending identifier '%s'\n", PL_tokenbuf); });
8963            
8964           /* if we're in a my(), we can't allow dynamics here.
8965           $foo'bar has already been turned into $foo::bar, so
8966           just check for colons.
8967            
8968           if it's a legal name, the OP is a PADANY.
8969           */
8970 142444391 100       if (PL_in_my) {
8971 23690304 100       if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
8972 1161493 100       if (has_colon)
8973 2 50       yyerror_pv(Perl_form(aTHX_ "No package name allowed for "
    50        
    50        
    0        
    0        
8974           "variable %s in \"our\"",
8975           PL_tokenbuf), UTF ? SVf_UTF8 : 0);
8976 1161493 50       tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
    100        
    50        
    50        
    100        
8977           }
8978           else {
8979 22528811 100       if (has_colon)
8980 4 50       yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
    50        
    50        
    0        
    0        
    100        
8981           PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
8982           UTF ? SVf_UTF8 : 0);
8983            
8984 22528811         pl_yylval.opval = newOP(OP_PADANY, 0);
8985 22528811 50       pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
    100        
    50        
    50        
    100        
8986           UTF ? SVf_UTF8 : 0);
8987 22528807         return PRIVATEREF;
8988           }
8989           }
8990            
8991           /*
8992           build the ops for accesses to a my() variable.
8993           */
8994            
8995 119915576 100       if (!has_colon) {
8996 117716705 100       if (!PL_in_my)
8997 116555218 50       tmp = pad_findmy_pvn(PL_tokenbuf, tokenbuf_len,
    100        
    50        
    100        
    100        
8998           UTF ? SVf_UTF8 : 0);
8999 117716705 100       if (tmp != NOT_IN_PAD) {
9000           /* might be an "our" variable" */
9001 86130860 100       if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
9002           /* build ops for a bareword */
9003 3831012 50       HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
9004 3831012 50       HEK * const stashname = HvNAME_HEK(stash);
    50        
    50        
9005 3831012         SV * const sym = newSVhek(stashname);
9006 3831012         sv_catpvs(sym, "::");
9007 3831012 50       sv_catpvn_flags(sym, PL_tokenbuf+1, tokenbuf_len - 1, (UTF ? SV_CATUTF8 : SV_CATBYTES ));
    100        
    50        
    50        
    100        
9008 3831012         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
9009 3831012         pl_yylval.opval->op_private = OPpCONST_ENTERED;
9010 3831012 100       if (pit != '&')
9011 3830972 100       gv_fetchsv(sym,
    100        
    100        
9012           (PL_in_eval
9013           ? (GV_ADDMULTI | GV_ADDINEVAL)
9014           : GV_ADDMULTI
9015           ),
9016           ((PL_tokenbuf[0] == '$') ? SVt_PV
9017           : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9018           : SVt_PVHV));
9019           return WORD;
9020           }
9021            
9022 82299848         pl_yylval.opval = newOP(OP_PADANY, 0);
9023 82299848         pl_yylval.opval->op_targ = tmp;
9024 82299848         return PRIVATEREF;
9025           }
9026           }
9027            
9028           /*
9029           Whine if they've said @foo in a doublequoted string,
9030           and @foo isn't a variable we can find in the symbol
9031           table.
9032           */
9033 33784716 100       if (ckWARN(WARN_AMBIGUOUS) &&
    100        
9034 1936768 100       pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
    100        
9035 12058 50       GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1,
    100        
    50        
    50        
    50        
9036           ( UTF ? SVf_UTF8 : 0 ), SVt_PVAV);
9037 12058 100       if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
    50        
    50        
    0        
9038           /* DO NOT warn for @- and @+ */
9039 24 100       && !( PL_tokenbuf[2] == '\0' &&
    100        
9040 12         ( PL_tokenbuf[1] == '-' || PL_tokenbuf[1] == '+' ))
9041           )
9042           {
9043           /* Downgraded from fatal to warning 20000522 mjd */
9044 20 50       Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
    50        
9045           "Possible unintended interpolation of %"UTF8f
9046           " in string",
9047 16 100       UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
    50        
    50        
9048           }
9049           }
9050            
9051           /* build ops for a bareword */
9052 33784716 50       pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
    100        
    50        
    100        
    100        
9053           newSVpvn_flags(PL_tokenbuf + 1,
9054           tokenbuf_len - 1,
9055           UTF ? SVf_UTF8 : 0 ));
9056 33784716         pl_yylval.opval->op_private = OPpCONST_ENTERED;
9057 33784716 100       if (pit != '&')
9058 84650408 100       gv_fetchpvn_flags(PL_tokenbuf+1, tokenbuf_len - 1,
    100        
    100        
    50        
    100        
    50        
    100        
    100        
9059           (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD)
9060           | ( UTF ? SVf_UTF8 : 0 ),
9061           ((PL_tokenbuf[0] == '$') ? SVt_PV
9062           : (PL_tokenbuf[0] == '@') ? SVt_PVAV
9063           : SVt_PVHV));
9064           return WORD;
9065           }
9066            
9067           STATIC void
9068 1572116         S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
9069           {
9070           dVAR;
9071            
9072           PERL_ARGS_ASSERT_CHECKCOMMA;
9073            
9074 1572116 100       if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
    100        
9075 444 100       if (ckWARN(WARN_SYNTAX)) {
9076           int level = 1;
9077           const char *w;
9078 7308 100       for (w = s+2; *w && level; w++) {
9079 7134 100       if (*w == '(')
9080 132         ++level;
9081 7002 100       else if (*w == ')')
9082 306         --level;
9083           }
9084 188 100       while (isSPACE(*w))
9085 14         ++w;
9086           /* the list of chars below is for end of statements or
9087           * block / parens, boolean operators (&&, ||, //) and branch
9088           * constructs (or, and, if, until, unless, while, err, for).
9089           * Not a very solid hack... */
9090 174 50       if (!*w || !strchr(";&/|})]oaiuwef!=", *w))
    100        
9091 847432         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
9092           "%s (...) interpreted as function",name);
9093           }
9094           }
9095 3139818 100       while (s < PL_bufend && isSPACE(*s))
    100        
9096 1567702         s++;
9097 1572116 100       if (*s == '(')
9098 871734         s++;
9099 1578082 100       while (s < PL_bufend && isSPACE(*s))
    100        
9100 5966         s++;
9101 1572116 100       if (isIDFIRST_lazy_if(s,UTF)) {
    50        
    100        
    50        
    100        
    100        
    100        
    50        
    0        
    0        
    100        
9102           const char * const w = s;
9103 525413 50       s += UTF ? UTF8SKIP(s) : 1;
    100        
    50        
    50        
    100        
9104 2867518 100       while (isWORDCHAR_lazy_if(s,UTF))
    50        
    100        
    50        
    50        
    100        
    100        
    50        
    50        
    50        
    100        
9105 2092896 50       s += UTF ? UTF8SKIP(s) : 1;
    100        
    50        
    50        
    100        
9106 996371 100       while (s < PL_bufend && isSPACE(*s))
    100        
9107 470958         s++;
9108 525413 100       if (*s == ',') {
9109           GV* gv;
9110 2222 100       if (keyword(w, s - w, 0))
9111           return;
9112            
9113 10 50       gv = gv_fetchpvn_flags(w, s - w, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
    100        
    50        
    50        
    50        
9114 10 50       if (gv && GvCVu(gv))
    50        
    100        
9115           return;
9116 847430         Perl_croak(aTHX_ "No comma allowed after %s", what);
9117           }
9118           }
9119           }
9120            
9121           /* S_new_constant(): do any overload::constant lookup.
9122            
9123           Either returns sv, or mortalizes/frees sv and returns a new SV*.
9124           Best used as sv=new_constant(..., sv, ...).
9125           If s, pv are NULL, calls subroutine with one argument,
9126           and is used with error messages only.
9127           is assumed to be well formed UTF-8 */
9128            
9129           STATIC SV *
9130 3218         S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, STRLEN keylen,
9131           SV *sv, SV *pv, const char *type, STRLEN typelen)
9132 3070 50       {
9133 3218         dVAR; dSP;
9134 3218         HV * table = GvHV(PL_hintgv); /* ^H */
9135           SV *res;
9136           SV *errsv = NULL;
9137           SV **cvp;
9138           SV *cv, *typesv;
9139           const char *why1 = "", *why2 = "", *why3 = "";
9140            
9141           PERL_ARGS_ASSERT_NEW_CONSTANT;
9142           /* We assume that this is true: */
9143           if (*key == 'c') { assert (strEQ(key, "charnames")); }
9144           assert(type || s);
9145            
9146           /* charnames doesn't work well if there have been errors found */
9147 3218 100       if (PL_error_count > 0 && *key == 'c')
    100        
9148           {
9149           SvREFCNT_dec_NN(sv);
9150           return &PL_sv_undef;
9151           }
9152            
9153 3172         sv_2mortal(sv); /* Parent created it permanently */
9154 3172 100       if (!table
9155 3154 100       || ! (PL_hints & HINT_LOCALIZE_HH)
9156 3012 100       || ! (cvp = hv_fetch(table, key, keylen, FALSE))
9157 2970 50       || ! SvOK(*cvp))
    0        
    0        
9158           {
9159           char *msg;
9160          
9161           /* Here haven't found what we're looking for. If it is charnames,
9162           * perhaps it needs to be loaded. Try doing that before giving up */
9163 202 100       if (*key == 'c') {
9164 104         Perl_load_module(aTHX_
9165           0,
9166           newSVpvs("_charnames"),
9167           /* version parameter; no need to specify it, as if
9168           * we get too early a version, will fail anyway,
9169           * not being able to find '_charnames' */
9170           NULL,
9171           newSVpvs(":full"),
9172           newSVpvs(":short"),
9173           NULL);
9174 104         SPAGAIN;
9175 104         table = GvHV(PL_hintgv);
9176 104 50       if (table
9177 104 100       && (PL_hints & HINT_LOCALIZE_HH)
9178 100 50       && (cvp = hv_fetch(table, key, keylen, FALSE))
9179 100 50       && SvOK(*cvp))
    0        
    0        
9180           {
9181           goto now_ok;
9182           }
9183           }
9184 102 100       if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
    100        
9185 62 100       msg = Perl_form(aTHX_
    100        
9186           "Constant(%.*s) unknown",
9187           (int)(type ? typelen : len),
9188           (type ? type: s));
9189           }
9190           else {
9191           why1 = "$^H{";
9192           why2 = key;
9193           why3 = "} is not defined";
9194           report:
9195 162 100       if (*key == 'c') {
9196 96         msg = Perl_form(aTHX_
9197           /* The +3 is for '\N{'; -4 for that, plus '}' */
9198 64         "Unknown charname '%.*s'", (int)typelen - 4, type + 3
9199           );
9200           }
9201           else {
9202 98 100       msg = Perl_form(aTHX_ "Constant(%.*s): %s%s%s",
    100        
9203           (int)(type ? typelen : len),
9204           (type ? type: s), why1, why2, why3);
9205           }
9206           }
9207 224 50       yyerror_pv(msg, UTF ? SVf_UTF8 : 0);
    100        
    50        
    50        
    50        
9208 212         return SvREFCNT_inc_simple_NN(sv);
9209           }
9210           now_ok:
9211 3070         cv = *cvp;
9212 3070 100       if (!pv && s)
9213 542         pv = newSVpvn_flags(s, len, SVs_TEMP);
9214 3070 100       if (type && pv)
9215 78         typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
9216           else
9217           typesv = &PL_sv_undef;
9218            
9219 3070 100       PUSHSTACKi(PERLSI_OVERLOAD);
9220 3070         ENTER ;
9221 3070         SAVETMPS;
9222            
9223 3070 50       PUSHMARK(SP) ;
9224 1535         EXTEND(sp, 3);
9225 3070 100       if (pv)
9226 544         PUSHs(pv);
9227 3070         PUSHs(sv);
9228 3070 100       if (pv)
9229 544         PUSHs(typesv);
9230 3070         PUTBACK;
9231 3070 100       call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9232            
9233 3066         SPAGAIN ;
9234            
9235           /* Check the eval first */
9236 3070 100       if (!PL_in_eval && ((errsv = ERRSV), SvTRUE_NN(errsv))) {
    50        
    50        
    50        
    0        
    0        
    50        
    50        
    100        
    50        
    0        
    0        
    0        
    0        
    0        
    0        
    100        
9237           STRLEN errlen;
9238           const char * errstr;
9239 4         sv_catpvs(errsv, "Propagated");
9240 4 50       errstr = SvPV_const(errsv, errlen);
9241 4         yyerror_pvn(errstr, errlen, 0); /* Duplicates the message inside eval */
9242 4         (void)POPs;
9243 4         res = SvREFCNT_inc_simple_NN(sv);
9244           }
9245           else {
9246 3062         res = POPs;
9247 3062         SvREFCNT_inc_simple_void_NN(res);
9248           }
9249            
9250 3066         PUTBACK ;
9251 3066 100       FREETMPS ;
9252 3066         LEAVE ;
9253 3066 50       POPSTACK;
9254            
9255 3066 100       if (!SvOK(res)) {
    50        
    50        
9256           why1 = "Call to &{$^H{";
9257           why2 = key;
9258           why3 = "}} did not return a defined value";
9259           sv = res;
9260 1723         (void)sv_2mortal(sv);
9261 122         goto report;
9262           }
9263            
9264           return res;
9265           }
9266            
9267           PERL_STATIC_INLINE void
9268 488411213         S_parse_ident(pTHX_ char **s, char **d, char * const e, int allow_package, bool is_utf8) {
9269           dVAR;
9270           PERL_ARGS_ASSERT_PARSE_IDENT;
9271            
9272           for (;;) {
9273 652473562 100       if (*d >= e)
9274 14         Perl_croak(aTHX_ "%s", ident_too_long);
9275 653898602 100       if (is_utf8 && isIDFIRST_utf8((U8*)*s)) {
    100        
    100        
    100        
    50        
    100        
    100        
    100        
9276           /* The UTF-8 case must come first, otherwise things
9277           * like c\N{COMBINING TILDE} would start failing, as the
9278           * isWORDCHAR_A case below would gobble the 'c' up.
9279           */
9280            
9281 1425054         char *t = *s + UTF8SKIP(*s);
9282 2873641 100       while (isIDCONT_utf8((U8*)t))
    100        
    50        
    100        
    100        
9283 736060         t += UTF8SKIP(t);
9284 1425054 50       if (*d + (t - *s) > e)
9285 0         Perl_croak(aTHX_ "%s", ident_too_long);
9286 1425054         Copy(*s, *d, t - *s, char);
9287 1425054         *d += t - *s;
9288 1425054         *s = t;
9289           }
9290 651048494 100       else if ( isWORDCHAR_A(**s) ) {
9291           do {
9292 1515795206         *(*d)++ = *(*s)++;
9293 1515795206 100       } while isWORDCHAR_A(**s);
9294           }
9295 332367595 100       else if (allow_package && **s == '\'' && isIDFIRST_lazy_if(*s+1,is_utf8)) {
    100        
    100        
    100        
    100        
    100        
    100        
    50        
    0        
    0        
    0        
    50        
9296 2612         *(*d)++ = ':';
9297 2612         *(*d)++ = ':';
9298 2612         (*s)++;
9299           }
9300 332364983 100       else if (allow_package && **s == ':' && (*s)[1] == ':'
    100        
    100        
9301           /* Disallow things like Foo::$bar. For the curious, this is
9302           * the code path that triggers the "Bad name after" warning
9303           * when looking for barewords.
9304           */
9305 18358566 100       && (*s)[2] != '$') {
9306 18358562         *(*d)++ = *(*s)++;
9307 18358562         *(*d)++ = *(*s)++;
9308           }
9309           else
9310           break;
9311           }
9312 314006421         return;
9313           }
9314            
9315           /* Returns a NUL terminated string, with the length of the string written to
9316           *slp
9317           */
9318           STATIC char *
9319 175654796         S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9320           {
9321           dVAR;
9322 175654796         char *d = dest;
9323 175654796         char * const e = d + destlen - 3; /* two-character token, ending NUL */
9324 175654796 50       bool is_utf8 = cBOOL(UTF);
    100        
    50        
    100        
    100        
9325            
9326           PERL_ARGS_ASSERT_SCAN_WORD;
9327            
9328 175654796         parse_ident(&s, &d, e, allow_package, is_utf8);
9329 175654796         *d = '\0';
9330 175654796         *slp = d - dest;
9331 175654796         return s;
9332           }
9333            
9334           STATIC char *
9335 139284652         S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9336           {
9337           dVAR;
9338           char *bracket = NULL;
9339 139284652         char funny = *s++;
9340 139284652         char *d = dest;
9341 139284652         char * const e = d + destlen - 3; /* two-character token, ending NUL */
9342 139284652 50       bool is_utf8 = cBOOL(UTF);
    100        
    50        
    100        
    100        
9343            
9344           PERL_ARGS_ASSERT_SCAN_IDENT;
9345            
9346 139284652 100       if (isSPACE(*s))
9347 39756         s = PEEKSPACE(s);
9348 139284652 100       if (isDIGIT(*s)) {
9349 2808694 100       while (isDIGIT(*s)) {
9350 1404422 50       if (d >= e)
9351 0         Perl_croak(aTHX_ "%s", ident_too_long);
9352 1404422         *d++ = *s++;
9353           }
9354           }
9355           else {
9356 137880380         parse_ident(&s, &d, e, 1, is_utf8);
9357           }
9358 139284638         *d = '\0';
9359 139284638         d = dest;
9360 139284638 100       if (*d) {
9361           /* Either a digit variable, or parse_ident() found an identifier
9362           (anything valid as a bareword), so job done and return. */
9363 130359558 100       if (PL_lex_state != LEX_NORMAL)
9364 8464463         PL_lex_state = LEX_INTERPENDMAYBE;
9365 130359558         return s;
9366           }
9367 12775087 100       if (*s == '$' && s[1] &&
    100        
    100        
    100        
    100        
    50        
9368 3829769 100       (isIDFIRST_lazy_if(s+1,is_utf8)
9369 23546 100       || isDIGIT_A((U8)s[1])
    0        
    0        
    100        
9370 45752 100       || s[1] == '$'
9371 45454 100       || s[1] == '{'
9372 45432 100       || strnEQ(s+1,"::",2)) )
9373           {
9374           /* Dereferencing a value in a scalar variable.
9375           The alternatives are different syntaxes for a scalar variable.
9376           Using ' as a leading package separator isn't allowed. :: is. */
9377 2595918         return s;
9378           }
9379           /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
9380 6329162 100       if (*s == '{') {
9381 2819598         bracket = s;
9382 2819598         s++;
9383 4394310 50       while (s < send && SPACE_OR_TAB(*s))
    100        
9384 218010         s++;
9385           }
9386            
9387           /* \c?, \c\, \c^, \c_, and \cA..\cZ minus the ones that have traditionally
9388           * been matched by \s on ASCII platforms, are the legal control char names
9389           * here, that is \c? plus 1-32 minus the \s ones. */
9390           #define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
9391           || isDIGIT_A((U8)(d)) \
9392           || (!(u) && !isASCII((U8)(d))) \
9393           || ((((U8)(d)) < 32) \
9394           && (((((U8)(d)) >= 14) \
9395           || (((U8)(d)) <= 8 && (d) != 0) \
9396           || (((U8)(d)) == 13)))) \
9397           || (((U8)(d)) == toCTRL('?')))
9398 9443511 100       if (s < send
    100        
    100        
    100        
9399 9402832 100       && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
    100        
    100        
    50        
    50        
    50        
    100        
    100        
    100        
    100        
    100        
    100        
    100        
    50        
    50        
    50        
9400           {
9401 6295104 100       if (is_utf8) {
9402 1082         const STRLEN skip = UTF8SKIP(s);
9403           STRLEN i;
9404 1082         d[skip] = '\0';
9405 2178 100       for ( i = 0; i < skip; i++ )
9406 1096         d[i] = *s++;
9407           }
9408           else {
9409 6294022         *d = *s++;
9410 6294022         d[1] = '\0';
9411           }
9412           }
9413           /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
9414 6329162 100       if (*d == '^' && *s && isCONTROLVAR(*s)) {
    50        
    100        
    50        
9415 1452138 50       *d = toCTRL(*s);
9416 1452138         s++;
9417           }
9418           /* Warn about ambiguous code after unary operators if {...} notation isn't
9419           used. There's no difference in ambiguity; it's merely a heuristic
9420           about when not to warn. */
9421 4877024 100       else if (ck_uni && !bracket)
9422 8         check_uni();
9423 6329162 100       if (bracket) {
9424           /* If we were processing {...} notation then... */
9425 2819598 100       if (isIDFIRST_lazy_if(d,is_utf8)) {
    100        
    100        
    50        
    0        
    0        
    100        
9426           /* if it starts as a valid identifier, assume that it is one.
9427           (the later check for } being at the expected point will trap
9428           cases where this doesn't pan out.) */
9429 471259 100       d += is_utf8 ? UTF8SKIP(d) : 1;
9430 471259         parse_ident(&s, &d, e, 1, is_utf8);
9431 471259         *d = '\0';
9432 708746 50       while (s < send && SPACE_OR_TAB(*s))
    100        
9433 10316         s++;
9434 471259 100       if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
    100        
    100        
    50        
    50        
    100        
9435           /* ${foo[0]} and ${foo{bar}} notation. */
9436 14 100       if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
    100        
9437           const char * const brack =
9438           (const char *)
9439 6 100       ((*s == '[') ? "[...]" : "{...}");
9440           /* diag_listed_as: Ambiguous use of %c{%s[...]} resolved to %c%s[...] */
9441 6         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9442           "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9443           funny, dest, brack, funny, dest, brack);
9444           }
9445           bracket++;
9446 14         PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9447 14         PL_lex_allbrackets++;
9448 14         return s;
9449           }
9450           }
9451           /* Handle extended ${^Foo} variables
9452           * 1999-02-27 mjd-perl-patch@plover.com */
9453 2348339 100       else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
9454 139154 100       && isWORDCHAR(*s))
9455           {
9456 137774         d++;
9457 1620119 100       while (isWORDCHAR(*s) && d < e) {
    50        
9458 1414538         *d++ = *s++;
9459           }
9460 137774 50       if (d >= e)
9461 0         Perl_croak(aTHX_ "%s", ident_too_long);
9462 1530696         *d = '\0';
9463           }
9464            
9465 2822276 100       while (s < send && SPACE_OR_TAB(*s))
    100        
9466 2692         s++;
9467            
9468           /* Expect to find a closing } after consuming any trailing whitespace.
9469           */
9470 2819584 100       if (*s == '}') {
9471 531073         s++;
9472 531073 100       if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
    100        
9473 384909         PL_lex_state = LEX_INTERPEND;
9474 384909         PL_expect = XREF;
9475           }
9476 531073 100       if (PL_lex_state == LEX_NORMAL) {
9477 197418         if (ckWARN(WARN_AMBIGUOUS) &&
9478 51454         (keyword(dest, d - dest, 0)
9479 51440 100       || get_cvn_flags(dest, d - dest, is_utf8 ? SVf_UTF8 : 0)))
    100        
9480           {
9481 20 100       SV *tmp = newSVpvn_flags( dest, d - dest,
9482           SVs_TEMP | (is_utf8 ? SVf_UTF8 : 0) );
9483 20 100       if (funny == '#')
9484           funny = '@';
9485 20         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9486           "Ambiguous use of %c{%"SVf"} resolved to %c%"SVf,
9487           funny, tmp, funny, tmp);
9488           }
9489           }
9490           }
9491           else {
9492           /* Didn't find the closing } at the point we expected, so restore
9493           state such that the next thing to process is the opening { and */
9494 2288511         s = bracket; /* let the parser handle it */
9495 2288511         *dest = '\0';
9496           }
9497           }
9498 3509564 100       else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
    100        
    100        
9499 803621         PL_lex_state = LEX_INTERPEND;
9500 75011878         return s;
9501           }
9502            
9503           static bool
9504 6274656         S_pmflag(pTHX_ const char* const valid_flags, U32 * pmfl, char** s, char* charset) {
9505            
9506           /* Adds, subtracts to/from 'pmfl' based on regex modifier flags found in
9507           * the parse starting at 's', based on the subset that are valid in this
9508           * context input to this routine in 'valid_flags'. Advances s. Returns
9509           * TRUE if the input should be treated as a valid flag, so the next char
9510           * may be as well; otherwise FALSE. 'charset' should point to a NUL upon
9511           * first call on the current regex. This routine will set it to any
9512           * charset modifier found. The caller shouldn't change it. This way,
9513           * another charset modifier encountered in the parse can be detected as an
9514           * error, as we have decided to allow only one */
9515            
9516 6274656         const char c = **s;
9517 6274656 50       STRLEN charlen = UTF ? UTF8SKIP(*s) : 1;
    100        
    50        
    100        
    100        
9518            
9519 6274656 100       if ( charlen != 1 || ! strchr(valid_flags, c) ) {
    50        
    0        
    100        
9520 4736811 100       if (isWORDCHAR_lazy_if(*s, UTF)) {
    50        
    100        
    50        
    100        
    100        
    100        
    50        
    0        
    0        
    100        
9521 24 50       yyerror_pv(Perl_form(aTHX_ "Unknown regexp modifier \"/%.*s\"", (int)charlen, *s),
    50        
    0        
    50        
    100        
9522           UTF ? SVf_UTF8 : 0);
9523 24         (*s) += charlen;
9524           /* Pretend that it worked, so will continue processing before
9525           * dieing */
9526 24         return TRUE;
9527           }
9528           return FALSE;
9529           }
9530            
9531 1537845         switch (c) {
9532            
9533 590694         CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
9534 619296         case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
9535 4124         case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break;
9536 32504         case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break;
9537 208         case KEEPCOPY_PAT_MOD: *pmfl |= RXf_PMf_KEEPCOPY; break;
9538 5144         case NONDESTRUCT_PAT_MOD: *pmfl |= PMf_NONDESTRUCT; break;
9539           case LOCALE_PAT_MOD:
9540 408 100       if (*charset) {
9541           goto multiple_charsets;
9542           }
9543           set_regex_charset(pmfl, REGEX_LOCALE_CHARSET);
9544 406         *charset = c;
9545 406         break;
9546           case UNICODE_PAT_MOD:
9547 10662 100       if (*charset) {
9548           goto multiple_charsets;
9549           }
9550           set_regex_charset(pmfl, REGEX_UNICODE_CHARSET);
9551 10660         *charset = c;
9552 10660         break;
9553           case ASCII_RESTRICT_PAT_MOD:
9554 1534 100       if (! *charset) {
9555           set_regex_charset(pmfl, REGEX_ASCII_RESTRICTED_CHARSET);
9556           }
9557           else {
9558            
9559           /* Error if previous modifier wasn't an 'a', but if it was, see
9560           * if, and accept, a second occurrence (only) */
9561 502 100       if (*charset != 'a'
9562 750 100       || get_regex_charset(*pmfl)
9563           != REGEX_ASCII_RESTRICTED_CHARSET)
9564           {
9565           goto multiple_charsets;
9566           }
9567           set_regex_charset(pmfl, REGEX_ASCII_MORE_RESTRICTED_CHARSET);
9568           }
9569 1530         *charset = c;
9570 1530         break;
9571           case DEPENDS_PAT_MOD:
9572 392 100       if (*charset) {
9573           goto multiple_charsets;
9574           }
9575           set_regex_charset(pmfl, REGEX_DEPENDS_CHARSET);
9576 312         *charset = c;
9577 312         break;
9578           }
9579            
9580 1537757         (*s)++;
9581 1537757         return TRUE;
9582            
9583           multiple_charsets:
9584 88 100       if (*charset != c) {
9585 4         yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
9586           }
9587 84 100       else if (c == 'a') {
9588 2         yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
9589           }
9590           else {
9591 82         yyerror(Perl_form(aTHX_ "Regexp modifier \"/%c\" may not appear twice", c));
9592           }
9593            
9594           /* Pretend that it worked, so will continue processing before dieing */
9595 80         (*s)++;
9596 3263349         return TRUE;
9597           }
9598            
9599           STATIC char *
9600 3248828         S_scan_pat(pTHX_ char *start, I32 type)
9601           {
9602           dVAR;
9603           PMOP *pm;
9604           char *s;
9605           const char * const valid_flags =
9606 3248828 100       (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
9607 3248828         char charset = '\0'; /* character set modifier */
9608           #ifdef PERL_MAD
9609           char *modstart;
9610           #endif
9611            
9612           PERL_ARGS_ASSERT_SCAN_PAT;
9613            
9614 3248828         s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
9615           TRUE /* look for escaped bracketed metas */ );
9616            
9617 3248828 100       if (!s) {
9618 46         const char * const delimiter = skipspace(start);
9619 46 50       Perl_croak(aTHX_
9620           (const char *)
9621 46         (*delimiter == '?'
9622           ? "Search pattern not terminated or ternary operator parsed as search pattern"
9623           : "Search pattern not terminated" ));
9624           }
9625            
9626 3248782         pm = (PMOP*)newPMOP(type, 0);
9627 3248782 100       if (PL_multi_open == '?') {
9628           /* This is the only point in the code that sets PMf_ONCE: */
9629 34         pm->op_pmflags |= PMf_ONCE;
9630            
9631           /* Hence it's safe to do this bit of PMOP book-keeping here, which
9632           allows us to restrict the list needed by reset to just the ??
9633           matches. */
9634           assert(type != OP_TRANS);
9635 34 50       if (PL_curstash) {
9636 34         MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
9637           U32 elements;
9638 34 100       if (!mg) {
9639 28         mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
9640           0);
9641           }
9642 34         elements = mg->mg_len / sizeof(PMOP**);
9643 34 50       Renewc(mg->mg_ptr, elements + 1, PMOP*, char);
9644 34         ((PMOP**)mg->mg_ptr) [elements++] = pm;
9645 34         mg->mg_len = elements * sizeof(PMOP**);
9646 34         PmopSTASH_set(pm,PL_curstash);
9647           }
9648           }
9649           #ifdef PERL_MAD
9650           modstart = s;
9651           #endif
9652            
9653           /* if qr/...(?{..}).../, then need to parse the pattern within a new
9654           * anon CV. False positives like qr/[(?{]/ are harmless */
9655            
9656 3248782 100       if (type == OP_QR) {
9657           STRLEN len;
9658 471994 50       char *e, *p = SvPV(PL_lex_stuff, len);
9659 471994         e = p + len;
9660 17041680 100       for (; p < e; p++) {
9661 16578630 100       if (p[0] == '(' && p[1] == '?'
    100        
9662 229308 100       && (p[2] == '{' || (p[2] == '?' && p[3] == '{')))
    100        
    50        
9663           {
9664 8944         pm->op_pmflags |= PMf_HAS_CV;
9665 8944         break;
9666           }
9667           }
9668 1909885         pm->op_pmflags |= PMf_IS_QR;
9669           }
9670            
9671 3937225 100       while (*s && S_pmflag(aTHX_ valid_flags, &(pm->op_pmflags), &s, &charset)) {};
    100        
9672           #ifdef PERL_MAD
9673           if (PL_madskills && modstart != s) {
9674           SV* tmptoken = newSVpvn(modstart, s - modstart);
9675           append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
9676           }
9677           #endif
9678           /* issue a warning if /c is specified,but /g is not */
9679 3248778 100       if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
9680           {
9681 6         Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),
9682           "Use of /c modifier is meaningless without /g" );
9683           }
9684            
9685 3248778         PL_lex_op = (OP*)pm;
9686 3248778         pl_yylval.ival = OP_MATCH;
9687 3248778         return s;
9688           }
9689            
9690           STATIC char *
9691 1488023         S_scan_subst(pTHX_ char *start)
9692           {
9693           dVAR;
9694           char *s;
9695           PMOP *pm;
9696           I32 first_start;
9697           line_t first_line;
9698           I32 es = 0;
9699 1488023         char charset = '\0'; /* character set modifier */
9700           #ifdef PERL_MAD
9701           char *modstart;
9702           #endif
9703            
9704           PERL_ARGS_ASSERT_SCAN_SUBST;
9705            
9706 1488023         pl_yylval.ival = OP_NULL;
9707            
9708 1488023         s = scan_str(start,!!PL_madskills,FALSE,FALSE,
9709           TRUE /* look for escaped bracketed metas */ );
9710            
9711 1488023 100       if (!s)
9712 2         Perl_croak(aTHX_ "Substitution pattern not terminated");
9713            
9714 1488021 100       if (s[-1] == PL_multi_open)
9715 1300140         s--;
9716           #ifdef PERL_MAD
9717           if (PL_madskills) {
9718           CURMAD('q', PL_thisopen);
9719           CURMAD('_', PL_thiswhite);
9720           CURMAD('E', PL_thisstuff);
9721           CURMAD('Q', PL_thisclose);
9722           PL_realtokenstart = s - SvPVX(PL_linestr);
9723           }
9724           #endif
9725            
9726 1488021         first_start = PL_multi_start;
9727 1488021         first_line = CopLINE(PL_curcop);
9728 1488021         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9729 1488021 100       if (!s) {
9730 6 50       if (PL_lex_stuff) {
9731 6         SvREFCNT_dec(PL_lex_stuff);
9732 6         PL_lex_stuff = NULL;
9733           }
9734 6         Perl_croak(aTHX_ "Substitution replacement not terminated");
9735           }
9736 1488015         PL_multi_start = first_start; /* so whole substitution is taken together */
9737            
9738 1488015         pm = (PMOP*)newPMOP(OP_SUBST, 0);
9739            
9740           #ifdef PERL_MAD
9741           if (PL_madskills) {
9742           CURMAD('z', PL_thisopen);
9743           CURMAD('R', PL_thisstuff);
9744           CURMAD('Z', PL_thisclose);
9745           }
9746           modstart = s;
9747           #endif
9748            
9749 3235211 50       while (*s) {
9750 2516216 100       if (*s == EXEC_PAT_MOD) {
9751 178783         s++;
9752 178783         es++;
9753           }
9754 2428984 100       else if (! S_pmflag(aTHX_ S_PAT_MODS, &(pm->op_pmflags), &s, &charset))
9755           {
9756           break;
9757           }
9758           }
9759            
9760           #ifdef PERL_MAD
9761           if (PL_madskills) {
9762           if (modstart != s)
9763           curmad('m', newSVpvn(modstart, s - modstart));
9764           append_madprops(PL_thismad, (OP*)pm, 0);
9765           PL_thismad = 0;
9766           }
9767           #endif
9768 1488011 100       if ((pm->op_pmflags & PMf_CONTINUE)) {
9769 8         Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
9770           }
9771            
9772 1488011 100       if (es) {
9773 175371         SV * const repl = newSVpvs("");
9774            
9775 175371         PL_multi_end = 0;
9776 175371         pm->op_pmflags |= PMf_EVAL;
9777 439680 100       while (es-- > 0) {
9778 178783 100       if (es)
9779 3412         sv_catpvs(repl, "eval ");
9780           else
9781 177077         sv_catpvs(repl, "do ");
9782           }
9783 175371         sv_catpvs(repl, "{");
9784 175371         sv_catsv(repl, PL_sublex_info.repl);
9785 175371         sv_catpvs(repl, "}");
9786 175371         SvEVALED_on(repl);
9787 175371         SvREFCNT_dec(PL_sublex_info.repl);
9788 175371         PL_sublex_info.repl = repl;
9789           }
9790 1488011 100       if (CopLINE(PL_curcop) != first_line) {
9791 28285         sv_upgrade(PL_sublex_info.repl, SVt_PVNV);
9792 56570         ((XPVNV*)SvANY(PL_sublex_info.repl))->xnv_u.xpad_cop_seq.xlow =
9793 28285         CopLINE(PL_curcop) - first_line;
9794 28285         CopLINE_set(PL_curcop, first_line);
9795           }
9796            
9797 1488011         PL_lex_op = (OP*)pm;
9798 1488011         pl_yylval.ival = OP_SUBST;
9799 1488011         return s;
9800           }
9801            
9802           STATIC char *
9803 109274         S_scan_trans(pTHX_ char *start)
9804           {
9805           dVAR;
9806           char* s;
9807           OP *o;
9808           U8 squash;
9809           U8 del;
9810           U8 complement;
9811           bool nondestruct = 0;
9812           #ifdef PERL_MAD
9813           char *modstart;
9814           #endif
9815            
9816           PERL_ARGS_ASSERT_SCAN_TRANS;
9817            
9818 109274         pl_yylval.ival = OP_NULL;
9819            
9820 109274         s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
9821 109274 100       if (!s)
9822 12         Perl_croak(aTHX_ "Transliteration pattern not terminated");
9823            
9824 109262 100       if (s[-1] == PL_multi_open)
9825 98316         s--;
9826           #ifdef PERL_MAD
9827           if (PL_madskills) {
9828           CURMAD('q', PL_thisopen);
9829           CURMAD('_', PL_thiswhite);
9830           CURMAD('E', PL_thisstuff);
9831           CURMAD('Q', PL_thisclose);
9832           PL_realtokenstart = s - SvPVX(PL_linestr);
9833           }
9834           #endif
9835            
9836 109262         s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
9837 109262 100       if (!s) {
9838 12 50       if (PL_lex_stuff) {
9839 12         SvREFCNT_dec(PL_lex_stuff);
9840 12         PL_lex_stuff = NULL;
9841           }
9842 12         Perl_croak(aTHX_ "Transliteration replacement not terminated");
9843           }
9844           if (PL_madskills) {
9845           CURMAD('z', PL_thisopen);
9846           CURMAD('R', PL_thisstuff);
9847           CURMAD('Z', PL_thisclose);
9848           }
9849            
9850           complement = del = squash = 0;
9851           #ifdef PERL_MAD
9852           modstart = s;
9853           #endif
9854           while (1) {
9855 139686         switch (*s) {
9856           case 'c':
9857           complement = OPpTRANS_COMPLEMENT;
9858           break;
9859           case 'd':
9860           del = OPpTRANS_DELETE;
9861 15794         break;
9862           case 's':
9863           squash = OPpTRANS_SQUASH;
9864 6394         break;
9865           case 'r':
9866           nondestruct = 1;
9867 28         break;
9868           default:
9869           goto no_more;
9870           }
9871 30436         s++;
9872 30436         }
9873           no_more:
9874            
9875 109250 100       o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
9876 109250         o->op_private &= ~OPpTRANS_ALL;
9877 372115 100       o->op_private |= del|squash|complement|
    100        
9878 109270 50       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9879 109270 50       (DO_UTF8(PL_sublex_info.repl) ? OPpTRANS_TO_UTF : 0);
9880            
9881 109250         PL_lex_op = o;
9882 109250 100       pl_yylval.ival = nondestruct ? OP_TRANSR : OP_TRANS;
9883            
9884           #ifdef PERL_MAD
9885           if (PL_madskills) {
9886           if (modstart != s)
9887           curmad('m', newSVpvn(modstart, s - modstart));
9888           append_madprops(PL_thismad, o, 0);
9889           PL_thismad = 0;
9890           }
9891           #endif
9892            
9893 109250         return s;
9894           }
9895            
9896           /* scan_heredoc
9897           Takes a pointer to the first < in <
9898           Returns a pointer to the byte following <
9899            
9900           This function scans a heredoc, which involves different methods
9901           depending on whether we are in a string eval, quoted construct, etc.
9902           This is because PL_linestr could containing a single line of input, or
9903           a whole string being evalled, or the contents of the current quote-
9904           like operator.
9905            
9906           The two basic methods are:
9907           - Steal lines from the input stream
9908           - Scan the heredoc in PL_linestr and remove it therefrom
9909            
9910           In a file scope or filtered eval, the first method is used; in a
9911           string eval, the second.
9912            
9913           In a quote-like operator, we have to choose between the two,
9914           depending on where we can find a newline. We peek into outer lex-
9915           ing scopes until we find one with a newline in it. If we reach the
9916           outermost lexing scope and it is a file, we use the stream method.
9917           Otherwise it is treated as an eval.
9918           */
9919            
9920           STATIC char *
9921 356411         S_scan_heredoc(pTHX_ char *s)
9922           {
9923           dVAR;
9924           I32 op_type = OP_SCALAR;
9925           I32 len;
9926           SV *tmpstr;
9927           char term;
9928           char *d;
9929           char *e;
9930           char *peek;
9931 356411 100       const bool infile = PL_rsfp || PL_parser->filtered;
    50        
9932 356411         LEXSHARED *shared = PL_parser->lex_shared;
9933           #ifdef PERL_MAD
9934           I32 stuffstart = s - SvPVX(PL_linestr);
9935           char *tstart;
9936          
9937           PL_realtokenstart = -1;
9938           #endif
9939            
9940           PERL_ARGS_ASSERT_SCAN_HEREDOC;
9941            
9942 356411         s += 2;
9943 356411         d = PL_tokenbuf + 1;
9944 356411         e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9945 356411         *PL_tokenbuf = '\n';
9946           peek = s;
9947 544184 100       while (SPACE_OR_TAB(*peek))
9948 10825         peek++;
9949 356411 100       if (*peek == '`' || *peek == '\'' || *peek =='"') {
    100        
9950           s = peek;
9951 287680         term = *s++;
9952 287680         s = delimcpy(d, e, s, PL_bufend, term, &len);
9953 287680 100       if (s == PL_bufend)
9954 2         Perl_croak(aTHX_ "Unterminated delimiter for here document");
9955 287678         d += len;
9956 287678         s++;
9957           }
9958           else {
9959 68731 100       if (*s == '\\')
9960           /* <<\FOO is equivalent to <<'FOO' */
9961 8         s++, term = '\'';
9962           else
9963           term = '"';
9964 68731 100       if (!isWORDCHAR_lazy_if(s,UTF))
    50        
    50        
    0        
    50        
    100        
    50        
    50        
    0        
    0        
    0        
    100        
9965 34762         deprecate("bare << to mean <<\"\"");
9966 345022 100       for (; isWORDCHAR_lazy_if(s,UTF); s++) {
    50        
    50        
    0        
    50        
    100        
    50        
    0        
    0        
    0        
    100        
9967 310297 50       if (d < e)
9968 310297         *d++ = *s;
9969           }
9970           }
9971 356409 50       if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9972 0         Perl_croak(aTHX_ "Delimiter for here document is too long");
9973 356409         *d++ = '\n';
9974 356409         *d = '\0';
9975 356409         len = d - PL_tokenbuf;
9976            
9977           #ifdef PERL_MAD
9978           if (PL_madskills) {
9979           tstart = PL_tokenbuf + 1;
9980           PL_thisclose = newSVpvn(tstart, len - 1);
9981           tstart = SvPVX(PL_linestr) + stuffstart;
9982           PL_thisopen = newSVpvn(tstart, s - tstart);
9983           stuffstart = s - SvPVX(PL_linestr);
9984           }
9985           #endif
9986           #ifndef PERL_STRICT_CR
9987 356409         d = strchr(s, '\r');
9988 356409 100       if (d) {
9989           char * const olds = s;
9990           s = d;
9991 28 100       while (s < PL_bufend) {
9992 14 50       if (*s == '\r') {
9993 14         *d++ = '\n';
9994 14 50       if (*++s == '\n')
9995 14         s++;
9996           }
9997 0 0       else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
    0        
9998 0         *d++ = *s++;
9999 0         s++;
10000           }
10001           else
10002 7         *d++ = *s++;
10003           }
10004 14         *d = '\0';
10005 14         PL_bufend = d;
10006 14         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10007           s = olds;
10008           }
10009           #endif
10010           #ifdef PERL_MAD
10011           if (PL_madskills) {
10012           tstart = SvPVX(PL_linestr) + stuffstart;
10013           if (PL_thisstuff)
10014           sv_catpvn(PL_thisstuff, tstart, s - tstart);
10015           else
10016           PL_thisstuff = newSVpvn(tstart, s - tstart);
10017           }
10018            
10019           stuffstart = s - SvPVX(PL_linestr);
10020           #endif
10021            
10022 356409         tmpstr = newSV_type(SVt_PVIV);
10023 356409 50       SvGROW(tmpstr, 80);
    50        
10024 356409 100       if (term == '\'') {
10025           op_type = OP_CONST;
10026 222166         SvIV_set(tmpstr, -1);
10027           }
10028 134243 50       else if (term == '`') {
10029           op_type = OP_BACKTICK;
10030 0         SvIV_set(tmpstr, '\\');
10031           }
10032            
10033 356409         PL_multi_start = CopLINE(PL_curcop) + 1;
10034 356409         PL_multi_open = PL_multi_close = '<';
10035           /* inside a string eval or quote-like operator */
10036 356409 100       if (!infile || PL_lex_inwhat) {
    100        
10037           SV *linestr;
10038           char *bufend;
10039           char * const olds = s;
10040 8934         PERL_CONTEXT * const cx = &cxstack[cxstack_ix];
10041           /* These two fields are not set until an inner lexing scope is
10042           entered. But we need them set here. */
10043 8934         shared->ls_bufptr = s;
10044 8934         shared->ls_linestr = PL_linestr;
10045 8934 100       if (PL_lex_inwhat)
10046           /* Look for a newline. If the current buffer does not have one,
10047           peek into the line buffer of the parent lexing scope, going
10048           up as many levels as necessary to find one with a newline
10049           after bufptr.
10050           */
10051 126 100       while (!(s = (char *)memchr(
10052 84         (void *)shared->ls_bufptr, '\n',
10053 84         SvEND(shared->ls_linestr)-shared->ls_bufptr
10054           ))) {
10055 40         shared = shared->ls_prev;
10056           /* shared is only null if we have gone beyond the outermost
10057           lexing scope. In a file, we will have broken out of the
10058           loop in the previous iteration. In an eval, the string buf-
10059           fer ends with "\n;", so the while condition above will have
10060           evaluated to false. So shared can never be null. */
10061           assert(shared);
10062           /* A LEXSHARED struct with a null ls_prev pointer is the outer-
10063           most lexing scope. In a file, shared->ls_linestr at that
10064           level is just one line, so there is no body to steal. */
10065 40 100       if (infile && !shared->ls_prev) {
    100        
10066           s = olds;
10067           goto streaming;
10068           }
10069           }
10070           else { /* eval */
10071 8880         s = (char*)memchr((void*)s, '\n', PL_bufend - s);
10072           assert(s);
10073           }
10074 8924         linestr = shared->ls_linestr;
10075 8924         bufend = SvEND(linestr);
10076           d = s;
10077 6439283 100       while (s < bufend - len + 1 &&
    100        
10078 4289870         memNE(s,PL_tokenbuf,len) ) {
10079 4280962 100       if (*s++ == '\n')
10080 2204377         ++shared->herelines;
10081           }
10082 8924 100       if (s >= bufend - len + 1) {
10083           goto interminable;
10084           }
10085 8908         sv_setpvn(tmpstr,d+1,s-d);
10086           #ifdef PERL_MAD
10087           if (PL_madskills) {
10088           if (PL_thisstuff)
10089           sv_catpvn(PL_thisstuff, d + 1, s - d);
10090           else
10091           PL_thisstuff = newSVpvn(d + 1, s - d);
10092           stuffstart = s - SvPVX(PL_linestr);
10093           }
10094           #endif
10095 8908         s += len - 1;
10096           /* the preceding stmt passes a newline */
10097 8908         shared->herelines++;
10098            
10099           /* s now points to the newline after the heredoc terminator.
10100           d points to the newline before the body of the heredoc.
10101           */
10102            
10103           /* We are going to modify linestr in place here, so set
10104           aside copies of the string if necessary for re-evals or
10105           (caller $n)[6]. */
10106           /* See the Paranoia note in case LEX_INTERPEND in yylex, for why we
10107           check shared->re_eval_str. */
10108 8908 100       if (shared->re_eval_start || shared->re_eval_str) {
    50        
10109           /* Set aside the rest of the regexp */
10110 6 50       if (!shared->re_eval_str)
10111 6         shared->re_eval_str =
10112 6         newSVpvn(shared->re_eval_start,
10113           bufend - shared->re_eval_start);
10114 6         shared->re_eval_start -= s-d;
10115           }
10116 13356 100       if (cxstack_ix >= 0 && CxTYPE(cx) == CXt_EVAL &&
    50        
    50        
10117 13344 100       CxOLD_OP_TYPE(cx) == OP_ENTEREVAL &&
10118 8896         cx->blk_eval.cur_text == linestr)
10119           {
10120 158         cx->blk_eval.cur_text = newSVsv(linestr);
10121 158         SvSCREAM_on(cx->blk_eval.cur_text);
10122           }
10123           /* Copy everything from s onwards back to d. */
10124 8908         Move(s,d,bufend-s + 1,char);
10125 8908         SvCUR_set(linestr, SvCUR(linestr) - (s-d));
10126           /* Setting PL_bufend only applies when we have not dug deeper
10127           into other scopes, because sublex_done sets PL_bufend to
10128           SvEND(PL_linestr). */
10129 8908 100       if (shared == PL_parser->lex_shared) PL_bufend = SvEND(linestr);
10130           s = olds;
10131           }
10132           else
10133           {
10134           SV *linestr_save;
10135           streaming:
10136 347485         sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
10137 347485         term = PL_tokenbuf[1];
10138 347485         len--;
10139 347485         linestr_save = PL_linestr; /* must restore this afterwards */
10140           d = s; /* and this */
10141 347485         PL_linestr = newSVpvs("");
10142 347485         PL_bufend = SvPVX(PL_linestr);
10143           while (1) {
10144           #ifdef PERL_MAD
10145           if (PL_madskills) {
10146           tstart = SvPVX(PL_linestr) + stuffstart;
10147           if (PL_thisstuff)
10148           sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10149           else
10150           PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10151           }
10152           #endif
10153 16607154         PL_bufptr = PL_bufend;
10154 16607154         CopLINE_set(PL_curcop,
10155           PL_multi_start + shared->herelines);
10156 16607154 100       if (!lex_next_chunk(LEX_NO_TERM)
10157 74 100       && (!SvCUR(tmpstr) || SvEND(tmpstr)[-1] != '\n')) {
    100        
10158 70         SvREFCNT_dec(linestr_save);
10159 70         goto interminable;
10160           }
10161 16607084         CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10162 16607084 100       if (!SvCUR(PL_linestr) || PL_bufend[-1] != '\n') {
    100        
10163 72         s = lex_grow_linestr(SvLEN(PL_linestr) + 3);
10164           /* ^That should be enough to avoid this needing to grow: */
10165 72         sv_catpvs(PL_linestr, "\n\0");
10166           assert(s == SvPVX(PL_linestr));
10167 72         PL_bufend = SvEND(PL_linestr);
10168           }
10169 16607084         s = PL_bufptr;
10170           #ifdef PERL_MAD
10171           stuffstart = s - SvPVX(PL_linestr);
10172           #endif
10173 16607084         shared->herelines++;
10174 16607084         PL_last_lop = PL_last_uni = NULL;
10175           #ifndef PERL_STRICT_CR
10176 16607084 100       if (PL_bufend - PL_linestart >= 2) {
10177 24423553 100       if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
    50        
    100        
10178 7999177 50       (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
10179           {
10180 816         PL_bufend[-2] = '\n';
10181 816         PL_bufend--;
10182 816         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
10183           }
10184 16423632 50       else if (PL_bufend[-1] == '\r')
10185 0         PL_bufend[-1] = '\n';
10186           }
10187 182636 50       else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
    50        
10188 0         PL_bufend[-1] = '\n';
10189           #endif
10190 16607084 100       if (*s == term && memEQ(s,PL_tokenbuf + 1,len)) {
    100        
10191 347415         SvREFCNT_dec(PL_linestr);
10192 347415         PL_linestr = linestr_save;
10193 347415         PL_linestart = SvPVX(linestr_save);
10194 347415         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10195           s = d;
10196 347415         break;
10197           }
10198           else {
10199 16259669         sv_catsv(tmpstr,PL_linestr);
10200           }
10201 16259669         }
10202           }
10203 356323         PL_multi_end = CopLINE(PL_curcop);
10204 356323 100       if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
10205 291782         SvPV_shrink_to_cur(tmpstr);
10206           }
10207 356323 100       if (!IN_BYTES) {
10208 355821 50       if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
    50        
    0        
    50        
    100        
    50        
10209 36         SvUTF8_on(tmpstr);
10210 355785 50       else if (PL_encoding)
10211 0         sv_recode_to_utf8(tmpstr, PL_encoding);
10212           }
10213 356323         PL_lex_stuff = tmpstr;
10214 356323         pl_yylval.ival = op_type;
10215 356323         return s;
10216            
10217           interminable:
10218 86         SvREFCNT_dec(tmpstr);
10219 86         CopLINE_set(PL_curcop, (line_t)PL_multi_start - 1);
10220 86         missingterm(PL_tokenbuf + 1);
10221           }
10222            
10223           /* scan_inputsymbol
10224           takes: current position in input buffer
10225           returns: new position in input buffer
10226           side-effects: pl_yylval and lex_op are set.
10227            
10228           This code handles:
10229            
10230           <> read from ARGV
10231           read from filehandle
10232           read from package qualified filehandle
10233           read from package qualified filehandle
10234           <$fh> read from filehandle in $fh
10235           <*.h> filename glob
10236            
10237           */
10238            
10239           STATIC char *
10240 90900         S_scan_inputsymbol(pTHX_ char *start)
10241           {
10242           dVAR;
10243           char *s = start; /* current position in buffer */
10244           char *end;
10245           I32 len;
10246 90900         char *d = PL_tokenbuf; /* start of temp holding space */
10247 90900         const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
10248            
10249           PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
10250            
10251 90900         end = strchr(s, '\n');
10252 90900 100       if (!end)
10253 16         end = PL_bufend;
10254 90900         s = delimcpy(d, e, s + 1, end, '>', &len); /* extract until > */
10255            
10256           /* die if we didn't have space for the contents of the <>,
10257           or if it didn't end, or if we see a newline
10258           */
10259            
10260 90900 50       if (len >= (I32)sizeof PL_tokenbuf)
10261 0         Perl_croak(aTHX_ "Excessively long <> operator");
10262 90900 100       if (s >= end)
10263 4         Perl_croak(aTHX_ "Unterminated <> operator");
10264            
10265           s++;
10266            
10267           /* check for <$fh>
10268           Remember, only scalar variables are interpreted as filehandles by
10269           this code. Anything more complex (e.g., <$fh{$num}>) will be
10270           treated as a glob() call.
10271           This code makes use of the fact that except for the $ at the front,
10272           a scalar variable and a filehandle look the same.
10273           */
10274 90896 100       if (*d == '$' && d[1]) d++;
    50        
10275            
10276           /* allow or */
10277 403640 100       while (*d && (isWORDCHAR_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
    100        
    50        
    50        
    0        
    50        
    100        
    100        
    100        
    50        
    100        
    50        
    50        
    50        
    50        
    50        
    100        
10278 312744 50       d += UTF ? UTF8SKIP(d) : 1;
    50        
    0        
    50        
    100        
10279            
10280           /* If we've tried to read what we allow filehandles to look like, and
10281           there's still text left, then it must be a glob() and not a getline.
10282           Use scan_str to pull out the stuff between the <> and treat it
10283           as nothing more than a string.
10284           */
10285            
10286 90896 100       if (d - PL_tokenbuf != len) {
10287 216         pl_yylval.ival = OP_GLOB;
10288 216         s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
10289 216 50       if (!s)
10290 0         Perl_croak(aTHX_ "Glob not terminated");
10291           return s;
10292           }
10293           else {
10294           bool readline_overriden = FALSE;
10295           GV *gv_readline;
10296           GV **gvp;
10297           /* we're in a filehandle read situation */
10298 90680         d = PL_tokenbuf;
10299            
10300           /* turn <> into */
10301 90680 100       if (!len)
10302 2548         Copy("ARGV",d,5,char);
10303            
10304           /* Check whether readline() is overriden */
10305 90680         gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
10306 90680 100       if ((gv_readline
10307 410 50       && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
    100        
    50        
10308 90674 100       ||
10309 90674         ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
10310 8 50       && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
    100        
    50        
10311 6 50       && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
    50        
    50        
10312           readline_overriden = TRUE;
10313            
10314           /* if <$fh>, create the ops to turn the variable into a
10315           filehandle
10316           */
10317 90680 100       if (*d == '$') {
10318           /* try to find it in the pad for this block, otherwise find
10319           add symbol table ops
10320           */
10321 55724 50       const PADOFFSET tmp = pad_findmy_pvn(d, len, UTF ? SVf_UTF8 : 0);
    50        
    0        
    50        
    100        
10322 55724 100       if (tmp != NOT_IN_PAD) {
10323 55604 100       if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
10324 4 50       HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
10325 4 50       HEK * const stashname = HvNAME_HEK(stash);
    50        
    50        
10326 4         SV * const sym = sv_2mortal(newSVhek(stashname));
10327 4         sv_catpvs(sym, "::");
10328 4         sv_catpv(sym, d+1);
10329 4         d = SvPVX(sym);
10330 4         goto intro_sym;
10331           }
10332           else {
10333 55600         OP * const o = newOP(OP_PADSV, 0);
10334 55600         o->op_targ = tmp;
10335 82320         PL_lex_op = readline_overriden
10336 4         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10337           op_append_elem(OP_LIST, o,
10338           newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
10339 55604 100       : (OP*)newUNOP(OP_READLINE, 0, o);
10340           }
10341           }
10342           else {
10343           GV *gv;
10344 120         ++d;
10345           intro_sym:
10346 124 100       gv = gv_fetchpv(d,
    50        
    50        
    0        
    50        
    50        
10347           (PL_in_eval
10348           ? (GV_ADDMULTI | GV_ADDINEVAL)
10349           : GV_ADDMULTI) | ( UTF ? SVf_UTF8 : 0 ),
10350           SVt_PV);
10351 186         PL_lex_op = readline_overriden
10352 4         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10353           op_append_elem(OP_LIST,
10354           newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
10355           newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10356 128 100       : (OP*)newUNOP(OP_READLINE, 0,
10357           newUNOP(OP_RV2SV, 0,
10358           newGVOP(OP_GV, 0, gv)));
10359           }
10360 55724 100       if (!readline_overriden)
10361 55716         PL_lex_op->op_flags |= OPf_SPECIAL;
10362           /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
10363 55724         pl_yylval.ival = OP_NULL;
10364           }
10365            
10366           /* If it's none of the above, it must be a literal filehandle
10367           ( or ) so build a simple readline OP */
10368           else {
10369 34956 50       GV * const gv = gv_fetchpv(d, GV_ADD | ( UTF ? SVf_UTF8 : 0 ), SVt_PVIO);
    50        
    0        
    50        
    100        
10370 69912         PL_lex_op = readline_overriden
10371 4         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
10372           op_append_elem(OP_LIST,
10373           newGVOP(OP_GV, 0, gv),
10374           newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
10375 34960 100       : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
10376 34956         pl_yylval.ival = OP_NULL;
10377           }
10378           }
10379            
10380 90788         return s;
10381           }
10382            
10383            
10384           /* scan_str
10385           takes:
10386           start position in buffer
10387           keep_quoted preserve \ on the embedded delimiter(s)
10388           keep_delims preserve the delimiters around the string
10389           re_reparse compiling a run-time /(?{})/:
10390           collapse // to /, and skip encoding src
10391           deprecate_escaped_meta issue a deprecation warning for cer-
10392           tain paired metacharacters that appear
10393           escaped within it
10394           returns: position to continue reading from buffer
10395           side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
10396           updates the read buffer.
10397            
10398           This subroutine pulls a string out of the input. It is called for:
10399           q single quotes q(literal text)
10400           ' single quotes 'literal text'
10401           qq double quotes qq(interpolate $here please)
10402           " double quotes "interpolate $here please"
10403           qx backticks qx(/bin/ls -l)
10404           ` backticks `/bin/ls -l`
10405           qw quote words @EXPORT_OK = qw( func() $spam )
10406           m// regexp match m/this/
10407           s/// regexp substitute s/this/that/
10408           tr/// string transliterate tr/this/that/
10409           y/// string transliterate y/this/that/
10410           ($*@) sub prototypes sub foo ($)
10411           (stuff) sub attr parameters sub foo : attr(stuff)
10412           <> readline or globs , <>, <$fh>, or <*.c>
10413          
10414           In most of these cases (all but <>, patterns and transliterate)
10415           yylex() calls scan_str(). m// makes yylex() call scan_pat() which
10416           calls scan_str(). s/// makes yylex() call scan_subst() which calls
10417           scan_str(). tr/// and y/// make yylex() call scan_trans() which
10418           calls scan_str().
10419            
10420           It skips whitespace before the string starts, and treats the first
10421           character as the delimiter. If the delimiter is one of ([{< then
10422           the corresponding "close" character )]}> is used as the closing
10423           delimiter. It allows quoting of delimiters, and if the string has
10424           balanced delimiters ([{<>}]) it allows nesting.
10425            
10426           On success, the SV with the resulting string is put into lex_stuff or,
10427           if that is already non-NULL, into lex_repl. The second case occurs only
10428           when parsing the RHS of the special constructs s/// and tr/// (y///).
10429           For convenience, the terminating delimiter character is stuffed into
10430           SvIVX of the SV.
10431           */
10432            
10433           STATIC char *
10434 56070300         S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
10435           bool deprecate_escaped_meta
10436           )
10437           {
10438           dVAR;
10439           SV *sv; /* scalar value: string */
10440           const char *tmps; /* temp string, used for delimiter matching */
10441           char *s = start; /* current position in the buffer */
10442           char term; /* terminating character */
10443           char *to; /* current position in the sv's data */
10444           I32 brackets = 1; /* bracket nesting level */
10445           bool has_utf8 = FALSE; /* is there any utf8 content? */
10446           I32 termcode; /* terminating char. code */
10447           U8 termstr[UTF8_MAXBYTES]; /* terminating string */
10448           STRLEN termlen; /* length of terminating string */
10449           int last_off = 0; /* last position for nesting bracket */
10450           char *escaped_open = NULL;
10451           line_t herelines;
10452           #ifdef PERL_MAD
10453           int stuffstart;
10454           char *tstart;
10455           #endif
10456            
10457           PERL_ARGS_ASSERT_SCAN_STR;
10458            
10459           /* skip space before the delimiter */
10460 56070300 100       if (isSPACE(*s)) {
10461 79437         s = PEEKSPACE(s);
10462           }
10463            
10464           #ifdef PERL_MAD
10465           if (PL_realtokenstart >= 0) {
10466           stuffstart = PL_realtokenstart;
10467           PL_realtokenstart = -1;
10468           }
10469           else
10470           stuffstart = start - SvPVX(PL_linestr);
10471           #endif
10472           /* mark where we are, in case we need to report errors */
10473 56070300         CLINE;
10474            
10475           /* after skipping whitespace, the next character is the terminator */
10476 56070300         term = *s;
10477 56070300 50       if (!UTF) {
    100        
    50        
    100        
    100        
10478 54956378         termcode = termstr[0] = term;
10479 54956378         termlen = 1;
10480           }
10481           else {
10482 1113922 100       termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
10483 1113922         Copy(s, termstr, termlen, U8);
10484 1113922 100       if (!UTF8_IS_INVARIANT(term))
10485           has_utf8 = TRUE;
10486           }
10487            
10488           /* mark where we are */
10489 56070300         PL_multi_start = CopLINE(PL_curcop);
10490 56070300         PL_multi_open = term;
10491 56070300         herelines = PL_parser->lex_shared->herelines;
10492            
10493           /* find corresponding closing delimiter */
10494 56070300 100       if (term && (tmps = strchr("([{< )]}> )]}>",term)))
    100        
10495 3744237         termcode = termstr[0] = term = tmps[5];
10496            
10497 56070300         PL_multi_close = term;
10498            
10499           /* A warning is raised if the input parameter requires it for escaped (by a
10500           * backslash) paired metacharacters {} [] and () when the delimiters are
10501           * those same characters, and the backslash is ineffective. This doesn't
10502           * happen for <>, as they aren't metas. */
10503 56070300 100       if (deprecate_escaped_meta
10504 4736851 100       && (PL_multi_open == PL_multi_close
10505 484315 100       || PL_multi_open == '<'
10506 476707 100       || ! ckWARN_d(WARN_DEPRECATED)))
10507           {
10508           deprecate_escaped_meta = FALSE;
10509           }
10510            
10511           /* create a new SV to hold the contents. 79 is the SV's initial length.
10512           What a random number. */
10513 56070300         sv = newSV_type(SVt_PVIV);
10514 56070300 50       SvGROW(sv, 80);
    50        
10515 56070300         SvIV_set(sv, termcode);
10516 56070300         (void)SvPOK_only(sv); /* validate pointer */
10517            
10518           /* move past delimiter and try to read a complete string */
10519 56070300 100       if (keep_delims)
10520 146         sv_catpvn(sv, s, termlen);
10521 56070300         s += termlen;
10522           #ifdef PERL_MAD
10523           tstart = SvPVX(PL_linestr) + stuffstart;
10524           if (PL_madskills && !PL_thisopen && !keep_delims) {
10525           PL_thisopen = newSVpvn(tstart, s - tstart);
10526           stuffstart = s - SvPVX(PL_linestr);
10527           }
10528           #endif
10529           for (;;) {
10530 59872816 100       if (PL_encoding && !UTF && !re_reparse) {
    50        
    100        
    50        
    50        
    100        
    50        
10531           bool cont = TRUE;
10532            
10533 3320 100       while (cont) {
10534 1692         int offset = s - SvPVX_const(PL_linestr);
10535 1692         const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
10536           &offset, (char*)termstr, termlen);
10537           const char *ns;
10538           char *svlast;
10539            
10540 1692 100       if (SvIsCOW(PL_linestr)) {
10541           STRLEN bufend_pos, bufptr_pos, oldbufptr_pos;
10542           STRLEN oldoldbufptr_pos, linestart_pos, last_uni_pos;
10543           STRLEN last_lop_pos, re_eval_start_pos, s_pos;
10544 44         char *buf = SvPVX(PL_linestr);
10545 44         bufend_pos = PL_parser->bufend - buf;
10546 44         bufptr_pos = PL_parser->bufptr - buf;
10547 44         oldbufptr_pos = PL_parser->oldbufptr - buf;
10548 44         oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
10549 44         linestart_pos = PL_parser->linestart - buf;
10550 50 100       last_uni_pos = PL_parser->last_uni
10551 12         ? PL_parser->last_uni - buf
10552           : 0;
10553 50 100       last_lop_pos = PL_parser->last_lop
10554 12         ? PL_parser->last_lop - buf
10555           : 0;
10556 44 50       re_eval_start_pos =
10557 44         PL_parser->lex_shared->re_eval_start ?
10558 0         PL_parser->lex_shared->re_eval_start - buf : 0;
10559 44         s_pos = s - buf;
10560            
10561 44         sv_force_normal(PL_linestr);
10562            
10563 44         buf = SvPVX(PL_linestr);
10564 44         PL_parser->bufend = buf + bufend_pos;
10565 44         PL_parser->bufptr = buf + bufptr_pos;
10566 44         PL_parser->oldbufptr = buf + oldbufptr_pos;
10567 44         PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
10568 44         PL_parser->linestart = buf + linestart_pos;
10569 44 100       if (PL_parser->last_uni)
10570 12         PL_parser->last_uni = buf + last_uni_pos;
10571 44 100       if (PL_parser->last_lop)
10572 12         PL_parser->last_lop = buf + last_lop_pos;
10573 44 50       if (PL_parser->lex_shared->re_eval_start)
10574 0         PL_parser->lex_shared->re_eval_start =
10575 0         buf + re_eval_start_pos;
10576 44         s = buf + s_pos;
10577           }
10578 1692         ns = SvPVX_const(PL_linestr) + offset;
10579 1692         svlast = SvEND(sv) - 1;
10580            
10581 20360 100       for (; s < ns; s++) {
10582 18668 100       if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
    50        
    50        
10583 10 50       COPLINE_INC_WITH_HERELINES;
10584           }
10585 1692 50       if (!found)
10586           goto read_more_line;
10587           else {
10588           /* handle quoted delimiters */
10589 1692 100       if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
    100        
10590           const char *t;
10591 96 50       for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
    50        
10592 0         t--;
10593 64 50       if ((svlast-1 - t) % 2) {
10594 64 50       if (!keep_quoted) {
10595 64         *(svlast-1) = term;
10596 64         *svlast = '\0';
10597 64         SvCUR_set(sv, SvCUR(sv) - 1);
10598           }
10599 64         continue;
10600           }
10601           }
10602 1628 100       if (PL_multi_open == PL_multi_close) {
10603           cont = FALSE;
10604           }
10605           else {
10606           const char *t;
10607           char *w;
10608 1190 100       for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
10609           /* At here, all closes are "was quoted" one,
10610           so we don't check PL_multi_close. */
10611 1144 100       if (*t == '\\') {
10612 22 50       if (!keep_quoted && *(t+1) == PL_multi_open)
    50        
10613 0         t++;
10614           else
10615 22         *w++ = *t++;
10616           }
10617 1122 50       else if (*t == PL_multi_open)
10618 0         brackets++;
10619            
10620 1144         *w = *t;
10621           }
10622 46 50       if (w < t) {
10623 0         *w++ = term;
10624 0         *w = '\0';
10625 0         SvCUR_set(sv, w - SvPVX_const(sv));
10626           }
10627 46         last_off = w - SvPVX(sv);
10628 869 50       if (--brackets <= 0)
10629           cont = FALSE;
10630           }
10631           }
10632           }
10633 1628 50       if (!keep_delims) {
10634 1628         SvCUR_set(sv, SvCUR(sv) - 1);
10635 1628         *SvEND(sv) = '\0';
10636           }
10637           break;
10638           }
10639            
10640           /* extend sv if need be */
10641 59871188 50       SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
    100        
10642           /* set 'to' to the next character in the sv's string */
10643 59871188         to = SvPVX(sv)+SvCUR(sv);
10644            
10645           /* if open delimiter is the close delimiter read unbridle */
10646 59871188 100       if (PL_multi_open == PL_multi_close) {
10647 642311262 100       for (; s < PL_bufend; s++,to++) {
10648           /* embedded newlines increment the current line number */
10649 667095485 100       if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
    100        
    50        
10650 14870 100       COPLINE_INC_WITH_HERELINES;
10651           /* handle quoted delimiters */
10652 667095485 100       if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
    100        
10653 44756080 50       if (!keep_quoted
10654 44756080 100       && (s[1] == term
10655 44265292 50       || (re_reparse && s[1] == '\\'))
    0        
10656           )
10657 490788         s++;
10658           /* any other quotes are simply copied straight through */
10659           else
10660 44265292         *to++ = *s++;
10661           }
10662           /* terminate when run out of buffer (the for() condition), or
10663           have found the terminator */
10664 622339405 100       else if (*s == term) {
10665 52324391 100       if (termlen == 1)
10666           break;
10667 6 50       if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
    50        
10668           break;
10669           }
10670 570015014 100       else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
    100        
    50        
    100        
    50        
    100        
    100        
10671           has_utf8 = TRUE;
10672 614771094         *to = *s;
10673           }
10674           }
10675          
10676           /* if the terminator isn't the same as the start character (e.g.,
10677           matched brackets), we have to allow more in the quoting, and
10678           be prepared for nested brackets.
10679           */
10680           else {
10681           /* read until we run out of string, or we find the terminator */
10682 119777949 100       for (; s < PL_bufend; s++,to++) {
10683           /* embedded newlines increment the line count */
10684 120161325 100       if (*s == '\n' && !PL_rsfp && !PL_parser->filtered)
    100        
    50        
10685 5024 50       COPLINE_INC_WITH_HERELINES;
10686           /* backslashes can escape the open or closing characters */
10687 120161325 100       if (*s == '\\' && s+1 < PL_bufend) {
    50        
10688 1414760 50       if (!keep_quoted &&
    100        
10689 1413216 100       ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10690           {
10691 2064         s++;
10692            
10693           /* Here, 'deprecate_escaped_meta' is true iff the
10694           * delimiters are paired metacharacters, and 's' points
10695           * to an occurrence of one of them within the string,
10696           * which was preceded by a backslash. If this is a
10697           * context where the delimiter is also a metacharacter,
10698           * the backslash is useless, and deprecated. () and []
10699           * are meta in any context. {} are meta only when
10700           * appearing in a quantifier or in things like '\p{'
10701           * (but '\\p{' isn't meta). They also aren't meta
10702           * unless there is a matching closed, escaped char
10703           * later on within the string. If 's' points to an
10704           * open, set a flag; if to a close, test that flag, and
10705           * raise a warning if it was set */
10706            
10707 2064 100       if (deprecate_escaped_meta) {
10708 1944 100       if (*s == PL_multi_open) {
10709 1528 100       if (*s != '{') {
10710           escaped_open = s;
10711           }
10712           /* Look for a closing '\}' */
10713 1524 100       else if (regcurly(s, TRUE)) {
10714           escaped_open = s;
10715           }
10716           /* Look for e.g. '\x{' */
10717 1520 100       else if (s - start > 2
10718 196 100       && _generic_isCC(*(s-2),
10719           _CC_BACKSLASH_FOO_LBRACE_IS_META))
10720           { /* Exclude '\\x', '\\\\x', etc. */
10721 8         char *lookbehind = s - 4;
10722           bool is_meta = TRUE;
10723 32 50       while (lookbehind >= start
10724 28 100       && *lookbehind == '\\')
10725           {
10726 20         is_meta = ! is_meta;
10727 20         lookbehind--;
10728           }
10729 8 100       if (is_meta) {
10730           escaped_open = s;
10731           }
10732           }
10733           }
10734 416 100       else if (escaped_open) {
10735 12         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
10736 12         "Useless use of '\\'; doesn't escape metacharacter '%c'", PL_multi_open);
10737           escaped_open = NULL;
10738           }
10739           }
10740           }
10741           else
10742 951188         *to++ = *s++;
10743           }
10744           /* allow nested opens and closes */
10745 119208073 100       else if (*s == PL_multi_close && --brackets <= 0)
    100        
10746           break;
10747 115463886 100       else if (*s == PL_multi_open)
10748 228397         brackets++;
10749 115235489 100       else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
    100        
    50        
    100        
    50        
    50        
    100        
10750           has_utf8 = TRUE;
10751 116417138         *to = *s;
10752           }
10753           }
10754           /* terminate the copied string and update the sv's end-of-string */
10755 59871188         *to = '\0';
10756 59871188         SvCUR_set(sv, to - SvPVX_const(sv));
10757            
10758           /*
10759           * this next chunk reads more into the buffer if we're not done yet
10760           */
10761            
10762 59871188 100       if (s < PL_bufend)
10763           break; /* handle case where we are done yet :-) */
10764            
10765           #ifndef PERL_STRICT_CR
10766 3802610 100       if (to - SvPVX_const(sv) >= 2) {
10767 5237457 100       if ((to[-2] == '\r' && to[-1] == '\n') ||
    50        
    100        
10768 1879073 50       (to[-2] == '\n' && to[-1] == '\r'))
10769           {
10770 84         to[-2] = '\n';
10771 84         to--;
10772 84         SvCUR_set(sv, to - SvPVX_const(sv));
10773           }
10774 3533780 50       else if (to[-1] == '\r')
10775 0         to[-1] = '\n';
10776           }
10777 268746 100       else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
    50        
10778 0         to[-1] = '\n';
10779           #endif
10780          
10781           read_more_line:
10782           /* if we're out of file, or a read fails, bail and reset the current
10783           line marker so we can report where the unterminated string began
10784           */
10785           #ifdef PERL_MAD
10786           if (PL_madskills) {
10787           char * const tstart = SvPVX(PL_linestr) + stuffstart;
10788           if (PL_thisstuff)
10789           sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
10790           else
10791           PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
10792           }
10793           #endif
10794 3802610 50       COPLINE_INC_WITH_HERELINES;
10795 3802610         PL_bufptr = PL_bufend;
10796 3802610 100       if (!lex_next_chunk(0)) {
10797 94         sv_free(sv);
10798 94         CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10799 94         return NULL;
10800           }
10801 3802516         s = PL_bufptr;
10802           #ifdef PERL_MAD
10803           stuffstart = 0;
10804           #endif
10805 3802516         }
10806            
10807           /* at this point, we have successfully read the delimited string */
10808            
10809 56070206 100       if (!PL_encoding || UTF || re_reparse) {
    50        
    100        
    50        
    50        
    100        
    50        
10810           #ifdef PERL_MAD
10811           if (PL_madskills) {
10812           char * const tstart = SvPVX(PL_linestr) + stuffstart;
10813           const int len = s - tstart;
10814           if (PL_thisstuff)
10815           sv_catpvn(PL_thisstuff, tstart, len);
10816           else
10817           PL_thisstuff = newSVpvn(tstart, len);
10818           if (!PL_thisclose && !keep_delims)
10819           PL_thisclose = newSVpvn(s,termlen);
10820           }
10821           #endif
10822            
10823 56068578 100       if (keep_delims)
10824 146         sv_catpvn(sv, s, termlen);
10825 56068578         s += termlen;
10826           }
10827           #ifdef PERL_MAD
10828           else {
10829           if (PL_madskills) {
10830           char * const tstart = SvPVX(PL_linestr) + stuffstart;
10831           const int len = s - tstart - termlen;
10832           if (PL_thisstuff)
10833           sv_catpvn(PL_thisstuff, tstart, len);
10834           else
10835           PL_thisstuff = newSVpvn(tstart, len);
10836           if (!PL_thisclose && !keep_delims)
10837           PL_thisclose = newSVpvn(s - termlen,termlen);
10838           }
10839           }
10840           #endif
10841 56070206 100       if (has_utf8 || (PL_encoding && !re_reparse))
    100        
10842 61958         SvUTF8_on(sv);
10843            
10844 56070206         PL_multi_end = CopLINE(PL_curcop);
10845 56070206         CopLINE_set(PL_curcop, PL_multi_start);
10846 56070206         PL_parser->lex_shared->herelines = herelines;
10847            
10848           /* if we allocated too much space, give some back */
10849 56070206 100       if (SvCUR(sv) + 5 < SvLEN(sv)) {
10850 56035358         SvLEN_set(sv, SvCUR(sv) + 1);
10851 56035358         SvPV_renew(sv, SvLEN(sv));
10852           }
10853            
10854           /* decide whether this is the first or second quoted string we've read
10855           for this op
10856           */
10857            
10858 56070206 100       if (PL_lex_stuff)
10859 1597273         PL_sublex_info.repl = sv;
10860           else
10861 55300049         PL_lex_stuff = sv;
10862           return s;
10863           }
10864            
10865           /*
10866           scan_num
10867           takes: pointer to position in buffer
10868           returns: pointer to new position in buffer
10869           side-effects: builds ops for the constant in pl_yylval.op
10870            
10871           Read a number in any of the formats that Perl accepts:
10872            
10873           \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12.
10874           \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34
10875           0b[01](_?[01])*
10876           0[0-7](_?[0-7])*
10877           0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10878            
10879           Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10880           thing it reads.
10881            
10882           If it reads a number without a decimal point or an exponent, it will
10883           try converting the number to an integer and see if it can do so
10884           without loss of precision.
10885           */
10886            
10887           char *
10888 24714567         Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10889           {
10890           dVAR;
10891           const char *s = start; /* current position in buffer */
10892           char *d; /* destination in temp buffer */
10893           char *e; /* end of temp buffer */
10894           NV nv; /* number read, as a double */
10895           SV *sv = NULL; /* place to put the converted number */
10896           bool floatit; /* boolean: int or float? */
10897           const char *lastub = NULL; /* position of last underbar */
10898           static const char* const number_too_long = "Number too long";
10899            
10900           PERL_ARGS_ASSERT_SCAN_NUM;
10901            
10902           /* We use the first character to decide what type of number this is */
10903            
10904 24714567         switch (*s) {
10905           default:
10906 0         Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
10907            
10908           /* if it starts with a 0, it could be an octal number, a decimal in
10909           0.13 disguise, or a hexadecimal number, or a binary number. */
10910           case '0':
10911           {
10912           /* variables:
10913           u holds the "number so far"
10914           shift the power of 2 of the base
10915           (hex == 4, octal == 3, binary == 1)
10916           overflowed was the number more than we can hold?
10917            
10918           Shift is used when we add a digit. It also serves as an "are
10919           we in octal/hex/binary?" indicator to disallow hex characters
10920           when in octal mode.
10921           */
10922           NV n = 0.0;
10923           UV u = 0;
10924           I32 shift;
10925           bool overflowed = FALSE;
10926           bool just_zero = TRUE; /* just plain 0 or binary number? */
10927           static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10928           static const char* const bases[5] =
10929           { "", "binary", "", "octal", "hexadecimal" };
10930           static const char* const Bases[5] =
10931           { "", "Binary", "", "Octal", "Hexadecimal" };
10932           static const char* const maxima[5] =
10933           { "",
10934           "0b11111111111111111111111111111111",
10935           "",
10936           "037777777777",
10937           "0xffffffff" };
10938           const char *base, *Base, *max;
10939            
10940           /* check for hex */
10941 7760654 100       if (s[1] == 'x' || s[1] == 'X') {
10942           shift = 4;
10943 655383         s += 2;
10944           just_zero = FALSE;
10945 7105271 100       } else if (s[1] == 'b' || s[1] == 'B') {
10946           shift = 1;
10947 74         s += 2;
10948           just_zero = FALSE;
10949           }
10950           /* check for a decimal in disguise */
10951 7105197 100       else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
    50        
10952           goto decimal;
10953           /* so it must be octal */
10954           else {
10955           shift = 3;
10956 7034995         s++;
10957           }
10958            
10959 7690452 100       if (*s == '_') {
10960 12         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10961           "Misplaced _ in number");
10962 12         lastub = s++;
10963           }
10964            
10965 7690452         base = bases[shift];
10966 7690452         Base = Bases[shift];
10967 9609127         max = maxima[shift];
10968            
10969           /* read the rest of the number */
10970           for (;;) {
10971           /* x is used in the overflow test,
10972           b is the digit we're adding on. */
10973           UV x, b;
10974            
10975 11441764         switch (*s) {
10976            
10977           /* if we don't mention it, we're done */
10978           default:
10979           goto out;
10980            
10981           /* _ are ignored -- but warned about if consecutive */
10982           case '_':
10983 68 100       if (lastub && s == lastub + 1)
    50        
10984 0         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
10985           "Misplaced _ in number");
10986 68         lastub = s++;
10987 68         break;
10988            
10989           /* 8 and 9 are not octal */
10990           case '8': case '9':
10991 130346 50       if (shift == 3)
10992 0         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10993           /* FALL THROUGH */
10994            
10995           /* octal digits */
10996           case '2': case '3': case '4':
10997           case '5': case '6': case '7':
10998 825032 100       if (shift == 1)
10999 2         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11000           /* FALL THROUGH */
11001            
11002           case '0': case '1':
11003 3439904         b = *s++ & 15; /* ASCII digit -> value of digit */
11004 3439904         goto digit;
11005            
11006           /* hex digits */
11007           case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11008           case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11009           /* make sure they said 0x */
11010 311340 50       if (shift != 4)
11011           goto out;
11012 311340         b = (*s++ & 7) + 9;
11013            
11014           /* Prepare to put the digit we have onto the end
11015           of the number so far. We check for overflows.
11016           */
11017            
11018           digit:
11019           just_zero = FALSE;
11020 3751244 50       if (!overflowed) {
11021 3751244         x = u << shift; /* make room for the digit */
11022            
11023 3751244 100       if ((x >> shift) != u
11024 38 100       && !(PL_hints & HINT_NEW_BINARY)) {
11025           overflowed = TRUE;
11026 12         n = (NV) u;
11027 12         Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11028           "Integer overflow in %s number",
11029           base);
11030           } else
11031 3751232         u = x | b; /* add the digit to the end */
11032           }
11033 3751244 100       if (overflowed) {
11034 12         n *= nvshift[shift];
11035           /* If an NV has not enough bits in its
11036           * mantissa to represent an UV this summing of
11037           * small low-order numbers is a waste of time
11038           * (because the NV cannot preserve the
11039           * low-order bits anyway): we could just
11040           * remember when did we overflow and in the
11041           * end just multiply n by the right
11042           * amount. */
11043 12         n += (NV) b;
11044           }
11045           break;
11046           }
11047           }
11048            
11049           /* if we get here, we had success: make a scalar value from
11050           the number.
11051           */
11052           out:
11053            
11054           /* final misplaced underbar check */
11055 7690450 100       if (s[-1] == '_') {
11056 4         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11057           }
11058            
11059 7690450 100       if (overflowed) {
11060 12 50       if (n > 4294967295.0)
11061 12         Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11062           "%s number > %s non-portable",
11063           Base, max);
11064 12         sv = newSVnv(n);
11065           }
11066           else {
11067           #if UVSIZE > 4
11068 7690438 100       if (u > 0xffffffff)
11069 112         Perl_ck_warner(aTHX_ packWARN(WARN_PORTABLE),
11070           "%s number > %s non-portable",
11071           Base, max);
11072           #endif
11073 7690438         sv = newSVuv(u);
11074           }
11075 7690450 100       if (just_zero && (PL_hints & HINT_NEW_INTEGER))
    100        
11076 6         sv = new_constant(start, s - start, "integer",
11077           sv, NULL, NULL, 0);
11078 7690444 100       else if (PL_hints & HINT_NEW_BINARY)
11079 50         sv = new_constant(start, s - start, "binary", sv, NULL, NULL, 0);
11080           }
11081           break;
11082            
11083           /*
11084           handle decimal numbers.
11085           we're also sent here when we read a 0 as the first digit
11086           */
11087           case '1': case '2': case '3': case '4': case '5':
11088           case '6': case '7': case '8': case '9': case '.':
11089           decimal:
11090 17017513         d = PL_tokenbuf;
11091 17017513         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
11092           floatit = FALSE;
11093            
11094           /* read next group of digits and _ and copy into d */
11095 48906545 100       while (isDIGIT(*s) || *s == '_') {
    100        
11096           /* skip underscores, checking for misplaced ones
11097           if -w is on
11098           */
11099 23729992 100       if (*s == '_') {
11100 3562 100       if (lastub && s == lastub + 1)
    100        
11101 4         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11102           "Misplaced _ in number");
11103 3562         lastub = s++;
11104           }
11105           else {
11106           /* check for end of fixed-length buffer */
11107 23726430 50       if (d >= e)
11108 0         Perl_croak(aTHX_ "%s", number_too_long);
11109           /* if we're ok, copy the character */
11110 23728211         *d++ = *s++;
11111           }
11112           }
11113            
11114           /* final misplaced underbar check */
11115 17017513 100       if (lastub && s == lastub + 1) {
    100        
11116 20         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
11117           }
11118            
11119           /* read a decimal portion if there is one. avoid
11120           3..5 being interpreted as the number 3. followed
11121           by .5
11122           */
11123 17017513 100       if (*s == '.' && s[1] != '.') {
    100        
11124           floatit = TRUE;
11125 819011         *d++ = *s++;
11126            
11127 819011 100       if (*s == '_') {
11128 420673         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11129           "Misplaced _ in number");
11130           lastub = s;
11131           }
11132            
11133           /* copy, ignoring underbars, until we run out of digits.
11134           */
11135 3358062 100       for (; isDIGIT(*s) || *s == '_'; s++) {
    100        
11136           /* fixed length buffer check */
11137 2937397 50       if (d >= e)
11138 0         Perl_croak(aTHX_ "%s", number_too_long);
11139 2937397 100       if (*s == '_') {
11140 20798 100       if (lastub && s == lastub + 1)
    100        
11141 10581         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11142           "Misplaced _ in number");
11143           lastub = s;
11144           }
11145           else
11146 2916599         *d++ = *s;
11147           }
11148           /* fractional part ending in underbar? */
11149 819011 100       if (s[-1] == '_') {
11150 20         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11151           "Misplaced _ in number");
11152           }
11153 819011 100       if (*s == '.' && isDIGIT(s[1])) {
    50        
11154           /* oops, it's really a v-string, but without the "v" */
11155           s = start;
11156           goto vstring;
11157           }
11158           }
11159            
11160           /* read exponent part, if present */
11161 16996019 100       if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
    50        
11162           floatit = TRUE;
11163 11548         s++;
11164            
11165           /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
11166 11548         *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
11167            
11168           /* stray preinitial _ */
11169 11548 100       if (*s == '_') {
11170 12         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11171           "Misplaced _ in number");
11172 12         lastub = s++;
11173           }
11174            
11175           /* allow positive or negative exponent */
11176 11548 100       if (*s == '+' || *s == '-')
11177 1392         *d++ = *s++;
11178            
11179           /* stray initial _ */
11180 11548 100       if (*s == '_') {
11181 8         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11182           "Misplaced _ in number");
11183 5778         lastub = s++;
11184           }
11185            
11186           /* read digits of exponent */
11187 24706 100       while (isDIGIT(*s) || *s == '_') {
    100        
11188 13158 100       if (isDIGIT(*s)) {
11189 13126 50       if (d >= e)
11190 0         Perl_croak(aTHX_ "%s", number_too_long);
11191 13126         *d++ = *s++;
11192           }
11193           else {
11194 46 100       if (((lastub && s == lastub + 1) ||
    50        
    100        
11195 30 100       (!isDIGIT(s[1]) && s[1] != '_')))
11196 16         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
11197           "Misplaced _ in number");
11198 6595         lastub = s++;
11199           }
11200           }
11201           }
11202            
11203            
11204           /*
11205           We try to do an integer conversion first if no characters
11206           indicating "float" have been found.
11207           */
11208            
11209 16996019 100       if (!floatit) {
11210           UV uv;
11211 16187102         const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
11212            
11213 16187102 100       if (flags == IS_NUMBER_IN_UV) {
11214 16181754 100       if (uv <= IV_MAX)
11215 16176264         sv = newSViv(uv); /* Prefer IVs over UVs. */
11216           else
11217 5490         sv = newSVuv(uv);
11218 5348 50       } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
11219 0 0       if (uv <= (UV) IV_MIN)
11220 0         sv = newSViv(-(IV)uv);
11221           else
11222           floatit = TRUE;
11223           } else
11224           floatit = TRUE;
11225           }
11226 16996019 100       if (floatit) {
11227           /* terminate the string */
11228 814265         *d = '\0';
11229 814265         nv = Atof(PL_tokenbuf);
11230 814265         sv = newSVnv(nv);
11231           }
11232            
11233 25144672 100       if ( floatit
    100        
11234 16996019         ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) {
11235 496 100       const char *const key = floatit ? "float" : "integer";
11236 496 100       const STRLEN keylen = floatit ? 5 : 7;
11237 496         sv = S_new_constant(aTHX_ PL_tokenbuf, d - PL_tokenbuf,
11238           key, keylen, sv, NULL, NULL, 0);
11239           }
11240           break;
11241            
11242           /* if it starts with a v, it could be a v-string */
11243           case 'v':
11244           vstring:
11245 28096         sv = newSV(5); /* preallocate storage space */
11246 28096         ENTER_with_name("scan_vstring");
11247 28096         SAVEFREESV(sv);
11248 28096         s = scan_vstring(s, PL_bufend, sv);
11249 28092         SvREFCNT_inc_simple_void_NN(sv);
11250 28092         LEAVE_with_name("scan_vstring");
11251 28092         break;
11252           }
11253            
11254           /* make the op for the constant and return */
11255            
11256 24714549 50       if (sv)
11257 24714549         lvalp->opval = newSVOP(OP_CONST, 0, sv);
11258           else
11259 0         lvalp->opval = NULL;
11260            
11261 24714549         return (char *)s;
11262           }
11263            
11264           STATIC char *
11265 666         S_scan_formline(pTHX_ char *s)
11266           {
11267           dVAR;
11268           char *eol;
11269           char *t;
11270 666         SV * const stuff = newSVpvs("");
11271           bool needargs = FALSE;
11272           bool eofmt = FALSE;
11273           #ifdef PERL_MAD
11274           char *tokenstart = s;
11275           SV* savewhite = NULL;
11276            
11277           if (PL_madskills) {
11278           savewhite = PL_thiswhite;
11279           PL_thiswhite = 0;
11280           }
11281           #endif
11282            
11283           PERL_ARGS_ASSERT_SCAN_FORMLINE;
11284            
11285 1419 100       while (!needargs) {
11286 770 100       if (*s == '.') {
11287 330         t = s+1;
11288           #ifdef PERL_STRICT_CR
11289           while (SPACE_OR_TAB(*t))
11290           t++;
11291           #else
11292 495 50       while (SPACE_OR_TAB(*t) || *t == '\r')
    50        
11293 0         t++;
11294           #endif
11295 330 100       if (*t == '\n' || t == PL_bufend) {
    50        
11296           eofmt = TRUE;
11297           break;
11298           }
11299           }
11300 440         eol = (char *) memchr(s,'\n',PL_bufend-s);
11301 440 100       if (!eol++)
11302 24         eol = PL_bufend;
11303 440 50       if (*s != '#') {
11304 5644 100       for (t = s; t < eol; t++) {
11305 5428 100       if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
    100        
    100        
11306           needargs = FALSE;
11307           goto enough; /* ~~ must be first line in formline */
11308           }
11309 5424 100       if (*t == '@' || *t == '^')
11310           needargs = TRUE;
11311           }
11312 436 100       if (eol > s) {
11313 420         sv_catpvn(stuff, s, eol-s);
11314           #ifndef PERL_STRICT_CR
11315 420 100       if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
    50        
    0        
11316 0         char *end = SvPVX(stuff) + SvCUR(stuff);
11317 0         end[-2] = '\n';
11318 0         end[-1] = '\0';
11319 0         SvCUR_set(stuff, SvCUR(stuff) - 1);
11320           }
11321           #endif
11322           }
11323           else
11324           break;
11325           }
11326           s = (char*)eol;
11327 420 100       if ((PL_rsfp || PL_parser->filtered)
    50        
11328 300 100       && PL_parser->form_lex_state == LEX_NORMAL) {
11329           bool got_some;
11330           #ifdef PERL_MAD
11331           if (PL_madskills) {
11332           if (PL_thistoken)
11333           sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
11334           else
11335           PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
11336           }
11337           #endif
11338 298         PL_bufptr = PL_bufend;
11339 298 50       COPLINE_INC_WITH_HERELINES;
11340 298         got_some = lex_next_chunk(0);
11341 298         CopLINE_dec(PL_curcop);
11342 298         s = PL_bufptr;
11343           #ifdef PERL_MAD
11344           tokenstart = PL_bufptr;
11345           #endif
11346 298 50       if (!got_some)
11347           break;
11348           }
11349 420         incline(s);
11350           }
11351           enough:
11352 666 100       if (!SvCUR(stuff) || needargs)
    100        
11353 606         PL_lex_state = PL_parser->form_lex_state;
11354 666 100       if (SvCUR(stuff)) {
11355 376         PL_expect = XSTATE;
11356 376 100       if (needargs) {
11357           start_force(PL_curforce);
11358 316         NEXTVAL_NEXTTOKE.ival = 0;
11359 316         force_next(FORMLBRACK);
11360           }
11361 376 50       if (!IN_BYTES) {
11362 376 50       if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
    100        
    50        
    50        
    100        
    50        
11363 14         SvUTF8_on(stuff);
11364 362 50       else if (PL_encoding)
11365 0         sv_recode_to_utf8(stuff, PL_encoding);
11366           }
11367           start_force(PL_curforce);
11368 376         NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
11369 376         force_next(THING);
11370           }
11371           else {
11372 290         SvREFCNT_dec(stuff);
11373 290 100       if (eofmt)
11374 282         PL_lex_formbrack = 0;
11375           }
11376           #ifdef PERL_MAD
11377           if (PL_madskills) {
11378           if (PL_thistoken)
11379           sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
11380           else
11381           PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
11382           PL_thiswhite = savewhite;
11383           }
11384           #endif
11385 666         return s;
11386           }
11387            
11388           I32
11389 14237458         Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
11390           {
11391           dVAR;
11392 14237458         const I32 oldsavestack_ix = PL_savestack_ix;
11393 14237458         CV* const outsidecv = PL_compcv;
11394            
11395 14237458         SAVEI32(PL_subline);
11396 14237458         save_item(PL_subname);
11397 14237458         SAVESPTR(PL_compcv);
11398            
11399 14237458 100       PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
11400 14237458         CvFLAGS(PL_compcv) |= flags;
11401            
11402 14237458         PL_subline = CopLINE(PL_curcop);
11403 14237458         CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
11404 28474916         CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
11405 14237458         CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
11406 14237458 100       if (outsidecv && CvPADLIST(outsidecv))
    50        
11407 21158363         CvPADLIST(PL_compcv)->xpadl_outid =
11408 14231076         PadlistNAMES(CvPADLIST(outsidecv));
11409            
11410 14237458         return oldsavestack_ix;
11411           }
11412            
11413           #ifdef __SC__
11414           #pragma segment Perl_yylex
11415           #endif
11416           static int
11417           S_yywarn(pTHX_ const char *const s, U32 flags)
11418           {
11419           dVAR;
11420            
11421           PERL_ARGS_ASSERT_YYWARN;
11422            
11423 108         PL_in_eval |= EVAL_WARNONLY;
11424 108         yyerror_pv(s, flags);
11425 108         PL_in_eval &= ~EVAL_WARNONLY;
11426           return 0;
11427           }
11428            
11429           int
11430 1348         Perl_yyerror(pTHX_ const char *const s)
11431           {
11432           PERL_ARGS_ASSERT_YYERROR;
11433 1348         return yyerror_pvn(s, strlen(s), 0);
11434           }
11435            
11436           int
11437 810         Perl_yyerror_pv(pTHX_ const char *const s, U32 flags)
11438           {
11439           PERL_ARGS_ASSERT_YYERROR_PV;
11440 810         return yyerror_pvn(s, strlen(s), flags);
11441           }
11442            
11443           int
11444 2162         Perl_yyerror_pvn(pTHX_ const char *const s, STRLEN len, U32 flags)
11445           {
11446           dVAR;
11447           const char *context = NULL;
11448           int contlen = -1;
11449           SV *msg;
11450 2162         SV * const where_sv = newSVpvs_flags("", SVs_TEMP);
11451 2162         int yychar = PL_parser->yychar;
11452            
11453           PERL_ARGS_ASSERT_YYERROR_PVN;
11454            
11455 2162 100       if (!yychar || (yychar == ';' && !PL_rsfp))
    100        
    100        
11456 426         sv_catpvs(where_sv, "at EOF");
11457 2373 50       else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
    100        
    50        
11458 2473 100       PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
    100        
11459 1124         PL_oldbufptr != PL_bufptr) {
11460           /*
11461           Only for NetWare:
11462           The code below is removed for NetWare because it abends/crashes on NetWare
11463           when the script has error such as not having the closing quotes like:
11464           if ($var eq "value)
11465           Checking of white spaces is anyway done in NetWare code.
11466           */
11467           #ifndef NETWARE
11468 970 100       while (isSPACE(*PL_oldoldbufptr))
11469 114         PL_oldoldbufptr++;
11470           #endif
11471 856         context = PL_oldoldbufptr;
11472 856         contlen = PL_bufptr - PL_oldoldbufptr;
11473           }
11474 955 50       else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
    100        
    50        
11475 225 50       PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
11476           /*
11477           Only for NetWare:
11478           The code below is removed for NetWare because it abends/crashes on NetWare
11479           when the script has error such as not having the closing quotes like:
11480           if ($var eq "value)
11481           Checking of white spaces is anyway done in NetWare code.
11482           */
11483           #ifndef NETWARE
11484 188 100       while (isSPACE(*PL_oldbufptr))
11485 38         PL_oldbufptr++;
11486           #endif
11487 150         context = PL_oldbufptr;
11488 150         contlen = PL_bufptr - PL_oldbufptr;
11489           }
11490 730 50       else if (yychar > 255)
11491 0         sv_catpvs(where_sv, "next token ???");
11492 730 50       else if (yychar == -2) { /* YYEMPTY */
11493 960 100       if (PL_lex_state == LEX_NORMAL ||
    50        
11494 230 0       (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
11495 270         sv_catpvs(where_sv, "at end of line");
11496 460 100       else if (PL_lex_inpat)
11497 114         sv_catpvs(where_sv, "within pattern");
11498           else
11499 346         sv_catpvs(where_sv, "within string");
11500           }
11501           else {
11502 0         sv_catpvs(where_sv, "next char ");
11503 0 0       if (yychar < 32)
11504 0 0       Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
    0        
11505 0 0       else if (isPRINT_LC(yychar)) {
    0        
11506 0         const char string = yychar;
11507 0         sv_catpvn(where_sv, &string, 1);
11508           }
11509           else
11510 0         Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
11511           }
11512 2162         msg = newSVpvn_flags(s, len, (flags & SVf_UTF8) | SVs_TEMP);
11513 4324 50       Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
11514 6486         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
11515 2162 100       if (context)
11516 3479 50       Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
    100        
11517 2472 100       UTF8fARG(UTF, contlen, context));
    50        
    100        
11518           else
11519 1156         Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
11520 2162 100       if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
    50        
11521 4         Perl_sv_catpvf(aTHX_ msg,
11522           " (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
11523 6         (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
11524 2         PL_multi_end = 0;
11525           }
11526 2162 100       if (PL_in_eval & EVAL_WARNONLY) {
11527 108         Perl_ck_warner_d(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
11528           }
11529           else
11530 2054         qerror(msg);
11531 2162 100       if (PL_error_count >= 10) {
11532           SV * errsv;
11533 58 50       if (PL_in_eval && ((errsv = ERRSV), SvCUR(errsv)))
    50        
    50        
11534 87 50       Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
11535 116         SVfARG(errsv), OutCopFILE(PL_curcop));
11536           else
11537 0 0       Perl_croak(aTHX_ "%s has too many errors.\n",
11538 0         OutCopFILE(PL_curcop));
11539           }
11540 2104         PL_in_my = 0;
11541 2104         PL_in_my_stash = NULL;
11542 2104         return 0;
11543           }
11544           #ifdef __SC__
11545           #pragma segment Main
11546           #endif
11547            
11548           STATIC char*
11549 24674         S_swallow_bom(pTHX_ U8 *s)
11550           {
11551           dVAR;
11552 24674         const STRLEN slen = SvCUR(PL_linestr);
11553            
11554           PERL_ARGS_ASSERT_SWALLOW_BOM;
11555            
11556 24674         switch (s[0]) {
11557           case 0xFF:
11558 1998 50       if (s[1] == 0xFE) {
11559           /* UTF-16 little-endian? (or UTF-32LE?) */
11560 1998 50       if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
    0        
11561           /* diag_listed_as: Unsupported script encoding %s */
11562 0         Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
11563           #ifndef PERL_NO_UTF16_FILTER
11564           if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
11565 1998         s += 2;
11566 1998 50       if (PL_bufend > (char*)s) {
11567 1998         s = add_utf16_textfilter(s, TRUE);
11568           }
11569           #else
11570           /* diag_listed_as: Unsupported script encoding %s */
11571           Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11572           #endif
11573           }
11574           break;
11575           case 0xFE:
11576 1998 50       if (s[1] == 0xFF) { /* UTF-16 big-endian? */
11577           #ifndef PERL_NO_UTF16_FILTER
11578           if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
11579 1998         s += 2;
11580 1998 50       if (PL_bufend > (char *)s) {
11581 1998         s = add_utf16_textfilter(s, FALSE);
11582           }
11583           #else
11584           /* diag_listed_as: Unsupported script encoding %s */
11585           Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11586           #endif
11587           }
11588           break;
11589           case BOM_UTF8_FIRST_BYTE: {
11590           const STRLEN len = sizeof(BOM_UTF8_TAIL) - 1; /* Exclude trailing NUL */
11591 28 50       if (slen > len && memEQ(s+1, BOM_UTF8_TAIL, len)) {
    50        
11592           if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
11593 28         s += len + 1; /* UTF-8 */
11594           }
11595           break;
11596           }
11597           case 0:
11598 2000 100       if (slen > 3) {
11599 1996 50       if (s[1] == 0) {
11600 0 0       if (s[2] == 0xFE && s[3] == 0xFF) {
    0        
11601           /* UTF-32 big-endian */
11602           /* diag_listed_as: Unsupported script encoding %s */
11603 0         Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
11604           }
11605           }
11606 1996 50       else if (s[2] == 0 && s[3] != 0) {
    50        
11607           /* Leading bytes
11608           * 00 xx 00 xx
11609           * are a good indicator of UTF-16BE. */
11610           #ifndef PERL_NO_UTF16_FILTER
11611           if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
11612 1996         s = add_utf16_textfilter(s, FALSE);
11613           #else
11614           /* diag_listed_as: Unsupported script encoding %s */
11615           Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
11616           #endif
11617           }
11618           }
11619            
11620           default:
11621 20650 100       if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
    100        
    50        
    50        
11622           /* Leading bytes
11623           * xx 00 xx 00
11624           * are a good indicator of UTF-16LE. */
11625           #ifndef PERL_NO_UTF16_FILTER
11626           if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
11627 1996         s = add_utf16_textfilter(s, TRUE);
11628           #else
11629           /* diag_listed_as: Unsupported script encoding %s */
11630           Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
11631           #endif
11632           }
11633           }
11634 24674         return (char*)s;
11635           }
11636            
11637            
11638           #ifndef PERL_NO_UTF16_FILTER
11639           static I32
11640 23704         S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
11641           {
11642           dVAR;
11643 23704 50       SV *const filter = FILTER_DATA(idx);
11644           /* We re-use this each time round, throwing the contents away before we
11645           return. */
11646 23704         SV *const utf16_buffer = MUTABLE_SV(IoTOP_GV(filter));
11647           SV *const utf8_buffer = filter;
11648 23704         IV status = IoPAGE(filter);
11649 23704         const bool reverse = cBOOL(IoLINES(filter));
11650           I32 retval;
11651            
11652           PERL_ARGS_ASSERT_UTF16_TEXTFILTER;
11653            
11654           /* As we're automatically added, at the lowest level, and hence only called
11655           from this file, we can be sure that we're not called in block mode. Hence
11656           don't bother writing code to deal with block mode. */
11657 23704 50       if (maxlen) {
11658 0         Perl_croak(aTHX_ "panic: utf16_textfilter called in block mode (for %d characters)", maxlen);
11659           }
11660 23704 50       if (status < 0) {
11661 14085         Perl_croak(aTHX_ "panic: utf16_textfilter called after error (status=%"IVdf")", status);
11662           }
11663           DEBUG_P(PerlIO_printf(Perl_debug_log,
11664           "utf16_textfilter(%p,%ce): idx=%d maxlen=%d status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11665           FPTR2DPTR(void *, S_utf16_textfilter),
11666           reverse ? 'l' : 'b', idx, maxlen, status,
11667           (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11668            
11669           while (1) {
11670           STRLEN chars;
11671           STRLEN have;
11672           I32 newlen;
11673           U8 *end;
11674           /* First, look in our buffer of existing UTF-8 data: */
11675 51874         char *nl = (char *)memchr(SvPVX(utf8_buffer), '\n', SvCUR(utf8_buffer));
11676            
11677 51874 100       if (nl) {
11678 11724         ++nl;
11679 40150 100       } else if (status == 0) {
11680           /* EOF */
11681 11980         IoPAGE(filter) = 0;
11682 11980         nl = SvEND(utf8_buffer);
11683           }
11684 51874 100       if (nl) {
11685 23704         STRLEN got = nl - SvPVX(utf8_buffer);
11686           /* Did we have anything to append? */
11687 23704         retval = got != 0;
11688 23704         sv_catpvn(sv, SvPVX(utf8_buffer), got);
11689           /* Everything else in this code works just fine if SVp_POK isn't
11690           set. This, however, needs it, and we need it to work, else
11691           we loop infinitely because the buffer is never consumed. */
11692 37789         sv_chop(utf8_buffer, nl);
11693           break;
11694           }
11695            
11696           /* OK, not a complete line there, so need to read some more UTF-16.
11697           Read an extra octect if the buffer currently has an odd number. */
11698           while (1) {
11699 48464 100       if (status <= 0)
11700           break;
11701 40476 100       if (SvCUR(utf16_buffer) >= 2) {
11702           /* Location of the high octet of the last complete code point.
11703           Gosh, UTF-16 is a pain. All the benefits of variable length,
11704           *coupled* with all the benefits of partial reads and
11705           endianness. */
11706 40588         const U8 *const last_hi = (U8*)SvPVX(utf16_buffer)
11707 20294 100       + ((SvCUR(utf16_buffer) & ~1) - (reverse ? 1 : 2));
11708            
11709 20294 100       if (*last_hi < 0xd8 || *last_hi > 0xdb) {
11710           break;
11711           }
11712            
11713           /* We have the first half of a surrogate. Read more. */
11714           DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter partial surrogate detected at %p\n", last_hi));
11715           }
11716            
11717 20294         status = FILTER_READ(idx + 1, utf16_buffer,
11718           160 + (SvCUR(utf16_buffer) & 1));
11719           DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter status=%"IVdf" SvCUR(sv)=%"UVuf"\n", status, (UV)SvCUR(utf16_buffer)));
11720           DEBUG_P({ sv_dump(utf16_buffer); sv_dump(utf8_buffer);});
11721 20294 50       if (status < 0) {
11722           /* Error */
11723 0         IoPAGE(filter) = status;
11724 0         return status;
11725           }
11726           }
11727            
11728 28170         chars = SvCUR(utf16_buffer) >> 1;
11729 28170         have = SvCUR(utf8_buffer);
11730 28170 50       SvGROW(utf8_buffer, have + chars * 3 + 1);
    100        
11731            
11732 28170 100       if (reverse) {
11733 14110         end = utf16_to_utf8_reversed((U8*)SvPVX(utf16_buffer),
11734           (U8*)SvPVX_const(utf8_buffer) + have,
11735           chars * 2, &newlen);
11736           } else {
11737 14060         end = utf16_to_utf8((U8*)SvPVX(utf16_buffer),
11738           (U8*)SvPVX_const(utf8_buffer) + have,
11739           chars * 2, &newlen);
11740           }
11741 28170         SvCUR_set(utf8_buffer, have + newlen);
11742 28170         *end = '\0';
11743            
11744           /* No need to keep this SV "well-formed" with a '\0' after the end, as
11745           it's private to us, and utf16_to_utf8{,reversed} take a
11746           (pointer,length) pair, rather than a NUL-terminated string. */
11747 28170 100       if(SvCUR(utf16_buffer) & 1) {
11748 3938         *SvPVX(utf16_buffer) = SvEND(utf16_buffer)[-1];
11749 3938         SvCUR_set(utf16_buffer, 1);
11750           } else {
11751 24232         SvCUR_set(utf16_buffer, 0);
11752           }
11753           }
11754           DEBUG_P(PerlIO_printf(Perl_debug_log,
11755           "utf16_textfilter: returns, status=%"IVdf" utf16=%"UVuf" utf8=%"UVuf"\n",
11756           status,
11757           (UV)SvCUR(utf16_buffer), (UV)SvCUR(utf8_buffer)));
11758           DEBUG_P({ sv_dump(utf8_buffer); sv_dump(sv);});
11759 23704         return retval;
11760           }
11761            
11762           static U8 *
11763 7988         S_add_utf16_textfilter(pTHX_ U8 *const s, bool reversed)
11764           {
11765 7988         SV *filter = filter_add(S_utf16_textfilter, NULL);
11766            
11767           PERL_ARGS_ASSERT_ADD_UTF16_TEXTFILTER;
11768            
11769 7988         IoTOP_GV(filter) = MUTABLE_GV(newSVpvn((char *)s, PL_bufend - (char*)s));
11770 7988         sv_setpvs(filter, "");
11771 7988         IoLINES(filter) = reversed;
11772 7988         IoPAGE(filter) = 1; /* Not EOF */
11773            
11774           /* Sadly, we have to return a valid pointer, come what may, so we have to
11775           ignore any error return from this. */
11776 7988         SvCUR_set(PL_linestr, 0);
11777 7988 50       if (FILTER_READ(0, PL_linestr, 0)) {
11778 7988         SvUTF8_on(PL_linestr);
11779           } else {
11780 0         SvUTF8_on(PL_linestr);
11781           }
11782 7988         PL_bufend = SvEND(PL_linestr);
11783 7988         return (U8*)SvPVX(PL_linestr);
11784           }
11785           #endif
11786            
11787           /*
11788           Returns a pointer to the next character after the parsed
11789           vstring, as well as updating the passed in sv.
11790            
11791           Function must be called like
11792            
11793           sv = sv_2mortal(newSV(5));
11794           s = scan_vstring(s,e,sv);
11795            
11796           where s and e are the start and end of the string.
11797           The sv should already be large enough to store the vstring
11798           passed in, for performance reasons.
11799            
11800           This function may croak if fatal warnings are enabled in the
11801           calling scope, hence the sv_2mortal in the example (to prevent
11802           a leak). Make sure to do SvREFCNT_inc afterwards if you use
11803           sv_2mortal.
11804            
11805           */
11806            
11807           char *
11808 32828         Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
11809           {
11810           dVAR;
11811           const char *pos = s;
11812           const char *start = s;
11813            
11814           PERL_ARGS_ASSERT_SCAN_VSTRING;
11815            
11816 32828 100       if (*pos == 'v') pos++; /* get past 'v' */
11817 67428 100       while (pos < e && (isDIGIT(*pos) || *pos == '_'))
    100        
    50        
11818 34600         pos++;
11819 32828 100       if ( *pos != '.') {
11820           /* this may not be a v-string if followed by => */
11821           const char *next = pos;
11822 5416 100       while (next < e && isSPACE(*next))
    100        
11823 76         ++next;
11824 5340 100       if ((e - next) >= 2 && *next == '=' && next[1] == '>' ) {
    100        
    50        
11825           /* return string not v-string */
11826 4         sv_setpvn(sv,(char *)s,pos-s);
11827 4         return (char *)pos;
11828           }
11829           }
11830            
11831 32824 50       if (!isALPHA(*pos)) {
11832           U8 tmpbuf[UTF8_MAXBYTES+1];
11833            
11834 32824 100       if (*s == 'v')
11835 11308         s++; /* get past 'v' */
11836            
11837 61296         sv_setpvs(sv, "");
11838            
11839           for (;;) {
11840           /* this is atoi() that tolerates underscores */
11841           U8 *tmpend;
11842           UV rev = 0;
11843           const char *end = pos;
11844           UV mult = 1;
11845 250566 100       while (--end >= s) {
11846 119158 100       if (*end != '_') {
11847           const UV orev = rev;
11848 119080         rev += (*end - '0') * mult;
11849 119080         mult *= 10;
11850 119080 100       if (orev > rev)
11851           /* diag_listed_as: Integer overflow in %s number */
11852 60841         Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
11853           "Integer overflow in decimal number");
11854           }
11855           }
11856           #ifdef EBCDIC
11857           if (rev > 0x7FFFFFFF)
11858           Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11859           #endif
11860           /* Append native character for the rev point */
11861 88324         tmpend = uvchr_to_utf8(tmpbuf, rev);
11862 88324         sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11863 88324 100       if (!NATIVE_IS_INVARIANT(rev))
11864 1342         SvUTF8_on(sv);
11865 88324 100       if (pos + 1 < e && *pos == '.' && isDIGIT(pos[1]))
    100        
    100        
11866 55504         s = ++pos;
11867           else {
11868           s = pos;
11869           break;
11870           }
11871 167210 100       while (pos < e && (isDIGIT(*pos) || *pos == '_'))
    100        
    100        
11872 84674         pos++;
11873           }
11874 32820         SvPOK_on(sv);
11875 32820         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11876 32820         SvRMAGICAL_on(sv);
11877           }
11878 32822         return (char *)s;
11879           }
11880            
11881           int
11882 117971631         Perl_keyword_plugin_standard(pTHX_
11883           char *keyword_ptr, STRLEN keyword_len, OP **op_ptr)
11884           {
11885           PERL_ARGS_ASSERT_KEYWORD_PLUGIN_STANDARD;
11886           PERL_UNUSED_CONTEXT;
11887           PERL_UNUSED_ARG(keyword_ptr);
11888           PERL_UNUSED_ARG(keyword_len);
11889           PERL_UNUSED_ARG(op_ptr);
11890 117971631         return KEYWORD_PLUGIN_DECLINE;
11891           }
11892            
11893           #define parse_recdescent(g,p) S_parse_recdescent(aTHX_ g,p)
11894           static void
11895 538         S_parse_recdescent(pTHX_ int gramtype, I32 fakeeof)
11896           {
11897 538         SAVEI32(PL_lex_brackets);
11898 538 50       if (PL_lex_brackets > 100)
11899 0         Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
11900 538         PL_lex_brackstack[PL_lex_brackets++] = XFAKEEOF;
11901 538         SAVEI32(PL_lex_allbrackets);
11902 538         PL_lex_allbrackets = 0;
11903 538         SAVEI8(PL_lex_fakeeof);
11904 538         PL_lex_fakeeof = (U8)fakeeof;
11905 538 100       if(yyparse(gramtype) && !PL_parser->error_count)
    50        
11906 0         qerror(Perl_mess(aTHX_ "Parse error"));
11907 534         }
11908            
11909           #define parse_recdescent_for_op(g,p) S_parse_recdescent_for_op(aTHX_ g,p)
11910           static OP *
11911 538         S_parse_recdescent_for_op(pTHX_ int gramtype, I32 fakeeof)
11912           {
11913           OP *o;
11914 538         ENTER;
11915 538         SAVEVPTR(PL_eval_root);
11916 538         PL_eval_root = NULL;
11917 538         parse_recdescent(gramtype, fakeeof);
11918 534         o = PL_eval_root;
11919 534         LEAVE;
11920 534         return o;
11921           }
11922            
11923           #define parse_expr(p,f) S_parse_expr(aTHX_ p,f)
11924           static OP *
11925 284         S_parse_expr(pTHX_ I32 fakeeof, U32 flags)
11926           {
11927           OP *exprop;
11928 284 50       if (flags & ~PARSE_OPTIONAL)
11929 0         Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_expr");
11930 284         exprop = parse_recdescent_for_op(GRAMEXPR, fakeeof);
11931 284 100       if (!exprop && !(flags & PARSE_OPTIONAL)) {
    100        
11932 4 100       if (!PL_parser->error_count)
11933 2         qerror(Perl_mess(aTHX_ "Parse error"));
11934 4         exprop = newOP(OP_NULL, 0);
11935           }
11936 284         return exprop;
11937           }
11938            
11939           /*
11940           =for apidoc Amx|OP *|parse_arithexpr|U32 flags
11941            
11942           Parse a Perl arithmetic expression. This may contain operators of precedence
11943           down to the bit shift operators. The expression must be followed (and thus
11944           terminated) either by a comparison or lower-precedence operator or by
11945           something that would normally terminate an expression such as semicolon.
11946           If I includes C then the expression is optional,
11947           otherwise it is mandatory. It is up to the caller to ensure that the
11948           dynamic parser state (L et al) is correctly set to reflect
11949           the source of the code to be parsed and the lexical context for the
11950           expression.
11951            
11952           The op tree representing the expression is returned. If an optional
11953           expression is absent, a null pointer is returned, otherwise the pointer
11954           will be non-null.
11955            
11956           If an error occurs in parsing or compilation, in most cases a valid op
11957           tree is returned anyway. The error is reflected in the parser state,
11958           normally resulting in a single exception at the top level of parsing
11959           which covers all the compilation errors that occurred. Some compilation
11960           errors, however, will throw an exception immediately.
11961            
11962           =cut
11963           */
11964            
11965           OP *
11966 68         Perl_parse_arithexpr(pTHX_ U32 flags)
11967           {
11968 68         return parse_expr(LEX_FAKEEOF_COMPARE, flags);
11969           }
11970            
11971           /*
11972           =for apidoc Amx|OP *|parse_termexpr|U32 flags
11973            
11974           Parse a Perl term expression. This may contain operators of precedence
11975           down to the assignment operators. The expression must be followed (and thus
11976           terminated) either by a comma or lower-precedence operator or by
11977           something that would normally terminate an expression such as semicolon.
11978           If I includes C then the expression is optional,
11979           otherwise it is mandatory. It is up to the caller to ensure that the
11980           dynamic parser state (L et al) is correctly set to reflect
11981           the source of the code to be parsed and the lexical context for the
11982           expression.
11983            
11984           The op tree representing the expression is returned. If an optional
11985           expression is absent, a null pointer is returned, otherwise the pointer
11986           will be non-null.
11987            
11988           If an error occurs in parsing or compilation, in most cases a valid op
11989           tree is returned anyway. The error is reflected in the parser state,
11990           normally resulting in a single exception at the top level of parsing
11991           which covers all the compilation errors that occurred. Some compilation
11992           errors, however, will throw an exception immediately.
11993            
11994           =cut
11995           */
11996            
11997           OP *
11998 68         Perl_parse_termexpr(pTHX_ U32 flags)
11999           {
12000 68         return parse_expr(LEX_FAKEEOF_COMMA, flags);
12001           }
12002            
12003           /*
12004           =for apidoc Amx|OP *|parse_listexpr|U32 flags
12005            
12006           Parse a Perl list expression. This may contain operators of precedence
12007           down to the comma operator. The expression must be followed (and thus
12008           terminated) either by a low-precedence logic operator such as C or by
12009           something that would normally terminate an expression such as semicolon.
12010           If I includes C then the expression is optional,
12011           otherwise it is mandatory. It is up to the caller to ensure that the
12012           dynamic parser state (L et al) is correctly set to reflect
12013           the source of the code to be parsed and the lexical context for the
12014           expression.
12015            
12016           The op tree representing the expression is returned. If an optional
12017           expression is absent, a null pointer is returned, otherwise the pointer
12018           will be non-null.
12019            
12020           If an error occurs in parsing or compilation, in most cases a valid op
12021           tree is returned anyway. The error is reflected in the parser state,
12022           normally resulting in a single exception at the top level of parsing
12023           which covers all the compilation errors that occurred. Some compilation
12024           errors, however, will throw an exception immediately.
12025            
12026           =cut
12027           */
12028            
12029           OP *
12030 80         Perl_parse_listexpr(pTHX_ U32 flags)
12031           {
12032 80         return parse_expr(LEX_FAKEEOF_LOWLOGIC, flags);
12033           }
12034            
12035           /*
12036           =for apidoc Amx|OP *|parse_fullexpr|U32 flags
12037            
12038           Parse a single complete Perl expression. This allows the full
12039           expression grammar, including the lowest-precedence operators such
12040           as C. The expression must be followed (and thus terminated) by a
12041           token that an expression would normally be terminated by: end-of-file,
12042           closing bracketing punctuation, semicolon, or one of the keywords that
12043           signals a postfix expression-statement modifier. If I includes
12044           C then the expression is optional, otherwise it is
12045           mandatory. It is up to the caller to ensure that the dynamic parser
12046           state (L et al) is correctly set to reflect the source of
12047           the code to be parsed and the lexical context for the expression.
12048            
12049           The op tree representing the expression is returned. If an optional
12050           expression is absent, a null pointer is returned, otherwise the pointer
12051           will be non-null.
12052            
12053           If an error occurs in parsing or compilation, in most cases a valid op
12054           tree is returned anyway. The error is reflected in the parser state,
12055           normally resulting in a single exception at the top level of parsing
12056           which covers all the compilation errors that occurred. Some compilation
12057           errors, however, will throw an exception immediately.
12058            
12059           =cut
12060           */
12061            
12062           OP *
12063 68         Perl_parse_fullexpr(pTHX_ U32 flags)
12064           {
12065 68         return parse_expr(LEX_FAKEEOF_NONEXPR, flags);
12066           }
12067            
12068           /*
12069           =for apidoc Amx|OP *|parse_block|U32 flags
12070            
12071           Parse a single complete Perl code block. This consists of an opening
12072           brace, a sequence of statements, and a closing brace. The block
12073           constitutes a lexical scope, so C variables and various compile-time
12074           effects can be contained within it. It is up to the caller to ensure
12075           that the dynamic parser state (L et al) is correctly set to
12076           reflect the source of the code to be parsed and the lexical context for
12077           the statement.
12078            
12079           The op tree representing the code block is returned. This is always a
12080           real op, never a null pointer. It will normally be a C list,
12081           including C or equivalent ops. No ops to construct any kind
12082           of runtime scope are included by virtue of it being a block.
12083            
12084           If an error occurs in parsing or compilation, in most cases a valid op
12085           tree (most likely null) is returned anyway. The error is reflected in
12086           the parser state, normally resulting in a single exception at the top
12087           level of parsing which covers all the compilation errors that occurred.
12088           Some compilation errors, however, will throw an exception immediately.
12089            
12090           The I parameter is reserved for future use, and must always
12091           be zero.
12092            
12093           =cut
12094           */
12095            
12096           OP *
12097 30         Perl_parse_block(pTHX_ U32 flags)
12098           {
12099 30 50       if (flags)
12100 0         Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_block");
12101 30         return parse_recdescent_for_op(GRAMBLOCK, LEX_FAKEEOF_NEVER);
12102           }
12103            
12104           /*
12105           =for apidoc Amx|OP *|parse_barestmt|U32 flags
12106            
12107           Parse a single unadorned Perl statement. This may be a normal imperative
12108           statement or a declaration that has compile-time effect. It does not
12109           include any label or other affixture. It is up to the caller to ensure
12110           that the dynamic parser state (L et al) is correctly set to
12111           reflect the source of the code to be parsed and the lexical context for
12112           the statement.
12113            
12114           The op tree representing the statement is returned. This may be a
12115           null pointer if the statement is null, for example if it was actually
12116           a subroutine definition (which has compile-time side effects). If not
12117           null, it will be ops directly implementing the statement, suitable to
12118           pass to L. It will not normally include a C or
12119           equivalent op (except for those embedded in a scope contained entirely
12120           within the statement).
12121            
12122           If an error occurs in parsing or compilation, in most cases a valid op
12123           tree (most likely null) is returned anyway. The error is reflected in
12124           the parser state, normally resulting in a single exception at the top
12125           level of parsing which covers all the compilation errors that occurred.
12126           Some compilation errors, however, will throw an exception immediately.
12127            
12128           The I parameter is reserved for future use, and must always
12129           be zero.
12130            
12131           =cut
12132           */
12133            
12134           OP *
12135 114         Perl_parse_barestmt(pTHX_ U32 flags)
12136           {
12137 114 50       if (flags)
12138 0         Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_barestmt");
12139 114         return parse_recdescent_for_op(GRAMBARESTMT, LEX_FAKEEOF_NEVER);
12140           }
12141            
12142           /*
12143           =for apidoc Amx|SV *|parse_label|U32 flags
12144            
12145           Parse a single label, possibly optional, of the type that may prefix a
12146           Perl statement. It is up to the caller to ensure that the dynamic parser
12147           state (L et al) is correctly set to reflect the source of
12148           the code to be parsed. If I includes C then the
12149           label is optional, otherwise it is mandatory.
12150            
12151           The name of the label is returned in the form of a fresh scalar. If an
12152           optional label is absent, a null pointer is returned.
12153            
12154           If an error occurs in parsing, which can only occur if the label is
12155           mandatory, a valid label is returned anyway. The error is reflected in
12156           the parser state, normally resulting in a single exception at the top
12157           level of parsing which covers all the compilation errors that occurred.
12158            
12159           =cut
12160           */
12161            
12162           SV *
12163 144         Perl_parse_label(pTHX_ U32 flags)
12164           {
12165 144 50       if (flags & ~PARSE_OPTIONAL)
12166 0         Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_label");
12167 144 100       if (PL_lex_state == LEX_KNOWNEXT) {
12168 48         PL_parser->yychar = yylex();
12169 48 100       if (PL_parser->yychar == LABEL) {
12170 40         char * const lpv = pl_yylval.pval;
12171 40         STRLEN llen = strlen(lpv);
12172 40         PL_parser->yychar = YYEMPTY;
12173 40 100       return newSVpvn_flags(lpv, llen, lpv[llen+1] ? SVf_UTF8 : 0);
12174           } else {
12175 8         yyunlex();
12176 8         goto no_label;
12177           }
12178           } else {
12179           char *s, *t;
12180           STRLEN wlen, bufptr_pos;
12181 96         lex_read_space(0);
12182 96         t = s = PL_bufptr;
12183 96 50       if (!isIDFIRST_lazy_if(s, UTF))
    50        
    100        
    50        
    50        
    100        
    100        
    50        
    0        
    0        
    100        
12184           goto no_label;
12185 84         t = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &wlen);
12186 84 100       if (word_takes_any_delimeter(s, wlen))
12187           goto no_label;
12188 80         bufptr_pos = s - SvPVX(PL_linestr);
12189 80         PL_bufptr = t;
12190 80         lex_read_space(LEX_KEEP_PREVIOUS);
12191 80         t = PL_bufptr;
12192 80         s = SvPVX(PL_linestr) + bufptr_pos;
12193 80 100       if (t[0] == ':' && t[1] != ':') {
    50        
12194 76         PL_oldoldbufptr = PL_oldbufptr;
12195 76         PL_oldbufptr = s;
12196 76         PL_bufptr = t+1;
12197 76 50       return newSVpvn_flags(s, wlen, UTF ? SVf_UTF8 : 0);
    100        
    50        
    50        
    100        
12198           } else {
12199 4         PL_bufptr = s;
12200           no_label:
12201 28 100       if (flags & PARSE_OPTIONAL) {
12202           return NULL;
12203           } else {
12204 8         qerror(Perl_mess(aTHX_ "Parse error"));
12205 76         return newSVpvs("x");
12206           }
12207           }
12208           }
12209           }
12210            
12211           /*
12212           =for apidoc Amx|OP *|parse_fullstmt|U32 flags
12213            
12214           Parse a single complete Perl statement. This may be a normal imperative
12215           statement or a declaration that has compile-time effect, and may include
12216           optional labels. It is up to the caller to ensure that the dynamic
12217           parser state (L et al) is correctly set to reflect the source
12218           of the code to be parsed and the lexical context for the statement.
12219            
12220           The op tree representing the statement is returned. This may be a
12221           null pointer if the statement is null, for example if it was actually
12222           a subroutine definition (which has compile-time side effects). If not
12223           null, it will be the result of a L call, normally including
12224           a C or equivalent op.
12225            
12226           If an error occurs in parsing or compilation, in most cases a valid op
12227           tree (most likely null) is returned anyway. The error is reflected in
12228           the parser state, normally resulting in a single exception at the top
12229           level of parsing which covers all the compilation errors that occurred.
12230           Some compilation errors, however, will throw an exception immediately.
12231            
12232           The I parameter is reserved for future use, and must always
12233           be zero.
12234            
12235           =cut
12236           */
12237            
12238           OP *
12239 68         Perl_parse_fullstmt(pTHX_ U32 flags)
12240           {
12241 68 50       if (flags)
12242 0         Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_fullstmt");
12243 68         return parse_recdescent_for_op(GRAMFULLSTMT, LEX_FAKEEOF_NEVER);
12244           }
12245            
12246           /*
12247           =for apidoc Amx|OP *|parse_stmtseq|U32 flags
12248            
12249           Parse a sequence of zero or more Perl statements. These may be normal
12250           imperative statements, including optional labels, or declarations
12251           that have compile-time effect, or any mixture thereof. The statement
12252           sequence ends when a closing brace or end-of-file is encountered in a
12253           place where a new statement could have validly started. It is up to
12254           the caller to ensure that the dynamic parser state (L et al)
12255           is correctly set to reflect the source of the code to be parsed and the
12256           lexical context for the statements.
12257            
12258           The op tree representing the statement sequence is returned. This may
12259           be a null pointer if the statements were all null, for example if there
12260           were no statements or if there were only subroutine definitions (which
12261           have compile-time side effects). If not null, it will be a C
12262           list, normally including C or equivalent ops.
12263            
12264           If an error occurs in parsing or compilation, in most cases a valid op
12265           tree is returned anyway. The error is reflected in the parser state,
12266           normally resulting in a single exception at the top level of parsing
12267           which covers all the compilation errors that occurred. Some compilation
12268           errors, however, will throw an exception immediately.
12269            
12270           The I parameter is reserved for future use, and must always
12271           be zero.
12272            
12273           =cut
12274           */
12275            
12276           OP *
12277 42         Perl_parse_stmtseq(pTHX_ U32 flags)
12278           {
12279           OP *stmtseqop;
12280           I32 c;
12281 42 50       if (flags)
12282 0         Perl_croak(aTHX_ "Parsing code internal error (%s)", "parse_stmtseq");
12283 42         stmtseqop = parse_recdescent_for_op(GRAMSTMTSEQ, LEX_FAKEEOF_CLOSING);
12284 42         c = lex_peek_unichar(0);
12285 42 100       if (c != -1 && c != /*{*/'}')
12286 4         qerror(Perl_mess(aTHX_ "Parse error"));
12287 42         return stmtseqop;
12288           }
12289            
12290           /*
12291           * Local variables:
12292           * c-indentation-style: bsd
12293           * c-basic-offset: 4
12294           * indent-tabs-mode: nil
12295           * End:
12296           *
12297           * ex: set ts=8 sts=4 sw=4 et:
12298           */