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