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