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