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