This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Reduce false positives for @hsh{$s} and @ary[$s] warnings
[perl5.git] / toke.c
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<PL_parser> 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<shift // 0>).
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->herelines)                      \
307             CopLINE(PL_curcop) += PL_parser->herelines, \
308             PL_parser->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->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 S_deprecate_commaless_var_list(pTHX) {
497     PL_expect = XTERM;
498     deprecate("comma-less variable list");
499     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 S_ao(pTHX_ int toketype)
511 {
512     dVAR;
513     if (*PL_bufptr == '=') {
514         PL_bufptr++;
515         if (toketype == ANDAND)
516             pl_yylval.ival = OP_ANDASSIGN;
517         else if (toketype == OROR)
518             pl_yylval.ival = OP_ORASSIGN;
519         else if (toketype == DORDOR)
520             pl_yylval.ival = OP_DORASSIGN;
521         toketype = ASSIGNOP;
522     }
523     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 "<something> 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 S_no_op(pTHX_ const char *const what, char *s)
541 {
542     dVAR;
543     char * const oldbp = PL_bufptr;
544     const bool is_first = (PL_oldbufptr == PL_linestart);
545
546     PERL_ARGS_ASSERT_NO_OP;
547
548     if (!s)
549         s = oldbp;
550     else
551         PL_bufptr = s;
552     yywarn(Perl_form(aTHX_ "%s found where operator expected", what), UTF ? SVf_UTF8 : 0);
553     if (ckWARN_d(WARN_SYNTAX)) {
554         if (is_first)
555             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
556                     "\t(Missing semicolon on previous line?)\n");
557         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
558             const char *t;
559             for (t = PL_oldoldbufptr; (isWORDCHAR_lazy_if(t,UTF) || *t == ':');
560                                                             t += UTF ? UTF8SKIP(t) : 1)
561                 NOOP;
562             if (t < PL_bufptr && isSPACE(*t))
563                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
564                         "\t(Do you need to predeclare %"UTF8f"?)\n",
565                       UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
566         }
567         else {
568             assert(s >= oldbp);
569             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
570                     "\t(Missing operator before %"UTF8f"?)\n",
571                      UTF8fARG(UTF, s - oldbp, oldbp));
572         }
573     }
574     PL_bufptr = oldbp;
575 }
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 S_missingterm(pTHX_ char *s)
588 {
589     dVAR;
590     char tmpbuf[3];
591     char q;
592     if (s) {
593         char * const nl = strrchr(s,'\n');
594         if (nl)
595             *nl = '\0';
596     }
597     else if ((U8) PL_multi_close < 32) {
598         *tmpbuf = '^';
599         tmpbuf[1] = (char)toCTRL(PL_multi_close);
600         tmpbuf[2] = '\0';
601         s = tmpbuf;
602     }
603     else {
604         *tmpbuf = (char)PL_multi_close;
605         tmpbuf[1] = '\0';
606         s = tmpbuf;
607     }
608     q = strchr(s,'"') ? '\'' : '"';
609     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 Perl_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
619 {
620     dVAR;
621     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     if (namelen > MAX_FEATURE_LEN)
628         return FALSE;
629     memcpy(&he_name[8], name, namelen);
630
631     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</PL_parser>.  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</PL_parser> 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<line> and I<rsfp>.  I<line>, 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<line>
689 does not affect parsing.  I<rsfp>, 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<line> comes first and must consist of complete lines of input,
692 and I<rsfp> supplies the remainder of the source.
693
694 The I<flags> 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 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
711 {
712     dVAR;
713     const char *s = NULL;
714     yy_parser *parser, *oparser;
715     if (flags && flags & ~LEX_START_FLAGS)
716         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_start");
717
718     /* create and initialise a parser */
719
720     Newxz(parser, 1, yy_parser);
721     parser->old_parser = oparser = PL_parser;
722     PL_parser = parser;
723
724     parser->stack = NULL;
725     parser->ps = NULL;
726     parser->stack_size = 0;
727
728     /* on scope exit, free this parser and restore any outer one */
729     SAVEPARSER(parser);
730     parser->saved_curcop = PL_curcop;
731
732     /* initialise lexer state */
733
734 #ifdef PERL_MAD
735     parser->curforce = -1;
736 #else
737     parser->nexttoke = 0;
738 #endif
739     parser->error_count = oparser ? oparser->error_count : 0;
740     parser->copline = parser->preambling = NOLINE;
741     parser->lex_state = LEX_NORMAL;
742     parser->expect = XSTATE;
743     parser->rsfp = rsfp;
744     parser->rsfp_filters =
745       !(flags & LEX_START_SAME_FILTER) || !oparser
746         ? NULL
747         : MUTABLE_AV(SvREFCNT_inc(
748             oparser->rsfp_filters
749              ? oparser->rsfp_filters
750              : (oparser->rsfp_filters = newAV())
751           ));
752
753     Newx(parser->lex_brackstack, 120, char);
754     Newx(parser->lex_casestack, 12, char);
755     *parser->lex_casestack = '\0';
756     Newxz(parser->lex_shared, 1, LEXSHARED);
757
758     if (line) {
759         STRLEN len;
760         s = SvPV_const(line, len);
761         parser->linestr = flags & LEX_START_COPIED
762                             ? SvREFCNT_inc_simple_NN(line)
763                             : newSVpvn_flags(s, len, SvUTF8(line));
764         sv_catpvn(parser->linestr, "\n;", rsfp ? 1 : 2);
765     } else {
766         parser->linestr = newSVpvn("\n;", rsfp ? 1 : 2);
767     }
768     parser->oldoldbufptr =
769         parser->oldbufptr =
770         parser->bufptr =
771         parser->linestart = SvPVX(parser->linestr);
772     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
773     parser->last_lop = parser->last_uni = NULL;
774     parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
775                                  |LEX_DONT_CLOSE_RSFP);
776
777     parser->in_pod = parser->filtered = 0;
778 }
779
780
781 /* delete a parser object */
782
783 void
784 Perl_parser_free(pTHX_  const yy_parser *parser)
785 {
786     PERL_ARGS_ASSERT_PARSER_FREE;
787
788     PL_curcop = parser->saved_curcop;
789     SvREFCNT_dec(parser->linestr);
790
791     if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
792         PerlIO_clearerr(parser->rsfp);
793     else if (parser->rsfp && (!parser->old_parser ||
794                 (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
795         PerlIO_close(parser->rsfp);
796     SvREFCNT_dec(parser->rsfp_filters);
797     SvREFCNT_dec(parser->lex_stuff);
798     SvREFCNT_dec(parser->sublex_info.repl);
799
800     Safefree(parser->lex_brackstack);
801     Safefree(parser->lex_casestack);
802     Safefree(parser->lex_shared);
803     PL_parser = parser->old_parser;
804     Safefree(parser);
805 }
806
807 void
808 Perl_parser_free_nexttoke_ops(pTHX_  yy_parser *parser, OPSLAB *slab)
809 {
810 #ifdef PERL_MAD
811     I32 nexttoke = parser->lasttoke;
812 #else
813     I32 nexttoke = parser->nexttoke;
814 #endif
815     PERL_ARGS_ASSERT_PARSER_FREE_NEXTTOKE_OPS;
816     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         if (S_is_opval_token(parser->nexttype[nexttoke] & 0xffff)
828          && parser->nextval[nexttoke].opval
829          && parser->nextval[nexttoke].opval->op_slabbed
830          && OpSLAB(parser->nextval[nexttoke].opval) == slab) {
831             op_free(parser->nextval[nexttoke].opval);
832             parser->nextval[nexttoke].opval = NULL;
833         }
834 #endif
835     }
836 }
837
838
839 /*
840 =for apidoc AmxU|SV *|PL_parser-E<gt>linestr
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<SvPOK> 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<char*> pointers to things in the
849 C<PL_parser-E<gt>linestr> buffer.  If C<PL_parser-E<gt>linestr> is ever
850 reallocated, all of these pointers must be updated.  Don't attempt to
851 do this manually, but rather use L</lex_grow_linestr> 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</lex_bufutf8> tells you which.  Do not use the C<SvUTF8>
859 flag on this scalar, which may disagree with it.
860
861 For direct examination of the buffer, the variable
862 L</PL_parser-E<gt>bufend> points to the end of the buffer.  The current
863 lexing position is pointed to by L</PL_parser-E<gt>bufptr>.  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-E<gt>bufend
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 C<SvPVX(PL_parser-E<gt>linestr)
871 + SvCUR(PL_parser-E<gt>linestr)>.  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-E<gt>bufptr
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 C<SvPVX(L</PL_parser-E<gt>linestr>)> and
880 L</PL_parser-E<gt>bufend>.  The octets of the buffer may be intended to be
881 interpreted as either UTF-8 or Latin-1, as indicated by L</lex_bufutf8>.
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</lex_read_to>,
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</lex_peek_unichar> and
891 L</lex_read_unichar>.
892
893 =for apidoc AmxU|char *|PL_parser-E<gt>linestart
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</lex_read_to> 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 (L</PL_parser-E<gt>linestr>) 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<SvUTF8> 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<SvUTF8> flag of the L</PL_parser-E<gt>linestr> 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<SvUTF8> flag is off, but the octets should be interpreted as
919 UTF-8 if the C<use utf8> pragma is in effect.  During a string eval,
920 however, the scalar may have the C<SvUTF8> flag on, and in this case its
921 octets should be interpreted as UTF-8 unless the C<use bytes> 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 Perl_lex_bufutf8(pTHX)
930 {
931     return UTF;
932 }
933
934 /*
935 =for apidoc Amx|char *|lex_grow_linestr|STRLEN len
936
937 Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
938 at least I<len> 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</lex_stuff_pvn> provides a more convenient way to insert text into
942 the buffer.
943
944 Do not use C<SvGROW> or C<sv_grow> directly on C<PL_parser-E<gt>linestr>;
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 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     linestr = PL_parser->linestr;
959     buf = SvPVX(linestr);
960     if (len <= SvLEN(linestr))
961         return buf;
962     bufend_pos = PL_parser->bufend - buf;
963     bufptr_pos = PL_parser->bufptr - buf;
964     oldbufptr_pos = PL_parser->oldbufptr - buf;
965     oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
966     linestart_pos = PL_parser->linestart - buf;
967     last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
968     last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
969     re_eval_start_pos = PL_parser->lex_shared->re_eval_start ?
970                             PL_parser->lex_shared->re_eval_start - buf : 0;
971
972     buf = sv_grow(linestr, len);
973
974     PL_parser->bufend = buf + bufend_pos;
975     PL_parser->bufptr = buf + bufptr_pos;
976     PL_parser->oldbufptr = buf + oldbufptr_pos;
977     PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
978     PL_parser->linestart = buf + linestart_pos;
979     if (PL_parser->last_uni)
980         PL_parser->last_uni = buf + last_uni_pos;
981     if (PL_parser->last_lop)
982         PL_parser->last_lop = buf + last_lop_pos;
983     if (PL_parser->lex_shared->re_eval_start)
984         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 (L</PL_parser-E<gt>linestr>),
992 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
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<len> octets starting
1000 at I<pv>.  These octets are interpreted as either UTF-8 or Latin-1,
1001 according to whether the C<LEX_STUFF_UTF8> flag is set in I<flags>.
1002 The characters are recoded for the lexer buffer, according to how the
1003 buffer is currently being interpreted (L</lex_bufutf8>).  If a string
1004 to be inserted is available as a Perl scalar, the L</lex_stuff_sv>
1005 function is more convenient.
1006
1007 =cut
1008 */
1009
1010 void
1011 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     if (flags & ~(LEX_STUFF_UTF8))
1017         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_pvn");
1018     if (UTF) {
1019         if (flags & LEX_STUFF_UTF8) {
1020             goto plain_copy;
1021         } else {
1022             STRLEN highhalf = 0;    /* Count of variants */
1023             const char *p, *e = pv+len;
1024             for (p = pv; p != e; p++) {
1025                 if (! UTF8_IS_INVARIANT(*p)) {
1026                     highhalf++;
1027                 }
1028             }
1029             if (!highhalf)
1030                 goto plain_copy;
1031             lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len+highhalf);
1032             bufptr = PL_parser->bufptr;
1033             Move(bufptr, bufptr+len+highhalf, PL_parser->bufend+1-bufptr, char);
1034             SvCUR_set(PL_parser->linestr,
1035                 SvCUR(PL_parser->linestr) + len+highhalf);
1036             PL_parser->bufend += len+highhalf;
1037             for (p = pv; p != e; p++) {
1038                 U8 c = (U8)*p;
1039                 if (! UTF8_IS_INVARIANT(c)) {
1040                     *bufptr++ = UTF8_TWO_BYTE_HI(c);
1041                     *bufptr++ = UTF8_TWO_BYTE_LO(c);
1042                 } else {
1043                     *bufptr++ = (char)c;
1044                 }
1045             }
1046         }
1047     } else {
1048         if (flags & LEX_STUFF_UTF8) {
1049             STRLEN highhalf = 0;
1050             const char *p, *e = pv+len;
1051             for (p = pv; p != e; p++) {
1052                 U8 c = (U8)*p;
1053                 if (UTF8_IS_ABOVE_LATIN1(c)) {
1054                     Perl_croak(aTHX_ "Lexing code attempted to stuff "
1055                                 "non-Latin-1 character into Latin-1 input");
1056                 } else if (UTF8_IS_NEXT_CHAR_DOWNGRADEABLE(p, e)) {
1057                     p++;
1058                     highhalf++;
1059                 } else if (! UTF8_IS_INVARIANT(c)) {
1060                     /* malformed UTF-8 */
1061                     ENTER;
1062                     SAVESPTR(PL_warnhook);
1063                     PL_warnhook = PERL_WARNHOOK_FATAL;
1064                     utf8n_to_uvchr((U8*)p, e-p, NULL, 0);
1065                     LEAVE;
1066                 }
1067             }
1068             if (!highhalf)
1069                 goto plain_copy;
1070             lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len-highhalf);
1071             bufptr = PL_parser->bufptr;
1072             Move(bufptr, bufptr+len-highhalf, PL_parser->bufend+1-bufptr, char);
1073             SvCUR_set(PL_parser->linestr,
1074                 SvCUR(PL_parser->linestr) + len-highhalf);
1075             PL_parser->bufend += len-highhalf;
1076             p = pv;
1077             while (p < e) {
1078                 if (UTF8_IS_INVARIANT(*p)) {
1079                     *bufptr++ = *p;
1080                     p++;
1081                 }
1082                 else {
1083                     assert(p < e -1 );
1084                     *bufptr++ = TWO_BYTE_UTF8_TO_NATIVE(*p, *(p+1));
1085                     p += 2;
1086                 }
1087             }
1088         } else {
1089           plain_copy:
1090             lex_grow_linestr(SvCUR(PL_parser->linestr)+1+len);
1091             bufptr = PL_parser->bufptr;
1092             Move(bufptr, bufptr+len, PL_parser->bufend+1-bufptr, char);
1093             SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) + len);
1094             PL_parser->bufend += len;
1095             Copy(pv, bufptr, len, char);
1096         }
1097     }
1098 }
1099
1100 /*
1101 =for apidoc Amx|void|lex_stuff_pv|const char *pv|U32 flags
1102
1103 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1104 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
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<pv>
1112 and continuing to the first nul.  These octets are interpreted as either
1113 UTF-8 or Latin-1, according to whether the C<LEX_STUFF_UTF8> flag is set
1114 in I<flags>.  The characters are recoded for the lexer buffer, according
1115 to how the buffer is currently being interpreted (L</lex_bufutf8>).
1116 If it is not convenient to nul-terminate a string to be inserted, the
1117 L</lex_stuff_pvn> function is more appropriate.
1118
1119 =cut
1120 */
1121
1122 void
1123 Perl_lex_stuff_pv(pTHX_ const char *pv, U32 flags)
1124 {
1125     PERL_ARGS_ASSERT_LEX_STUFF_PV;
1126     lex_stuff_pvn(pv, strlen(pv), flags);
1127 }
1128
1129 /*
1130 =for apidoc Amx|void|lex_stuff_sv|SV *sv|U32 flags
1131
1132 Insert characters into the lexer buffer (L</PL_parser-E<gt>linestr>),
1133 immediately after the current lexing point (L</PL_parser-E<gt>bufptr>),
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<sv>.  The characters
1141 are recoded for the lexer buffer, according to how the buffer is currently
1142 being interpreted (L</lex_bufutf8>).  If a string to be inserted is
1143 not already a Perl scalar, the L</lex_stuff_pvn> function avoids the
1144 need to construct a scalar.
1145
1146 =cut
1147 */
1148
1149 void
1150 Perl_lex_stuff_sv(pTHX_ SV *sv, U32 flags)
1151 {
1152     char *pv;
1153     STRLEN len;
1154     PERL_ARGS_ASSERT_LEX_STUFF_SV;
1155     if (flags)
1156         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_stuff_sv");
1157     pv = SvPV(sv, len);
1158     lex_stuff_pvn(pv, len, flags | (SvUTF8(sv) ? LEX_STUFF_UTF8 : 0));
1159 }
1160
1161 /*
1162 =for apidoc Amx|void|lex_unstuff|char *ptr
1163
1164 Discards text about to be lexed, from L</PL_parser-E<gt>bufptr> up to
1165 I<ptr>.  Text following I<ptr> 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</lex_read_to>.
1171
1172 =cut
1173 */
1174
1175 void
1176 Perl_lex_unstuff(pTHX_ char *ptr)
1177 {
1178     char *buf, *bufend;
1179     STRLEN unstuff_len;
1180     PERL_ARGS_ASSERT_LEX_UNSTUFF;
1181     buf = PL_parser->bufptr;
1182     if (ptr < buf)
1183         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1184     if (ptr == buf)
1185         return;
1186     bufend = PL_parser->bufend;
1187     if (ptr > bufend)
1188         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_unstuff");
1189     unstuff_len = ptr - buf;
1190     Move(ptr, buf, bufend+1-ptr, char);
1191     SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - unstuff_len);
1192     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 L</PL_parser-E<gt>bufptr> up
1199 to I<ptr>.  This advances L</PL_parser-E<gt>bufptr> to match I<ptr>,
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</lex_peek_unichar> and
1205 L</lex_read_unichar>.
1206
1207 =cut
1208 */
1209
1210 void
1211 Perl_lex_read_to(pTHX_ char *ptr)
1212 {
1213     char *s;
1214     PERL_ARGS_ASSERT_LEX_READ_TO;
1215     s = PL_parser->bufptr;
1216     if (ptr < s || ptr > PL_parser->bufend)
1217         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_to");
1218     for (; s != ptr; s++)
1219         if (*s == '\n') {
1220             COPLINE_INC_WITH_HERELINES;
1221             PL_parser->linestart = s+1;
1222         }
1223     PL_parser->bufptr = ptr;
1224 }
1225
1226 /*
1227 =for apidoc Amx|void|lex_discard_to|char *ptr
1228
1229 Discards the first part of the L</PL_parser-E<gt>linestr> buffer,
1230 up to I<ptr>.  The remaining content of the buffer will be moved, and
1231 all pointers into the buffer updated appropriately.  I<ptr> must not
1232 be later in the buffer than the position of L</PL_parser-E<gt>bufptr>:
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</lex_next_chunk> 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 Perl_lex_discard_to(pTHX_ char *ptr)
1248 {
1249     char *buf;
1250     STRLEN discard_len;
1251     PERL_ARGS_ASSERT_LEX_DISCARD_TO;
1252     buf = SvPVX(PL_parser->linestr);
1253     if (ptr < buf)
1254         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1255     if (ptr == buf)
1256         return;
1257     if (ptr > PL_parser->bufptr)
1258         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_discard_to");
1259     discard_len = ptr - buf;
1260     if (PL_parser->oldbufptr < ptr)
1261         PL_parser->oldbufptr = ptr;
1262     if (PL_parser->oldoldbufptr < ptr)
1263         PL_parser->oldoldbufptr = ptr;
1264     if (PL_parser->last_uni && PL_parser->last_uni < ptr)
1265         PL_parser->last_uni = NULL;
1266     if (PL_parser->last_lop && PL_parser->last_lop < ptr)
1267         PL_parser->last_lop = NULL;
1268     Move(ptr, buf, PL_parser->bufend+1-ptr, char);
1269     SvCUR_set(PL_parser->linestr, SvCUR(PL_parser->linestr) - discard_len);
1270     PL_parser->bufend -= discard_len;
1271     PL_parser->bufptr -= discard_len;
1272     PL_parser->oldbufptr -= discard_len;
1273     PL_parser->oldoldbufptr -= discard_len;
1274     if (PL_parser->last_uni)
1275         PL_parser->last_uni -= discard_len;
1276     if (PL_parser->last_lop)
1277         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 L</PL_parser-E<gt>linestr>.  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 L</PL_parser-E<gt>bufptr> 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<flags> includes C<LEX_KEEP_PREVIOUS>, 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 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     if (flags & ~(LEX_KEEP_PREVIOUS|LEX_FAKE_EOF|LEX_NO_TERM))
1316         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_next_chunk");
1317     linestr = PL_parser->linestr;
1318     buf = SvPVX(linestr);
1319     if (!(flags & LEX_KEEP_PREVIOUS) &&
1320             PL_parser->bufptr == PL_parser->bufend) {
1321         old_bufend_pos = bufptr_pos = oldbufptr_pos = oldoldbufptr_pos = 0;
1322         linestart_pos = 0;
1323         if (PL_parser->last_uni != PL_parser->bufend)
1324             PL_parser->last_uni = NULL;
1325         if (PL_parser->last_lop != PL_parser->bufend)
1326             PL_parser->last_lop = NULL;
1327         last_uni_pos = last_lop_pos = 0;
1328         *buf = 0;
1329         SvCUR(linestr) = 0;
1330     } else {
1331         old_bufend_pos = PL_parser->bufend - buf;
1332         bufptr_pos = PL_parser->bufptr - buf;
1333         oldbufptr_pos = PL_parser->oldbufptr - buf;
1334         oldoldbufptr_pos = PL_parser->oldoldbufptr - buf;
1335         linestart_pos = PL_parser->linestart - buf;
1336         last_uni_pos = PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
1337         last_lop_pos = PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
1338     }
1339     if (flags & LEX_FAKE_EOF) {
1340         goto eof;
1341     } else if (!PL_parser->rsfp && !PL_parser->filtered) {
1342         got_some = 0;
1343     } else if (filter_gets(linestr, old_bufend_pos)) {
1344         got_some = 1;
1345         got_some_for_debugger = 1;
1346     } else if (flags & LEX_NO_TERM) {
1347         got_some = 0;
1348     } else {
1349         if (!SvPOK(linestr))   /* can get undefined by filter_gets */
1350             sv_setpvs(linestr, "");
1351         eof:
1352         /* End of real input.  Close filehandle (unless it was STDIN),
1353          * then add implicit termination.
1354          */
1355         if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
1356             PerlIO_clearerr(PL_parser->rsfp);
1357         else if (PL_parser->rsfp)
1358             (void)PerlIO_close(PL_parser->rsfp);
1359         PL_parser->rsfp = NULL;
1360         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         if (!PL_in_eval && PL_minus_p) {
1366             sv_catpvs(linestr,
1367                 /*{*/";}continue{print or die qq(-p destination: $!\\n);}");
1368             PL_minus_n = PL_minus_p = 0;
1369         } else if (!PL_in_eval && PL_minus_n) {
1370             sv_catpvs(linestr, /*{*/";}");
1371             PL_minus_n = 0;
1372         } else
1373             sv_catpvs(linestr, ";");
1374         got_some = 1;
1375     }
1376     buf = SvPVX(linestr);
1377     new_bufend_pos = SvCUR(linestr);
1378     PL_parser->bufend = buf + new_bufend_pos;
1379     PL_parser->bufptr = buf + bufptr_pos;
1380     PL_parser->oldbufptr = buf + oldbufptr_pos;
1381     PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
1382     PL_parser->linestart = buf + linestart_pos;
1383     if (PL_parser->last_uni)
1384         PL_parser->last_uni = buf + last_uni_pos;
1385     if (PL_parser->last_lop)
1386         PL_parser->last_lop = buf + last_lop_pos;
1387     if (PL_parser->preambling != NOLINE) {
1388         CopLINE_set(PL_curcop, PL_parser->preambling + 1);
1389         PL_parser->preambling = NOLINE;
1390     }
1391     if (got_some_for_debugger && (PERLDB_LINE || PERLDB_SAVESRC) &&
1392             PL_curstash != PL_debstash) {
1393         /* debugger active and we're not compiling the debugger code,
1394          * so store the line into the debugger's array of lines
1395          */
1396         update_debugger_info(NULL, buf+old_bufend_pos,
1397             new_bufend_pos-old_bufend_pos);
1398     }
1399     return got_some;
1400 }
1401
1402 /*
1403 =for apidoc Amx|I32|lex_peek_unichar|U32 flags
1404
1405 Looks ahead one (Unicode) character in the text currently being lexed.
1406 Returns the codepoint (unsigned integer value) of the next character,
1407 or -1 if lexing has reached the end of the input text.  To consume the
1408 peeked character, use L</lex_read_unichar>.
1409
1410 If the next character is in (or extends into) the next chunk of input
1411 text, the next chunk will be read in.  Normally the current chunk will be
1412 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1413 then the current chunk will not be discarded.
1414
1415 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1416 is encountered, an exception is generated.
1417
1418 =cut
1419 */
1420
1421 I32
1422 Perl_lex_peek_unichar(pTHX_ U32 flags)
1423 {
1424     dVAR;
1425     char *s, *bufend;
1426     if (flags & ~(LEX_KEEP_PREVIOUS))
1427         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_peek_unichar");
1428     s = PL_parser->bufptr;
1429     bufend = PL_parser->bufend;
1430     if (UTF) {
1431         U8 head;
1432         I32 unichar;
1433         STRLEN len, retlen;
1434         if (s == bufend) {
1435             if (!lex_next_chunk(flags))
1436                 return -1;
1437             s = PL_parser->bufptr;
1438             bufend = PL_parser->bufend;
1439         }
1440         head = (U8)*s;
1441         if (UTF8_IS_INVARIANT(head))
1442             return head;
1443         if (UTF8_IS_START(head)) {
1444             len = UTF8SKIP(&head);
1445             while ((STRLEN)(bufend-s) < len) {
1446                 if (!lex_next_chunk(flags | LEX_KEEP_PREVIOUS))
1447                     break;
1448                 s = PL_parser->bufptr;
1449                 bufend = PL_parser->bufend;
1450             }
1451         }
1452         unichar = utf8n_to_uvchr((U8*)s, bufend-s, &retlen, UTF8_CHECK_ONLY);
1453         if (retlen == (STRLEN)-1) {
1454             /* malformed UTF-8 */
1455             ENTER;
1456             SAVESPTR(PL_warnhook);
1457             PL_warnhook = PERL_WARNHOOK_FATAL;
1458             utf8n_to_uvchr((U8*)s, bufend-s, NULL, 0);
1459             LEAVE;
1460         }
1461         return unichar;
1462     } else {
1463         if (s == bufend) {
1464             if (!lex_next_chunk(flags))
1465                 return -1;
1466             s = PL_parser->bufptr;
1467         }
1468         return (U8)*s;
1469     }
1470 }
1471
1472 /*
1473 =for apidoc Amx|I32|lex_read_unichar|U32 flags
1474
1475 Reads the next (Unicode) character in the text currently being lexed.
1476 Returns the codepoint (unsigned integer value) of the character read,
1477 and moves L</PL_parser-E<gt>bufptr> past the character, or returns -1
1478 if lexing has reached the end of the input text.  To non-destructively
1479 examine the next character, use L</lex_peek_unichar> instead.
1480
1481 If the next character is in (or extends into) the next chunk of input
1482 text, the next chunk will be read in.  Normally the current chunk will be
1483 discarded at the same time, but if I<flags> includes C<LEX_KEEP_PREVIOUS>
1484 then the current chunk will not be discarded.
1485
1486 If the input is being interpreted as UTF-8 and a UTF-8 encoding error
1487 is encountered, an exception is generated.
1488
1489 =cut
1490 */
1491
1492 I32
1493 Perl_lex_read_unichar(pTHX_ U32 flags)
1494 {
1495     I32 c;
1496     if (flags & ~(LEX_KEEP_PREVIOUS))
1497         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_unichar");
1498     c = lex_peek_unichar(flags);
1499     if (c != -1) {
1500         if (c == '\n')
1501             COPLINE_INC_WITH_HERELINES;
1502         if (UTF)
1503             PL_parser->bufptr += UTF8SKIP(PL_parser->bufptr);
1504         else
1505             ++(PL_parser->bufptr);
1506     }
1507     return c;
1508 }
1509
1510 /*
1511 =for apidoc Amx|void|lex_read_space|U32 flags
1512
1513 Reads optional spaces, in Perl style, in the text currently being
1514 lexed.  The spaces may include ordinary whitespace characters and
1515 Perl-style comments.  C<#line> directives are processed if encountered.
1516 L</PL_parser-E<gt>bufptr> is moved past the spaces, so that it points
1517 at a non-space character (or the end of the input text).
1518
1519 If spaces extend into the next chunk of input text, the next chunk will
1520 be read in.  Normally the current chunk will be discarded at the same
1521 time, but if I<flags> includes C<LEX_KEEP_PREVIOUS> then the current
1522 chunk will not be discarded.
1523
1524 =cut
1525 */
1526
1527 #define LEX_NO_INCLINE    0x40000000
1528 #define LEX_NO_NEXT_CHUNK 0x80000000
1529
1530 void
1531 Perl_lex_read_space(pTHX_ U32 flags)
1532 {
1533     char *s, *bufend;
1534     const bool can_incline = !(flags & LEX_NO_INCLINE);
1535     bool need_incline = 0;
1536     if (flags & ~(LEX_KEEP_PREVIOUS|LEX_NO_NEXT_CHUNK|LEX_NO_INCLINE))
1537         Perl_croak(aTHX_ "Lexing code internal error (%s)", "lex_read_space");
1538 #ifdef PERL_MAD
1539     if (PL_skipwhite) {
1540         sv_free(PL_skipwhite);
1541         PL_skipwhite = NULL;
1542     }
1543     if (PL_madskills)
1544         PL_skipwhite = newSVpvs("");
1545 #endif /* PERL_MAD */
1546     s = PL_parser->bufptr;
1547     bufend = PL_parser->bufend;
1548     while (1) {
1549         char c = *s;
1550         if (c == '#') {
1551             do {
1552                 c = *++s;
1553             } while (!(c == '\n' || (c == 0 && s == bufend)));
1554         } else if (c == '\n') {
1555             s++;
1556             if (can_incline) {
1557                 PL_parser->linestart = s;
1558                 if (s == bufend)
1559                     need_incline = 1;
1560                 else
1561                     incline(s);
1562             }
1563         } else if (isSPACE(c)) {
1564             s++;
1565         } else if (c == 0 && s == bufend) {
1566             bool got_more;
1567             line_t l;
1568 #ifdef PERL_MAD
1569             if (PL_madskills)
1570                 sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1571 #endif /* PERL_MAD */
1572             if (flags & LEX_NO_NEXT_CHUNK)
1573                 break;
1574             PL_parser->bufptr = s;
1575             l = CopLINE(PL_curcop);
1576             CopLINE(PL_curcop) += PL_parser->herelines + 1;
1577             got_more = lex_next_chunk(flags);
1578             CopLINE_set(PL_curcop, l);
1579             s = PL_parser->bufptr;
1580             bufend = PL_parser->bufend;
1581             if (!got_more)
1582                 break;
1583             if (can_incline && need_incline && PL_parser->rsfp) {
1584                 incline(s);
1585                 need_incline = 0;
1586             }
1587         } else {
1588             break;
1589         }
1590     }
1591 #ifdef PERL_MAD
1592     if (PL_madskills)
1593         sv_catpvn(PL_skipwhite, PL_parser->bufptr, s-PL_parser->bufptr);
1594 #endif /* PERL_MAD */
1595     PL_parser->bufptr = s;
1596 }
1597
1598 /*
1599
1600 =for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
1601
1602 This function performs syntax checking on a prototype, C<proto>.
1603 If C<warn> is true, any illegal characters or mismatched brackets
1604 will trigger illegalproto warnings, declaring that they were
1605 detected in the prototype for C<name>.
1606
1607 The return value is C<true> if this is a valid prototype, and
1608 C<false> if it is not, regardless of whether C<warn> was C<true> or
1609 C<false>.
1610
1611 Note that C<NULL> is a valid C<proto> and will always return C<true>.
1612
1613 =cut
1614
1615  */
1616
1617 bool
1618 Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
1619 {
1620     STRLEN len, origlen;
1621     char *p = proto ? SvPV(proto, len) : NULL;
1622     bool bad_proto = FALSE;
1623     bool in_brackets = FALSE;
1624     bool after_slash = FALSE;
1625     char greedy_proto = ' ';
1626     bool proto_after_greedy_proto = FALSE;
1627     bool must_be_last = FALSE;
1628     bool underscore = FALSE;
1629     bool bad_proto_after_underscore = FALSE;
1630
1631     PERL_ARGS_ASSERT_VALIDATE_PROTO;
1632
1633     if (!proto)
1634         return TRUE;
1635
1636     origlen = len;
1637     for (; len--; p++) {
1638         if (!isSPACE(*p)) {
1639             if (must_be_last)
1640                 proto_after_greedy_proto = TRUE;
1641             if (underscore) {
1642                 if (!strchr(";@%", *p))
1643                     bad_proto_after_underscore = TRUE;
1644                 underscore = FALSE;
1645             }
1646             if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
1647                 bad_proto = TRUE;
1648             }
1649             else {
1650                 if (*p == '[')
1651                     in_brackets = TRUE;
1652                 else if (*p == ']')
1653                     in_brackets = FALSE;
1654                 else if ((*p == '@' || *p == '%') &&
1655                     !after_slash &&
1656                     !in_brackets ) {
1657                     must_be_last = TRUE;
1658                     greedy_proto = *p;
1659                 }
1660                 else if (*p == '_')
1661                     underscore = TRUE;
1662             }
1663             if (*p == '\\')
1664                 after_slash = TRUE;
1665             else
1666                 after_slash = FALSE;
1667         }
1668     }
1669
1670     if (warn) {
1671         SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
1672         p -= origlen;
1673         p = SvUTF8(proto)
1674             ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
1675                              origlen, UNI_DISPLAY_ISPRINT)
1676             : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
1677
1678         if (proto_after_greedy_proto)
1679             Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1680                         "Prototype after '%c' for %"SVf" : %s",
1681                         greedy_proto, SVfARG(name), p);
1682         if (in_brackets)
1683             Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1684                         "Missing ']' in prototype for %"SVf" : %s",
1685                         SVfARG(name), p);
1686         if (bad_proto)
1687             Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1688                         "Illegal character in prototype for %"SVf" : %s",
1689                         SVfARG(name), p);
1690         if (bad_proto_after_underscore)
1691             Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
1692                         "Illegal character after '_' in prototype for %"SVf" : %s",
1693                         SVfARG(name), p);
1694     }
1695
1696     return (! (proto_after_greedy_proto || bad_proto) );
1697 }
1698
1699 /*
1700  * S_incline
1701  * This subroutine has nothing to do with tilting, whether at windmills
1702  * or pinball tables.  Its name is short for "increment line".  It
1703  * increments the current line number in CopLINE(PL_curcop) and checks
1704  * to see whether the line starts with a comment of the form
1705  *    # line 500 "foo.pm"
1706  * If so, it sets the current line number and file to the values in the comment.
1707  */
1708
1709 STATIC void
1710 S_incline(pTHX_ const char *s)
1711 {
1712     dVAR;
1713     const char *t;
1714     const char *n;
1715     const char *e;
1716     line_t line_num;
1717
1718     PERL_ARGS_ASSERT_INCLINE;
1719
1720     COPLINE_INC_WITH_HERELINES;
1721     if (!PL_rsfp && !PL_parser->filtered && PL_lex_state == LEX_NORMAL
1722      && s+1 == PL_bufend && *s == ';') {
1723         /* fake newline in string eval */
1724         CopLINE_dec(PL_curcop);
1725         return;
1726     }
1727     if (*s++ != '#')
1728         return;
1729     while (SPACE_OR_TAB(*s))
1730         s++;
1731     if (strnEQ(s, "line", 4))
1732         s += 4;
1733     else
1734         return;
1735     if (SPACE_OR_TAB(*s))
1736         s++;
1737     else
1738         return;
1739     while (SPACE_OR_TAB(*s))
1740         s++;
1741     if (!isDIGIT(*s))
1742         return;
1743
1744     n = s;
1745     while (isDIGIT(*s))
1746         s++;
1747     if (!SPACE_OR_TAB(*s) && *s != '\r' && *s != '\n' && *s != '\0')
1748         return;
1749     while (SPACE_OR_TAB(*s))
1750         s++;
1751     if (*s == '"' && (t = strchr(s+1, '"'))) {
1752         s++;
1753         e = t + 1;
1754     }
1755     else {
1756         t = s;
1757         while (!isSPACE(*t))
1758             t++;
1759         e = t;
1760     }
1761     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
1762         e++;
1763     if (*e != '\n' && *e != '\0')
1764         return;         /* false alarm */
1765
1766     line_num = atoi(n)-1;
1767
1768     if (t - s > 0) {
1769         const STRLEN len = t - s;
1770
1771         if (!PL_rsfp && !PL_parser->filtered) {
1772             /* must copy *{"::_<(eval N)[oldfilename:L]"}
1773              * to *{"::_<newfilename"} */
1774             /* However, the long form of evals is only turned on by the
1775                debugger - usually they're "(eval %lu)" */
1776             GV * const cfgv = CopFILEGV(PL_curcop);
1777             if (cfgv) {
1778                 char smallbuf[128];
1779                 STRLEN tmplen2 = len;
1780                 char *tmpbuf2;
1781                 GV *gv2;
1782
1783                 if (tmplen2 + 2 <= sizeof smallbuf)
1784                     tmpbuf2 = smallbuf;
1785                 else
1786                     Newx(tmpbuf2, tmplen2 + 2, char);
1787
1788                 tmpbuf2[0] = '_';
1789                 tmpbuf2[1] = '<';
1790
1791                 memcpy(tmpbuf2 + 2, s, tmplen2);
1792                 tmplen2 += 2;
1793
1794                 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
1795                 if (!isGV(gv2)) {
1796                     gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
1797                     /* adjust ${"::_<newfilename"} to store the new file name */
1798                     GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
1799                     /* The line number may differ. If that is the case,
1800                        alias the saved lines that are in the array.
1801                        Otherwise alias the whole array. */
1802                     if (CopLINE(PL_curcop) == line_num) {
1803                         GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(cfgv)));
1804                         GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(cfgv)));
1805                     }
1806                     else if (GvAV(cfgv)) {
1807                         AV * const av = GvAV(cfgv);
1808                         const I32 start = CopLINE(PL_curcop)+1;
1809                         I32 items = AvFILLp(av) - start;
1810                         if (items > 0) {
1811                             AV * const av2 = GvAVn(gv2);
1812                             SV **svp = AvARRAY(av) + start;
1813                             I32 l = (I32)line_num+1;
1814                             while (items--)
1815                                 av_store(av2, l++, SvREFCNT_inc(*svp++));
1816                         }
1817                     }
1818                 }
1819
1820                 if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
1821             }
1822         }
1823         CopFILE_free(PL_curcop);
1824         CopFILE_setn(PL_curcop, s, len);
1825     }
1826     CopLINE_set(PL_curcop, line_num);
1827 }
1828
1829 #define skipspace(s) skipspace_flags(s, 0)
1830
1831 #ifdef PERL_MAD
1832 /* skip space before PL_thistoken */
1833
1834 STATIC char *
1835 S_skipspace0(pTHX_ char *s)
1836 {
1837     PERL_ARGS_ASSERT_SKIPSPACE0;
1838
1839     s = skipspace(s);
1840     if (!PL_madskills)
1841         return s;
1842     if (PL_skipwhite) {
1843         if (!PL_thiswhite)
1844             PL_thiswhite = newSVpvs("");
1845         sv_catsv(PL_thiswhite, PL_skipwhite);
1846         sv_free(PL_skipwhite);
1847         PL_skipwhite = 0;
1848     }
1849     PL_realtokenstart = s - SvPVX(PL_linestr);
1850     return s;
1851 }
1852
1853 /* skip space after PL_thistoken */
1854
1855 STATIC char *
1856 S_skipspace1(pTHX_ char *s)
1857 {
1858     const char *start = s;
1859     I32 startoff = start - SvPVX(PL_linestr);
1860
1861     PERL_ARGS_ASSERT_SKIPSPACE1;
1862
1863     s = skipspace(s);
1864     if (!PL_madskills)
1865         return s;
1866     start = SvPVX(PL_linestr) + startoff;
1867     if (!PL_thistoken && PL_realtokenstart >= 0) {
1868         const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1869         PL_thistoken = newSVpvn(tstart, start - tstart);
1870     }
1871     PL_realtokenstart = -1;
1872     if (PL_skipwhite) {
1873         if (!PL_nextwhite)
1874             PL_nextwhite = newSVpvs("");
1875         sv_catsv(PL_nextwhite, PL_skipwhite);
1876         sv_free(PL_skipwhite);
1877         PL_skipwhite = 0;
1878     }
1879     return s;
1880 }
1881
1882 STATIC char *
1883 S_skipspace2(pTHX_ char *s, SV **svp)
1884 {
1885     char *start;
1886     const I32 startoff = s - SvPVX(PL_linestr);
1887
1888     PERL_ARGS_ASSERT_SKIPSPACE2;
1889
1890     s = skipspace(s);
1891     if (!PL_madskills || !svp)
1892         return s;
1893     start = SvPVX(PL_linestr) + startoff;
1894     if (!PL_thistoken && PL_realtokenstart >= 0) {
1895         char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
1896         PL_thistoken = newSVpvn(tstart, start - tstart);
1897         PL_realtokenstart = -1;
1898     }
1899     if (PL_skipwhite) {
1900         if (!*svp)
1901             *svp = newSVpvs("");
1902         sv_setsv(*svp, PL_skipwhite);
1903         sv_free(PL_skipwhite);
1904         PL_skipwhite = 0;
1905     }
1906     
1907     return s;
1908 }
1909 #endif
1910
1911 STATIC void
1912 S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
1913 {
1914     AV *av = CopFILEAVx(PL_curcop);
1915     if (av) {
1916         SV * sv;
1917         if (PL_parser->preambling == NOLINE) sv = newSV_type(SVt_PVMG);
1918         else {
1919             sv = *av_fetch(av, 0, 1);
1920             SvUPGRADE(sv, SVt_PVMG);
1921         }
1922         if (!SvPOK(sv)) sv_setpvs(sv,"");
1923         if (orig_sv)
1924             sv_catsv(sv, orig_sv);
1925         else
1926             sv_catpvn(sv, buf, len);
1927         if (!SvIOK(sv)) {
1928             (void)SvIOK_on(sv);
1929             SvIV_set(sv, 0);
1930         }
1931         if (PL_parser->preambling == NOLINE)
1932             av_store(av, CopLINE(PL_curcop), sv);
1933     }
1934 }
1935
1936 /*
1937  * S_skipspace
1938  * Called to gobble the appropriate amount and type of whitespace.
1939  * Skips comments as well.
1940  */
1941
1942 STATIC char *
1943 S_skipspace_flags(pTHX_ char *s, U32 flags)
1944 {
1945 #ifdef PERL_MAD
1946     char *start = s;
1947 #endif /* PERL_MAD */
1948     PERL_ARGS_ASSERT_SKIPSPACE_FLAGS;
1949 #ifdef PERL_MAD
1950     if (PL_skipwhite) {
1951         sv_free(PL_skipwhite);
1952         PL_skipwhite = NULL;
1953     }
1954 #endif /* PERL_MAD */
1955     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
1956         while (s < PL_bufend && SPACE_OR_TAB(*s))
1957             s++;
1958     } else {
1959         STRLEN bufptr_pos = PL_bufptr - SvPVX(PL_linestr);
1960         PL_bufptr = s;
1961         lex_read_space(flags | LEX_KEEP_PREVIOUS |
1962                 (PL_sublex_info.sub_inwhat || PL_lex_state == LEX_FORMLINE ?
1963                     LEX_NO_NEXT_CHUNK : 0));
1964         s = PL_bufptr;
1965         PL_bufptr = SvPVX(PL_linestr) + bufptr_pos;
1966         if (PL_linestart > PL_bufptr)
1967             PL_bufptr = PL_linestart;
1968         return s;
1969     }
1970 #ifdef PERL_MAD
1971     if (PL_madskills)
1972         PL_skipwhite = newSVpvn(start, s-start);
1973 #endif /* PERL_MAD */
1974     return s;
1975 }
1976
1977 /*
1978  * S_check_uni
1979  * Check the unary operators to ensure there's no ambiguity in how they're
1980  * used.  An ambiguous piece of code would be:
1981  *     rand + 5
1982  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
1983  * the +5 is its argument.
1984  */
1985
1986 STATIC void
1987 S_check_uni(pTHX)
1988 {
1989     dVAR;
1990     const char *s;
1991     const char *t;
1992
1993     if (PL_oldoldbufptr != PL_last_uni)
1994         return;
1995     while (isSPACE(*PL_last_uni))
1996         PL_last_uni++;
1997     s = PL_last_uni;
1998     while (isWORDCHAR_lazy_if(s,UTF) || *s == '-')
1999         s++;
2000     if ((t = strchr(s, '(')) && t < PL_bufptr)
2001         return;
2002
2003     Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
2004                      "Warning: Use of \"%.*s\" without parentheses is ambiguous",
2005                      (int)(s - PL_last_uni), PL_last_uni);
2006 }
2007
2008 /*
2009  * LOP : macro to build a list operator.  Its behaviour has been replaced
2010  * with a subroutine, S_lop() for which LOP is just another name.
2011  */
2012
2013 #define LOP(f,x) return lop(f,x,s)
2014
2015 /*
2016  * S_lop
2017  * Build a list operator (or something that might be one).  The rules:
2018  *  - if we have a next token, then it's a list operator [why?]
2019  *  - if the next thing is an opening paren, then it's a function
2020  *  - else it's a list operator
2021  */
2022
2023 STATIC I32
2024 S_lop(pTHX_ I32 f, int x, char *s)
2025 {
2026     dVAR;
2027
2028     PERL_ARGS_ASSERT_LOP;
2029
2030     pl_yylval.ival = f;
2031     CLINE;
2032     PL_expect = x;
2033     PL_bufptr = s;
2034     PL_last_lop = PL_oldbufptr;
2035     PL_last_lop_op = (OPCODE)f;
2036 #ifdef PERL_MAD
2037     if (PL_lasttoke)
2038         goto lstop;
2039 #else
2040     if (PL_nexttoke)
2041         goto lstop;
2042 #endif
2043     if (*s == '(')
2044         return REPORT(FUNC);
2045     s = PEEKSPACE(s);
2046     if (*s == '(')
2047         return REPORT(FUNC);
2048     else {
2049         lstop:
2050         if (!PL_lex_allbrackets && PL_lex_fakeeof > LEX_FAKEEOF_LOWLOGIC)
2051             PL_lex_fakeeof = LEX_FAKEEOF_LOWLOGIC;
2052         return REPORT(LSTOP);
2053     }
2054 }
2055
2056 #ifdef PERL_MAD
2057  /*
2058  * S_start_force
2059  * Sets up for an eventual force_next().  start_force(0) basically does
2060  * an unshift, while start_force(-1) does a push.  yylex removes items
2061  * on the "pop" end.
2062  */
2063
2064 STATIC void
2065 S_start_force(pTHX_ int where)
2066 {
2067     int i;
2068
2069     if (where < 0)      /* so people can duplicate start_force(PL_curforce) */
2070         where = PL_lasttoke;
2071     assert(PL_curforce < 0 || PL_curforce == where);
2072     if (PL_curforce != where) {
2073         for (i = PL_lasttoke; i > where; --i) {
2074             PL_nexttoke[i] = PL_nexttoke[i-1];
2075         }
2076         PL_lasttoke++;
2077     }
2078     if (PL_curforce < 0)        /* in case of duplicate start_force() */
2079         Zero(&PL_nexttoke[where], 1, NEXTTOKE);
2080     PL_curforce = where;
2081     if (PL_nextwhite) {
2082         if (PL_madskills)
2083             curmad('^', newSVpvs(""));
2084         CURMAD('_', PL_nextwhite);
2085     }
2086 }
2087
2088 STATIC void
2089 S_curmad(pTHX_ char slot, SV *sv)
2090 {
2091     MADPROP **where;
2092
2093     if (!sv)
2094         return;
2095     if (PL_curforce < 0)
2096         where = &PL_thismad;
2097     else
2098         where = &PL_nexttoke[PL_curforce].next_mad;
2099
2100     if (PL_faketokens)
2101         sv_setpvs(sv, "");
2102     else {
2103         if (!IN_BYTES) {
2104             if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
2105                 SvUTF8_on(sv);
2106             else if (PL_encoding) {
2107                 sv_recode_to_utf8(sv, PL_encoding);
2108             }
2109         }
2110     }
2111
2112     /* keep a slot open for the head of the list? */
2113     if (slot != '_' && *where && (*where)->mad_key == '^') {
2114         (*where)->mad_key = slot;
2115         sv_free(MUTABLE_SV(((*where)->mad_val)));
2116         (*where)->mad_val = (void*)sv;
2117     }
2118     else
2119         addmad(newMADsv(slot, sv), where, 0);
2120 }
2121 #else
2122 #  define start_force(where)    NOOP
2123 #  define curmad(slot, sv)      NOOP
2124 #endif
2125
2126 /*
2127  * S_force_next
2128  * When the lexer realizes it knows the next token (for instance,
2129  * it is reordering tokens for the parser) then it can call S_force_next
2130  * to know what token to return the next time the lexer is called.  Caller
2131  * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
2132  * and possibly PL_expect to ensure the lexer handles the token correctly.
2133  */
2134
2135 STATIC void
2136 S_force_next(pTHX_ I32 type)
2137 {
2138     dVAR;
2139 #ifdef DEBUGGING
2140     if (DEBUG_T_TEST) {
2141         PerlIO_printf(Perl_debug_log, "### forced token:\n");
2142         tokereport(type, &NEXTVAL_NEXTTOKE);
2143     }
2144 #endif
2145 #ifdef PERL_MAD
2146     if (PL_curforce < 0)
2147         start_force(PL_lasttoke);
2148     PL_nexttoke[PL_curforce].next_type = type;
2149     if (PL_lex_state != LEX_KNOWNEXT)
2150         PL_lex_defer = PL_lex_state;
2151     PL_lex_state = LEX_KNOWNEXT;
2152     PL_lex_expect = PL_expect;
2153     PL_curforce = -1;
2154 #else
2155     PL_nexttype[PL_nexttoke] = type;
2156     PL_nexttoke++;
2157     if (PL_lex_state != LEX_KNOWNEXT) {
2158         PL_lex_defer = PL_lex_state;
2159         PL_lex_expect = PL_expect;
2160         PL_lex_state = LEX_KNOWNEXT;
2161     }
2162 #endif
2163 }
2164
2165 void
2166 Perl_yyunlex(pTHX)
2167 {
2168     int yyc = PL_parser->yychar;
2169     if (yyc != YYEMPTY) {
2170         if (yyc) {
2171             start_force(-1);
2172             NEXTVAL_NEXTTOKE = PL_parser->yylval;
2173             if (yyc == '{'/*}*/ || yyc == HASHBRACK || yyc == '['/*]*/) {
2174                 PL_lex_allbrackets--;
2175                 PL_lex_brackets--;
2176                 yyc |= (3<<24) | (PL_lex_brackstack[PL_lex_brackets] << 16);
2177             } else if (yyc == '('/*)*/) {
2178                 PL_lex_allbrackets--;
2179                 yyc |= (2<<24);
2180             }
2181             force_next(yyc);
2182         }
2183         PL_parser->yychar = YYEMPTY;
2184     }
2185 }
2186
2187 STATIC SV *
2188 S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
2189 {
2190     dVAR;
2191     SV * const sv = newSVpvn_utf8(start, len,
2192                                   !IN_BYTES
2193                                   && UTF
2194                                   && !is_ascii_string((const U8*)start, len)
2195                                   && is_utf8_string((const U8*)start, len));
2196     return sv;
2197 }
2198
2199 /*
2200  * S_force_word
2201  * When the lexer knows the next thing is a word (for instance, it has
2202  * just seen -> and it knows that the next char is a word char, then
2203  * it calls S_force_word to stick the next word into the PL_nexttoke/val
2204  * lookahead.
2205  *
2206  * Arguments:
2207  *   char *start : buffer position (must be within PL_linestr)
2208  *   int token   : PL_next* will be this type of bare word (e.g., METHOD,WORD)
2209  *   int check_keyword : if true, Perl checks to make sure the word isn't
2210  *       a keyword (do this if the word is a label, e.g. goto FOO)
2211  *   int allow_pack : if true, : characters will also be allowed (require,
2212  *       use, etc. do this)
2213  *   int allow_initial_tick : used by the "sub" lexer only.
2214  */
2215
2216 STATIC char *
2217 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
2218 {
2219     dVAR;
2220     char *s;
2221     STRLEN len;
2222
2223     PERL_ARGS_ASSERT_FORCE_WORD;
2224
2225     start = SKIPSPACE1(start);
2226     s = start;
2227     if (isIDFIRST_lazy_if(s,UTF) ||
2228         (allow_pack && *s == ':') )
2229     {
2230         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2231         if (check_keyword) {
2232           char *s2 = PL_tokenbuf;
2233           if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2234             s2 += 6, len -= 6;
2235           if (keyword(s2, len, 0))
2236             return start;
2237         }
2238         start_force(PL_curforce);
2239         if (PL_madskills)
2240             curmad('X', newSVpvn(start,s-start));
2241         if (token == METHOD) {
2242             s = SKIPSPACE1(s);
2243             if (*s == '(')
2244                 PL_expect = XTERM;
2245             else {
2246                 PL_expect = XOPERATOR;
2247             }
2248         }
2249         if (PL_madskills)
2250             curmad('g', newSVpvs( "forced" ));
2251         NEXTVAL_NEXTTOKE.opval
2252             = (OP*)newSVOP(OP_CONST,0,
2253                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2254         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2255         force_next(token);
2256     }
2257     return s;
2258 }
2259
2260 /*
2261  * S_force_ident
2262  * Called when the lexer wants $foo *foo &foo etc, but the program
2263  * text only contains the "foo" portion.  The first argument is a pointer
2264  * to the "foo", and the second argument is the type symbol to prefix.
2265  * Forces the next token to be a "WORD".
2266  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2267  */
2268
2269 STATIC void
2270 S_force_ident(pTHX_ const char *s, int kind)
2271 {
2272     dVAR;
2273
2274     PERL_ARGS_ASSERT_FORCE_IDENT;
2275
2276     if (s[0]) {
2277         const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2278         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2279                                                                 UTF ? SVf_UTF8 : 0));
2280         start_force(PL_curforce);
2281         NEXTVAL_NEXTTOKE.opval = o;
2282         force_next(WORD);
2283         if (kind) {
2284             o->op_private = OPpCONST_ENTERED;
2285             /* XXX see note in pp_entereval() for why we forgo typo
2286                warnings if the symbol must be introduced in an eval.
2287                GSAR 96-10-12 */
2288             gv_fetchpvn_flags(s, len,
2289                               (PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
2290                               : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2291                               kind == '$' ? SVt_PV :
2292                               kind == '@' ? SVt_PVAV :
2293                               kind == '%' ? SVt_PVHV :
2294                               SVt_PVGV
2295                               );
2296         }
2297     }
2298 }
2299
2300 static void
2301 S_force_ident_maybe_lex(pTHX_ char pit)
2302 {
2303     start_force(PL_curforce);
2304     NEXTVAL_NEXTTOKE.ival = pit;
2305     force_next('p');
2306 }
2307
2308 NV
2309 Perl_str_to_version(pTHX_ SV *sv)
2310 {
2311     NV retval = 0.0;
2312     NV nshift = 1.0;
2313     STRLEN len;
2314     const char *start = SvPV_const(sv,len);
2315     const char * const end = start + len;
2316     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2317
2318     PERL_ARGS_ASSERT_STR_TO_VERSION;
2319
2320     while (start < end) {
2321         STRLEN skip;
2322         UV n;
2323         if (utf)
2324             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2325         else {
2326             n = *(U8*)start;
2327             skip = 1;
2328         }
2329         retval += ((NV)n)/nshift;
2330         start += skip;
2331         nshift *= 1000;
2332     }
2333     return retval;
2334 }
2335
2336 /*
2337  * S_force_version
2338  * Forces the next token to be a version number.
2339  * If the next token appears to be an invalid version number, (e.g. "v2b"),
2340  * and if "guessing" is TRUE, then no new token is created (and the caller
2341  * must use an alternative parsing method).
2342  */
2343
2344 STATIC char *
2345 S_force_version(pTHX_ char *s, int guessing)
2346 {
2347     dVAR;
2348     OP *version = NULL;
2349     char *d;
2350 #ifdef PERL_MAD
2351     I32 startoff = s - SvPVX(PL_linestr);
2352 #endif
2353
2354     PERL_ARGS_ASSERT_FORCE_VERSION;
2355
2356     s = SKIPSPACE1(s);
2357
2358     d = s;
2359     if (*d == 'v')
2360         d++;
2361     if (isDIGIT(*d)) {
2362         while (isDIGIT(*d) || *d == '_' || *d == '.')
2363             d++;
2364 #ifdef PERL_MAD
2365         if (PL_madskills) {
2366             start_force(PL_curforce);
2367             curmad('X', newSVpvn(s,d-s));
2368         }
2369 #endif
2370         if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2371             SV *ver;
2372 #ifdef USE_LOCALE_NUMERIC
2373             char *loc = savepv(setlocale(LC_NUMERIC, NULL));
2374             setlocale(LC_NUMERIC, "C");
2375 #endif
2376             s = scan_num(s, &pl_yylval);
2377 #ifdef USE_LOCALE_NUMERIC
2378             setlocale(LC_NUMERIC, loc);
2379             Safefree(loc);
2380 #endif
2381             version = pl_yylval.opval;
2382             ver = cSVOPx(version)->op_sv;
2383             if (SvPOK(ver) && !SvNIOK(ver)) {
2384                 SvUPGRADE(ver, SVt_PVNV);
2385                 SvNV_set(ver, str_to_version(ver));
2386                 SvNOK_on(ver);          /* hint that it is a version */
2387             }
2388         }
2389         else if (guessing) {
2390 #ifdef PERL_MAD
2391             if (PL_madskills) {
2392                 sv_free(PL_nextwhite);  /* let next token collect whitespace */
2393                 PL_nextwhite = 0;
2394                 s = SvPVX(PL_linestr) + startoff;
2395             }
2396 #endif
2397             return s;
2398         }
2399     }
2400
2401 #ifdef PERL_MAD
2402     if (PL_madskills && !version) {
2403         sv_free(PL_nextwhite);  /* let next token collect whitespace */
2404         PL_nextwhite = 0;
2405         s = SvPVX(PL_linestr) + startoff;
2406     }
2407 #endif
2408     /* NOTE: The parser sees the package name and the VERSION swapped */
2409     start_force(PL_curforce);
2410     NEXTVAL_NEXTTOKE.opval = version;
2411     force_next(WORD);
2412
2413     return s;
2414 }
2415
2416 /*
2417  * S_force_strict_version
2418  * Forces the next token to be a version number using strict syntax rules.
2419  */
2420
2421 STATIC char *
2422 S_force_strict_version(pTHX_ char *s)
2423 {
2424     dVAR;
2425     OP *version = NULL;
2426 #ifdef PERL_MAD
2427     I32 startoff = s - SvPVX(PL_linestr);
2428 #endif
2429     const char *errstr = NULL;
2430
2431     PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2432
2433     while (isSPACE(*s)) /* leading whitespace */
2434         s++;
2435
2436     if (is_STRICT_VERSION(s,&errstr)) {
2437         SV *ver = newSV(0);
2438         s = (char *)scan_version(s, ver, 0);
2439         version = newSVOP(OP_CONST, 0, ver);
2440     }
2441     else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2442             (s = SKIPSPACE1(s), (*s != ';' && *s != '{' && *s != '}' )))
2443     {
2444         PL_bufptr = s;
2445         if (errstr)
2446             yyerror(errstr); /* version required */
2447         return s;
2448     }
2449
2450 #ifdef PERL_MAD
2451     if (PL_madskills && !version) {
2452         sv_free(PL_nextwhite);  /* let next token collect whitespace */
2453         PL_nextwhite = 0;
2454         s = SvPVX(PL_linestr) + startoff;
2455     }
2456 #endif
2457     /* NOTE: The parser sees the package name and the VERSION swapped */
2458     start_force(PL_curforce);
2459     NEXTVAL_NEXTTOKE.opval = version;
2460     force_next(WORD);
2461
2462     return s;
2463 }
2464
2465 /*
2466  * S_tokeq
2467  * Tokenize a quoted string passed in as an SV.  It finds the next
2468  * chunk, up to end of string or a backslash.  It may make a new
2469  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
2470  * turns \\ into \.
2471  */
2472
2473 STATIC SV *
2474 S_tokeq(pTHX_ SV *sv)
2475 {
2476     dVAR;
2477     char *s;
2478     char *send;
2479     char *d;
2480     STRLEN len = 0;
2481     SV *pv = sv;
2482
2483     PERL_ARGS_ASSERT_TOKEQ;
2484
2485     if (!SvLEN(sv))
2486         goto finish;
2487
2488     s = SvPV_force(sv, len);
2489     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
2490         goto finish;
2491     send = s + len;
2492     /* This is relying on the SV being "well formed" with a trailing '\0'  */
2493     while (s < send && !(*s == '\\' && s[1] == '\\'))
2494         s++;
2495     if (s == send)
2496         goto finish;
2497     d = s;
2498     if ( PL_hints & HINT_NEW_STRING ) {
2499         pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
2500     }
2501     while (s < send) {
2502         if (*s == '\\') {
2503             if (s + 1 < send && (s[1] == '\\'))
2504                 s++;            /* all that, just for this */
2505         }
2506         *d++ = *s++;
2507     }
2508     *d = '\0';
2509     SvCUR_set(sv, d - SvPVX_const(sv));
2510   finish:
2511     if ( PL_hints & HINT_NEW_STRING )
2512        return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2513     return sv;
2514 }
2515
2516 /*
2517  * Now come three functions related to double-quote context,
2518  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
2519  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
2520  * interact with PL_lex_state, and create fake ( ... ) argument lists
2521  * to handle functions and concatenation.
2522  * For example,
2523  *   "foo\lbar"
2524  * is tokenised as
2525  *    stringify ( const[foo] concat lcfirst ( const[bar] ) )
2526  */
2527
2528 /*
2529  * S_sublex_start
2530  * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2531  *
2532  * Pattern matching will set PL_lex_op to the pattern-matching op to
2533  * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2534  *
2535  * OP_CONST and OP_READLINE are easy--just make the new op and return.
2536  *
2537  * Everything else becomes a FUNC.
2538  *
2539  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2540  * had an OP_CONST or OP_READLINE).  This just sets us up for a
2541  * call to S_sublex_push().
2542  */
2543
2544 STATIC I32
2545 S_sublex_start(pTHX)
2546 {
2547     dVAR;
2548     const I32 op_type = pl_yylval.ival;
2549
2550     if (op_type == OP_NULL) {
2551         pl_yylval.opval = PL_lex_op;
2552         PL_lex_op = NULL;
2553         return THING;
2554     }
2555     if (op_type == OP_CONST || op_type == OP_READLINE) {
2556         SV *sv = tokeq(PL_lex_stuff);
2557
2558         if (SvTYPE(sv) == SVt_PVIV) {
2559             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2560             STRLEN len;
2561             const char * const p = SvPV_const(sv, len);
2562             SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2563             SvREFCNT_dec(sv);
2564             sv = nsv;
2565         }
2566         pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2567         PL_lex_stuff = NULL;
2568         /* Allow <FH> // "foo" */
2569         if (op_type == OP_READLINE)
2570             PL_expect = XTERMORDORDOR;
2571         return THING;
2572     }
2573     else if (op_type == OP_BACKTICK && PL_lex_op) {
2574         /* readpipe() was overridden */
2575         cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
2576         pl_yylval.opval = PL_lex_op;
2577         PL_lex_op = NULL;
2578         PL_lex_stuff = NULL;
2579         return THING;
2580     }
2581
2582     PL_sublex_info.super_state = PL_lex_state;
2583     PL_sublex_info.sub_inwhat = (U16)op_type;
2584     PL_sublex_info.sub_op = PL_lex_op;
2585     PL_lex_state = LEX_INTERPPUSH;
2586
2587     PL_expect = XTERM;
2588     if (PL_lex_op) {
2589         pl_yylval.opval = PL_lex_op;
2590         PL_lex_op = NULL;
2591         return PMFUNC;
2592     }
2593     else
2594         return FUNC;
2595 }
2596
2597 /*
2598  * S_sublex_push
2599  * Create a new scope to save the lexing state.  The scope will be
2600  * ended in S_sublex_done.  Returns a '(', starting the function arguments
2601  * to the uc, lc, etc. found before.
2602  * Sets PL_lex_state to LEX_INTERPCONCAT.
2603  */
2604
2605 STATIC I32
2606 S_sublex_push(pTHX)
2607 {
2608     dVAR;
2609     LEXSHARED *shared;
2610     const bool is_heredoc = PL_multi_close == '<';
2611     ENTER;
2612
2613     PL_lex_state = PL_sublex_info.super_state;
2614     SAVEBOOL(PL_lex_dojoin);
2615     SAVEI32(PL_lex_brackets);
2616     SAVEI32(PL_lex_allbrackets);
2617     SAVEI32(PL_lex_formbrack);
2618     SAVEI8(PL_lex_fakeeof);
2619     SAVEI32(PL_lex_casemods);
2620     SAVEI32(PL_lex_starts);
2621     SAVEI8(PL_lex_state);
2622     SAVESPTR(PL_lex_repl);
2623     SAVEVPTR(PL_lex_inpat);
2624     SAVEI16(PL_lex_inwhat);
2625     if (is_heredoc)
2626     {
2627         SAVECOPLINE(PL_curcop);
2628         SAVEI32(PL_multi_end);
2629         SAVEI32(PL_parser->herelines);
2630         PL_parser->herelines = 0;
2631     }
2632     SAVEI8(PL_multi_close);
2633     SAVEPPTR(PL_bufptr);
2634     SAVEPPTR(PL_bufend);
2635     SAVEPPTR(PL_oldbufptr);
2636     SAVEPPTR(PL_oldoldbufptr);
2637     SAVEPPTR(PL_last_lop);
2638     SAVEPPTR(PL_last_uni);
2639     SAVEPPTR(PL_linestart);
2640     SAVESPTR(PL_linestr);
2641     SAVEGENERICPV(PL_lex_brackstack);
2642     SAVEGENERICPV(PL_lex_casestack);
2643     SAVEGENERICPV(PL_parser->lex_shared);
2644     SAVEBOOL(PL_parser->lex_re_reparsing);
2645     SAVEI32(PL_copline);
2646
2647     /* The here-doc parser needs to be able to peek into outer lexing
2648        scopes to find the body of the here-doc.  So we put PL_linestr and
2649        PL_bufptr into lex_shared, to ‘share’ those values.
2650      */
2651     PL_parser->lex_shared->ls_linestr = PL_linestr;
2652     PL_parser->lex_shared->ls_bufptr  = PL_bufptr;
2653
2654     PL_linestr = PL_lex_stuff;
2655     PL_lex_repl = PL_sublex_info.repl;
2656     PL_lex_stuff = NULL;
2657     PL_sublex_info.repl = NULL;
2658
2659     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2660         = SvPVX(PL_linestr);
2661     PL_bufend += SvCUR(PL_linestr);
2662     PL_last_lop = PL_last_uni = NULL;
2663     SAVEFREESV(PL_linestr);
2664     if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2665
2666     PL_lex_dojoin = FALSE;
2667     PL_lex_brackets = PL_lex_formbrack = 0;
2668     PL_lex_allbrackets = 0;
2669     PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2670     Newx(PL_lex_brackstack, 120, char);
2671     Newx(PL_lex_casestack, 12, char);
2672     PL_lex_casemods = 0;
2673     *PL_lex_casestack = '\0';
2674     PL_lex_starts = 0;
2675     PL_lex_state = LEX_INTERPCONCAT;
2676     if (is_heredoc)
2677         CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2678     PL_copline = NOLINE;
2679     
2680     Newxz(shared, 1, LEXSHARED);
2681     shared->ls_prev = PL_parser->lex_shared;
2682     PL_parser->lex_shared = shared;
2683
2684     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2685     if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2686     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2687         PL_lex_inpat = PL_sublex_info.sub_op;
2688     else
2689         PL_lex_inpat = NULL;
2690
2691     PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2692     PL_in_eval &= ~EVAL_RE_REPARSING;
2693
2694     return '(';
2695 }
2696
2697 /*
2698  * S_sublex_done
2699  * Restores lexer state after a S_sublex_push.
2700  */
2701
2702 STATIC I32
2703 S_sublex_done(pTHX)
2704 {
2705     dVAR;
2706     if (!PL_lex_starts++) {
2707         SV * const sv = newSVpvs("");
2708         if (SvUTF8(PL_linestr))
2709             SvUTF8_on(sv);
2710         PL_expect = XOPERATOR;
2711         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2712         return THING;
2713     }
2714
2715     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
2716         PL_lex_state = LEX_INTERPCASEMOD;
2717         return yylex();
2718     }
2719
2720     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2721     assert(PL_lex_inwhat != OP_TRANSR);
2722     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
2723         PL_linestr = PL_lex_repl;
2724         PL_lex_inpat = 0;
2725         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2726         PL_bufend += SvCUR(PL_linestr);
2727         PL_last_lop = PL_last_uni = NULL;
2728         PL_lex_dojoin = FALSE;
2729         PL_lex_brackets = 0;
2730         PL_lex_allbrackets = 0;
2731         PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2732         PL_lex_casemods = 0;
2733         *PL_lex_casestack = '\0';
2734         PL_lex_starts = 0;
2735         if (SvEVALED(PL_lex_repl)) {
2736             PL_lex_state = LEX_INTERPNORMAL;
2737             PL_lex_starts++;
2738             /*  we don't clear PL_lex_repl here, so that we can check later
2739                 whether this is an evalled subst; that means we rely on the
2740                 logic to ensure sublex_done() is called again only via the
2741                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2742         }
2743         else {
2744             PL_lex_state = LEX_INTERPCONCAT;
2745             PL_lex_repl = NULL;
2746         }
2747         if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2748             CopLINE(PL_curcop) +=
2749                 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2750                  + PL_parser->herelines;
2751             PL_parser->herelines = 0;
2752         }
2753         return ',';
2754     }
2755     else {
2756         const line_t l = CopLINE(PL_curcop);
2757 #ifdef PERL_MAD
2758         if (PL_madskills) {
2759             if (PL_thiswhite) {
2760                 if (!PL_endwhite)
2761                     PL_endwhite = newSVpvs("");
2762                 sv_catsv(PL_endwhite, PL_thiswhite);
2763                 PL_thiswhite = 0;
2764             }
2765             if (PL_thistoken)
2766                 sv_setpvs(PL_thistoken,"");
2767             else
2768                 PL_realtokenstart = -1;
2769         }
2770 #endif
2771         LEAVE;
2772         if (PL_multi_close == '<')
2773             PL_parser->herelines += l - PL_multi_end;
2774         PL_bufend = SvPVX(PL_linestr);
2775         PL_bufend += SvCUR(PL_linestr);
2776         PL_expect = XOPERATOR;
2777         PL_sublex_info.sub_inwhat = 0;
2778         return ')';
2779     }
2780 }
2781
2782 PERL_STATIC_INLINE SV*
2783 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2784 {
2785     /* <s> points to first character of interior of \N{}, <e> to one beyond the
2786      * interior, hence to the "}".  Finds what the name resolves to, returning
2787      * an SV* containing it; NULL if no valid one found */
2788
2789     SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2790
2791     HV * table;
2792     SV **cvp;
2793     SV *cv;
2794     SV *rv;
2795     HV *stash;
2796     const U8* first_bad_char_loc;
2797     const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2798
2799     PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2800
2801     if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2802                                      e - backslash_ptr,
2803                                      &first_bad_char_loc))
2804     {
2805         /* If warnings are on, this will print a more detailed analysis of what
2806          * is wrong than the error message below */
2807         utf8n_to_uvchr(first_bad_char_loc,
2808                        e - ((char *) first_bad_char_loc),
2809                        NULL, 0);
2810
2811         /* We deliberately don't try to print the malformed character, which
2812          * might not print very well; it also may be just the first of many
2813          * malformations, so don't print what comes after it */
2814         yyerror(Perl_form(aTHX_
2815             "Malformed UTF-8 character immediately after '%.*s'",
2816             (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2817         return NULL;
2818     }
2819
2820     res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2821                         /* include the <}> */
2822                         e - backslash_ptr + 1);
2823     if (! SvPOK(res)) {
2824         SvREFCNT_dec_NN(res);
2825         return NULL;
2826     }
2827
2828     /* See if the charnames handler is the Perl core's, and if so, we can skip
2829      * the validation needed for a user-supplied one, as Perl's does its own
2830      * validation. */
2831     table = GvHV(PL_hintgv);             /* ^H */
2832     cvp = hv_fetchs(table, "charnames", FALSE);
2833     if (cvp && (cv = *cvp) && SvROK(cv) && ((rv = SvRV(cv)) != NULL)
2834         && SvTYPE(rv) == SVt_PVCV && ((stash = CvSTASH(rv)) != NULL))
2835     {
2836         const char * const name = HvNAME(stash);
2837         if strEQ(name, "_charnames") {
2838            return res;
2839        }
2840     }
2841
2842     /* Here, it isn't Perl's charname handler.  We can't rely on a
2843      * user-supplied handler to validate the input name.  For non-ut8 input,
2844      * look to see that the first character is legal.  Then loop through the
2845      * rest checking that each is a continuation */
2846
2847     /* This code needs to be sync'ed with a regex in _charnames.pm which does
2848      * the same thing */
2849
2850     if (! UTF) {
2851         if (! isALPHAU(*s)) {
2852             goto bad_charname;
2853         }
2854         s++;
2855         while (s < e) {
2856             if (! isCHARNAME_CONT(*s)) {
2857                 goto bad_charname;
2858             }
2859             if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2860                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2861                            "A sequence of multiple spaces in a charnames "
2862                            "alias definition is deprecated");
2863             }
2864             s++;
2865         }
2866         if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2867             Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2868                         "Trailing white-space in a charnames alias "
2869                         "definition is deprecated");
2870         }
2871     }
2872     else {
2873         /* Similarly for utf8.  For invariants can check directly; for other
2874          * Latin1, can calculate their code point and check; otherwise  use a
2875          * swash */
2876         if (UTF8_IS_INVARIANT(*s)) {
2877             if (! isALPHAU(*s)) {
2878                 goto bad_charname;
2879             }
2880             s++;
2881         } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2882             if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2883                 goto bad_charname;
2884             }
2885             s += 2;
2886         }
2887         else {
2888             if (! PL_utf8_charname_begin) {
2889                 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2890                 PL_utf8_charname_begin = _core_swash_init("utf8",
2891                                                         "_Perl_Charname_Begin",
2892                                                         &PL_sv_undef,
2893                                                         1, 0, NULL, &flags);
2894             }
2895             if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2896                 goto bad_charname;
2897             }
2898             s += UTF8SKIP(s);
2899         }
2900
2901         while (s < e) {
2902             if (UTF8_IS_INVARIANT(*s)) {
2903                 if (! isCHARNAME_CONT(*s)) {
2904                     goto bad_charname;
2905                 }
2906                 if (*s == ' ' && *(s-1) == ' '
2907                  && ckWARN_d(WARN_DEPRECATED)) {
2908                     Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2909                                "A sequence of multiple spaces in a charnam"
2910                                "es alias definition is deprecated");
2911                 }
2912                 s++;
2913             }
2914             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2915                 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2916                 {
2917                     goto bad_charname;
2918                 }
2919                 s += 2;
2920             }
2921             else {
2922                 if (! PL_utf8_charname_continue) {
2923                     U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2924                     PL_utf8_charname_continue = _core_swash_init("utf8",
2925                                                 "_Perl_Charname_Continue",
2926                                                 &PL_sv_undef,
2927                                                 1, 0, NULL, &flags);
2928                 }
2929                 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2930                     goto bad_charname;
2931                 }
2932                 s += UTF8SKIP(s);
2933             }
2934         }
2935         if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
2936             Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2937                        "Trailing white-space in a charnames alias "
2938                        "definition is deprecated");
2939         }
2940     }
2941
2942     if (SvUTF8(res)) { /* Don't accept malformed input */
2943         const U8* first_bad_char_loc;
2944         STRLEN len;
2945         const char* const str = SvPV_const(res, len);
2946         if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2947             /* If warnings are on, this will print a more detailed analysis of
2948              * what is wrong than the error message below */
2949             utf8n_to_uvchr(first_bad_char_loc,
2950                            (char *) first_bad_char_loc - str,
2951                            NULL, 0);
2952
2953             /* We deliberately don't try to print the malformed character,
2954              * which might not print very well; it also may be just the first
2955              * of many malformations, so don't print what comes after it */
2956             yyerror_pv(
2957               Perl_form(aTHX_
2958                 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2959                  (int) (e - backslash_ptr + 1), backslash_ptr,
2960                  (int) ((char *) first_bad_char_loc - str), str
2961               ),
2962               SVf_UTF8);
2963             return NULL;
2964         }
2965     }
2966
2967     return res;
2968
2969   bad_charname: {
2970         int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
2971
2972         /* The final %.*s makes sure that should the trailing NUL be missing
2973          * that this print won't run off the end of the string */
2974         yyerror_pv(
2975           Perl_form(aTHX_
2976             "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2977             (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
2978             (int)(e - s + bad_char_size), s + bad_char_size
2979           ),
2980           UTF ? SVf_UTF8 : 0);
2981         return NULL;
2982     }
2983 }
2984
2985 /*
2986   scan_const
2987
2988   Extracts the next constant part of a pattern, double-quoted string,
2989   or transliteration.  This is terrifying code.
2990
2991   For example, in parsing the double-quoted string "ab\x63$d", it would
2992   stop at the '$' and return an OP_CONST containing 'abc'.
2993
2994   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2995   processing a pattern (PL_lex_inpat is true), a transliteration
2996   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2997
2998   Returns a pointer to the character scanned up to. If this is
2999   advanced from the start pointer supplied (i.e. if anything was
3000   successfully parsed), will leave an OP_CONST for the substring scanned
3001   in pl_yylval. Caller must intuit reason for not parsing further
3002   by looking at the next characters herself.
3003
3004   In patterns:
3005     expand:
3006       \N{FOO}  => \N{U+hex_for_character_FOO}
3007       (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
3008
3009     pass through:
3010         all other \-char, including \N and \N{ apart from \N{ABC}
3011
3012     stops on:
3013         @ and $ where it appears to be a var, but not for $ as tail anchor
3014         \l \L \u \U \Q \E
3015         (?{  or  (??{
3016
3017
3018   In transliterations:
3019     characters are VERY literal, except for - not at the start or end
3020     of the string, which indicates a range. If the range is in bytes,
3021     scan_const expands the range to the full set of intermediate
3022     characters. If the range is in utf8, the hyphen is replaced with
3023     a certain range mark which will be handled by pmtrans() in op.c.
3024
3025   In double-quoted strings:
3026     backslashes:
3027       double-quoted style: \r and \n
3028       constants: \x31, etc.
3029       deprecated backrefs: \1 (in substitution replacements)
3030       case and quoting: \U \Q \E
3031     stops on @ and $
3032
3033   scan_const does *not* construct ops to handle interpolated strings.
3034   It stops processing as soon as it finds an embedded $ or @ variable
3035   and leaves it to the caller to work out what's going on.
3036
3037   embedded arrays (whether in pattern or not) could be:
3038       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
3039
3040   $ in double-quoted strings must be the symbol of an embedded scalar.
3041
3042   $ in pattern could be $foo or could be tail anchor.  Assumption:
3043   it's a tail anchor if $ is the last thing in the string, or if it's
3044   followed by one of "()| \r\n\t"
3045
3046   \1 (backreferences) are turned into $1 in substitutions
3047
3048   The structure of the code is
3049       while (there's a character to process) {
3050           handle transliteration ranges
3051           skip regexp comments /(?#comment)/ and codes /(?{code})/
3052           skip #-initiated comments in //x patterns
3053           check for embedded arrays
3054           check for embedded scalars
3055           if (backslash) {
3056               deprecate \1 in substitution replacements
3057               handle string-changing backslashes \l \U \Q \E, etc.
3058               switch (what was escaped) {
3059                   handle \- in a transliteration (becomes a literal -)
3060                   if a pattern and not \N{, go treat as regular character
3061                   handle \132 (octal characters)
3062                   handle \x15 and \x{1234} (hex characters)
3063                   handle \N{name} (named characters, also \N{3,5} in a pattern)
3064                   handle \cV (control characters)
3065                   handle printf-style backslashes (\f, \r, \n, etc)
3066               } (end switch)
3067               continue
3068           } (end if backslash)
3069           handle regular character
3070     } (end while character to read)
3071                 
3072 */
3073
3074 STATIC char *
3075 S_scan_const(pTHX_ char *start)
3076 {
3077     dVAR;
3078     char *send = PL_bufend;             /* end of the constant */
3079     SV *sv = newSV(send - start);               /* sv for the constant.  See
3080                                                    note below on sizing. */
3081     char *s = start;                    /* start of the constant */
3082     char *d = SvPVX(sv);                /* destination for copies */
3083     bool dorange = FALSE;                       /* are we in a translit range? */
3084     bool didrange = FALSE;                      /* did we just finish a range? */
3085     bool in_charclass = FALSE;                  /* within /[...]/ */
3086     bool has_utf8 = FALSE;                      /* Output constant is UTF8 */
3087     bool  this_utf8 = cBOOL(UTF);               /* Is the source string assumed
3088                                                    to be UTF8?  But, this can
3089                                                    show as true when the source
3090                                                    isn't utf8, as for example
3091                                                    when it is entirely composed
3092                                                    of hex constants */
3093     SV *res;                            /* result from charnames */
3094
3095     /* Note on sizing:  The scanned constant is placed into sv, which is
3096      * initialized by newSV() assuming one byte of output for every byte of
3097      * input.  This routine expects newSV() to allocate an extra byte for a
3098      * trailing NUL, which this routine will append if it gets to the end of
3099      * the input.  There may be more bytes of input than output (eg., \N{LATIN
3100      * CAPITAL LETTER A}), or more output than input if the constant ends up
3101      * recoded to utf8, but each time a construct is found that might increase
3102      * the needed size, SvGROW() is called.  Its size parameter each time is
3103      * based on the best guess estimate at the time, namely the length used so
3104      * far, plus the length the current construct will occupy, plus room for
3105      * the trailing NUL, plus one byte for every input byte still unscanned */ 
3106
3107     UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
3108                        before set */
3109 #ifdef EBCDIC
3110     UV literal_endpoint = 0;
3111     bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
3112 #endif
3113
3114     PERL_ARGS_ASSERT_SCAN_CONST;
3115
3116     assert(PL_lex_inwhat != OP_TRANSR);
3117     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3118         /* If we are doing a trans and we know we want UTF8 set expectation */
3119         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
3120         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3121     }
3122
3123     /* Protect sv from errors and fatal warnings. */
3124     ENTER_with_name("scan_const");
3125     SAVEFREESV(sv);
3126
3127     while (s < send || dorange) {
3128
3129         /* get transliterations out of the way (they're most literal) */
3130         if (PL_lex_inwhat == OP_TRANS) {
3131             /* expand a range A-Z to the full set of characters.  AIE! */
3132             if (dorange) {
3133                 I32 i;                          /* current expanded character */
3134                 I32 min;                        /* first character in range */
3135                 I32 max;                        /* last character in range */
3136
3137 #ifdef EBCDIC
3138                 UV uvmax = 0;
3139 #endif
3140
3141                 if (has_utf8
3142 #ifdef EBCDIC
3143                     && !native_range
3144 #endif
3145                 ) {
3146                     char * const c = (char*)utf8_hop((U8*)d, -1);
3147                     char *e = d++;
3148                     while (e-- > c)
3149                         *(e + 1) = *e;
3150                     *c = (char) ILLEGAL_UTF8_BYTE;
3151                     /* mark the range as done, and continue */
3152                     dorange = FALSE;
3153                     didrange = TRUE;
3154                     continue;
3155                 }
3156
3157                 i = d - SvPVX_const(sv);                /* remember current offset */
3158 #ifdef EBCDIC
3159                 SvGROW(sv,
3160                        SvLEN(sv) + (has_utf8 ?
3161                                     (512 - UTF_CONTINUATION_MARK +
3162                                      UNISKIP(0x100))
3163                                     : 256));
3164                 /* How many two-byte within 0..255: 128 in UTF-8,
3165                  * 96 in UTF-8-mod. */
3166 #else
3167                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
3168 #endif
3169                 d = SvPVX(sv) + i;              /* refresh d after realloc */
3170 #ifdef EBCDIC
3171                 if (has_utf8) {
3172                     int j;
3173                     for (j = 0; j <= 1; j++) {
3174                         char * const c = (char*)utf8_hop((U8*)d, -1);
3175                         const UV uv    = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
3176                         if (j)
3177                             min = (U8)uv;
3178                         else if (uv < 256)
3179                             max = (U8)uv;
3180                         else {
3181                             max = (U8)0xff; /* only to \xff */
3182                             uvmax = uv; /* \x{100} to uvmax */
3183                         }
3184                         d = c; /* eat endpoint chars */
3185                      }
3186                 }
3187                else {
3188 #endif
3189                    d -= 2;              /* eat the first char and the - */
3190                    min = (U8)*d;        /* first char in range */
3191                    max = (U8)d[1];      /* last char in range  */
3192 #ifdef EBCDIC
3193                }
3194 #endif
3195
3196                 if (min > max) {
3197                     Perl_croak(aTHX_
3198                                "Invalid range \"%c-%c\" in transliteration operator",
3199                                (char)min, (char)max);
3200                 }
3201
3202 #ifdef EBCDIC
3203                 if (literal_endpoint == 2 &&
3204                     ((isLOWER_A(min) && isLOWER_A(max)) ||
3205                      (isUPPER_A(min) && isUPPER_A(max))))
3206                 {
3207                     for (i = min; i <= max; i++) {
3208                         if (isALPHA_A(i))
3209                             *d++ = i;
3210                     }
3211                 }
3212                 else
3213 #endif
3214                     for (i = min; i <= max; i++)
3215 #ifdef EBCDIC
3216                         if (has_utf8) {
3217                             append_utf8_from_native_byte(i, &d);
3218                         }
3219                         else
3220 #endif
3221                             *d++ = (char)i;
3222  
3223 #ifdef EBCDIC
3224                 if (uvmax) {
3225                     d = (char*)uvchr_to_utf8((U8*)d, 0x100);
3226                     if (uvmax > 0x101)
3227                         *d++ = (char) ILLEGAL_UTF8_BYTE;
3228                     if (uvmax > 0x100)
3229                         d = (char*)uvchr_to_utf8((U8*)d, uvmax);
3230                 }
3231 #endif
3232
3233                 /* mark the range as done, and continue */
3234                 dorange = FALSE;
3235                 didrange = TRUE;
3236 #ifdef EBCDIC
3237                 literal_endpoint = 0;
3238 #endif
3239                 continue;
3240             }
3241
3242             /* range begins (ignore - as first or last char) */
3243             else if (*s == '-' && s+1 < send  && s != start) {
3244                 if (didrange) {
3245                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
3246                 }
3247                 if (has_utf8
3248 #ifdef EBCDIC
3249                     && !native_range
3250 #endif
3251                     ) {
3252                     *d++ = (char) ILLEGAL_UTF8_BYTE;    /* use illegal utf8 byte--see pmtrans */
3253                     s++;
3254                     continue;
3255                 }
3256                 dorange = TRUE;
3257                 s++;
3258             }
3259             else {
3260                 didrange = FALSE;
3261 #ifdef EBCDIC
3262                 literal_endpoint = 0;
3263                 native_range = TRUE;
3264 #endif
3265             }
3266         }
3267
3268         /* if we get here, we're not doing a transliteration */
3269
3270         else if (*s == '[' && PL_lex_inpat && !in_charclass) {
3271             char *s1 = s-1;
3272             int esc = 0;
3273             while (s1 >= start && *s1-- == '\\')
3274                 esc = !esc;
3275             if (!esc)
3276                 in_charclass = TRUE;
3277         }
3278
3279         else if (*s == ']' && PL_lex_inpat &&  in_charclass) {
3280             char *s1 = s-1;
3281             int esc = 0;
3282             while (s1 >= start && *s1-- == '\\')
3283                 esc = !esc;
3284             if (!esc)
3285                 in_charclass = FALSE;
3286         }
3287
3288         /* skip for regexp comments /(?#comment)/, except for the last
3289          * char, which will be done separately.
3290          * Stop on (?{..}) and friends */
3291
3292         else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3293             if (s[2] == '#') {
3294                 while (s+1 < send && *s != ')')
3295                     *d++ = *s++;
3296             }
3297             else if (!PL_lex_casemods &&
3298                      (    s[2] == '{' /* This should match regcomp.c */
3299                       || (s[2] == '?' && s[3] == '{')))
3300             {
3301                 break;
3302             }
3303         }
3304
3305         /* likewise skip #-initiated comments in //x patterns */
3306         else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3307           ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3308             while (s+1 < send && *s != '\n')
3309                 *d++ = *s++;
3310         }
3311
3312         /* no further processing of single-quoted regex */
3313         else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3314             goto default_action;
3315
3316         /* check for embedded arrays
3317            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3318            */
3319         else if (*s == '@' && s[1]) {
3320             if (isWORDCHAR_lazy_if(s+1,UTF))
3321                 break;
3322             if (strchr(":'{$", s[1]))
3323                 break;
3324             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3325                 break; /* in regexp, neither @+ nor @- are interpolated */
3326         }
3327
3328         /* check for embedded scalars.  only stop if we're sure it's a
3329            variable.
3330         */
3331         else if (*s == '$') {
3332             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
3333                 break;
3334             if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3335                 if (s[1] == '\\') {
3336                     Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3337                                    "Possible unintended interpolation of $\\ in regex");
3338                 }
3339                 break;          /* in regexp, $ might be tail anchor */
3340             }
3341         }
3342
3343         /* End of else if chain - OP_TRANS rejoin rest */
3344
3345         /* backslashes */
3346         if (*s == '\\' && s+1 < send) {
3347             char* e;    /* Can be used for ending '}', etc. */
3348
3349             s++;
3350
3351             /* warn on \1 - \9 in substitution replacements, but note that \11
3352              * is an octal; and \19 is \1 followed by '9' */
3353             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3354                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3355             {
3356                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3357                 *--s = '$';
3358                 break;
3359             }
3360
3361             /* string-change backslash escapes */
3362             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3363                 --s;
3364                 break;
3365             }
3366             /* In a pattern, process \N, but skip any other backslash escapes.
3367              * This is because we don't want to translate an escape sequence
3368              * into a meta symbol and have the regex compiler use the meta
3369              * symbol meaning, e.g. \x{2E} would be confused with a dot.  But
3370              * in spite of this, we do have to process \N here while the proper
3371              * charnames handler is in scope.  See bugs #56444 and #62056.
3372              * There is a complication because \N in a pattern may also stand
3373              * for 'match a non-nl', and not mean a charname, in which case its
3374              * processing should be deferred to the regex compiler.  To be a
3375              * charname it must be followed immediately by a '{', and not look
3376              * like \N followed by a curly quantifier, i.e., not something like
3377              * \N{3,}.  regcurly returns a boolean indicating if it is a legal
3378              * quantifier */
3379             else if (PL_lex_inpat
3380                     && (*s != 'N'
3381                         || s[1] != '{'
3382                         || regcurly(s + 1, FALSE)))
3383             {
3384                 *d++ = '\\';
3385                 goto default_action;
3386             }
3387
3388             switch (*s) {
3389
3390             /* quoted - in transliterations */
3391             case '-':
3392                 if (PL_lex_inwhat == OP_TRANS) {
3393                     *d++ = *s++;
3394                     continue;
3395                 }
3396                 /* FALL THROUGH */
3397             default:
3398                 {
3399                     if ((isALPHANUMERIC(*s)))
3400                         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3401                                        "Unrecognized escape \\%c passed through",
3402                                        *s);
3403                     /* default action is to copy the quoted character */
3404                     goto default_action;
3405                 }
3406
3407             /* eg. \132 indicates the octal constant 0132 */
3408             case '0': case '1': case '2': case '3':
3409             case '4': case '5': case '6': case '7':
3410                 {
3411                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3412                     STRLEN len = 3;
3413                     uv = grok_oct(s, &len, &flags, NULL);
3414                     s += len;
3415                     if (len < 3 && s < send && isDIGIT(*s)
3416                         && ckWARN(WARN_MISC))
3417                     {
3418                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3419                                     "%s", form_short_octal_warning(s, len));
3420                     }
3421                 }
3422                 goto NUM_ESCAPE_INSERT;
3423
3424             /* eg. \o{24} indicates the octal constant \024 */
3425             case 'o':
3426                 {
3427                     const char* error;
3428
3429                     bool valid = grok_bslash_o(&s, &uv, &error,
3430                                                TRUE, /* Output warning */
3431                                                FALSE, /* Not strict */
3432                                                TRUE, /* Output warnings for
3433                                                          non-portables */
3434                                                UTF);
3435                     if (! valid) {
3436                         yyerror(error);
3437                         continue;
3438                     }
3439                     goto NUM_ESCAPE_INSERT;
3440                 }
3441
3442             /* eg. \x24 indicates the hex constant 0x24 */
3443             case 'x':
3444                 {
3445                     const char* error;
3446
3447                     bool valid = grok_bslash_x(&s, &uv, &error,
3448                                                TRUE, /* Output warning */
3449                                                FALSE, /* Not strict */
3450                                                TRUE,  /* Output warnings for
3451                                                          non-portables */
3452                                                UTF);
3453                     if (! valid) {
3454                         yyerror(error);
3455                         continue;
3456                     }
3457                 }
3458
3459               NUM_ESCAPE_INSERT:
3460                 /* Insert oct or hex escaped character.  There will always be
3461                  * enough room in sv since such escapes will be longer than any
3462                  * UTF-8 sequence they can end up as, except if they force us
3463                  * to recode the rest of the string into utf8 */
3464                 
3465                 /* Here uv is the ordinal of the next character being added */
3466                 if (!UVCHR_IS_INVARIANT(uv)) {
3467                     if (!has_utf8 && uv > 255) {
3468                         /* Might need to recode whatever we have accumulated so
3469                          * far if it contains any chars variant in utf8 or
3470                          * utf-ebcdic. */
3471                           
3472                         SvCUR_set(sv, d - SvPVX_const(sv));
3473                         SvPOK_on(sv);
3474                         *d = '\0';
3475                         /* See Note on sizing above.  */
3476                         sv_utf8_upgrade_flags_grow(sv,
3477                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3478                                         UNISKIP(uv) + (STRLEN)(send - s) + 1);
3479                         d = SvPVX(sv) + SvCUR(sv);
3480                         has_utf8 = TRUE;
3481                     }
3482
3483                     if (has_utf8) {
3484                         d = (char*)uvchr_to_utf8((U8*)d, uv);
3485                         if (PL_lex_inwhat == OP_TRANS &&
3486                             PL_sublex_info.sub_op) {
3487                             PL_sublex_info.sub_op->op_private |=
3488                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
3489                                              : OPpTRANS_TO_UTF);
3490                         }
3491 #ifdef EBCDIC
3492                         if (uv > 255 && !dorange)
3493                             native_range = FALSE;
3494 #endif
3495                     }
3496                     else {
3497                         *d++ = (char)uv;
3498                     }
3499                 }
3500                 else {
3501                     *d++ = (char) uv;
3502                 }
3503                 continue;
3504
3505             case 'N':
3506                 /* In a non-pattern \N must be a named character, like \N{LATIN
3507                  * SMALL LETTER A} or \N{U+0041}.  For patterns, it also can
3508                  * mean to match a non-newline.  For non-patterns, named
3509                  * characters are converted to their string equivalents. In
3510                  * patterns, named characters are not converted to their
3511                  * ultimate forms for the same reasons that other escapes
3512                  * aren't.  Instead, they are converted to the \N{U+...} form
3513                  * to get the value from the charnames that is in effect right
3514                  * now, while preserving the fact that it was a named character
3515                  * so that the regex compiler knows this */
3516
3517                 /* The structure of this section of code (besides checking for
3518                  * errors and upgrading to utf8) is:
3519                  *  Further disambiguate between the two meanings of \N, and if
3520                  *      not a charname, go process it elsewhere
3521                  *  If of form \N{U+...}, pass it through if a pattern;
3522                  *      otherwise convert to utf8
3523                  *  Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3524                  *  pattern; otherwise convert to utf8 */
3525
3526                 /* Here, s points to the 'N'; the test below is guaranteed to
3527                  * succeed if we are being called on a pattern as we already
3528                  * know from a test above that the next character is a '{'.
3529                  * On a non-pattern \N must mean 'named sequence, which
3530                  * requires braces */
3531                 s++;
3532                 if (*s != '{') {
3533                     yyerror("Missing braces on \\N{}"); 
3534                     continue;
3535                 }
3536                 s++;
3537
3538                 /* If there is no matching '}', it is an error. */
3539                 if (! (e = strchr(s, '}'))) {
3540                     if (! PL_lex_inpat) {
3541                         yyerror("Missing right brace on \\N{}");
3542                     } else {
3543                         yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
3544                     }
3545                     continue;
3546                 }
3547
3548                 /* Here it looks like a named character */
3549
3550                 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3551                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3552                                 | PERL_SCAN_DISALLOW_PREFIX;
3553                     STRLEN len;
3554
3555                     /* For \N{U+...}, the '...' is a unicode value even on
3556                      * EBCDIC machines */
3557                     s += 2;         /* Skip to next char after the 'U+' */
3558                     len = e - s;
3559                     uv = grok_hex(s, &len, &flags, NULL);
3560                     if (len == 0 || len != (STRLEN)(e - s)) {
3561                         yyerror("Invalid hexadecimal number in \\N{U+...}");
3562                         s = e + 1;
3563                         continue;
3564                     }
3565
3566                     if (PL_lex_inpat) {
3567
3568                         /* On non-EBCDIC platforms, pass through to the regex
3569                          * compiler unchanged.  The reason we evaluated the
3570                          * number above is to make sure there wasn't a syntax
3571                          * error.  But on EBCDIC we convert to native so
3572                          * downstream code can continue to assume it's native
3573                          */
3574                         s -= 5;     /* Include the '\N{U+' */
3575 #ifdef EBCDIC
3576                         d += my_snprintf(d, e - s + 1 + 1,  /* includes the }
3577                                                                and the \0 */
3578                                     "\\N{U+%X}",
3579                                     (unsigned int) UNI_TO_NATIVE(uv));
3580 #else
3581                         Copy(s, d, e - s + 1, char);    /* 1 = include the } */
3582                         d += e - s + 1;
3583 #endif
3584                     }
3585                     else {  /* Not a pattern: convert the hex to string */
3586
3587                          /* If destination is not in utf8, unconditionally
3588                           * recode it to be so.  This is because \N{} implies
3589                           * Unicode semantics, and scalars have to be in utf8
3590                           * to guarantee those semantics */
3591                         if (! has_utf8) {
3592                             SvCUR_set(sv, d - SvPVX_const(sv));
3593                             SvPOK_on(sv);
3594                             *d = '\0';
3595                             /* See Note on sizing above.  */
3596                             sv_utf8_upgrade_flags_grow(
3597                                         sv,
3598                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3599                                         UNISKIP(uv) + (STRLEN)(send - e) + 1);
3600                             d = SvPVX(sv) + SvCUR(sv);
3601                             has_utf8 = TRUE;
3602                         }
3603
3604                         /* Add the (Unicode) code point to the output. */
3605                         if (UNI_IS_INVARIANT(uv)) {
3606                             *d++ = (char) LATIN1_TO_NATIVE(uv);
3607                         }
3608                         else {
3609                             d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3610                         }
3611                     }
3612                 }
3613                 else /* Here is \N{NAME} but not \N{U+...}. */
3614                      if ((res = get_and_check_backslash_N_name(s, e)))
3615                 {
3616                     STRLEN len;
3617                     const char *str = SvPV_const(res, len);
3618                     if (PL_lex_inpat) {
3619
3620                         if (! len) { /* The name resolved to an empty string */
3621                             Copy("\\N{}", d, 4, char);
3622                             d += 4;
3623                         }
3624                         else {
3625                             /* In order to not lose information for the regex
3626                             * compiler, pass the result in the specially made
3627                             * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3628                             * the code points in hex of each character
3629                             * returned by charnames */
3630
3631                             const char *str_end = str + len;
3632                             const STRLEN off = d - SvPVX_const(sv);
3633
3634                             if (! SvUTF8(res)) {
3635                                 /* For the non-UTF-8 case, we can determine the
3636                                  * exact length needed without having to parse
3637                                  * through the string.  Each character takes up
3638                                  * 2 hex digits plus either a trailing dot or
3639                                  * the "}" */
3640                                 d = off + SvGROW(sv, off
3641                                                     + 3 * len
3642                                                     + 6 /* For the "\N{U+", and
3643                                                            trailing NUL */
3644                                                     + (STRLEN)(send - e));
3645                                 Copy("\\N{U+", d, 5, char);
3646                                 d += 5;
3647                                 while (str < str_end) {
3648                                     char hex_string[4];
3649                                     my_snprintf(hex_string, sizeof(hex_string),
3650                                                 "%02X.", (U8) *str);
3651                                     Copy(hex_string, d, 3, char);
3652                                     d += 3;
3653                                     str++;
3654                                 }
3655                                 d--;    /* We will overwrite below the final
3656                                            dot with a right brace */
3657                             }
3658                             else {
3659                                 STRLEN char_length; /* cur char's byte length */
3660
3661                                 /* and the number of bytes after this is
3662                                  * translated into hex digits */
3663                                 STRLEN output_length;
3664
3665                                 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3666                                  * for max('U+', '.'); and 1 for NUL */
3667                                 char hex_string[2 * UTF8_MAXBYTES + 5];
3668
3669                                 /* Get the first character of the result. */
3670                                 U32 uv = utf8n_to_uvchr((U8 *) str,
3671                                                         len,
3672                                                         &char_length,
3673                                                         UTF8_ALLOW_ANYUV);
3674                                 /* Convert first code point to hex, including
3675                                  * the boiler plate before it. */
3676                                 output_length =
3677                                     my_snprintf(hex_string, sizeof(hex_string),
3678                                                 "\\N{U+%X",
3679                                                 (unsigned int) uv);
3680
3681                                 /* Make sure there is enough space to hold it */
3682                                 d = off + SvGROW(sv, off
3683                                                     + output_length
3684                                                     + (STRLEN)(send - e)
3685                                                     + 2);       /* '}' + NUL */
3686                                 /* And output it */
3687                                 Copy(hex_string, d, output_length, char);
3688                                 d += output_length;
3689
3690                                 /* For each subsequent character, append dot and
3691                                 * its ordinal in hex */
3692                                 while ((str += char_length) < str_end) {
3693                                     const STRLEN off = d - SvPVX_const(sv);
3694                                     U32 uv = utf8n_to_uvchr((U8 *) str,
3695                                                             str_end - str,
3696                                                             &char_length,
3697                                                             UTF8_ALLOW_ANYUV);
3698                                     output_length =
3699                                         my_snprintf(hex_string,
3700                                                     sizeof(hex_string),
3701                                                     ".%X",
3702                                                     (unsigned int) uv);
3703
3704                                     d = off + SvGROW(sv, off
3705                                                         + output_length
3706                                                         + (STRLEN)(send - e)
3707                                                         + 2);   /* '}' +  NUL */
3708                                     Copy(hex_string, d, output_length, char);
3709                                     d += output_length;
3710                                 }
3711                             }
3712
3713                             *d++ = '}'; /* Done.  Add the trailing brace */
3714                         }
3715                     }
3716                     else { /* Here, not in a pattern.  Convert the name to a
3717                             * string. */
3718
3719                          /* If destination is not in utf8, unconditionally
3720                           * recode it to be so.  This is because \N{} implies
3721                           * Unicode semantics, and scalars have to be in utf8
3722                           * to guarantee those semantics */
3723                         if (! has_utf8) {
3724                             SvCUR_set(sv, d - SvPVX_const(sv));
3725                             SvPOK_on(sv);
3726                             *d = '\0';
3727                             /* See Note on sizing above.  */
3728                             sv_utf8_upgrade_flags_grow(sv,
3729                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3730                                                 len + (STRLEN)(send - s) + 1);
3731                             d = SvPVX(sv) + SvCUR(sv);
3732                             has_utf8 = TRUE;
3733                         } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3734
3735                             /* See Note on sizing above.  (NOTE: SvCUR() is not
3736                              * set correctly here). */
3737                             const STRLEN off = d - SvPVX_const(sv);
3738                             d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3739                         }
3740                         Copy(str, d, len, char);
3741                         d += len;
3742                     }
3743
3744                     SvREFCNT_dec(res);
3745
3746                 } /* End \N{NAME} */
3747 #ifdef EBCDIC
3748                 if (!dorange) 
3749                     native_range = FALSE; /* \N{} is defined to be Unicode */
3750 #endif
3751                 s = e + 1;  /* Point to just after the '}' */
3752                 continue;
3753
3754             /* \c is a control character */
3755             case 'c':
3756                 s++;
3757                 if (s < send) {
3758                     *d++ = grok_bslash_c(*s++, has_utf8, 1);
3759                 }
3760                 else {
3761                     yyerror("Missing control char name in \\c");
3762                 }
3763                 continue;
3764
3765             /* printf-style backslashes, formfeeds, newlines, etc */
3766             case 'b':
3767                 *d++ = '\b';
3768                 break;
3769             case 'n':
3770                 *d++ = '\n';
3771                 break;
3772             case 'r':
3773                 *d++ = '\r';
3774                 break;
3775             case 'f':
3776                 *d++ = '\f';
3777                 break;
3778             case 't':
3779                 *d++ = '\t';
3780                 break;
3781             case 'e':
3782                 *d++ = ASCII_TO_NATIVE('\033');
3783                 break;
3784             case 'a':
3785                 *d++ = '\a';
3786                 break;
3787             } /* end switch */
3788
3789             s++;
3790             continue;
3791         } /* end if (backslash) */
3792 #ifdef EBCDIC
3793         else
3794             literal_endpoint++;
3795 #endif
3796
3797     default_action:
3798         /* If we started with encoded form, or already know we want it,
3799            then encode the next character */
3800         if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3801             STRLEN len  = 1;
3802
3803
3804             /* One might think that it is wasted effort in the case of the
3805              * source being utf8 (this_utf8 == TRUE) to take the next character
3806              * in the source, convert it to an unsigned value, and then convert
3807              * it back again.  But the source has not been validated here.  The
3808              * routine that does the conversion checks for errors like
3809              * malformed utf8 */
3810
3811             const UV nextuv   = (this_utf8)
3812                                 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3813                                 : (UV) ((U8) *s);
3814             const STRLEN need = UNISKIP(nextuv);
3815             if (!has_utf8) {
3816                 SvCUR_set(sv, d - SvPVX_const(sv));
3817                 SvPOK_on(sv);
3818                 *d = '\0';
3819                 /* See Note on sizing above.  */
3820                 sv_utf8_upgrade_flags_grow(sv,
3821                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3822                                         need + (STRLEN)(send - s) + 1);
3823                 d = SvPVX(sv) + SvCUR(sv);
3824                 has_utf8 = TRUE;
3825             } else if (need > len) {
3826                 /* encoded value larger than old, may need extra space (NOTE:
3827                  * SvCUR() is not set correctly here).   See Note on sizing
3828                  * above.  */
3829                 const STRLEN off = d - SvPVX_const(sv);
3830                 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3831             }
3832             s += len;
3833
3834             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3835 #ifdef EBCDIC
3836             if (uv > 255 && !dorange)
3837                 native_range = FALSE;
3838 #endif
3839         }
3840         else {
3841             *d++ = *s++;
3842         }
3843     } /* while loop to process each character */
3844
3845     /* terminate the string and set up the sv */
3846     *d = '\0';
3847     SvCUR_set(sv, d - SvPVX_const(sv));
3848     if (SvCUR(sv) >= SvLEN(sv))
3849         Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3850                    " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3851
3852     SvPOK_on(sv);
3853     if (PL_encoding && !has_utf8) {
3854         sv_recode_to_utf8(sv, PL_encoding);
3855         if (SvUTF8(sv))
3856             has_utf8 = TRUE;
3857     }
3858     if (has_utf8) {
3859         SvUTF8_on(sv);
3860         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3861             PL_sublex_info.sub_op->op_private |=
3862                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3863         }
3864     }
3865
3866     /* shrink the sv if we allocated more than we used */
3867     if (SvCUR(sv) + 5 < SvLEN(sv)) {
3868         SvPV_shrink_to_cur(sv);
3869     }
3870
3871     /* return the substring (via pl_yylval) only if we parsed anything */
3872     if (s > start) {
3873         char *s2 = start;
3874         for (; s2 < s; s2++) {
3875             if (*s2 == '\n')
3876                 COPLINE_INC_WITH_HERELINES;
3877         }
3878         SvREFCNT_inc_simple_void_NN(sv);
3879         if (   (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3880             && ! PL_parser->lex_re_reparsing)
3881         {
3882             const char *const key = PL_lex_inpat ? "qr" : "q";
3883             const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3884             const char *type;
3885             STRLEN typelen;
3886
3887             if (PL_lex_inwhat == OP_TRANS) {
3888                 type = "tr";
3889                 typelen = 2;
3890             } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3891                 type = "s";
3892                 typelen = 1;
3893             } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3894                 type = "q";
3895                 typelen = 1;
3896             } else  {
3897                 type = "qq";
3898                 typelen = 2;
3899             }
3900
3901             sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3902                                 type, typelen);
3903         }
3904         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3905     }
3906     LEAVE_with_name("scan_const");
3907     return s;
3908 }
3909
3910 /* S_intuit_more
3911  * Returns TRUE if there's more to the expression (e.g., a subscript),
3912  * FALSE otherwise.
3913  *
3914  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3915  *
3916  * ->[ and ->{ return TRUE
3917  * { and [ outside a pattern are always subscripts, so return TRUE
3918  * if we're outside a pattern and it's not { or [, then return FALSE
3919  * if we're in a pattern and the first char is a {
3920  *   {4,5} (any digits around the comma) returns FALSE
3921  * if we're in a pattern and the first char is a [
3922  *   [] returns FALSE
3923  *   [SOMETHING] has a funky algorithm to decide whether it's a
3924  *      character class or not.  It has to deal with things like
3925  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3926  * anything else returns TRUE
3927  */
3928
3929 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3930
3931 STATIC int
3932 S_intuit_more(pTHX_ char *s)
3933 {
3934     dVAR;
3935
3936     PERL_ARGS_ASSERT_INTUIT_MORE;
3937
3938     if (PL_lex_brackets)
3939         return TRUE;
3940     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3941         return TRUE;
3942     if (*s != '{' && *s != '[')
3943         return FALSE;
3944     if (!PL_lex_inpat)
3945         return TRUE;
3946
3947     /* In a pattern, so maybe we have {n,m}. */
3948     if (*s == '{') {
3949         if (regcurly(s, FALSE)) {
3950             return FALSE;
3951         }
3952         return TRUE;
3953     }
3954
3955     /* On the other hand, maybe we have a character class */
3956
3957     s++;
3958     if (*s == ']' || *s == '^')
3959         return FALSE;
3960     else {
3961         /* this is terrifying, and it works */
3962         int weight;
3963         char seen[256];
3964         const char * const send = strchr(s,']');
3965         unsigned char un_char, last_un_char;
3966         char tmpbuf[sizeof PL_tokenbuf * 4];
3967
3968         if (!send)              /* has to be an expression */
3969             return TRUE;
3970         weight = 2;             /* let's weigh the evidence */
3971
3972         if (*s == '$')
3973             weight -= 3;
3974         else if (isDIGIT(*s)) {
3975             if (s[1] != ']') {
3976                 if (isDIGIT(s[1]) && s[2] == ']')
3977                     weight -= 10;
3978             }
3979             else
3980                 weight -= 100;
3981         }
3982         Zero(seen,256,char);
3983         un_char = 255;
3984         for (; s < send; s++) {
3985             last_un_char = un_char;
3986             un_char = (unsigned char)*s;
3987             switch (*s) {
3988             case '@':
3989             case '&':
3990             case '$':
3991                 weight -= seen[un_char] * 10;
3992                 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3993                     int len;
3994                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
3995                     len = (int)strlen(tmpbuf);
3996                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3997                                                     UTF ? SVf_UTF8 : 0, SVt_PV))
3998                         weight -= 100;
3999                     else
4000                         weight -= 10;
4001                 }
4002                 else if (*s == '$' && s[1] &&
4003                   strchr("[#!%*<>()-=",s[1])) {
4004                     if (/*{*/ strchr("])} =",s[2]))
4005                         weight -= 10;
4006                     else
4007                         weight -= 1;
4008                 }
4009                 break;
4010             case '\\':
4011                 un_char = 254;
4012                 if (s[1]) {
4013                     if (strchr("wds]",s[1]))
4014                         weight += 100;
4015                     else if (seen[(U8)'\''] || seen[(U8)'"'])
4016                         weight += 1;
4017                     else if (strchr("rnftbxcav",s[1]))
4018                         weight += 40;
4019                     else if (isDIGIT(s[1])) {
4020                         weight += 40;
4021                         while (s[1] && isDIGIT(s[1]))
4022                             s++;
4023                     }
4024                 }
4025                 else
4026                     weight += 100;
4027                 break;
4028             case '-':
4029                 if (s[1] == '\\')
4030                     weight += 50;
4031                 if (strchr("aA01! ",last_un_char))
4032                     weight += 30;
4033                 if (strchr("zZ79~",s[1]))
4034                     weight += 30;
4035                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
4036                     weight -= 5;        /* cope with negative subscript */
4037                 break;
4038             default:
4039                 if (!isWORDCHAR(last_un_char)
4040                     && !(last_un_char == '$' || last_un_char == '@'
4041                          || last_un_char == '&')
4042                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
4043                     char *d = tmpbuf;
4044                     while (isALPHA(*s))
4045                         *d++ = *s++;
4046                     *d = '\0';
4047                     if (keyword(tmpbuf, d - tmpbuf, 0))
4048                         weight -= 150;
4049                 }
4050                 if (un_char == last_un_char + 1)
4051                     weight += 5;
4052                 weight -= seen[un_char];
4053                 break;
4054             }
4055             seen[un_char]++;
4056         }
4057         if (weight >= 0)        /* probably a character class */
4058             return FALSE;
4059     }
4060
4061     return TRUE;
4062 }
4063
4064 /*
4065  * S_intuit_method
4066  *
4067  * Does all the checking to disambiguate
4068  *   foo bar
4069  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
4070  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
4071  *
4072  * First argument is the stuff after the first token, e.g. "bar".
4073  *
4074  * Not a method if foo is a filehandle.
4075  * Not a method if foo is a subroutine prototyped to take a filehandle.
4076  * Not a method if it's really "Foo $bar"
4077  * Method if it's "foo $bar"
4078  * Not a method if it's really "print foo $bar"
4079  * Method if it's really "foo package::" (interpreted as package->foo)
4080  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
4081  * Not a method if bar is a filehandle or package, but is quoted with
4082  *   =>
4083  */
4084
4085 STATIC int
4086 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
4087 {
4088     dVAR;
4089     char *s = start + (*start == '$');
4090     char tmpbuf[sizeof PL_tokenbuf];
4091     STRLEN len;
4092     GV* indirgv;
4093 #ifdef PERL_MAD
4094     int soff;
4095 #endif
4096
4097     PERL_ARGS_ASSERT_INTUIT_METHOD;
4098
4099     if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
4100             return 0;
4101     if (cv && SvPOK(cv)) {
4102         const char *proto = CvPROTO(cv);
4103         if (proto) {
4104             while (*proto && (isSPACE(*proto) || *proto == ';'))
4105                 proto++;
4106             if (*proto == '*')
4107                 return 0;
4108         }
4109     }
4110
4111     if (*start == '$') {
4112         if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
4113                 isUPPER(*PL_tokenbuf))
4114             return 0;
4115 #ifdef PERL_MAD
4116         len = start - SvPVX(PL_linestr);
4117 #endif
4118         s = PEEKSPACE(s);
4119 #ifdef PERL_MAD
4120         start = SvPVX(PL_linestr) + len;
4121 #endif
4122         PL_bufptr = start;
4123         PL_expect = XREF;
4124         return *s == '(' ? FUNCMETH : METHOD;
4125     }
4126
4127     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4128     /* start is the beginning of the possible filehandle/object,
4129      * and s is the end of it
4130      * tmpbuf is a copy of it (but with single quotes as double colons)
4131      */
4132
4133     if (!keyword(tmpbuf, len, 0)) {
4134         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
4135             len -= 2;
4136             tmpbuf[len] = '\0';
4137 #ifdef PERL_MAD
4138             soff = s - SvPVX(PL_linestr);
4139 #endif
4140             goto bare_package;
4141         }
4142         indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
4143         if (indirgv && GvCVu(indirgv))
4144             return 0;
4145         /* filehandle or package name makes it a method */
4146         if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
4147 #ifdef PERL_MAD
4148             soff = s - SvPVX(PL_linestr);
4149 #endif
4150             s = PEEKSPACE(s);
4151             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
4152                 return 0;       /* no assumptions -- "=>" quotes bareword */
4153       bare_package:
4154             start_force(PL_curforce);
4155             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
4156                                                   S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
4157             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
4158             if (PL_madskills)
4159                 curmad('X', newSVpvn_flags(start,SvPVX(PL_linestr) + soff - start,
4160                                                             ( UTF ? SVf_UTF8 : 0 )));
4161             PL_expect = XTERM;
4162             force_next(WORD);
4163             PL_bufptr = s;
4164 #ifdef PERL_MAD
4165             PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
4166 #endif
4167             return *s == '(' ? FUNCMETH : METHOD;
4168         }
4169     }
4170     return 0;
4171 }
4172
4173 /* Encoded script support. filter_add() effectively inserts a
4174  * 'pre-processing' function into the current source input stream.
4175  * Note that the filter function only applies to the current source file
4176  * (e.g., it will not affect files 'require'd or 'use'd by this one).
4177  *
4178  * The datasv parameter (which may be NULL) can be used to pass
4179  * private data to this instance of the filter. The filter function
4180  * can recover the SV using the FILTER_DATA macro and use it to
4181  * store private buffers and state information.
4182  *
4183  * The supplied datasv parameter is upgraded to a PVIO type
4184  * and the IoDIRP/IoANY field is used to store the function pointer,
4185  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
4186  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
4187  * private use must be set using malloc'd pointers.
4188  */
4189
4190 SV *
4191 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
4192 {
4193     dVAR;
4194     if (!funcp)
4195         return NULL;
4196
4197     if (!PL_parser)
4198         return NULL;
4199
4200     if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
4201         Perl_croak(aTHX_ "Source filters apply only to byte streams");
4202
4203     if (!PL_rsfp_filters)
4204         PL_rsfp_filters = newAV();
4205     if (!datasv)
4206         datasv = newSV(0);
4207     SvUPGRADE(datasv, SVt_PVIO);
4208     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
4209     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
4210     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
4211                           FPTR2DPTR(void *, IoANY(datasv)),
4212                           SvPV_nolen(datasv)));
4213     av_unshift(PL_rsfp_filters, 1);
4214     av_store(PL_rsfp_filters, 0, datasv) ;
4215     if (
4216         !PL_parser->filtered
4217      && PL_parser->lex_flags & LEX_EVALBYTES
4218      && PL_bufptr < PL_bufend
4219     ) {
4220         const char *s = PL_bufptr;
4221         while (s < PL_bufend) {
4222             if (*s == '\n') {
4223                 SV *linestr = PL_parser->linestr;
4224                 char *buf = SvPVX(linestr);
4225                 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
4226                 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
4227                 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
4228                 STRLEN const linestart_pos = PL_parser->linestart - buf;
4229                 STRLEN const last_uni_pos =
4230                     PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
4231                 STRLEN const last_lop_pos =
4232                     PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
4233                 av_push(PL_rsfp_filters, linestr);
4234                 PL_parser->linestr = 
4235                     newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
4236                 buf = SvPVX(PL_parser->linestr);
4237                 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
4238                 PL_parser->bufptr = buf + bufptr_pos;
4239                 PL_parser->oldbufptr = buf + oldbufptr_pos;
4240                 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
4241                 PL_parser->linestart = buf + linestart_pos;
4242                 if (PL_parser->last_uni)
4243                     PL_parser->last_uni = buf + last_uni_pos;
4244                 if (PL_parser->last_lop)
4245                     PL_parser->last_lop = buf + last_lop_pos;
4246                 SvLEN(linestr) = SvCUR(linestr);
4247                 SvCUR(linestr) = s-SvPVX(linestr);
4248                 PL_parser->filtered = 1;
4249                 break;
4250             }
4251             s++;
4252         }
4253     }
4254     return(datasv);
4255 }
4256
4257
4258 /* Delete most recently added instance of this filter function. */
4259 void
4260 Perl_filter_del(pTHX_ filter_t funcp)
4261 {
4262     dVAR;
4263     SV *datasv;
4264
4265     PERL_ARGS_ASSERT_FILTER_DEL;
4266
4267 #ifdef DEBUGGING
4268     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
4269                           FPTR2DPTR(void*, funcp)));
4270 #endif
4271     if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
4272         return;
4273     /* if filter is on top of stack (usual case) just pop it off */
4274     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
4275     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
4276         sv_free(av_pop(PL_rsfp_filters));
4277
4278         return;
4279     }
4280     /* we need to search for the correct entry and clear it     */
4281     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
4282 }
4283
4284
4285 /* Invoke the idxth filter function for the current rsfp.        */
4286 /* maxlen 0 = read one text line */
4287 I32
4288 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
4289 {
4290     dVAR;
4291     filter_t funcp;
4292     SV *datasv = NULL;
4293     /* This API is bad. It should have been using unsigned int for maxlen.
4294        Not sure if we want to change the API, but if not we should sanity
4295        check the value here.  */
4296     unsigned int correct_length = maxlen < 0 ?  PERL_INT_MAX : maxlen;
4297
4298     PERL_ARGS_ASSERT_FILTER_READ;
4299
4300     if (!PL_parser || !PL_rsfp_filters)
4301         return -1;
4302     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
4303         /* Provide a default input filter to make life easy.    */
4304         /* Note that we append to the line. This is handy.      */
4305         DEBUG_P(PerlIO_printf(Perl_debug_log,
4306                               "filter_read %d: from rsfp\n", idx));
4307         if (correct_length) {
4308             /* Want a block */
4309             int len ;
4310             const int old_len = SvCUR(buf_sv);
4311
4312             /* ensure buf_sv is large enough */
4313             SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4314             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4315                                    correct_length)) <= 0) {
4316                 if (PerlIO_error(PL_rsfp))
4317                     return -1;          /* error */
4318                 else
4319                     return 0 ;          /* end of file */
4320             }
4321             SvCUR_set(buf_sv, old_len + len) ;
4322             SvPVX(buf_sv)[old_len + len] = '\0';
4323         } else {
4324             /* Want a line */
4325             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4326                 if (PerlIO_error(PL_rsfp))
4327                     return -1;          /* error */
4328                 else
4329                     return 0 ;          /* end of file */
4330             }
4331         }
4332         return SvCUR(buf_sv);
4333     }
4334     /* Skip this filter slot if filter has been deleted */
4335     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4336         DEBUG_P(PerlIO_printf(Perl_debug_log,
4337                               "filter_read %d: skipped (filter deleted)\n",
4338                               idx));
4339         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4340     }
4341     if (SvTYPE(datasv) != SVt_PVIO) {
4342         if (correct_length) {
4343             /* Want a block */
4344             const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4345             if (!remainder) return 0; /* eof */
4346             if (correct_length > remainder) correct_length = remainder;
4347             sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4348             SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4349         } else {
4350             /* Want a line */
4351             const char *s = SvEND(datasv);
4352             const char *send = SvPVX(datasv) + SvLEN(datasv);
4353             while (s < send) {
4354                 if (*s == '\n') {
4355                     s++;
4356                     break;
4357                 }
4358                 s++;
4359             }
4360             if (s == send) return 0; /* eof */
4361             sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4362             SvCUR_set(datasv, s-SvPVX(datasv));
4363         }
4364         return SvCUR(buf_sv);
4365     }
4366     /* Get function pointer hidden within datasv        */
4367     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4368     DEBUG_P(PerlIO_printf(Perl_debug_log,
4369                           "filter_read %d: via function %p (%s)\n",
4370                           idx, (void*)datasv, SvPV_nolen_const(datasv)));
4371     /* Call function. The function is expected to       */
4372     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
4373     /* Return: <0:error, =0:eof, >0:not eof             */
4374     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4375 }
4376
4377 STATIC char *
4378 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4379 {
4380     dVAR;
4381
4382     PERL_ARGS_ASSERT_FILTER_GETS;
4383
4384 #ifdef PERL_CR_FILTER
4385     if (!PL_rsfp_filters) {
4386         filter_add(S_cr_textfilter,NULL);
4387     }
4388 #endif
4389     if (PL_rsfp_filters) {
4390         if (!append)
4391             SvCUR_set(sv, 0);   /* start with empty line        */
4392         if (FILTER_READ(0, sv, 0) > 0)
4393             return ( SvPVX(sv) ) ;
4394         else
4395             return NULL ;
4396     }
4397     else
4398         return (sv_gets(sv, PL_rsfp, append));
4399 }
4400
4401 STATIC HV *
4402 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4403 {
4404     dVAR;
4405     GV *gv;
4406
4407     PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4408
4409     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4410         return PL_curstash;
4411
4412     if (len > 2 &&
4413         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4414         (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4415     {
4416         return GvHV(gv);                        /* Foo:: */
4417     }
4418
4419     /* use constant CLASS => 'MyClass' */
4420     gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4421     if (gv && GvCV(gv)) {
4422         SV * const sv = cv_const_sv(GvCV(gv));
4423         if (sv)
4424             pkgname = SvPV_const(sv, len);
4425     }
4426
4427     return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4428 }
4429
4430 /*
4431  * S_readpipe_override
4432  * Check whether readpipe() is overridden, and generates the appropriate
4433  * optree, provided sublex_start() is called afterwards.
4434  */
4435 STATIC void
4436 S_readpipe_override(pTHX)
4437 {
4438     GV **gvp;
4439     GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
4440     pl_yylval.ival = OP_BACKTICK;
4441     if ((gv_readpipe
4442                 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
4443             ||
4444             ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
4445              && (gv_readpipe = *gvp) && isGV_with_GP(gv_readpipe)
4446              && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
4447     {
4448         COPLINE_SET_FROM_MULTI_END;
4449         PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
4450             op_append_elem(OP_LIST,
4451                 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
4452                 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
4453     }
4454 }
4455
4456 #ifdef PERL_MAD 
4457  /*
4458  * Perl_madlex
4459  * The intent of this yylex wrapper is to minimize the changes to the
4460  * tokener when we aren't interested in collecting madprops.  It remains
4461  * to be seen how successful this strategy will be...
4462  */
4463
4464 int
4465 Perl_madlex(pTHX)
4466 {
4467     int optype;
4468     char *s = PL_bufptr;
4469
4470     /* make sure PL_thiswhite is initialized */
4471     PL_thiswhite = 0;
4472