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