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