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