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