Perl_scalarvoid remove duplicate SvNV call
[perl.git] / toke.c
1 /*    toke.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *  'It all comes from here, the stench and the peril.'    --Frodo
13  *
14  *     [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
15  */
16
17 /*
18  * This file is the lexer for Perl.  It's closely linked to the
19  * parser, perly.y.
20  *
21  * The main routine is yylex(), which returns the next token.
22  */
23
24 /*
25 =head1 Lexer interface
26 This is the lower layer of the Perl parser, managing characters and tokens.
27
28 =for apidoc AmU|yy_parser *|PL_parser
29
30 Pointer to a structure encapsulating the state of the parsing operation
31 currently in progress.  The pointer can be locally changed to perform
32 a nested parse without interfering with the state of an outer parse.
33 Individual members of C<PL_parser> have their own documentation.
34
35 =cut
36 */
37
38 #include "EXTERN.h"
39 #define PERL_IN_TOKE_C
40 #include "perl.h"
41 #include "dquote_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  */
1991
1992 STATIC char *
1993 S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
1994 {
1995     char *s;
1996     STRLEN len;
1997
1998     PERL_ARGS_ASSERT_FORCE_WORD;
1999
2000     start = skipspace(start);
2001     s = start;
2002     if (isIDFIRST_lazy_if(s,UTF) ||
2003         (allow_pack && *s == ':') )
2004     {
2005         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
2006         if (check_keyword) {
2007           char *s2 = PL_tokenbuf;
2008           if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
2009             s2 += 6, len -= 6;
2010           if (keyword(s2, len, 0))
2011             return start;
2012         }
2013         if (token == METHOD) {
2014             s = skipspace(s);
2015             if (*s == '(')
2016                 PL_expect = XTERM;
2017             else {
2018                 PL_expect = XOPERATOR;
2019             }
2020         }
2021         NEXTVAL_NEXTTOKE.opval
2022             = (OP*)newSVOP(OP_CONST,0,
2023                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
2024         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
2025         force_next(token);
2026     }
2027     return s;
2028 }
2029
2030 /*
2031  * S_force_ident
2032  * Called when the lexer wants $foo *foo &foo etc, but the program
2033  * text only contains the "foo" portion.  The first argument is a pointer
2034  * to the "foo", and the second argument is the type symbol to prefix.
2035  * Forces the next token to be a "WORD".
2036  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
2037  */
2038
2039 STATIC void
2040 S_force_ident(pTHX_ const char *s, int kind)
2041 {
2042     PERL_ARGS_ASSERT_FORCE_IDENT;
2043
2044     if (s[0]) {
2045         const STRLEN len = s[1] ? strlen(s) : 1; /* s = "\"" see yylex */
2046         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn_flags(s, len,
2047                                                                 UTF ? SVf_UTF8 : 0));
2048         NEXTVAL_NEXTTOKE.opval = o;
2049         force_next(WORD);
2050         if (kind) {
2051             o->op_private = OPpCONST_ENTERED;
2052             /* XXX see note in pp_entereval() for why we forgo typo
2053                warnings if the symbol must be introduced in an eval.
2054                GSAR 96-10-12 */
2055             gv_fetchpvn_flags(s, len,
2056                               (PL_in_eval ? GV_ADDMULTI
2057                               : GV_ADD) | ( UTF ? SVf_UTF8 : 0 ),
2058                               kind == '$' ? SVt_PV :
2059                               kind == '@' ? SVt_PVAV :
2060                               kind == '%' ? SVt_PVHV :
2061                               SVt_PVGV
2062                               );
2063         }
2064     }
2065 }
2066
2067 static void
2068 S_force_ident_maybe_lex(pTHX_ char pit)
2069 {
2070     NEXTVAL_NEXTTOKE.ival = pit;
2071     force_next('p');
2072 }
2073
2074 NV
2075 Perl_str_to_version(pTHX_ SV *sv)
2076 {
2077     NV retval = 0.0;
2078     NV nshift = 1.0;
2079     STRLEN len;
2080     const char *start = SvPV_const(sv,len);
2081     const char * const end = start + len;
2082     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
2083
2084     PERL_ARGS_ASSERT_STR_TO_VERSION;
2085
2086     while (start < end) {
2087         STRLEN skip;
2088         UV n;
2089         if (utf)
2090             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
2091         else {
2092             n = *(U8*)start;
2093             skip = 1;
2094         }
2095         retval += ((NV)n)/nshift;
2096         start += skip;
2097         nshift *= 1000;
2098     }
2099     return retval;
2100 }
2101
2102 /*
2103  * S_force_version
2104  * Forces the next token to be a version number.
2105  * If the next token appears to be an invalid version number, (e.g. "v2b"),
2106  * and if "guessing" is TRUE, then no new token is created (and the caller
2107  * must use an alternative parsing method).
2108  */
2109
2110 STATIC char *
2111 S_force_version(pTHX_ char *s, int guessing)
2112 {
2113     OP *version = NULL;
2114     char *d;
2115
2116     PERL_ARGS_ASSERT_FORCE_VERSION;
2117
2118     s = skipspace(s);
2119
2120     d = s;
2121     if (*d == 'v')
2122         d++;
2123     if (isDIGIT(*d)) {
2124         while (isDIGIT(*d) || *d == '_' || *d == '.')
2125             d++;
2126         if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
2127             SV *ver;
2128             s = scan_num(s, &pl_yylval);
2129             version = pl_yylval.opval;
2130             ver = cSVOPx(version)->op_sv;
2131             if (SvPOK(ver) && !SvNIOK(ver)) {
2132                 SvUPGRADE(ver, SVt_PVNV);
2133                 SvNV_set(ver, str_to_version(ver));
2134                 SvNOK_on(ver);          /* hint that it is a version */
2135             }
2136         }
2137         else if (guessing) {
2138             return s;
2139         }
2140     }
2141
2142     /* NOTE: The parser sees the package name and the VERSION swapped */
2143     NEXTVAL_NEXTTOKE.opval = version;
2144     force_next(WORD);
2145
2146     return s;
2147 }
2148
2149 /*
2150  * S_force_strict_version
2151  * Forces the next token to be a version number using strict syntax rules.
2152  */
2153
2154 STATIC char *
2155 S_force_strict_version(pTHX_ char *s)
2156 {
2157     OP *version = NULL;
2158     const char *errstr = NULL;
2159
2160     PERL_ARGS_ASSERT_FORCE_STRICT_VERSION;
2161
2162     while (isSPACE(*s)) /* leading whitespace */
2163         s++;
2164
2165     if (is_STRICT_VERSION(s,&errstr)) {
2166         SV *ver = newSV(0);
2167         s = (char *)scan_version(s, ver, 0);
2168         version = newSVOP(OP_CONST, 0, ver);
2169     }
2170     else if ( (*s != ';' && *s != '{' && *s != '}' ) &&
2171             (s = skipspace(s), (*s != ';' && *s != '{' && *s != '}' )))
2172     {
2173         PL_bufptr = s;
2174         if (errstr)
2175             yyerror(errstr); /* version required */
2176         return s;
2177     }
2178
2179     /* NOTE: The parser sees the package name and the VERSION swapped */
2180     NEXTVAL_NEXTTOKE.opval = version;
2181     force_next(WORD);
2182
2183     return s;
2184 }
2185
2186 /*
2187  * S_tokeq
2188  * Tokenize a quoted string passed in as an SV.  It finds the next
2189  * chunk, up to end of string or a backslash.  It may make a new
2190  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
2191  * turns \\ into \.
2192  */
2193
2194 STATIC SV *
2195 S_tokeq(pTHX_ SV *sv)
2196 {
2197     char *s;
2198     char *send;
2199     char *d;
2200     SV *pv = sv;
2201
2202     PERL_ARGS_ASSERT_TOKEQ;
2203
2204     assert (SvPOK(sv));
2205     assert (SvLEN(sv));
2206     assert (!SvIsCOW(sv));
2207     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) /* <<'heredoc' */
2208         goto finish;
2209     s = SvPVX(sv);
2210     send = SvEND(sv);
2211     /* This is relying on the SV being "well formed" with a trailing '\0'  */
2212     while (s < send && !(*s == '\\' && s[1] == '\\'))
2213         s++;
2214     if (s == send)
2215         goto finish;
2216     d = s;
2217     if ( PL_hints & HINT_NEW_STRING ) {
2218         pv = newSVpvn_flags(SvPVX_const(pv), SvCUR(sv),
2219                             SVs_TEMP | SvUTF8(sv));
2220     }
2221     while (s < send) {
2222         if (*s == '\\') {
2223             if (s + 1 < send && (s[1] == '\\'))
2224                 s++;            /* all that, just for this */
2225         }
2226         *d++ = *s++;
2227     }
2228     *d = '\0';
2229     SvCUR_set(sv, d - SvPVX_const(sv));
2230   finish:
2231     if ( PL_hints & HINT_NEW_STRING )
2232        return new_constant(NULL, 0, "q", sv, pv, "q", 1);
2233     return sv;
2234 }
2235
2236 /*
2237  * Now come three functions related to double-quote context,
2238  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
2239  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
2240  * interact with PL_lex_state, and create fake ( ... ) argument lists
2241  * to handle functions and concatenation.
2242  * For example,
2243  *   "foo\lbar"
2244  * is tokenised as
2245  *    stringify ( const[foo] concat lcfirst ( const[bar] ) )
2246  */
2247
2248 /*
2249  * S_sublex_start
2250  * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
2251  *
2252  * Pattern matching will set PL_lex_op to the pattern-matching op to
2253  * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
2254  *
2255  * OP_CONST and OP_READLINE are easy--just make the new op and return.
2256  *
2257  * Everything else becomes a FUNC.
2258  *
2259  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
2260  * had an OP_CONST or OP_READLINE).  This just sets us up for a
2261  * call to S_sublex_push().
2262  */
2263
2264 STATIC I32
2265 S_sublex_start(pTHX)
2266 {
2267     const I32 op_type = pl_yylval.ival;
2268
2269     if (op_type == OP_NULL) {
2270         pl_yylval.opval = PL_lex_op;
2271         PL_lex_op = NULL;
2272         return THING;
2273     }
2274     if (op_type == OP_CONST) {
2275         SV *sv = tokeq(PL_lex_stuff);
2276
2277         if (SvTYPE(sv) == SVt_PVIV) {
2278             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
2279             STRLEN len;
2280             const char * const p = SvPV_const(sv, len);
2281             SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
2282             SvREFCNT_dec(sv);
2283             sv = nsv;
2284         }
2285         pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
2286         PL_lex_stuff = NULL;
2287         return THING;
2288     }
2289
2290     PL_sublex_info.super_state = PL_lex_state;
2291     PL_sublex_info.sub_inwhat = (U16)op_type;
2292     PL_sublex_info.sub_op = PL_lex_op;
2293     PL_lex_state = LEX_INTERPPUSH;
2294
2295     PL_expect = XTERM;
2296     if (PL_lex_op) {
2297         pl_yylval.opval = PL_lex_op;
2298         PL_lex_op = NULL;
2299         return PMFUNC;
2300     }
2301     else
2302         return FUNC;
2303 }
2304
2305 /*
2306  * S_sublex_push
2307  * Create a new scope to save the lexing state.  The scope will be
2308  * ended in S_sublex_done.  Returns a '(', starting the function arguments
2309  * to the uc, lc, etc. found before.
2310  * Sets PL_lex_state to LEX_INTERPCONCAT.
2311  */
2312
2313 STATIC I32
2314 S_sublex_push(pTHX)
2315 {
2316     LEXSHARED *shared;
2317     const bool is_heredoc = PL_multi_close == '<';
2318     ENTER;
2319
2320     PL_lex_state = PL_sublex_info.super_state;
2321     SAVEI8(PL_lex_dojoin);
2322     SAVEI32(PL_lex_brackets);
2323     SAVEI32(PL_lex_allbrackets);
2324     SAVEI32(PL_lex_formbrack);
2325     SAVEI8(PL_lex_fakeeof);
2326     SAVEI32(PL_lex_casemods);
2327     SAVEI32(PL_lex_starts);
2328     SAVEI8(PL_lex_state);
2329     SAVESPTR(PL_lex_repl);
2330     SAVEVPTR(PL_lex_inpat);
2331     SAVEI16(PL_lex_inwhat);
2332     if (is_heredoc)
2333     {
2334         SAVECOPLINE(PL_curcop);
2335         SAVEI32(PL_multi_end);
2336         SAVEI32(PL_parser->herelines);
2337         PL_parser->herelines = 0;
2338     }
2339     SAVEI8(PL_multi_close);
2340     SAVEPPTR(PL_bufptr);
2341     SAVEPPTR(PL_bufend);
2342     SAVEPPTR(PL_oldbufptr);
2343     SAVEPPTR(PL_oldoldbufptr);
2344     SAVEPPTR(PL_last_lop);
2345     SAVEPPTR(PL_last_uni);
2346     SAVEPPTR(PL_linestart);
2347     SAVESPTR(PL_linestr);
2348     SAVEGENERICPV(PL_lex_brackstack);
2349     SAVEGENERICPV(PL_lex_casestack);
2350     SAVEGENERICPV(PL_parser->lex_shared);
2351     SAVEBOOL(PL_parser->lex_re_reparsing);
2352     SAVEI32(PL_copline);
2353
2354     /* The here-doc parser needs to be able to peek into outer lexing
2355        scopes to find the body of the here-doc.  So we put PL_linestr and
2356        PL_bufptr into lex_shared, to ‘share’ those values.
2357      */
2358     PL_parser->lex_shared->ls_linestr = PL_linestr;
2359     PL_parser->lex_shared->ls_bufptr  = PL_bufptr;
2360
2361     PL_linestr = PL_lex_stuff;
2362     PL_lex_repl = PL_sublex_info.repl;
2363     PL_lex_stuff = NULL;
2364     PL_sublex_info.repl = NULL;
2365
2366     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
2367         = SvPVX(PL_linestr);
2368     PL_bufend += SvCUR(PL_linestr);
2369     PL_last_lop = PL_last_uni = NULL;
2370     SAVEFREESV(PL_linestr);
2371     if (PL_lex_repl) SAVEFREESV(PL_lex_repl);
2372
2373     PL_lex_dojoin = FALSE;
2374     PL_lex_brackets = PL_lex_formbrack = 0;
2375     PL_lex_allbrackets = 0;
2376     PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2377     Newx(PL_lex_brackstack, 120, char);
2378     Newx(PL_lex_casestack, 12, char);
2379     PL_lex_casemods = 0;
2380     *PL_lex_casestack = '\0';
2381     PL_lex_starts = 0;
2382     PL_lex_state = LEX_INTERPCONCAT;
2383     if (is_heredoc)
2384         CopLINE_set(PL_curcop, (line_t)PL_multi_start);
2385     PL_copline = NOLINE;
2386     
2387     Newxz(shared, 1, LEXSHARED);
2388     shared->ls_prev = PL_parser->lex_shared;
2389     PL_parser->lex_shared = shared;
2390
2391     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
2392     if (PL_lex_inwhat == OP_TRANSR) PL_lex_inwhat = OP_TRANS;
2393     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
2394         PL_lex_inpat = PL_sublex_info.sub_op;
2395     else
2396         PL_lex_inpat = NULL;
2397
2398     PL_parser->lex_re_reparsing = cBOOL(PL_in_eval & EVAL_RE_REPARSING);
2399     PL_in_eval &= ~EVAL_RE_REPARSING;
2400
2401     return '(';
2402 }
2403
2404 /*
2405  * S_sublex_done
2406  * Restores lexer state after a S_sublex_push.
2407  */
2408
2409 STATIC I32
2410 S_sublex_done(pTHX)
2411 {
2412     if (!PL_lex_starts++) {
2413         SV * const sv = newSVpvs("");
2414         if (SvUTF8(PL_linestr))
2415             SvUTF8_on(sv);
2416         PL_expect = XOPERATOR;
2417         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2418         return THING;
2419     }
2420
2421     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
2422         PL_lex_state = LEX_INTERPCASEMOD;
2423         return yylex();
2424     }
2425
2426     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
2427     assert(PL_lex_inwhat != OP_TRANSR);
2428     if (PL_lex_repl) {
2429         assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
2430         PL_linestr = PL_lex_repl;
2431         PL_lex_inpat = 0;
2432         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
2433         PL_bufend += SvCUR(PL_linestr);
2434         PL_last_lop = PL_last_uni = NULL;
2435         PL_lex_dojoin = FALSE;
2436         PL_lex_brackets = 0;
2437         PL_lex_allbrackets = 0;
2438         PL_lex_fakeeof = LEX_FAKEEOF_NEVER;
2439         PL_lex_casemods = 0;
2440         *PL_lex_casestack = '\0';
2441         PL_lex_starts = 0;
2442         if (SvEVALED(PL_lex_repl)) {
2443             PL_lex_state = LEX_INTERPNORMAL;
2444             PL_lex_starts++;
2445             /*  we don't clear PL_lex_repl here, so that we can check later
2446                 whether this is an evalled subst; that means we rely on the
2447                 logic to ensure sublex_done() is called again only via the
2448                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
2449         }
2450         else {
2451             PL_lex_state = LEX_INTERPCONCAT;
2452             PL_lex_repl = NULL;
2453         }
2454         if (SvTYPE(PL_linestr) >= SVt_PVNV) {
2455             CopLINE(PL_curcop) +=
2456                 ((XPVNV*)SvANY(PL_linestr))->xnv_u.xpad_cop_seq.xlow
2457                  + PL_parser->herelines;
2458             PL_parser->herelines = 0;
2459         }
2460         return ',';
2461     }
2462     else {
2463         const line_t l = CopLINE(PL_curcop);
2464         LEAVE;
2465         if (PL_multi_close == '<')
2466             PL_parser->herelines += l - PL_multi_end;
2467         PL_bufend = SvPVX(PL_linestr);
2468         PL_bufend += SvCUR(PL_linestr);
2469         PL_expect = XOPERATOR;
2470         PL_sublex_info.sub_inwhat = 0;
2471         return ')';
2472     }
2473 }
2474
2475 PERL_STATIC_INLINE SV*
2476 S_get_and_check_backslash_N_name(pTHX_ const char* s, const char* const e)
2477 {
2478     /* <s> points to first character of interior of \N{}, <e> to one beyond the
2479      * interior, hence to the "}".  Finds what the name resolves to, returning
2480      * an SV* containing it; NULL if no valid one found */
2481
2482     SV* res = newSVpvn_flags(s, e - s, UTF ? SVf_UTF8 : 0);
2483
2484     HV * table;
2485     SV **cvp;
2486     SV *cv;
2487     SV *rv;
2488     HV *stash;
2489     const U8* first_bad_char_loc;
2490     const char* backslash_ptr = s - 3; /* Points to the <\> of \N{... */
2491
2492     PERL_ARGS_ASSERT_GET_AND_CHECK_BACKSLASH_N_NAME;
2493
2494     if (UTF && ! is_utf8_string_loc((U8 *) backslash_ptr,
2495                                      e - backslash_ptr,
2496                                      &first_bad_char_loc))
2497     {
2498         /* If warnings are on, this will print a more detailed analysis of what
2499          * is wrong than the error message below */
2500         utf8n_to_uvchr(first_bad_char_loc,
2501                        e - ((char *) first_bad_char_loc),
2502                        NULL, 0);
2503
2504         /* We deliberately don't try to print the malformed character, which
2505          * might not print very well; it also may be just the first of many
2506          * malformations, so don't print what comes after it */
2507         yyerror(Perl_form(aTHX_
2508             "Malformed UTF-8 character immediately after '%.*s'",
2509             (int) (first_bad_char_loc - (U8 *) backslash_ptr), backslash_ptr));
2510         return NULL;
2511     }
2512
2513     res = new_constant( NULL, 0, "charnames", res, NULL, backslash_ptr,
2514                         /* include the <}> */
2515                         e - backslash_ptr + 1);
2516     if (! SvPOK(res)) {
2517         SvREFCNT_dec_NN(res);
2518         return NULL;
2519     }
2520
2521     /* See if the charnames handler is the Perl core's, and if so, we can skip
2522      * the validation needed for a user-supplied one, as Perl's does its own
2523      * validation. */
2524     table = GvHV(PL_hintgv);             /* ^H */
2525     cvp = hv_fetchs(table, "charnames", FALSE);
2526     if (cvp && (cv = *cvp) && SvROK(cv) && (rv = SvRV(cv),
2527         SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
2528     {
2529         const char * const name = HvNAME(stash);
2530         if (HvNAMELEN(stash) == sizeof("_charnames")-1
2531          && strEQ(name, "_charnames")) {
2532            return res;
2533        }
2534     }
2535
2536     /* Here, it isn't Perl's charname handler.  We can't rely on a
2537      * user-supplied handler to validate the input name.  For non-ut8 input,
2538      * look to see that the first character is legal.  Then loop through the
2539      * rest checking that each is a continuation */
2540
2541     /* This code makes the reasonable assumption that the only Latin1-range
2542      * characters that begin a character name alias are alphabetic, otherwise
2543      * would have to create a isCHARNAME_BEGIN macro */
2544
2545     if (! UTF) {
2546         if (! isALPHAU(*s)) {
2547             goto bad_charname;
2548         }
2549         s++;
2550         while (s < e) {
2551             if (! isCHARNAME_CONT(*s)) {
2552                 goto bad_charname;
2553             }
2554             if (*s == ' ' && *(s-1) == ' ') {
2555                 goto multi_spaces;
2556             }
2557             if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
2558                 Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2559                            "NO-BREAK SPACE in a charnames "
2560                            "alias definition is deprecated");
2561             }
2562             s++;
2563         }
2564     }
2565     else {
2566         /* Similarly for utf8.  For invariants can check directly; for other
2567          * Latin1, can calculate their code point and check; otherwise  use a
2568          * swash */
2569         if (UTF8_IS_INVARIANT(*s)) {
2570             if (! isALPHAU(*s)) {
2571                 goto bad_charname;
2572             }
2573             s++;
2574         } else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2575             if (! isALPHAU(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1)))) {
2576                 goto bad_charname;
2577             }
2578             s += 2;
2579         }
2580         else {
2581             if (! PL_utf8_charname_begin) {
2582                 U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2583                 PL_utf8_charname_begin = _core_swash_init("utf8",
2584                                                         "_Perl_Charname_Begin",
2585                                                         &PL_sv_undef,
2586                                                         1, 0, NULL, &flags);
2587             }
2588             if (! swash_fetch(PL_utf8_charname_begin, (U8 *) s, TRUE)) {
2589                 goto bad_charname;
2590             }
2591             s += UTF8SKIP(s);
2592         }
2593
2594         while (s < e) {
2595             if (UTF8_IS_INVARIANT(*s)) {
2596                 if (! isCHARNAME_CONT(*s)) {
2597                     goto bad_charname;
2598                 }
2599                 if (*s == ' ' && *(s-1) == ' ') {
2600                     goto multi_spaces;
2601                 }
2602                 s++;
2603             }
2604             else if (UTF8_IS_DOWNGRADEABLE_START(*s)) {
2605                 if (! isCHARNAME_CONT(TWO_BYTE_UTF8_TO_NATIVE(*s, *(s+1))))
2606                 {
2607                     goto bad_charname;
2608                 }
2609                 if (*s == *NBSP_UTF8
2610                     && *(s+1) == *(NBSP_UTF8+1)
2611                     && ckWARN_d(WARN_DEPRECATED))
2612                 {
2613                     Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
2614                                 "NO-BREAK SPACE in a charnames "
2615                                 "alias definition is deprecated");
2616                 }
2617                 s += 2;
2618             }
2619             else {
2620                 if (! PL_utf8_charname_continue) {
2621                     U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2622                     PL_utf8_charname_continue = _core_swash_init("utf8",
2623                                                 "_Perl_Charname_Continue",
2624                                                 &PL_sv_undef,
2625                                                 1, 0, NULL, &flags);
2626                 }
2627                 if (! swash_fetch(PL_utf8_charname_continue, (U8 *) s, TRUE)) {
2628                     goto bad_charname;
2629                 }
2630                 s += UTF8SKIP(s);
2631             }
2632         }
2633     }
2634     if (*(s-1) == ' ') {
2635         yyerror_pv(
2636             Perl_form(aTHX_
2637             "charnames alias definitions may not contain trailing "
2638             "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
2639             (int)(s - backslash_ptr + 1), backslash_ptr,
2640             (int)(e - s + 1), s + 1
2641             ),
2642         UTF ? SVf_UTF8 : 0);
2643         return NULL;
2644     }
2645
2646     if (SvUTF8(res)) { /* Don't accept malformed input */
2647         const U8* first_bad_char_loc;
2648         STRLEN len;
2649         const char* const str = SvPV_const(res, len);
2650         if (! is_utf8_string_loc((U8 *) str, len, &first_bad_char_loc)) {
2651             /* If warnings are on, this will print a more detailed analysis of
2652              * what is wrong than the error message below */
2653             utf8n_to_uvchr(first_bad_char_loc,
2654                            (char *) first_bad_char_loc - str,
2655                            NULL, 0);
2656
2657             /* We deliberately don't try to print the malformed character,
2658              * which might not print very well; it also may be just the first
2659              * of many malformations, so don't print what comes after it */
2660             yyerror_pv(
2661               Perl_form(aTHX_
2662                 "Malformed UTF-8 returned by %.*s immediately after '%.*s'",
2663                  (int) (e - backslash_ptr + 1), backslash_ptr,
2664                  (int) ((char *) first_bad_char_loc - str), str
2665               ),
2666               SVf_UTF8);
2667             return NULL;
2668         }
2669     }
2670
2671     return res;
2672
2673   bad_charname: {
2674
2675         /* The final %.*s makes sure that should the trailing NUL be missing
2676          * that this print won't run off the end of the string */
2677         yyerror_pv(
2678           Perl_form(aTHX_
2679             "Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
2680             (int)(s - backslash_ptr + 1), backslash_ptr,
2681             (int)(e - s + 1), s + 1
2682           ),
2683           UTF ? SVf_UTF8 : 0);
2684         return NULL;
2685     }
2686
2687   multi_spaces:
2688         yyerror_pv(
2689           Perl_form(aTHX_
2690             "charnames alias definitions may not contain a sequence of "
2691             "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
2692             (int)(s - backslash_ptr + 1), backslash_ptr,
2693             (int)(e - s + 1), s + 1
2694           ),
2695           UTF ? SVf_UTF8 : 0);
2696         return NULL;
2697 }
2698
2699 /*
2700   scan_const
2701
2702   Extracts the next constant part of a pattern, double-quoted string,
2703   or transliteration.  This is terrifying code.
2704
2705   For example, in parsing the double-quoted string "ab\x63$d", it would
2706   stop at the '$' and return an OP_CONST containing 'abc'.
2707
2708   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
2709   processing a pattern (PL_lex_inpat is true), a transliteration
2710   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
2711
2712   Returns a pointer to the character scanned up to. If this is
2713   advanced from the start pointer supplied (i.e. if anything was
2714   successfully parsed), will leave an OP_CONST for the substring scanned
2715   in pl_yylval. Caller must intuit reason for not parsing further
2716   by looking at the next characters herself.
2717
2718   In patterns:
2719     expand:
2720       \N{FOO}  => \N{U+hex_for_character_FOO}
2721       (if FOO expands to multiple characters, expands to \N{U+xx.XX.yy ...})
2722
2723     pass through:
2724         all other \-char, including \N and \N{ apart from \N{ABC}
2725
2726     stops on:
2727         @ and $ where it appears to be a var, but not for $ as tail anchor
2728         \l \L \u \U \Q \E
2729         (?{  or  (??{
2730
2731
2732   In transliterations:
2733     characters are VERY literal, except for - not at the start or end
2734     of the string, which indicates a range. If the range is in bytes,
2735     scan_const expands the range to the full set of intermediate
2736     characters. If the range is in utf8, the hyphen is replaced with
2737     a certain range mark which will be handled by pmtrans() in op.c.
2738
2739   In double-quoted strings:
2740     backslashes:
2741       double-quoted style: \r and \n
2742       constants: \x31, etc.
2743       deprecated backrefs: \1 (in substitution replacements)
2744       case and quoting: \U \Q \E
2745     stops on @ and $
2746
2747   scan_const does *not* construct ops to handle interpolated strings.
2748   It stops processing as soon as it finds an embedded $ or @ variable
2749   and leaves it to the caller to work out what's going on.
2750
2751   embedded arrays (whether in pattern or not) could be:
2752       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
2753
2754   $ in double-quoted strings must be the symbol of an embedded scalar.
2755
2756   $ in pattern could be $foo or could be tail anchor.  Assumption:
2757   it's a tail anchor if $ is the last thing in the string, or if it's
2758   followed by one of "()| \r\n\t"
2759
2760   \1 (backreferences) are turned into $1 in substitutions
2761
2762   The structure of the code is
2763       while (there's a character to process) {
2764           handle transliteration ranges
2765           skip regexp comments /(?#comment)/ and codes /(?{code})/
2766           skip #-initiated comments in //x patterns
2767           check for embedded arrays
2768           check for embedded scalars
2769           if (backslash) {
2770               deprecate \1 in substitution replacements
2771               handle string-changing backslashes \l \U \Q \E, etc.
2772               switch (what was escaped) {
2773                   handle \- in a transliteration (becomes a literal -)
2774                   if a pattern and not \N{, go treat as regular character
2775                   handle \132 (octal characters)
2776                   handle \x15 and \x{1234} (hex characters)
2777                   handle \N{name} (named characters, also \N{3,5} in a pattern)
2778                   handle \cV (control characters)
2779                   handle printf-style backslashes (\f, \r, \n, etc)
2780               } (end switch)
2781               continue
2782           } (end if backslash)
2783           handle regular character
2784     } (end while character to read)
2785                 
2786 */
2787
2788 STATIC char *
2789 S_scan_const(pTHX_ char *start)
2790 {
2791     char *send = PL_bufend;             /* end of the constant */
2792     SV *sv = newSV(send - start);       /* sv for the constant.  See note below
2793                                            on sizing. */
2794     char *s = start;                    /* start of the constant */
2795     char *d = SvPVX(sv);                /* destination for copies */
2796     bool dorange = FALSE;               /* are we in a translit range? */
2797     bool didrange = FALSE;              /* did we just finish a range? */
2798     bool in_charclass = FALSE;          /* within /[...]/ */
2799     bool has_utf8 = FALSE;              /* Output constant is UTF8 */
2800     bool  this_utf8 = cBOOL(UTF);       /* Is the source string assumed to be
2801                                            UTF8?  But, this can show as true
2802                                            when the source isn't utf8, as for
2803                                            example when it is entirely composed
2804                                            of hex constants */
2805     SV *res;                            /* result from charnames */
2806
2807     /* Note on sizing:  The scanned constant is placed into sv, which is
2808      * initialized by newSV() assuming one byte of output for every byte of
2809      * input.  This routine expects newSV() to allocate an extra byte for a
2810      * trailing NUL, which this routine will append if it gets to the end of
2811      * the input.  There may be more bytes of input than output (eg., \N{LATIN
2812      * CAPITAL LETTER A}), or more output than input if the constant ends up
2813      * recoded to utf8, but each time a construct is found that might increase
2814      * the needed size, SvGROW() is called.  Its size parameter each time is
2815      * based on the best guess estimate at the time, namely the length used so
2816      * far, plus the length the current construct will occupy, plus room for
2817      * the trailing NUL, plus one byte for every input byte still unscanned */ 
2818
2819     UV uv = UV_MAX; /* Initialize to weird value to try to catch any uses
2820                        before set */
2821 #ifdef EBCDIC
2822     UV literal_endpoint = 0;
2823     bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
2824 #endif
2825
2826     PERL_ARGS_ASSERT_SCAN_CONST;
2827
2828     assert(PL_lex_inwhat != OP_TRANSR);
2829     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2830         /* If we are doing a trans and we know we want UTF8 set expectation */
2831         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
2832         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2833     }
2834
2835     /* Protect sv from errors and fatal warnings. */
2836     ENTER_with_name("scan_const");
2837     SAVEFREESV(sv);
2838
2839     while (s < send || dorange) {
2840
2841         /* get transliterations out of the way (they're most literal) */
2842         if (PL_lex_inwhat == OP_TRANS) {
2843             /* expand a range A-Z to the full set of characters.  AIE! */
2844             if (dorange) {
2845                 I32 i;                          /* current expanded character */
2846                 I32 min;                        /* first character in range */
2847                 I32 max;                        /* last character in range */
2848
2849 #ifdef EBCDIC
2850                 UV uvmax = 0;
2851 #endif
2852
2853                 if (has_utf8
2854 #ifdef EBCDIC
2855                     && !native_range
2856 #endif
2857                 ) {
2858                     char * const c = (char*)utf8_hop((U8*)d, -1);
2859                     char *e = d++;
2860                     while (e-- > c)
2861                         *(e + 1) = *e;
2862                     *c = (char) ILLEGAL_UTF8_BYTE;
2863                     /* mark the range as done, and continue */
2864                     dorange = FALSE;
2865                     didrange = TRUE;
2866                     continue;
2867                 }
2868
2869                 i = d - SvPVX_const(sv);                /* remember current offset */
2870 #ifdef EBCDIC
2871                 SvGROW(sv,
2872                        SvLEN(sv) + ((has_utf8)
2873                                     ?  (512 - UTF_CONTINUATION_MARK
2874                                         + UNISKIP(0x100))
2875                                     : 256));
2876                 /* How many two-byte within 0..255: 128 in UTF-8,
2877                  * 96 in UTF-8-mod. */
2878 #else
2879                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
2880 #endif
2881                 d = SvPVX(sv) + i;              /* refresh d after realloc */
2882 #ifdef EBCDIC
2883                 if (has_utf8) {
2884                     int j;
2885                     for (j = 0; j <= 1; j++) {
2886                         char * const c = (char*)utf8_hop((U8*)d, -1);
2887                         const UV uv    = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
2888                         if (j)
2889                             min = (U8)uv;
2890                         else if (uv < 256)
2891                             max = (U8)uv;
2892                         else {
2893                             max = (U8)0xff; /* only to \xff */
2894                             uvmax = uv; /* \x{100} to uvmax */
2895                         }
2896                         d = c; /* eat endpoint chars */
2897                      }
2898                 }
2899                else {
2900 #endif
2901                    d -= 2;              /* eat the first char and the - */
2902                    min = (U8)*d;        /* first char in range */
2903                    max = (U8)d[1];      /* last char in range  */
2904 #ifdef EBCDIC
2905                }
2906 #endif
2907
2908                 if (min > max) {
2909                     Perl_croak(aTHX_
2910                                "Invalid range \"%c-%c\" in transliteration operator",
2911                                (char)min, (char)max);
2912                 }
2913
2914 #ifdef EBCDIC
2915                 /* Because of the discontinuities in EBCDIC A-Z and a-z, expand
2916                  * any subsets of these ranges into individual characters */
2917                 if (literal_endpoint == 2 &&
2918                     ((isLOWER_A(min) && isLOWER_A(max)) ||
2919                      (isUPPER_A(min) && isUPPER_A(max))))
2920                 {
2921                     for (i = min; i <= max; i++) {
2922                         if (isALPHA_A(i))
2923                             *d++ = i;
2924                     }
2925                 }
2926                 else
2927 #endif
2928                     for (i = min; i <= max; i++)
2929 #ifdef EBCDIC
2930                         if (has_utf8) {
2931                             append_utf8_from_native_byte(i, &d);
2932                         }
2933                         else
2934 #endif
2935                             *d++ = (char)i;
2936  
2937 #ifdef EBCDIC
2938                 if (uvmax) {
2939                     d = (char*)uvchr_to_utf8((U8*)d, 0x100);
2940                     if (uvmax > 0x101)
2941                         *d++ = (char) ILLEGAL_UTF8_BYTE;
2942                     if (uvmax > 0x100)
2943                         d = (char*)uvchr_to_utf8((U8*)d, uvmax);
2944                 }
2945 #endif
2946
2947                 /* mark the range as done, and continue */
2948                 dorange = FALSE;
2949                 didrange = TRUE;
2950 #ifdef EBCDIC
2951                 literal_endpoint = 0;
2952 #endif
2953                 continue;
2954             }
2955
2956             /* range begins (ignore - as first or last char) */
2957             else if (*s == '-' && s+1 < send  && s != start) {
2958                 if (didrange) {
2959                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
2960                 }
2961                 if (has_utf8
2962 #ifdef EBCDIC
2963                     && !native_range
2964 #endif
2965                     ) {
2966                     *d++ = (char) ILLEGAL_UTF8_BYTE;    /* use illegal utf8 byte--see pmtrans */
2967                     s++;
2968                     continue;
2969                 }
2970                 dorange = TRUE;
2971                 s++;
2972             }
2973             else {
2974                 didrange = FALSE;
2975 #ifdef EBCDIC
2976                 literal_endpoint = 0;
2977                 native_range = TRUE;
2978 #endif
2979             }
2980         }
2981
2982         /* if we get here, we're not doing a transliteration */
2983
2984         else if (*s == '[' && PL_lex_inpat && !in_charclass) {
2985             char *s1 = s-1;
2986             int esc = 0;
2987             while (s1 >= start && *s1-- == '\\')
2988                 esc = !esc;
2989             if (!esc)
2990                 in_charclass = TRUE;
2991         }
2992
2993         else if (*s == ']' && PL_lex_inpat &&  in_charclass) {
2994             char *s1 = s-1;
2995             int esc = 0;
2996             while (s1 >= start && *s1-- == '\\')
2997                 esc = !esc;
2998             if (!esc)
2999                 in_charclass = FALSE;
3000         }
3001
3002         /* skip for regexp comments /(?#comment)/, except for the last
3003          * char, which will be done separately.
3004          * Stop on (?{..}) and friends */
3005
3006         else if (*s == '(' && PL_lex_inpat && s[1] == '?' && !in_charclass) {
3007             if (s[2] == '#') {
3008                 while (s+1 < send && *s != ')')
3009                     *d++ = *s++;
3010             }
3011             else if (!PL_lex_casemods &&
3012                      (    s[2] == '{' /* This should match regcomp.c */
3013                       || (s[2] == '?' && s[3] == '{')))
3014             {
3015                 break;
3016             }
3017         }
3018
3019         /* likewise skip #-initiated comments in //x patterns */
3020         else if (*s == '#' && PL_lex_inpat && !in_charclass &&
3021           ((PMOP*)PL_lex_inpat)->op_pmflags & RXf_PMf_EXTENDED) {
3022             while (s+1 < send && *s != '\n')
3023                 *d++ = *s++;
3024         }
3025
3026         /* no further processing of single-quoted regex */
3027         else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'')
3028             goto default_action;
3029
3030         /* check for embedded arrays
3031            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
3032            */
3033         else if (*s == '@' && s[1]) {
3034             if (isWORDCHAR_lazy_if(s+1,UTF))
3035                 break;
3036             if (strchr(":'{$", s[1]))
3037                 break;
3038             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
3039                 break; /* in regexp, neither @+ nor @- are interpolated */
3040         }
3041
3042         /* check for embedded scalars.  only stop if we're sure it's a
3043            variable.
3044         */
3045         else if (*s == '$') {
3046             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
3047                 break;
3048             if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
3049                 if (s[1] == '\\') {
3050                     Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3051                                    "Possible unintended interpolation of $\\ in regex");
3052                 }
3053                 break;          /* in regexp, $ might be tail anchor */
3054             }
3055         }
3056
3057         /* End of else if chain - OP_TRANS rejoin rest */
3058
3059         /* backslashes */
3060         if (*s == '\\' && s+1 < send) {
3061             char* e;    /* Can be used for ending '}', etc. */
3062
3063             s++;
3064
3065             /* warn on \1 - \9 in substitution replacements, but note that \11
3066              * is an octal; and \19 is \1 followed by '9' */
3067             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
3068                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
3069             {
3070                 /* diag_listed_as: \%d better written as $%d */
3071                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
3072                 *--s = '$';
3073                 break;
3074             }
3075
3076             /* string-change backslash escapes */
3077             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
3078                 --s;
3079                 break;
3080             }
3081             /* In a pattern, process \N, but skip any other backslash escapes.
3082              * This is because we don't want to translate an escape sequence
3083              * into a meta symbol and have the regex compiler use the meta
3084              * symbol meaning, e.g. \x{2E} would be confused with a dot.  But
3085              * in spite of this, we do have to process \N here while the proper
3086              * charnames handler is in scope.  See bugs #56444 and #62056.
3087              * There is a complication because \N in a pattern may also stand
3088              * for 'match a non-nl', and not mean a charname, in which case its
3089              * processing should be deferred to the regex compiler.  To be a
3090              * charname it must be followed immediately by a '{', and not look
3091              * like \N followed by a curly quantifier, i.e., not something like
3092              * \N{3,}.  regcurly returns a boolean indicating if it is a legal
3093              * quantifier */
3094             else if (PL_lex_inpat
3095                     && (*s != 'N'
3096                         || s[1] != '{'
3097                         || regcurly(s + 1)))
3098             {
3099                 *d++ = '\\';
3100                 goto default_action;
3101             }
3102
3103             switch (*s) {
3104
3105             /* quoted - in transliterations */
3106             case '-':
3107                 if (PL_lex_inwhat == OP_TRANS) {
3108                     *d++ = *s++;
3109                     continue;
3110                 }
3111                 /* FALLTHROUGH */
3112             default:
3113                 {
3114                     if ((isALPHANUMERIC(*s)))
3115                         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
3116                                        "Unrecognized escape \\%c passed through",
3117                                        *s);
3118                     /* default action is to copy the quoted character */
3119                     goto default_action;
3120                 }
3121
3122             /* eg. \132 indicates the octal constant 0132 */
3123             case '0': case '1': case '2': case '3':
3124             case '4': case '5': case '6': case '7':
3125                 {
3126                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
3127                     STRLEN len = 3;
3128                     uv = grok_oct(s, &len, &flags, NULL);
3129                     s += len;
3130                     if (len < 3 && s < send && isDIGIT(*s)
3131                         && ckWARN(WARN_MISC))
3132                     {
3133                         Perl_warner(aTHX_ packWARN(WARN_MISC),
3134                                     "%s", form_short_octal_warning(s, len));
3135                     }
3136                 }
3137                 goto NUM_ESCAPE_INSERT;
3138
3139             /* eg. \o{24} indicates the octal constant \024 */
3140             case 'o':
3141                 {
3142                     const char* error;
3143
3144                     bool valid = grok_bslash_o(&s, &uv, &error,
3145                                                TRUE, /* Output warning */
3146                                                FALSE, /* Not strict */
3147                                                TRUE, /* Output warnings for
3148                                                          non-portables */
3149                                                UTF);
3150                     if (! valid) {
3151                         yyerror(error);
3152                         continue;
3153                     }
3154                     goto NUM_ESCAPE_INSERT;
3155                 }
3156
3157             /* eg. \x24 indicates the hex constant 0x24 */
3158             case 'x':
3159                 {
3160                     const char* error;
3161
3162                     bool valid = grok_bslash_x(&s, &uv, &error,
3163                                                TRUE, /* Output warning */
3164                                                FALSE, /* Not strict */
3165                                                TRUE,  /* Output warnings for
3166                                                          non-portables */
3167                                                UTF);
3168                     if (! valid) {
3169                         yyerror(error);
3170                         continue;
3171                     }
3172                 }
3173
3174               NUM_ESCAPE_INSERT:
3175                 /* Insert oct or hex escaped character.  There will always be
3176                  * enough room in sv since such escapes will be longer than any
3177                  * UTF-8 sequence they can end up as, except if they force us
3178                  * to recode the rest of the string into utf8 */
3179                 
3180                 /* Here uv is the ordinal of the next character being added */
3181                 if (!UVCHR_IS_INVARIANT(uv)) {
3182                     if (!has_utf8 && uv > 255) {
3183                         /* Might need to recode whatever we have accumulated so
3184                          * far if it contains any chars variant in utf8 or
3185                          * utf-ebcdic. */
3186                           
3187                         SvCUR_set(sv, d - SvPVX_const(sv));
3188                         SvPOK_on(sv);
3189                         *d = '\0';
3190                         /* See Note on sizing above.  */
3191                         sv_utf8_upgrade_flags_grow(sv,
3192                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3193                                         UNISKIP(uv) + (STRLEN)(send - s) + 1);
3194                         d = SvPVX(sv) + SvCUR(sv);
3195                         has_utf8 = TRUE;
3196                     }
3197
3198                     if (has_utf8) {
3199                         d = (char*)uvchr_to_utf8((U8*)d, uv);
3200                         if (PL_lex_inwhat == OP_TRANS &&
3201                             PL_sublex_info.sub_op) {
3202                             PL_sublex_info.sub_op->op_private |=
3203                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
3204                                              : OPpTRANS_TO_UTF);
3205                         }
3206 #ifdef EBCDIC
3207                         if (uv > 255 && !dorange)
3208                             native_range = FALSE;
3209 #endif
3210                     }
3211                     else {
3212                         *d++ = (char)uv;
3213                     }
3214                 }
3215                 else {
3216                     *d++ = (char) uv;
3217                 }
3218                 continue;
3219
3220             case 'N':
3221                 /* In a non-pattern \N must be a named character, like \N{LATIN
3222                  * SMALL LETTER A} or \N{U+0041}.  For patterns, it also can
3223                  * mean to match a non-newline.  For non-patterns, named
3224                  * characters are converted to their string equivalents. In
3225                  * patterns, named characters are not converted to their
3226                  * ultimate forms for the same reasons that other escapes
3227                  * aren't.  Instead, they are converted to the \N{U+...} form
3228                  * to get the value from the charnames that is in effect right
3229                  * now, while preserving the fact that it was a named character
3230                  * so that the regex compiler knows this */
3231
3232                 /* The structure of this section of code (besides checking for
3233                  * errors and upgrading to utf8) is:
3234                  *  Further disambiguate between the two meanings of \N, and if
3235                  *      not a charname, go process it elsewhere
3236                  *  If of form \N{U+...}, pass it through if a pattern;
3237                  *      otherwise convert to utf8
3238                  *  Otherwise must be \N{NAME}: convert to \N{U+c1.c2...} if a
3239                  *  pattern; otherwise convert to utf8 */
3240
3241                 /* Here, s points to the 'N'; the test below is guaranteed to
3242                  * succeed if we are being called on a pattern as we already
3243                  * know from a test above that the next character is a '{'.
3244                  * On a non-pattern \N must mean 'named sequence, which
3245                  * requires braces */
3246                 s++;
3247                 if (*s != '{') {
3248                     yyerror("Missing braces on \\N{}"); 
3249                     continue;
3250                 }
3251                 s++;
3252
3253                 /* If there is no matching '}', it is an error. */
3254                 if (! (e = strchr(s, '}'))) {
3255                     if (! PL_lex_inpat) {
3256                         yyerror("Missing right brace on \\N{}");
3257                     } else {
3258                         yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
3259                     }
3260                     continue;
3261                 }
3262
3263                 /* Here it looks like a named character */
3264
3265                 if (*s == 'U' && s[1] == '+') { /* \N{U+...} */
3266                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3267                                 | PERL_SCAN_DISALLOW_PREFIX;
3268                     STRLEN len;
3269
3270                     /* For \N{U+...}, the '...' is a unicode value even on
3271                      * EBCDIC machines */
3272                     s += 2;         /* Skip to next char after the 'U+' */
3273                     len = e - s;
3274                     uv = grok_hex(s, &len, &flags, NULL);
3275                     if (len == 0 || len != (STRLEN)(e - s)) {
3276                         yyerror("Invalid hexadecimal number in \\N{U+...}");
3277                         s = e + 1;
3278                         continue;
3279                     }
3280
3281                     if (PL_lex_inpat) {
3282
3283                         /* On non-EBCDIC platforms, pass through to the regex
3284                          * compiler unchanged.  The reason we evaluated the
3285                          * number above is to make sure there wasn't a syntax
3286                          * error.  But on EBCDIC we convert to native so
3287                          * downstream code can continue to assume it's native
3288                          */
3289                         s -= 5;     /* Include the '\N{U+' */
3290 #ifdef EBCDIC
3291                         d += my_snprintf(d, e - s + 1 + 1,  /* includes the }
3292                                                                and the \0 */
3293                                     "\\N{U+%X}",
3294                                     (unsigned int) UNI_TO_NATIVE(uv));
3295 #else
3296                         Copy(s, d, e - s + 1, char);    /* 1 = include the } */
3297                         d += e - s + 1;
3298 #endif
3299                     }
3300                     else {  /* Not a pattern: convert the hex to string */
3301
3302                          /* If destination is not in utf8, unconditionally
3303                           * recode it to be so.  This is because \N{} implies
3304                           * Unicode semantics, and scalars have to be in utf8
3305                           * to guarantee those semantics */
3306                         if (! has_utf8) {
3307                             SvCUR_set(sv, d - SvPVX_const(sv));
3308                             SvPOK_on(sv);
3309                             *d = '\0';
3310                             /* See Note on sizing above.  */
3311                             sv_utf8_upgrade_flags_grow(
3312                                         sv,
3313                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3314                                         UNISKIP(uv) + (STRLEN)(send - e) + 1);
3315                             d = SvPVX(sv) + SvCUR(sv);
3316                             has_utf8 = TRUE;
3317                         }
3318
3319                         /* Add the (Unicode) code point to the output. */
3320                         if (UNI_IS_INVARIANT(uv)) {
3321                             *d++ = (char) LATIN1_TO_NATIVE(uv);
3322                         }
3323                         else {
3324                             d = (char*) uvoffuni_to_utf8_flags((U8*)d, uv, 0);
3325                         }
3326                     }
3327                 }
3328                 else /* Here is \N{NAME} but not \N{U+...}. */
3329                      if ((res = get_and_check_backslash_N_name(s, e)))
3330                 {
3331                     STRLEN len;
3332                     const char *str = SvPV_const(res, len);
3333                     if (PL_lex_inpat) {
3334
3335                         if (! len) { /* The name resolved to an empty string */
3336                             Copy("\\N{}", d, 4, char);
3337                             d += 4;
3338                         }
3339                         else {
3340                             /* In order to not lose information for the regex
3341                             * compiler, pass the result in the specially made
3342                             * syntax: \N{U+c1.c2.c3...}, where c1 etc. are
3343                             * the code points in hex of each character
3344                             * returned by charnames */
3345
3346                             const char *str_end = str + len;
3347                             const STRLEN off = d - SvPVX_const(sv);
3348
3349                             if (! SvUTF8(res)) {
3350                                 /* For the non-UTF-8 case, we can determine the
3351                                  * exact length needed without having to parse
3352                                  * through the string.  Each character takes up
3353                                  * 2 hex digits plus either a trailing dot or
3354                                  * the "}" */
3355                                 d = off + SvGROW(sv, off
3356                                                     + 3 * len
3357                                                     + 6 /* For the "\N{U+", and
3358                                                            trailing NUL */
3359                                                     + (STRLEN)(send - e));
3360                                 Copy("\\N{U+", d, 5, char);
3361                                 d += 5;
3362                                 while (str < str_end) {
3363                                     char hex_string[4];
3364                                     int len =
3365                                         my_snprintf(hex_string,
3366                                                     sizeof(hex_string),
3367                                                     "%02X.", (U8) *str);
3368                                     PERL_MY_SNPRINTF_POST_GUARD(len, sizeof(hex_string));
3369                                     Copy(hex_string, d, 3, char);
3370                                     d += 3;
3371                                     str++;
3372                                 }
3373                                 d--;    /* We will overwrite below the final
3374                                            dot with a right brace */
3375                             }
3376                             else {
3377                                 STRLEN char_length; /* cur char's byte length */
3378
3379                                 /* and the number of bytes after this is
3380                                  * translated into hex digits */
3381                                 STRLEN output_length;
3382
3383                                 /* 2 hex per byte; 2 chars for '\N'; 2 chars
3384                                  * for max('U+', '.'); and 1 for NUL */
3385                                 char hex_string[2 * UTF8_MAXBYTES + 5];
3386
3387                                 /* Get the first character of the result. */
3388                                 U32 uv = utf8n_to_uvchr((U8 *) str,
3389                                                         len,
3390                                                         &char_length,
3391                                                         UTF8_ALLOW_ANYUV);
3392                                 /* Convert first code point to hex, including
3393                                  * the boiler plate before it. */
3394                                 output_length =
3395                                     my_snprintf(hex_string, sizeof(hex_string),
3396                                                 "\\N{U+%X",
3397                                                 (unsigned int) uv);
3398
3399                                 /* Make sure there is enough space to hold it */
3400                                 d = off + SvGROW(sv, off
3401                                                     + output_length
3402                                                     + (STRLEN)(send - e)
3403                                                     + 2);       /* '}' + NUL */
3404                                 /* And output it */
3405                                 Copy(hex_string, d, output_length, char);
3406                                 d += output_length;
3407
3408                                 /* For each subsequent character, append dot and
3409                                 * its ordinal in hex */
3410                                 while ((str += char_length) < str_end) {
3411                                     const STRLEN off = d - SvPVX_const(sv);
3412                                     U32 uv = utf8n_to_uvchr((U8 *) str,
3413                                                             str_end - str,
3414                                                             &char_length,
3415                                                             UTF8_ALLOW_ANYUV);
3416                                     output_length =
3417                                         my_snprintf(hex_string,
3418                                                     sizeof(hex_string),
3419                                                     ".%X",
3420                                                     (unsigned int) uv);
3421
3422                                     d = off + SvGROW(sv, off
3423                                                         + output_length
3424                                                         + (STRLEN)(send - e)
3425                                                         + 2);   /* '}' +  NUL */
3426                                     Copy(hex_string, d, output_length, char);
3427                                     d += output_length;
3428                                 }
3429                             }
3430
3431                             *d++ = '}'; /* Done.  Add the trailing brace */
3432                         }
3433                     }
3434                     else { /* Here, not in a pattern.  Convert the name to a
3435                             * string. */
3436
3437                          /* If destination is not in utf8, unconditionally
3438                           * recode it to be so.  This is because \N{} implies
3439                           * Unicode semantics, and scalars have to be in utf8
3440                           * to guarantee those semantics */
3441                         if (! has_utf8) {
3442                             SvCUR_set(sv, d - SvPVX_const(sv));
3443                             SvPOK_on(sv);
3444                             *d = '\0';
3445                             /* See Note on sizing above.  */
3446                             sv_utf8_upgrade_flags_grow(sv,
3447                                                 SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3448                                                 len + (STRLEN)(send - s) + 1);
3449                             d = SvPVX(sv) + SvCUR(sv);
3450                             has_utf8 = TRUE;
3451                         } else if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
3452
3453                             /* See Note on sizing above.  (NOTE: SvCUR() is not
3454                              * set correctly here). */
3455                             const STRLEN off = d - SvPVX_const(sv);
3456                             d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
3457                         }
3458                         if (! SvUTF8(res)) {    /* Make sure is \N{} return is UTF-8 */
3459                             sv_utf8_upgrade(res);
3460                             str = SvPV_const(res, len);
3461                         }
3462                         Copy(str, d, len, char);
3463                         d += len;
3464                     }
3465
3466                     SvREFCNT_dec(res);
3467
3468                 } /* End \N{NAME} */
3469 #ifdef EBCDIC
3470                 if (!dorange) 
3471                     native_range = FALSE; /* \N{} is defined to be Unicode */
3472 #endif
3473                 s = e + 1;  /* Point to just after the '}' */
3474                 continue;
3475
3476             /* \c is a control character */
3477             case 'c':
3478                 s++;
3479                 if (s < send) {
3480                     *d++ = grok_bslash_c(*s++, 1);
3481                 }
3482                 else {
3483                     yyerror("Missing control char name in \\c");
3484                 }
3485                 continue;
3486
3487             /* printf-style backslashes, formfeeds, newlines, etc */
3488             case 'b':
3489                 *d++ = '\b';
3490                 break;
3491             case 'n':
3492                 *d++ = '\n';
3493                 break;
3494             case 'r':
3495                 *d++ = '\r';
3496                 break;
3497             case 'f':
3498                 *d++ = '\f';
3499                 break;
3500             case 't':
3501                 *d++ = '\t';
3502                 break;
3503             case 'e':
3504                 *d++ = ESC_NATIVE;
3505                 break;
3506             case 'a':
3507                 *d++ = '\a';
3508                 break;
3509             } /* end switch */
3510
3511             s++;
3512             continue;
3513         } /* end if (backslash) */
3514 #ifdef EBCDIC
3515         else
3516             literal_endpoint++;
3517 #endif
3518
3519     default_action:
3520         /* If we started with encoded form, or already know we want it,
3521            then encode the next character */
3522         if (! NATIVE_BYTE_IS_INVARIANT((U8)(*s)) && (this_utf8 || has_utf8)) {
3523             STRLEN len  = 1;
3524
3525
3526             /* One might think that it is wasted effort in the case of the
3527              * source being utf8 (this_utf8 == TRUE) to take the next character
3528              * in the source, convert it to an unsigned value, and then convert
3529              * it back again.  But the source has not been validated here.  The
3530              * routine that does the conversion checks for errors like
3531              * malformed utf8 */
3532
3533             const UV nextuv   = (this_utf8)
3534                                 ? utf8n_to_uvchr((U8*)s, send - s, &len, 0)
3535                                 : (UV) ((U8) *s);
3536             const STRLEN need = UNISKIP(nextuv);
3537             if (!has_utf8) {
3538                 SvCUR_set(sv, d - SvPVX_const(sv));
3539                 SvPOK_on(sv);
3540                 *d = '\0';
3541                 /* See Note on sizing above.  */
3542                 sv_utf8_upgrade_flags_grow(sv,
3543                                         SV_GMAGIC|SV_FORCE_UTF8_UPGRADE,
3544                                         need + (STRLEN)(send - s) + 1);
3545                 d = SvPVX(sv) + SvCUR(sv);
3546                 has_utf8 = TRUE;
3547             } else if (need > len) {
3548                 /* encoded value larger than old, may need extra space (NOTE:
3549                  * SvCUR() is not set correctly here).   See Note on sizing
3550                  * above.  */
3551                 const STRLEN off = d - SvPVX_const(sv);
3552                 d = SvGROW(sv, off + need + (STRLEN)(send - s) + 1) + off;
3553             }
3554             s += len;
3555
3556             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
3557 #ifdef EBCDIC
3558             if (uv > 255 && !dorange)
3559                 native_range = FALSE;
3560 #endif
3561         }
3562         else {
3563             *d++ = *s++;
3564         }
3565     } /* while loop to process each character */
3566
3567     /* terminate the string and set up the sv */
3568     *d = '\0';
3569     SvCUR_set(sv, d - SvPVX_const(sv));
3570     if (SvCUR(sv) >= SvLEN(sv))
3571         Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
3572                    " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
3573
3574     SvPOK_on(sv);
3575     if (PL_encoding && !has_utf8) {
3576         sv_recode_to_utf8(sv, PL_encoding);
3577         if (SvUTF8(sv))
3578             has_utf8 = TRUE;
3579     }
3580     if (has_utf8) {
3581         SvUTF8_on(sv);
3582         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
3583             PL_sublex_info.sub_op->op_private |=
3584                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
3585         }
3586     }
3587
3588     /* shrink the sv if we allocated more than we used */
3589     if (SvCUR(sv) + 5 < SvLEN(sv)) {
3590         SvPV_shrink_to_cur(sv);
3591     }
3592
3593     /* return the substring (via pl_yylval) only if we parsed anything */
3594     if (s > start) {
3595         char *s2 = start;
3596         for (; s2 < s; s2++) {
3597             if (*s2 == '\n')
3598                 COPLINE_INC_WITH_HERELINES;
3599         }
3600         SvREFCNT_inc_simple_void_NN(sv);
3601         if (   (PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ))
3602             && ! PL_parser->lex_re_reparsing)
3603         {
3604             const char *const key = PL_lex_inpat ? "qr" : "q";
3605             const STRLEN keylen = PL_lex_inpat ? 2 : 1;
3606             const char *type;
3607             STRLEN typelen;
3608
3609             if (PL_lex_inwhat == OP_TRANS) {
3610                 type = "tr";
3611                 typelen = 2;
3612             } else if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) {
3613                 type = "s";
3614                 typelen = 1;
3615             } else if (PL_lex_inpat && SvIVX(PL_linestr) == '\'') {
3616                 type = "q";
3617                 typelen = 1;
3618             } else  {
3619                 type = "qq";
3620                 typelen = 2;
3621             }
3622
3623             sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
3624                                 type, typelen);
3625         }
3626         pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3627     }
3628     LEAVE_with_name("scan_const");
3629     return s;
3630 }
3631
3632 /* S_intuit_more
3633  * Returns TRUE if there's more to the expression (e.g., a subscript),
3634  * FALSE otherwise.
3635  *
3636  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
3637  *
3638  * ->[ and ->{ return TRUE
3639  * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
3640  * { and [ outside a pattern are always subscripts, so return TRUE
3641  * if we're outside a pattern and it's not { or [, then return FALSE
3642  * if we're in a pattern and the first char is a {
3643  *   {4,5} (any digits around the comma) returns FALSE
3644  * if we're in a pattern and the first char is a [
3645  *   [] returns FALSE
3646  *   [SOMETHING] has a funky algorithm to decide whether it's a
3647  *      character class or not.  It has to deal with things like
3648  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
3649  * anything else returns TRUE
3650  */
3651
3652 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
3653
3654 STATIC int
3655 S_intuit_more(pTHX_ char *s)
3656 {
3657     PERL_ARGS_ASSERT_INTUIT_MORE;
3658
3659     if (PL_lex_brackets)
3660         return TRUE;
3661     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
3662         return TRUE;
3663     if (*s == '-' && s[1] == '>'
3664      && FEATURE_POSTDEREF_QQ_IS_ENABLED
3665      && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
3666         ||(s[2] == '@' && strchr("*[{",s[3])) ))
3667         return TRUE;
3668     if (*s != '{' && *s != '[')
3669         return FALSE;
3670     if (!PL_lex_inpat)
3671         return TRUE;
3672
3673     /* In a pattern, so maybe we have {n,m}. */
3674     if (*s == '{') {
3675         if (regcurly(s)) {
3676             return FALSE;
3677         }
3678         return TRUE;
3679     }
3680
3681     /* On the other hand, maybe we have a character class */
3682
3683     s++;
3684     if (*s == ']' || *s == '^')
3685         return FALSE;
3686     else {
3687         /* this is terrifying, and it works */
3688         int weight;
3689         char seen[256];
3690         const char * const send = strchr(s,']');
3691         unsigned char un_char, last_un_char;
3692         char tmpbuf[sizeof PL_tokenbuf * 4];
3693
3694         if (!send)              /* has to be an expression */
3695             return TRUE;
3696         weight = 2;             /* let's weigh the evidence */
3697
3698         if (*s == '$')
3699             weight -= 3;
3700         else if (isDIGIT(*s)) {
3701             if (s[1] != ']') {
3702                 if (isDIGIT(s[1]) && s[2] == ']')
3703                     weight -= 10;
3704             }
3705             else
3706                 weight -= 100;
3707         }
3708         Zero(seen,256,char);
3709         un_char = 255;
3710         for (; s < send; s++) {
3711             last_un_char = un_char;
3712             un_char = (unsigned char)*s;
3713             switch (*s) {
3714             case '@':
3715             case '&':
3716             case '$':
3717                 weight -= seen[un_char] * 10;
3718                 if (isWORDCHAR_lazy_if(s+1,UTF)) {
3719                     int len;
3720                     char *tmp = PL_bufend;
3721                     PL_bufend = (char*)send;
3722                     scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE);
3723                     PL_bufend = tmp;
3724                     len = (int)strlen(tmpbuf);
3725                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len,
3726                                                     UTF ? SVf_UTF8 : 0, SVt_PV))
3727                         weight -= 100;
3728                     else
3729                         weight -= 10;
3730                 }
3731                 else if (*s == '$' && s[1] &&
3732                   strchr("[#!%*<>()-=",s[1])) {
3733                     if (/*{*/ strchr("])} =",s[2]))
3734                         weight -= 10;
3735                     else
3736                         weight -= 1;
3737                 }
3738                 break;
3739             case '\\':
3740                 un_char = 254;
3741                 if (s[1]) {
3742                     if (strchr("wds]",s[1]))
3743                         weight += 100;
3744                     else if (seen[(U8)'\''] || seen[(U8)'"'])
3745                         weight += 1;
3746                     else if (strchr("rnftbxcav",s[1]))
3747                         weight += 40;
3748                     else if (isDIGIT(s[1])) {
3749                         weight += 40;
3750                         while (s[1] && isDIGIT(s[1]))
3751                             s++;
3752                     }
3753                 }
3754                 else
3755                     weight += 100;
3756                 break;
3757             case '-':
3758                 if (s[1] == '\\')
3759                     weight += 50;
3760                 if (strchr("aA01! ",last_un_char))
3761                     weight += 30;
3762                 if (strchr("zZ79~",s[1]))
3763                     weight += 30;
3764                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
3765                     weight -= 5;        /* cope with negative subscript */
3766                 break;
3767             default:
3768                 if (!isWORDCHAR(last_un_char)
3769                     && !(last_un_char == '$' || last_un_char == '@'
3770                          || last_un_char == '&')
3771                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
3772                     char *d = tmpbuf;
3773                     while (isALPHA(*s))
3774                         *d++ = *s++;
3775                     *d = '\0';
3776                     if (keyword(tmpbuf, d - tmpbuf, 0))
3777                         weight -= 150;
3778                 }
3779                 if (un_char == last_un_char + 1)
3780                     weight += 5;
3781                 weight -= seen[un_char];
3782                 break;
3783             }
3784             seen[un_char]++;
3785         }
3786         if (weight >= 0)        /* probably a character class */
3787             return FALSE;
3788     }
3789
3790     return TRUE;
3791 }
3792
3793 /*
3794  * S_intuit_method
3795  *
3796  * Does all the checking to disambiguate
3797  *   foo bar
3798  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
3799  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
3800  *
3801  * First argument is the stuff after the first token, e.g. "bar".
3802  *
3803  * Not a method if foo is a filehandle.
3804  * Not a method if foo is a subroutine prototyped to take a filehandle.
3805  * Not a method if it's really "Foo $bar"
3806  * Method if it's "foo $bar"
3807  * Not a method if it's really "print foo $bar"
3808  * Method if it's really "foo package::" (interpreted as package->foo)
3809  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
3810  * Not a method if bar is a filehandle or package, but is quoted with
3811  *   =>
3812  */
3813
3814 STATIC int
3815 S_intuit_method(pTHX_ char *start, SV *ioname, CV *cv)
3816 {
3817     char *s = start + (*start == '$');
3818     char tmpbuf[sizeof PL_tokenbuf];
3819     STRLEN len;
3820     GV* indirgv;
3821         /* Mustn't actually add anything to a symbol table.
3822            But also don't want to "initialise" any placeholder
3823            constants that might already be there into full
3824            blown PVGVs with attached PVCV.  */
3825     GV * const gv =
3826         ioname ? gv_fetchsv(ioname, GV_NOADD_NOINIT, SVt_PVCV) : NULL;
3827
3828     PERL_ARGS_ASSERT_INTUIT_METHOD;
3829
3830     if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
3831             return 0;
3832     if (cv && SvPOK(cv)) {
3833         const char *proto = CvPROTO(cv);
3834         if (proto) {
3835             while (*proto && (isSPACE(*proto) || *proto == ';'))
3836                 proto++;
3837             if (*proto == '*')
3838                 return 0;
3839         }
3840     }
3841
3842     if (*start == '$') {
3843         if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
3844                 isUPPER(*PL_tokenbuf))
3845             return 0;
3846         s = skipspace(s);
3847         PL_bufptr = start;
3848         PL_expect = XREF;
3849         return *s == '(' ? FUNCMETH : METHOD;
3850     }
3851
3852     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3853     /* start is the beginning of the possible filehandle/object,
3854      * and s is the end of it
3855      * tmpbuf is a copy of it (but with single quotes as double colons)
3856      */
3857
3858     if (!keyword(tmpbuf, len, 0)) {
3859         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
3860             len -= 2;
3861             tmpbuf[len] = '\0';
3862             goto bare_package;
3863         }
3864         indirgv = gv_fetchpvn_flags(tmpbuf, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVCV);
3865         if (indirgv && GvCVu(indirgv))
3866             return 0;
3867         /* filehandle or package name makes it a method */
3868         if (!cv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, UTF ? SVf_UTF8 : 0)) {
3869             s = skipspace(s);
3870             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
3871                 return 0;       /* no assumptions -- "=>" quotes bareword */
3872       bare_package:
3873             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
3874                                                   S_newSV_maybe_utf8(aTHX_ tmpbuf, len));
3875             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
3876             PL_expect = XTERM;
3877             force_next(WORD);
3878             PL_bufptr = s;
3879             return *s == '(' ? FUNCMETH : METHOD;
3880         }
3881     }
3882     return 0;
3883 }
3884
3885 /* Encoded script support. filter_add() effectively inserts a
3886  * 'pre-processing' function into the current source input stream.
3887  * Note that the filter function only applies to the current source file
3888  * (e.g., it will not affect files 'require'd or 'use'd by this one).
3889  *
3890  * The datasv parameter (which may be NULL) can be used to pass
3891  * private data to this instance of the filter. The filter function
3892  * can recover the SV using the FILTER_DATA macro and use it to
3893  * store private buffers and state information.
3894  *
3895  * The supplied datasv parameter is upgraded to a PVIO type
3896  * and the IoDIRP/IoANY field is used to store the function pointer,
3897  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
3898  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
3899  * private use must be set using malloc'd pointers.
3900  */
3901
3902 SV *
3903 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
3904 {
3905     if (!funcp)
3906         return NULL;
3907
3908     if (!PL_parser)
3909         return NULL;
3910
3911     if (PL_parser->lex_flags & LEX_IGNORE_UTF8_HINTS)
3912         Perl_croak(aTHX_ "Source filters apply only to byte streams");
3913
3914     if (!PL_rsfp_filters)
3915         PL_rsfp_filters = newAV();
3916     if (!datasv)
3917         datasv = newSV(0);
3918     SvUPGRADE(datasv, SVt_PVIO);
3919     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
3920     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
3921     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
3922                           FPTR2DPTR(void *, IoANY(datasv)),
3923                           SvPV_nolen(datasv)));
3924     av_unshift(PL_rsfp_filters, 1);
3925     av_store(PL_rsfp_filters, 0, datasv) ;
3926     if (
3927         !PL_parser->filtered
3928      && PL_parser->lex_flags & LEX_EVALBYTES
3929      && PL_bufptr < PL_bufend
3930     ) {
3931         const char *s = PL_bufptr;
3932         while (s < PL_bufend) {
3933             if (*s == '\n') {
3934                 SV *linestr = PL_parser->linestr;
3935                 char *buf = SvPVX(linestr);
3936                 STRLEN const bufptr_pos = PL_parser->bufptr - buf;
3937                 STRLEN const oldbufptr_pos = PL_parser->oldbufptr - buf;
3938                 STRLEN const oldoldbufptr_pos=PL_parser->oldoldbufptr-buf;
3939                 STRLEN const linestart_pos = PL_parser->linestart - buf;
3940                 STRLEN const last_uni_pos =
3941                     PL_parser->last_uni ? PL_parser->last_uni - buf : 0;
3942                 STRLEN const last_lop_pos =
3943                     PL_parser->last_lop ? PL_parser->last_lop - buf : 0;
3944                 av_push(PL_rsfp_filters, linestr);
3945                 PL_parser->linestr = 
3946                     newSVpvn(SvPVX(linestr), ++s-SvPVX(linestr));
3947                 buf = SvPVX(PL_parser->linestr);
3948                 PL_parser->bufend = buf + SvCUR(PL_parser->linestr);
3949                 PL_parser->bufptr = buf + bufptr_pos;
3950                 PL_parser->oldbufptr = buf + oldbufptr_pos;
3951                 PL_parser->oldoldbufptr = buf + oldoldbufptr_pos;
3952                 PL_parser->linestart = buf + linestart_pos;
3953                 if (PL_parser->last_uni)
3954                     PL_parser->last_uni = buf + last_uni_pos;
3955                 if (PL_parser->last_lop)
3956                     PL_parser->last_lop = buf + last_lop_pos;
3957                 SvLEN(linestr) = SvCUR(linestr);
3958                 SvCUR(linestr) = s-SvPVX(linestr);
3959                 PL_parser->filtered = 1;
3960                 break;
3961             }
3962             s++;
3963         }
3964     }
3965     return(datasv);
3966 }
3967
3968
3969 /* Delete most recently added instance of this filter function. */
3970 void
3971 Perl_filter_del(pTHX_ filter_t funcp)
3972 {
3973     SV *datasv;
3974
3975     PERL_ARGS_ASSERT_FILTER_DEL;
3976
3977 #ifdef DEBUGGING
3978     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
3979                           FPTR2DPTR(void*, funcp)));
3980 #endif
3981     if (!PL_parser || !PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
3982         return;
3983     /* if filter is on top of stack (usual case) just pop it off */
3984     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
3985     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
3986         sv_free(av_pop(PL_rsfp_filters));
3987
3988         return;
3989     }
3990     /* we need to search for the correct entry and clear it     */
3991     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
3992 }
3993
3994
3995 /* Invoke the idxth filter function for the current rsfp.        */
3996 /* maxlen 0 = read one text line */
3997 I32
3998 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
3999 {
4000     filter_t funcp;
4001     SV *datasv = NULL;
4002     /* This API is bad. It should have been using unsigned int for maxlen.
4003        Not sure if we want to change the API, but if not we should sanity
4004        check the value here.  */
4005     unsigned int correct_length = maxlen < 0 ?  PERL_INT_MAX : maxlen;
4006
4007     PERL_ARGS_ASSERT_FILTER_READ;
4008
4009     if (!PL_parser || !PL_rsfp_filters)
4010         return -1;
4011     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
4012         /* Provide a default input filter to make life easy.    */
4013         /* Note that we append to the line. This is handy.      */
4014         DEBUG_P(PerlIO_printf(Perl_debug_log,
4015                               "filter_read %d: from rsfp\n", idx));
4016         if (correct_length) {
4017             /* Want a block */
4018             int len ;
4019             const int old_len = SvCUR(buf_sv);
4020
4021             /* ensure buf_sv is large enough */
4022             SvGROW(buf_sv, (STRLEN)(old_len + correct_length + 1)) ;
4023             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
4024                                    correct_length)) <= 0) {
4025                 if (PerlIO_error(PL_rsfp))
4026                     return -1;          /* error */
4027                 else
4028                     return 0 ;          /* end of file */
4029             }
4030             SvCUR_set(buf_sv, old_len + len) ;
4031             SvPVX(buf_sv)[old_len + len] = '\0';
4032         } else {
4033             /* Want a line */
4034             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
4035                 if (PerlIO_error(PL_rsfp))
4036                     return -1;          /* error */
4037                 else
4038                     return 0 ;          /* end of file */
4039             }
4040         }
4041         return SvCUR(buf_sv);
4042     }
4043     /* Skip this filter slot if filter has been deleted */
4044     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
4045         DEBUG_P(PerlIO_printf(Perl_debug_log,
4046                               "filter_read %d: skipped (filter deleted)\n",
4047                               idx));
4048         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
4049     }
4050     if (SvTYPE(datasv) != SVt_PVIO) {
4051         if (correct_length) {
4052             /* Want a block */
4053             const STRLEN remainder = SvLEN(datasv) - SvCUR(datasv);
4054             if (!remainder) return 0; /* eof */
4055             if (correct_length > remainder) correct_length = remainder;
4056             sv_catpvn(buf_sv, SvEND(datasv), correct_length);
4057             SvCUR_set(datasv, SvCUR(datasv) + correct_length);
4058         } else {
4059             /* Want a line */
4060             const char *s = SvEND(datasv);
4061             const char *send = SvPVX(datasv) + SvLEN(datasv);
4062             while (s < send) {
4063                 if (*s == '\n') {
4064                     s++;
4065                     break;
4066                 }
4067                 s++;
4068             }
4069             if (s == send) return 0; /* eof */
4070             sv_catpvn(buf_sv, SvEND(datasv), s-SvEND(datasv));
4071             SvCUR_set(datasv, s-SvPVX(datasv));
4072         }
4073         return SvCUR(buf_sv);
4074     }
4075     /* Get function pointer hidden within datasv        */
4076     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
4077     DEBUG_P(PerlIO_printf(Perl_debug_log,
4078                           "filter_read %d: via function %p (%s)\n",
4079                           idx, (void*)datasv, SvPV_nolen_const(datasv)));
4080     /* Call function. The function is expected to       */
4081     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
4082     /* Return: <0:error, =0:eof, >0:not eof             */
4083     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
4084 }
4085
4086 STATIC char *
4087 S_filter_gets(pTHX_ SV *sv, STRLEN append)
4088 {
4089     PERL_ARGS_ASSERT_FILTER_GETS;
4090
4091 #ifdef PERL_CR_FILTER
4092     if (!PL_rsfp_filters) {
4093         filter_add(S_cr_textfilter,NULL);
4094     }
4095 #endif
4096     if (PL_rsfp_filters) {
4097         if (!append)
4098             SvCUR_set(sv, 0);   /* start with empty line        */
4099         if (FILTER_READ(0, sv, 0) > 0)
4100             return ( SvPVX(sv) ) ;
4101         else
4102             return NULL ;
4103     }
4104     else
4105         return (sv_gets(sv, PL_rsfp, append));
4106 }
4107
4108 STATIC HV *
4109 S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
4110 {
4111     GV *gv;
4112
4113     PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
4114
4115     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
4116         return PL_curstash;
4117
4118     if (len > 2 &&
4119         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
4120         (gv = gv_fetchpvn_flags(pkgname, len, ( UTF ? SVf_UTF8 : 0 ), SVt_PVHV)))
4121     {
4122         return GvHV(gv);                        /* Foo:: */
4123     }
4124
4125     /* use constant CLASS => 'MyClass' */
4126     gv = gv_fetchpvn_flags(pkgname, len, UTF ? SVf_UTF8 : 0, SVt_PVCV);
4127     if (gv && GvCV(gv)) {
4128         SV * const sv = cv_const_sv(GvCV(gv));
4129         if (sv)
4130             return gv_stashsv(sv, 0);
4131     }
4132
4133     return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
4134 }
4135
4136
4137 STATIC char *
4138 S_tokenize_use(pTHX_ int is_use, char *s) {
4139     PERL_ARGS_ASSERT_TOKENIZE_USE;
4140
4141     if (PL_expect != XSTATE)
4142         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
4143                     is_use ? "use" : "no"));
4144     PL_expect = XTERM;
4145     s = skipspace(s);
4146     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4147         s = force_version(s, TRUE);
4148         if (*s == ';' || *s == '}'
4149                 || (s = skipspace(s), (*s == ';' || *s == '}'))) {
4150             NEXTVAL_NEXTTOKE.opval = NULL;
4151             force_next(WORD);
4152         }
4153         else if (*s == 'v') {
4154             s = force_word(s,WORD,FALSE,TRUE);
4155             s = force_version(s, FALSE);
4156         }
4157     }
4158     else {
4159         s = force_word(s,WORD,FALSE,TRUE);
4160         s = force_version(s, FALSE);
4161     }
4162     pl_yylval.ival = is_use;
4163     return s;
4164 }
4165 #ifdef DEBUGGING
4166     static const char* const exp_name[] =
4167         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
4168           "ATTRTERM", "TERMBLOCK", "XBLOCKTERM", "POSTDEREF",
4169           "TERMORDORDOR"
4170         };
4171 #endif
4172
4173 #define word_takes_any_delimeter(p,l) S_word_takes_any_delimeter(p,l)
4174 STATIC bool
4175 S_word_takes_any_delimeter(char *p, STRLEN len)
4176 {
4177     return (len == 1 && strchr("msyq", p[0])) ||
4178            (len == 2 && (
4179             (p[0] == 't' && p[1] == 'r') ||
4180             (p[0] == 'q' && strchr("qwxr", p[1]))));
4181 }
4182
4183 static void
4184 S_check_scalar_slice(pTHX_ char *s)
4185 {
4186     s++;
4187     while (*s == ' ' || *s == '\t') s++;
4188     if (*s == 'q' && s[1] == 'w'
4189      && !isWORDCHAR_lazy_if(s+2,UTF))
4190         return;
4191     while (*s && (isWORDCHAR_lazy_if(s,UTF) || strchr(" \t$#+-'\"", *s)))
4192         s += UTF ? UTF8SKIP(s) : 1;
4193     if (*s == '}' || *s == ']')
4194         pl_yylval.ival = OPpSLICEWARNING;
4195 }
4196
4197 /*
4198   yylex
4199
4200   Works out what to call the token just pulled out of the input
4201   stream.  The yacc parser takes care of taking the ops we return and
4202   stitching them into a tree.
4203
4204   Returns:
4205     The type of the next token
4206
4207   Structure:
4208       Switch based on the current state:
4209           - if we already built the token before, use it
4210           - if we have a case modifier in a string, deal with that
4211           - handle other cases of interpolation inside a string
4212           - scan the next line if we are inside a format
4213       In the normal state switch on the next character:
4214           - default:
4215             if alphabetic, go to key lookup
4216             unrecoginized character - croak
4217           - 0/4/26: handle end-of-line or EOF
4218           - cases for whitespace
4219           - \n and #: handle comments and line numbers
4220           - various operators, brackets and sigils
4221           - numbers
4222           - quotes
4223           - 'v': vstrings (or go to key lookup)
4224           - 'x' repetition operator (or go to key lookup)
4225           - other ASCII alphanumerics (key lookup begins here):
4226               word before => ?
4227               keyword plugin
4228               scan built-in keyword (but do nothing with it yet)
4229               check for statement label
4230               check for lexical subs
4231                   goto just_a_word if there is one
4232               see whether built-in keyword is overridden
4233               switch on keyword number:
4234                   - default: just_a_word:
4235                       not a built-in keyword; handle bareword lookup
4236                       disambiguate between method and sub call
4237                       fall back to bareword
4238                   - cases for built-in keywords
4239 */
4240
4241
4242 int
4243 Perl_yylex(pTHX)
4244 {
4245     dVAR;
4246     char *s = PL_bufptr;
4247     char *d;
4248     STRLEN len;
4249     bool bof = FALSE;
4250     const bool saw_infix_sigil = cBOOL(PL_parser->saw_infix_sigil);
4251     U8 formbrack = 0;
4252     U32 fake_eof = 0;
4253
4254     /* orig_keyword, gvp, and gv are initialized here because
4255      * jump to the label just_a_word_zero can bypass their
4256      * initialization later. */
4257     I32 orig_keyword = 0;
4258     GV *gv = NULL;
4259     GV **gvp = NULL;
4260
4261     DEBUG_T( {
4262         SV* tmp = newSVpvs("");
4263         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
4264             (IV)CopLINE(PL_curcop),
4265             lex_state_names[PL_lex_state],
4266             exp_name[PL_expect],
4267             pv_display(tmp, s, strlen(s), 0, 60));
4268         SvREFCNT_dec(tmp);
4269     } );
4270
4271     switch (PL_lex_state) {
4272     case LEX_NORMAL:
4273     case LEX_INTERPNORMAL:
4274         break;
4275
4276     /* when we've already built the next token, just pull it out of the queue */
4277     case LEX_KNOWNEXT:
4278         PL_nexttoke--;
4279         pl_yylval = PL_nextval[PL_nexttoke];
4280         if (!PL_nexttoke) {
4281             PL_lex_state = PL_lex_defer;
4282             PL_lex_defer = LEX_NORMAL;
4283         }
4284         {
4285             I32 next_type;
4286             next_type = PL_nexttype[PL_nexttoke];
4287             if (next_type & (7<<24)) {
4288                 if (next_type & (1<<24)) {
4289                     if (PL_lex_brackets > 100)
4290                         Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4291                     PL_lex_brackstack[PL_lex_brackets++] =
4292                         (char) ((next_type >> 16) & 0xff);
4293                 }
4294                 if (next_type & (2<<24))
4295                     PL_lex_allbrackets++;
4296                 if (next_type & (4<<24))
4297                     PL_lex_allbrackets--;
4298                 next_type &= 0xffff;
4299             }
4300             return REPORT(next_type == 'p' ? pending_ident() : next_type);
4301         }
4302
4303     /* interpolated case modifiers like \L \U, including \Q and \E.
4304        when we get here, PL_bufptr is at the \
4305     */
4306     case LEX_INTERPCASEMOD:
4307 #ifdef DEBUGGING
4308         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
4309             Perl_croak(aTHX_
4310                        "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
4311                        PL_bufptr, PL_bufend, *PL_bufptr);
4312 #endif
4313         /* handle \E or end of string */
4314         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
4315             /* if at a \E */
4316             if (PL_lex_casemods) {
4317                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
4318                 PL_lex_casestack[PL_lex_casemods] = '\0';
4319
4320                 if (PL_bufptr != PL_bufend
4321                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
4322                         || oldmod == 'F')) {
4323                     PL_bufptr += 2;
4324                     PL_lex_state = LEX_INTERPCONCAT;
4325                 }
4326                 PL_lex_allbrackets--;
4327                 return REPORT(')');
4328             }
4329             else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
4330                /* Got an unpaired \E */
4331                Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
4332                         "Useless use of \\E");
4333             }
4334             if (PL_bufptr != PL_bufend)
4335                 PL_bufptr += 2;
4336             PL_lex_state = LEX_INTERPCONCAT;
4337             return yylex();
4338         }
4339         else {
4340             DEBUG_T({ PerlIO_printf(Perl_debug_log,
4341               "### Saw case modifier\n"); });
4342             s = PL_bufptr + 1;
4343             if (s[1] == '\\' && s[2] == 'E') {
4344                 PL_bufptr = s + 3;
4345                 PL_lex_state = LEX_INTERPCONCAT;
4346                 return yylex();
4347             }
4348             else {
4349                 I32 tmp;
4350                 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
4351                     tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
4352                 if ((*s == 'L' || *s == 'U' || *s == 'F') &&
4353                     (strchr(PL_lex_casestack, 'L')
4354                         || strchr(PL_lex_casestack, 'U')
4355                         || strchr(PL_lex_casestack, 'F'))) {
4356                     PL_lex_casestack[--PL_lex_casemods] = '\0';
4357                     PL_lex_allbrackets--;
4358                     return REPORT(')');
4359                 }
4360                 if (PL_lex_casemods > 10)
4361                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
4362                 PL_lex_casestack[PL_lex_casemods++] = *s;
4363                 PL_lex_casestack[PL_lex_casemods] = '\0';
4364                 PL_lex_state = LEX_INTERPCONCAT;
4365                 NEXTVAL_NEXTTOKE.ival = 0;
4366                 force_next((2<<24)|'(');
4367                 if (*s == 'l')
4368                     NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
4369                 else if (*s == 'u')
4370                     NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
4371                 else if (*s == 'L')
4372                     NEXTVAL_NEXTTOKE.ival = OP_LC;
4373                 else if (*s == 'U')
4374                     NEXTVAL_NEXTTOKE.ival = OP_UC;
4375                 else if (*s == 'Q')
4376                     NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
4377                 else if (*s == 'F')
4378                     NEXTVAL_NEXTTOKE.ival = OP_FC;
4379                 else
4380                     Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
4381                 PL_bufptr = s + 1;
4382             }
4383             force_next(FUNC);
4384             if (PL_lex_starts) {
4385                 s = PL_bufptr;
4386                 PL_lex_starts = 0;
4387                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
4388                 if (PL_lex_casemods == 1 && PL_lex_inpat)
4389                     TOKEN(',');
4390                 else
4391                     AopNOASSIGN(OP_CONCAT);
4392             }
4393             else
4394                 return yylex();
4395         }
4396
4397     case LEX_INTERPPUSH:
4398         return REPORT(sublex_push());
4399
4400     case LEX_INTERPSTART:
4401         if (PL_bufptr == PL_bufend)
4402             return REPORT(sublex_done());
4403         DEBUG_T({ if(*PL_bufptr != '(') PerlIO_printf(Perl_debug_log,
4404               "### Interpolated variable\n"); });
4405         PL_expect = XTERM;
4406         /* for /@a/, we leave the joining for the regex engine to do
4407          * (unless we're within \Q etc) */
4408         PL_lex_dojoin = (*PL_bufptr == '@'
4409                             && (!PL_lex_inpat || PL_lex_casemods));
4410         PL_lex_state = LEX_INTERPNORMAL;
4411         if (PL_lex_dojoin) {
4412             NEXTVAL_NEXTTOKE.ival = 0;
4413             force_next(',');
4414             force_ident("\"", '$');
4415             NEXTVAL_NEXTTOKE.ival = 0;
4416             force_next('$');
4417             NEXTVAL_NEXTTOKE.ival = 0;
4418             force_next((2<<24)|'(');