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