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