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