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