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