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