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