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