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