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