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