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