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