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