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