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