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