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