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