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