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