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