This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dc94328bc9e3474be2dbf4b831e9892907feba18
[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     /* This API is bad. It should have been using unsigned int for maxlen.
2637        Not sure if we want to change the API, but if not we should sanity
2638        check the value here.  */
2639     const unsigned int correct_length = maxlen < 0 ? INT_MAX : maxlen;
2640
2641     if (!PL_rsfp_filters)
2642         return -1;
2643     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2644         /* Provide a default input filter to make life easy.    */
2645         /* Note that we append to the line. This is handy.      */
2646         DEBUG_P(PerlIO_printf(Perl_debug_log,
2647                               "filter_read %d: from rsfp\n", idx));
2648         if (correct_length) {
2649             /* Want a block */
2650             int len ;
2651             const int old_len = SvCUR(buf_sv);
2652
2653             /* ensure buf_sv is large enough */
2654             SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2655             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2656                                    correct_length)) <= 0) {
2657                 if (PerlIO_error(PL_rsfp))
2658                     return -1;          /* error */
2659                 else
2660                     return 0 ;          /* end of file */
2661             }
2662             SvCUR_set(buf_sv, old_len + len) ;
2663         } else {
2664             /* Want a line */
2665             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2666                 if (PerlIO_error(PL_rsfp))
2667                     return -1;          /* error */
2668                 else
2669                     return 0 ;          /* end of file */
2670             }
2671         }
2672         return SvCUR(buf_sv);
2673     }
2674     /* Skip this filter slot if filter has been deleted */
2675     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2676         DEBUG_P(PerlIO_printf(Perl_debug_log,
2677                               "filter_read %d: skipped (filter deleted)\n",
2678                               idx));
2679         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2680     }
2681     /* Get function pointer hidden within datasv        */
2682     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2683     DEBUG_P(PerlIO_printf(Perl_debug_log,
2684                           "filter_read %d: via function %p (%s)\n",
2685                           idx, datasv, SvPV_nolen_const(datasv)));
2686     /* Call function. The function is expected to       */
2687     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2688     /* Return: <0:error, =0:eof, >0:not eof             */
2689     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2690 }
2691
2692 STATIC char *
2693 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2694 {
2695     dVAR;
2696 #ifdef PERL_CR_FILTER
2697     if (!PL_rsfp_filters) {
2698         filter_add(S_cr_textfilter,NULL);
2699     }
2700 #endif
2701     if (PL_rsfp_filters) {
2702         if (!append)
2703             SvCUR_set(sv, 0);   /* start with empty line        */
2704         if (FILTER_READ(0, sv, 0) > 0)
2705             return ( SvPVX(sv) ) ;
2706         else
2707             return NULL ;
2708     }
2709     else
2710         return (sv_gets(sv, fp, append));
2711 }
2712
2713 STATIC HV *
2714 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2715 {
2716     dVAR;
2717     GV *gv;
2718
2719     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2720         return PL_curstash;
2721
2722     if (len > 2 &&
2723         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2724         (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2725     {
2726         return GvHV(gv);                        /* Foo:: */
2727     }
2728
2729     /* use constant CLASS => 'MyClass' */
2730     if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) {
2731         SV *sv;
2732         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2733             pkgname = SvPV_nolen_const(sv);
2734         }
2735     }
2736
2737     return gv_stashpv(pkgname, FALSE);
2738 }
2739
2740 #ifdef PERL_MAD 
2741  /*
2742  * Perl_madlex
2743  * The intent of this yylex wrapper is to minimize the changes to the
2744  * tokener when we aren't interested in collecting madprops.  It remains
2745  * to be seen how successful this strategy will be...
2746  */
2747
2748 int
2749 Perl_madlex(pTHX)
2750 {
2751     int optype;
2752     char *s = PL_bufptr;
2753
2754     /* make sure PL_thiswhite is initialized */
2755     PL_thiswhite = 0;
2756     PL_thismad = 0;
2757
2758     /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2759     if (PL_pending_ident)
2760         return S_pending_ident(aTHX);
2761
2762     /* previous token ate up our whitespace? */
2763     if (!PL_lasttoke && PL_nextwhite) {
2764         PL_thiswhite = PL_nextwhite;
2765         PL_nextwhite = 0;
2766     }
2767
2768     /* isolate the token, and figure out where it is without whitespace */
2769     PL_realtokenstart = -1;
2770     PL_thistoken = 0;
2771     optype = yylex();
2772     s = PL_bufptr;
2773     assert(PL_curforce < 0);
2774
2775     if (!PL_thismad || PL_thismad->mad_key == '^') {    /* not forced already? */
2776         if (!PL_thistoken) {
2777             if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
2778                 PL_thistoken = newSVpvn("",0);
2779             else {
2780                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
2781                 PL_thistoken = newSVpvn(tstart, s - tstart);
2782             }
2783         }
2784         if (PL_thismad) /* install head */
2785             CURMAD('X', PL_thistoken);
2786     }
2787
2788     /* last whitespace of a sublex? */
2789     if (optype == ')' && PL_endwhite) {
2790         CURMAD('X', PL_endwhite);
2791     }
2792
2793     if (!PL_thismad) {
2794
2795         /* if no whitespace and we're at EOF, bail.  Otherwise fake EOF below. */
2796         if (!PL_thiswhite && !PL_endwhite && !optype) {
2797             sv_free(PL_thistoken);
2798             PL_thistoken = 0;
2799             return 0;
2800         }
2801
2802         /* put off final whitespace till peg */
2803         if (optype == ';' && !PL_rsfp) {
2804             PL_nextwhite = PL_thiswhite;
2805             PL_thiswhite = 0;
2806         }
2807         else if (PL_thisopen) {
2808             CURMAD('q', PL_thisopen);
2809             if (PL_thistoken)
2810                 sv_free(PL_thistoken);
2811             PL_thistoken = 0;
2812         }
2813         else {
2814             /* Store actual token text as madprop X */
2815             CURMAD('X', PL_thistoken);
2816         }
2817
2818         if (PL_thiswhite) {
2819             /* add preceding whitespace as madprop _ */
2820             CURMAD('_', PL_thiswhite);
2821         }
2822
2823         if (PL_thisstuff) {
2824             /* add quoted material as madprop = */
2825             CURMAD('=', PL_thisstuff);
2826         }
2827
2828         if (PL_thisclose) {
2829             /* add terminating quote as madprop Q */
2830             CURMAD('Q', PL_thisclose);
2831         }
2832     }
2833
2834     /* special processing based on optype */
2835
2836     switch (optype) {
2837
2838     /* opval doesn't need a TOKEN since it can already store mp */
2839     case WORD:
2840     case METHOD:
2841     case FUNCMETH:
2842     case THING:
2843     case PMFUNC:
2844     case PRIVATEREF:
2845     case FUNC0SUB:
2846     case UNIOPSUB:
2847     case LSTOPSUB:
2848         if (yylval.opval)
2849             append_madprops(PL_thismad, yylval.opval, 0);
2850         PL_thismad = 0;
2851         return optype;
2852
2853     /* fake EOF */
2854     case 0:
2855         optype = PEG;
2856         if (PL_endwhite) {
2857             addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
2858             PL_endwhite = 0;
2859         }
2860         break;
2861
2862     case ']':
2863     case '}':
2864         if (PL_faketokens)
2865             break;
2866         /* remember any fake bracket that lexer is about to discard */ 
2867         if (PL_lex_brackets == 1 &&
2868             ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
2869         {
2870             s = PL_bufptr;
2871             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2872                 s++;
2873             if (*s == '}') {
2874                 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
2875                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
2876                 PL_thiswhite = 0;
2877                 PL_bufptr = s - 1;
2878                 break;  /* don't bother looking for trailing comment */
2879             }
2880             else
2881                 s = PL_bufptr;
2882         }
2883         if (optype == ']')
2884             break;
2885         /* FALLTHROUGH */
2886
2887     /* attach a trailing comment to its statement instead of next token */
2888     case ';':
2889         if (PL_faketokens)
2890             break;
2891         if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
2892             s = PL_bufptr;
2893             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2894                 s++;
2895             if (*s == '\n' || *s == '#') {
2896                 while (s < PL_bufend && *s != '\n')
2897                     s++;
2898                 if (s < PL_bufend)
2899                     s++;
2900                 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
2901                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
2902                 PL_thiswhite = 0;
2903                 PL_bufptr = s;
2904             }
2905         }
2906         break;
2907
2908     /* pval */
2909     case LABEL:
2910         break;
2911
2912     /* ival */
2913     default:
2914         break;
2915
2916     }
2917
2918     /* Create new token struct.  Note: opvals return early above. */
2919     yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
2920     PL_thismad = 0;
2921     return optype;
2922 }
2923 #endif
2924
2925 STATIC char *
2926 S_tokenize_use(pTHX_ int is_use, char *s) {
2927     dVAR;
2928     if (PL_expect != XSTATE)
2929         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2930                     is_use ? "use" : "no"));
2931     s = SKIPSPACE1(s);
2932     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2933         s = force_version(s, TRUE);
2934         if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
2935             start_force(PL_curforce);
2936             NEXTVAL_NEXTTOKE.opval = NULL;
2937             force_next(WORD);
2938         }
2939         else if (*s == 'v') {
2940             s = force_word(s,WORD,FALSE,TRUE,FALSE);
2941             s = force_version(s, FALSE);
2942         }
2943     }
2944     else {
2945         s = force_word(s,WORD,FALSE,TRUE,FALSE);
2946         s = force_version(s, FALSE);
2947     }
2948     yylval.ival = is_use;
2949     return s;
2950 }
2951 #ifdef DEBUGGING
2952     static const char* const exp_name[] =
2953         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2954           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2955         };
2956 #endif
2957
2958 /*
2959   yylex
2960
2961   Works out what to call the token just pulled out of the input
2962   stream.  The yacc parser takes care of taking the ops we return and
2963   stitching them into a tree.
2964
2965   Returns:
2966     PRIVATEREF
2967
2968   Structure:
2969       if read an identifier
2970           if we're in a my declaration
2971               croak if they tried to say my($foo::bar)
2972               build the ops for a my() declaration
2973           if it's an access to a my() variable
2974               are we in a sort block?
2975                   croak if my($a); $a <=> $b
2976               build ops for access to a my() variable
2977           if in a dq string, and they've said @foo and we can't find @foo
2978               croak
2979           build ops for a bareword
2980       if we already built the token before, use it.
2981 */
2982
2983
2984 #ifdef __SC__
2985 #pragma segment Perl_yylex
2986 #endif
2987 int
2988 Perl_yylex(pTHX)
2989 {
2990     dVAR;
2991     register char *s = PL_bufptr;
2992     register char *d;
2993     STRLEN len;
2994     bool bof = FALSE;
2995
2996     DEBUG_T( {
2997         SV* tmp = newSVpvs("");
2998         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
2999             (IV)CopLINE(PL_curcop),
3000             lex_state_names[PL_lex_state],
3001             exp_name[PL_expect],
3002             pv_display(tmp, s, strlen(s), 0, 60));
3003         SvREFCNT_dec(tmp);
3004     } );
3005     /* check if there's an identifier for us to look at */
3006     if (PL_pending_ident)
3007         return REPORT(S_pending_ident(aTHX));
3008
3009     /* no identifier pending identification */
3010
3011     switch (PL_lex_state) {
3012 #ifdef COMMENTARY
3013     case LEX_NORMAL:            /* Some compilers will produce faster */
3014     case LEX_INTERPNORMAL:      /* code if we comment these out. */
3015         break;
3016 #endif
3017
3018     /* when we've already built the next token, just pull it out of the queue */
3019     case LEX_KNOWNEXT:
3020 #ifdef PERL_MAD
3021         PL_lasttoke--;
3022         yylval = PL_nexttoke[PL_lasttoke].next_val;
3023         if (PL_madskills) {
3024             PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3025             PL_nexttoke[PL_lasttoke].next_mad = 0;
3026             if (PL_thismad && PL_thismad->mad_key == '_') {
3027                 PL_thiswhite = (SV*)PL_thismad->mad_val;
3028                 PL_thismad->mad_val = 0;
3029                 mad_free(PL_thismad);
3030                 PL_thismad = 0;
3031             }
3032         }
3033         if (!PL_lasttoke) {
3034             PL_lex_state = PL_lex_defer;
3035             PL_expect = PL_lex_expect;
3036             PL_lex_defer = LEX_NORMAL;
3037             if (!PL_nexttoke[PL_lasttoke].next_type)
3038                 return yylex();
3039         }
3040 #else
3041         PL_nexttoke--;
3042         yylval = PL_nextval[PL_nexttoke];
3043         if (!PL_nexttoke) {
3044             PL_lex_state = PL_lex_defer;
3045             PL_expect = PL_lex_expect;
3046             PL_lex_defer = LEX_NORMAL;
3047         }
3048 #endif
3049 #ifdef PERL_MAD
3050         /* FIXME - can these be merged?  */
3051         return(PL_nexttoke[PL_lasttoke].next_type);
3052 #else
3053         return REPORT(PL_nexttype[PL_nexttoke]);
3054 #endif
3055
3056     /* interpolated case modifiers like \L \U, including \Q and \E.
3057        when we get here, PL_bufptr is at the \
3058     */
3059     case LEX_INTERPCASEMOD:
3060 #ifdef DEBUGGING
3061         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3062             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3063 #endif
3064         /* handle \E or end of string */
3065         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3066             /* if at a \E */
3067             if (PL_lex_casemods) {
3068                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3069                 PL_lex_casestack[PL_lex_casemods] = '\0';
3070
3071                 if (PL_bufptr != PL_bufend
3072                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3073                     PL_bufptr += 2;
3074                     PL_lex_state = LEX_INTERPCONCAT;
3075 #ifdef PERL_MAD
3076                     if (PL_madskills)
3077                         PL_thistoken = newSVpvn("\\E",2);
3078 #endif
3079                 }
3080                 return REPORT(')');
3081             }
3082 #ifdef PERL_MAD
3083             while (PL_bufptr != PL_bufend &&
3084               PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3085                 if (!PL_thiswhite)
3086                     PL_thiswhite = newSVpvn("",0);
3087                 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3088                 PL_bufptr += 2;
3089             }
3090 #else
3091             if (PL_bufptr != PL_bufend)
3092                 PL_bufptr += 2;
3093 #endif
3094             PL_lex_state = LEX_INTERPCONCAT;
3095             return yylex();
3096         }
3097         else {
3098             DEBUG_T({ PerlIO_printf(Perl_debug_log,
3099               "### Saw case modifier\n"); });
3100             s = PL_bufptr + 1;
3101             if (s[1] == '\\' && s[2] == 'E') {
3102 #ifdef PERL_MAD
3103                 if (!PL_thiswhite)
3104                     PL_thiswhite = newSVpvn("",0);
3105                 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3106 #endif
3107                 PL_bufptr = s + 3;
3108                 PL_lex_state = LEX_INTERPCONCAT;
3109                 return yylex();
3110             }
3111             else {
3112                 I32 tmp;
3113                 if (!PL_madskills) /* when just compiling don't need correct */
3114                     if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3115                         tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
3116                 if ((*s == 'L' || *s == 'U') &&
3117                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3118                     PL_lex_casestack[--PL_lex_casemods] = '\0';
3119                     return REPORT(')');
3120                 }
3121                 if (PL_lex_casemods > 10)
3122                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3123                 PL_lex_casestack[PL_lex_casemods++] = *s;
3124                 PL_lex_casestack[PL_lex_casemods] = '\0';
3125                 PL_lex_state = LEX_INTERPCONCAT;
3126                 start_force(PL_curforce);
3127                 NEXTVAL_NEXTTOKE.ival = 0;
3128                 force_next('(');
3129                 start_force(PL_curforce);
3130                 if (*s == 'l')
3131                     NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3132                 else if (*s == 'u')
3133                     NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3134                 else if (*s == 'L')
3135                     NEXTVAL_NEXTTOKE.ival = OP_LC;
3136                 else if (*s == 'U')
3137                     NEXTVAL_NEXTTOKE.ival = OP_UC;
3138                 else if (*s == 'Q')
3139                     NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3140                 else
3141                     Perl_croak(aTHX_ "panic: yylex");
3142                 if (PL_madskills) {
3143                     SV* const tmpsv = newSVpvn("",0);
3144                     Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3145                     curmad('_', tmpsv);
3146                 }
3147                 PL_bufptr = s + 1;
3148             }
3149             force_next(FUNC);
3150             if (PL_lex_starts) {
3151                 s = PL_bufptr;
3152                 PL_lex_starts = 0;
3153 #ifdef PERL_MAD
3154                 if (PL_madskills) {
3155                     if (PL_thistoken)
3156                         sv_free(PL_thistoken);
3157                     PL_thistoken = newSVpvn("",0);
3158                 }
3159 #endif
3160                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3161                 if (PL_lex_casemods == 1 && PL_lex_inpat)
3162                     OPERATOR(',');
3163                 else
3164                     Aop(OP_CONCAT);
3165             }
3166             else
3167                 return yylex();
3168         }
3169
3170     case LEX_INTERPPUSH:
3171         return REPORT(sublex_push());
3172
3173     case LEX_INTERPSTART:
3174         if (PL_bufptr == PL_bufend)
3175             return REPORT(sublex_done());
3176         DEBUG_T({ PerlIO_printf(Perl_debug_log,
3177               "### Interpolated variable\n"); });
3178         PL_expect = XTERM;
3179         PL_lex_dojoin = (*PL_bufptr == '@');
3180         PL_lex_state = LEX_INTERPNORMAL;
3181         if (PL_lex_dojoin) {
3182             start_force(PL_curforce);
3183             NEXTVAL_NEXTTOKE.ival = 0;
3184             force_next(',');
3185             start_force(PL_curforce);
3186             force_ident("\"", '$');
3187             start_force(PL_curforce);
3188             NEXTVAL_NEXTTOKE.ival = 0;
3189             force_next('$');
3190             start_force(PL_curforce);
3191             NEXTVAL_NEXTTOKE.ival = 0;
3192             force_next('(');
3193             start_force(PL_curforce);
3194             NEXTVAL_NEXTTOKE.ival = OP_JOIN;    /* emulate join($", ...) */
3195             force_next(FUNC);
3196         }
3197         if (PL_lex_starts++) {
3198             s = PL_bufptr;
3199 #ifdef PERL_MAD
3200             if (PL_madskills) {
3201                 if (PL_thistoken)
3202                     sv_free(PL_thistoken);
3203                 PL_thistoken = newSVpvn("",0);
3204             }
3205 #endif
3206             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3207             if (!PL_lex_casemods && PL_lex_inpat)
3208                 OPERATOR(',');
3209             else
3210                 Aop(OP_CONCAT);
3211         }
3212         return yylex();
3213
3214     case LEX_INTERPENDMAYBE:
3215         if (intuit_more(PL_bufptr)) {
3216             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
3217             break;
3218         }
3219         /* FALL THROUGH */
3220
3221     case LEX_INTERPEND:
3222         if (PL_lex_dojoin) {
3223             PL_lex_dojoin = FALSE;
3224             PL_lex_state = LEX_INTERPCONCAT;
3225 #ifdef PERL_MAD
3226             if (PL_madskills) {
3227                 if (PL_thistoken)
3228                     sv_free(PL_thistoken);
3229                 PL_thistoken = newSVpvn("",0);
3230             }
3231 #endif
3232             return REPORT(')');
3233         }
3234         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3235             && SvEVALED(PL_lex_repl))
3236         {
3237             if (PL_bufptr != PL_bufend)
3238                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3239             PL_lex_repl = NULL;
3240         }
3241         /* FALLTHROUGH */
3242     case LEX_INTERPCONCAT:
3243 #ifdef DEBUGGING
3244         if (PL_lex_brackets)
3245             Perl_croak(aTHX_ "panic: INTERPCONCAT");
3246 #endif
3247         if (PL_bufptr == PL_bufend)
3248             return REPORT(sublex_done());
3249
3250         if (SvIVX(PL_linestr) == '\'') {
3251             SV *sv = newSVsv(PL_linestr);
3252             if (!PL_lex_inpat)
3253                 sv = tokeq(sv);
3254             else if ( PL_hints & HINT_NEW_RE )
3255                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3256             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3257             s = PL_bufend;
3258         }
3259         else {
3260             s = scan_const(PL_bufptr);
3261             if (*s == '\\')
3262                 PL_lex_state = LEX_INTERPCASEMOD;
3263             else
3264                 PL_lex_state = LEX_INTERPSTART;
3265         }
3266
3267         if (s != PL_bufptr) {
3268             start_force(PL_curforce);
3269             if (PL_madskills) {
3270                 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3271             }
3272             NEXTVAL_NEXTTOKE = yylval;
3273             PL_expect = XTERM;
3274             force_next(THING);
3275             if (PL_lex_starts++) {
3276 #ifdef PERL_MAD
3277                 if (PL_madskills) {
3278                     if (PL_thistoken)
3279                         sv_free(PL_thistoken);
3280                     PL_thistoken = newSVpvn("",0);
3281                 }
3282 #endif
3283                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3284                 if (!PL_lex_casemods && PL_lex_inpat)
3285                     OPERATOR(',');
3286                 else
3287                     Aop(OP_CONCAT);
3288             }
3289             else {
3290                 PL_bufptr = s;
3291                 return yylex();
3292             }
3293         }
3294
3295         return yylex();
3296     case LEX_FORMLINE:
3297         PL_lex_state = LEX_NORMAL;
3298         s = scan_formline(PL_bufptr);
3299         if (!PL_lex_formbrack)
3300             goto rightbracket;
3301         OPERATOR(';');
3302     }
3303
3304     s = PL_bufptr;
3305     PL_oldoldbufptr = PL_oldbufptr;
3306     PL_oldbufptr = s;
3307
3308   retry:
3309 #ifdef PERL_MAD
3310     if (PL_thistoken) {
3311         sv_free(PL_thistoken);
3312         PL_thistoken = 0;
3313     }
3314     PL_realtokenstart = s - SvPVX(PL_linestr);  /* assume but undo on ws */
3315 #endif
3316     switch (*s) {
3317     default:
3318         if (isIDFIRST_lazy_if(s,UTF))
3319             goto keylookup;
3320         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3321     case 4:
3322     case 26:
3323         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
3324     case 0:
3325 #ifdef PERL_MAD
3326         if (PL_madskills)
3327             PL_faketokens = 0;
3328 #endif
3329         if (!PL_rsfp) {
3330             PL_last_uni = 0;
3331             PL_last_lop = 0;
3332             if (PL_lex_brackets) {
3333                 yyerror(PL_lex_formbrack
3334                     ? "Format not terminated"
3335                     : "Missing right curly or square bracket");
3336             }
3337             DEBUG_T( { PerlIO_printf(Perl_debug_log,
3338                         "### Tokener got EOF\n");
3339             } );
3340             TOKEN(0);
3341         }
3342         if (s++ < PL_bufend)
3343             goto retry;                 /* ignore stray nulls */
3344         PL_last_uni = 0;
3345         PL_last_lop = 0;
3346         if (!PL_in_eval && !PL_preambled) {
3347             PL_preambled = TRUE;
3348 #ifdef PERL_MAD
3349             if (PL_madskills)
3350                 PL_faketokens = 1;
3351 #endif
3352             sv_setpv(PL_linestr,incl_perldb());
3353             if (SvCUR(PL_linestr))
3354                 sv_catpvs(PL_linestr,";");
3355             if (PL_preambleav){
3356                 while(AvFILLp(PL_preambleav) >= 0) {
3357                     SV *tmpsv = av_shift(PL_preambleav);
3358                     sv_catsv(PL_linestr, tmpsv);
3359                     sv_catpvs(PL_linestr, ";");
3360                     sv_free(tmpsv);
3361                 }
3362                 sv_free((SV*)PL_preambleav);
3363                 PL_preambleav = NULL;
3364             }
3365             if (PL_minus_n || PL_minus_p) {
3366                 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3367                 if (PL_minus_l)
3368                     sv_catpvs(PL_linestr,"chomp;");
3369                 if (PL_minus_a) {
3370                     if (PL_minus_F) {
3371                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3372                              || *PL_splitstr == '"')
3373                               && strchr(PL_splitstr + 1, *PL_splitstr))
3374                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3375                         else {
3376                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3377                                bytes can be used as quoting characters.  :-) */
3378                             const char *splits = PL_splitstr;
3379                             sv_catpvs(PL_linestr, "our @F=split(q\0");
3380                             do {
3381                                 /* Need to \ \s  */
3382                                 if (*splits == '\\')
3383                                     sv_catpvn(PL_linestr, splits, 1);
3384                                 sv_catpvn(PL_linestr, splits, 1);
3385                             } while (*splits++);
3386                             /* This loop will embed the trailing NUL of
3387                                PL_linestr as the last thing it does before
3388                                terminating.  */
3389                             sv_catpvs(PL_linestr, ");");
3390                         }
3391                     }
3392                     else
3393                         sv_catpvs(PL_linestr,"our @F=split(' ');");
3394                 }
3395             }
3396             if (PL_minus_E)
3397                 sv_catpvs(PL_linestr,"use feature ':5.10';");
3398             sv_catpvs(PL_linestr, "\n");
3399             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3400             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3401             PL_last_lop = PL_last_uni = NULL;
3402             if (PERLDB_LINE && PL_curstash != PL_debstash) {
3403                 SV * const sv = newSV(0);
3404
3405                 sv_upgrade(sv, SVt_PVMG);
3406                 sv_setsv(sv,PL_linestr);
3407                 (void)SvIOK_on(sv);
3408                 SvIV_set(sv, 0);
3409                 av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3410             }
3411             goto retry;
3412         }
3413         do {
3414             bof = PL_rsfp ? TRUE : FALSE;
3415             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3416               fake_eof:
3417 #ifdef PERL_MAD
3418                 PL_realtokenstart = -1;
3419 #endif
3420                 if (PL_rsfp) {
3421                     if (PL_preprocess && !PL_in_eval)
3422                         (void)PerlProc_pclose(PL_rsfp);
3423                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3424                         PerlIO_clearerr(PL_rsfp);
3425                     else
3426                         (void)PerlIO_close(PL_rsfp);
3427                     PL_rsfp = NULL;
3428                     PL_doextract = FALSE;
3429                 }
3430                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3431 #ifdef PERL_MAD
3432                     if (PL_madskills)
3433                         PL_faketokens = 1;
3434 #endif
3435                     sv_setpv(PL_linestr,PL_minus_p
3436                              ? ";}continue{print;}" : ";}");
3437                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3438                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3439                     PL_last_lop = PL_last_uni = NULL;
3440                     PL_minus_n = PL_minus_p = 0;
3441                     goto retry;
3442                 }
3443                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3444                 PL_last_lop = PL_last_uni = NULL;
3445                 sv_setpvn(PL_linestr,"",0);
3446                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
3447             }
3448             /* If it looks like the start of a BOM or raw UTF-16,
3449              * check if it in fact is. */
3450             else if (bof &&
3451                      (*s == 0 ||
3452                       *(U8*)s == 0xEF ||
3453                       *(U8*)s >= 0xFE ||
3454                       s[1] == 0)) {
3455 #ifdef PERLIO_IS_STDIO
3456 #  ifdef __GNU_LIBRARY__
3457 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3458 #      define FTELL_FOR_PIPE_IS_BROKEN
3459 #    endif
3460 #  else
3461 #    ifdef __GLIBC__
3462 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3463 #        define FTELL_FOR_PIPE_IS_BROKEN
3464 #      endif
3465 #    endif
3466 #  endif
3467 #endif
3468 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3469                 /* This loses the possibility to detect the bof
3470                  * situation on perl -P when the libc5 is being used.
3471                  * Workaround?  Maybe attach some extra state to PL_rsfp?
3472                  */
3473                 if (!PL_preprocess)
3474                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3475 #else
3476                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3477 #endif
3478                 if (bof) {
3479                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3480                     s = swallow_bom((U8*)s);
3481                 }
3482             }
3483             if (PL_doextract) {
3484                 /* Incest with pod. */
3485 #ifdef PERL_MAD
3486                 if (PL_madskills)
3487                     sv_catsv(PL_thiswhite, PL_linestr);
3488 #endif
3489                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3490                     sv_setpvn(PL_linestr, "", 0);
3491                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3492                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3493                     PL_last_lop = PL_last_uni = NULL;
3494                     PL_doextract = FALSE;
3495                 }
3496             }
3497             incline(s);
3498         } while (PL_doextract);
3499         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3500         if (PERLDB_LINE && PL_curstash != PL_debstash) {
3501             SV * const sv = newSV(0);
3502
3503             sv_upgrade(sv, SVt_PVMG);
3504             sv_setsv(sv,PL_linestr);
3505             (void)SvIOK_on(sv);
3506             SvIV_set(sv, 0);
3507             av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv);
3508         }
3509         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3510         PL_last_lop = PL_last_uni = NULL;
3511         if (CopLINE(PL_curcop) == 1) {
3512             while (s < PL_bufend && isSPACE(*s))
3513                 s++;
3514             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3515                 s++;
3516 #ifdef PERL_MAD
3517             if (PL_madskills)
3518                 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3519 #endif
3520             d = NULL;
3521             if (!PL_in_eval) {
3522                 if (*s == '#' && *(s+1) == '!')
3523                     d = s + 2;
3524 #ifdef ALTERNATE_SHEBANG
3525                 else {
3526                     static char const as[] = ALTERNATE_SHEBANG;
3527                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3528                         d = s + (sizeof(as) - 1);
3529                 }
3530 #endif /* ALTERNATE_SHEBANG */
3531             }
3532             if (d) {
3533                 char *ipath;
3534                 char *ipathend;
3535
3536                 while (isSPACE(*d))
3537                     d++;
3538                 ipath = d;
3539                 while (*d && !isSPACE(*d))
3540                     d++;
3541                 ipathend = d;
3542
3543 #ifdef ARG_ZERO_IS_SCRIPT
3544                 if (ipathend > ipath) {
3545                     /*
3546                      * HP-UX (at least) sets argv[0] to the script name,
3547                      * which makes $^X incorrect.  And Digital UNIX and Linux,
3548                      * at least, set argv[0] to the basename of the Perl
3549                      * interpreter. So, having found "#!", we'll set it right.
3550                      */
3551                     SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3552                                                     SVt_PV)); /* $^X */
3553                     assert(SvPOK(x) || SvGMAGICAL(x));
3554                     if (sv_eq(x, CopFILESV(PL_curcop))) {
3555                         sv_setpvn(x, ipath, ipathend - ipath);
3556                         SvSETMAGIC(x);
3557                     }
3558                     else {
3559                         STRLEN blen;
3560                         STRLEN llen;
3561                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3562                         const char * const lstart = SvPV_const(x,llen);
3563                         if (llen < blen) {
3564                             bstart += blen - llen;
3565                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3566                                 sv_setpvn(x, ipath, ipathend - ipath);
3567                                 SvSETMAGIC(x);
3568                             }
3569                         }
3570                     }
3571                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
3572                 }
3573 #endif /* ARG_ZERO_IS_SCRIPT */
3574
3575                 /*
3576                  * Look for options.
3577                  */
3578                 d = instr(s,"perl -");
3579                 if (!d) {
3580                     d = instr(s,"perl");
3581 #if defined(DOSISH)
3582                     /* avoid getting into infinite loops when shebang
3583                      * line contains "Perl" rather than "perl" */
3584                     if (!d) {
3585                         for (d = ipathend-4; d >= ipath; --d) {
3586                             if ((*d == 'p' || *d == 'P')
3587                                 && !ibcmp(d, "perl", 4))
3588                             {
3589                                 break;
3590                             }
3591                         }
3592                         if (d < ipath)
3593                             d = NULL;
3594                     }
3595 #endif
3596                 }
3597 #ifdef ALTERNATE_SHEBANG
3598                 /*
3599                  * If the ALTERNATE_SHEBANG on this system starts with a
3600                  * character that can be part of a Perl expression, then if
3601                  * we see it but not "perl", we're probably looking at the
3602                  * start of Perl code, not a request to hand off to some
3603                  * other interpreter.  Similarly, if "perl" is there, but
3604                  * not in the first 'word' of the line, we assume the line
3605                  * contains the start of the Perl program.
3606                  */
3607                 if (d && *s != '#') {
3608                     const char *c = ipath;
3609                     while (*c && !strchr("; \t\r\n\f\v#", *c))
3610                         c++;
3611                     if (c < d)
3612                         d = NULL;       /* "perl" not in first word; ignore */
3613                     else
3614                         *s = '#';       /* Don't try to parse shebang line */
3615                 }
3616 #endif /* ALTERNATE_SHEBANG */
3617 #ifndef MACOS_TRADITIONAL
3618                 if (!d &&
3619                     *s == '#' &&
3620                     ipathend > ipath &&
3621                     !PL_minus_c &&
3622                     !instr(s,"indir") &&
3623                     instr(PL_origargv[0],"perl"))
3624                 {
3625                     dVAR;
3626                     char **newargv;
3627
3628                     *ipathend = '\0';
3629                     s = ipathend + 1;
3630                     while (s < PL_bufend && isSPACE(*s))
3631                         s++;
3632                     if (s < PL_bufend) {
3633                         Newxz(newargv,PL_origargc+3,char*);
3634                         newargv[1] = s;
3635                         while (s < PL_bufend && !isSPACE(*s))
3636                             s++;
3637                         *s = '\0';
3638                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3639                     }
3640                     else
3641                         newargv = PL_origargv;
3642                     newargv[0] = ipath;
3643                     PERL_FPU_PRE_EXEC
3644                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3645                     PERL_FPU_POST_EXEC
3646                     Perl_croak(aTHX_ "Can't exec %s", ipath);
3647                 }
3648 #endif
3649                 if (d) {
3650                     while (*d && !isSPACE(*d)) d++;
3651                     while (SPACE_OR_TAB(*d)) d++;
3652
3653                     if (*d++ == '-') {
3654                         const bool switches_done = PL_doswitches;
3655                         const U32 oldpdb = PL_perldb;
3656                         const bool oldn = PL_minus_n;
3657                         const bool oldp = PL_minus_p;
3658
3659                         do {
3660                             if (*d == 'M' || *d == 'm' || *d == 'C') {
3661                                 const char * const m = d;
3662                                 while (*d && !isSPACE(*d))
3663                                     d++;
3664                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3665                                       (int)(d - m), m);
3666                             }
3667                             d = moreswitches(d);
3668                         } while (d);
3669                         if (PL_doswitches && !switches_done) {
3670                             int argc = PL_origargc;
3671                             char **argv = PL_origargv;
3672                             do {
3673                                 argc--,argv++;
3674                             } while (argc && argv[0][0] == '-' && argv[0][1]);
3675                             init_argv_symbols(argc,argv);
3676                         }
3677                         if ((PERLDB_LINE && !oldpdb) ||
3678                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3679                               /* if we have already added "LINE: while (<>) {",
3680                                  we must not do it again */
3681                         {
3682                             sv_setpvn(PL_linestr, "", 0);
3683                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3684                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3685                             PL_last_lop = PL_last_uni = NULL;
3686                             PL_preambled = FALSE;
3687                             if (PERLDB_LINE)
3688                                 (void)gv_fetchfile(PL_origfilename);
3689                             goto retry;
3690                         }
3691                     }
3692                 }
3693             }
3694         }
3695         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3696             PL_bufptr = s;
3697             PL_lex_state = LEX_FORMLINE;
3698             return yylex();
3699         }
3700         goto retry;
3701     case '\r':
3702 #ifdef PERL_STRICT_CR
3703         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3704         Perl_croak(aTHX_
3705       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3706 #endif
3707     case ' ': case '\t': case '\f': case 013:
3708 #ifdef MACOS_TRADITIONAL
3709     case '\312':
3710 #endif
3711 #ifdef PERL_MAD
3712         PL_realtokenstart = -1;
3713         s = SKIPSPACE0(s);
3714 #else
3715         s++;
3716 #endif
3717         goto retry;
3718     case '#':
3719     case '\n':
3720 #ifdef PERL_MAD
3721         PL_realtokenstart = -1;
3722         if (PL_madskills)
3723             PL_faketokens = 0;
3724 #endif
3725         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3726             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3727                 /* handle eval qq[#line 1 "foo"\n ...] */
3728                 CopLINE_dec(PL_curcop);
3729                 incline(s);
3730             }
3731             if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3732                 s = SKIPSPACE0(s);
3733                 if (!PL_in_eval || PL_rsfp)
3734                     incline(s);
3735             }
3736             else {
3737                 d = s;
3738                 while (d < PL_bufend && *d != '\n')
3739                     d++;
3740                 if (d < PL_bufend)
3741                     d++;
3742                 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3743                   Perl_croak(aTHX_ "panic: input overflow");
3744 #ifdef PERL_MAD
3745                 if (PL_madskills)
3746                     PL_thiswhite = newSVpvn(s, d - s);
3747 #endif
3748                 s = d;
3749                 incline(s);
3750             }
3751             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3752                 PL_bufptr = s;
3753                 PL_lex_state = LEX_FORMLINE;
3754                 return yylex();
3755             }
3756         }
3757         else {
3758 #ifdef PERL_MAD
3759             if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3760                 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3761                     PL_faketokens = 0;
3762                     s = SKIPSPACE0(s);
3763                     TOKEN(PEG); /* make sure any #! line is accessible */
3764                 }
3765                 s = SKIPSPACE0(s);
3766             }
3767             else {
3768 /*              if (PL_madskills && PL_lex_formbrack) { */
3769                     d = s;
3770                     while (d < PL_bufend && *d != '\n')
3771                         d++;
3772                     if (d < PL_bufend)
3773                         d++;
3774                     else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3775                       Perl_croak(aTHX_ "panic: input overflow");
3776                     if (PL_madskills && CopLINE(PL_curcop) >= 1) {
3777                         if (!PL_thiswhite)
3778                             PL_thiswhite = newSVpvn("",0);
3779                         if (CopLINE(PL_curcop) == 1) {
3780                             sv_setpvn(PL_thiswhite, "", 0);
3781                             PL_faketokens = 0;
3782                         }
3783                         sv_catpvn(PL_thiswhite, s, d - s);
3784                     }
3785                     s = d;
3786 /*              }
3787                 *s = '\0';
3788                 PL_bufend = s; */
3789             }
3790 #else
3791             *s = '\0';
3792             PL_bufend = s;
3793 #endif
3794         }
3795         goto retry;
3796     case '-':
3797         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3798             I32 ftst = 0;
3799             char tmp;
3800
3801             s++;
3802             PL_bufptr = s;
3803             tmp = *s++;
3804
3805             while (s < PL_bufend && SPACE_OR_TAB(*s))
3806                 s++;
3807
3808             if (strnEQ(s,"=>",2)) {
3809                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3810                 DEBUG_T( { S_printbuf(aTHX_
3811                         "### Saw unary minus before =>, forcing word %s\n", s);
3812                 } );
3813                 OPERATOR('-');          /* unary minus */
3814             }
3815             PL_last_uni = PL_oldbufptr;
3816             switch (tmp) {
3817             case 'r': ftst = OP_FTEREAD;        break;
3818             case 'w': ftst = OP_FTEWRITE;       break;
3819             case 'x': ftst = OP_FTEEXEC;        break;
3820             case 'o': ftst = OP_FTEOWNED;       break;
3821             case 'R': ftst = OP_FTRREAD;        break;
3822             case 'W': ftst = OP_FTRWRITE;       break;
3823             case 'X': ftst = OP_FTREXEC;        break;
3824             case 'O': ftst = OP_FTROWNED;       break;
3825             case 'e': ftst = OP_FTIS;           break;
3826             case 'z': ftst = OP_FTZERO;         break;
3827             case 's': ftst = OP_FTSIZE;         break;
3828             case 'f': ftst = OP_FTFILE;         break;
3829             case 'd': ftst = OP_FTDIR;          break;
3830             case 'l': ftst = OP_FTLINK;         break;
3831             case 'p': ftst = OP_FTPIPE;         break;
3832             case 'S': ftst = OP_FTSOCK;         break;
3833             case 'u': ftst = OP_FTSUID;         break;
3834             case 'g': ftst = OP_FTSGID;         break;
3835             case 'k': ftst = OP_FTSVTX;         break;
3836             case 'b': ftst = OP_FTBLK;          break;
3837             case 'c': ftst = OP_FTCHR;          break;
3838             case 't': ftst = OP_FTTTY;          break;
3839             case 'T': ftst = OP_FTTEXT;         break;
3840             case 'B': ftst = OP_FTBINARY;       break;
3841             case 'M': case 'A': case 'C':
3842                 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
3843                 switch (tmp) {
3844                 case 'M': ftst = OP_FTMTIME;    break;
3845                 case 'A': ftst = OP_FTATIME;    break;
3846                 case 'C': ftst = OP_FTCTIME;    break;
3847                 default:                        break;
3848                 }
3849                 break;
3850             default:
3851                 break;
3852             }
3853             if (ftst) {
3854                 PL_last_lop_op = (OPCODE)ftst;
3855                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3856                         "### Saw file test %c\n", (int)tmp);
3857                 } );
3858                 FTST(ftst);
3859             }
3860             else {
3861                 /* Assume it was a minus followed by a one-letter named
3862                  * subroutine call (or a -bareword), then. */
3863                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3864                         "### '-%c' looked like a file test but was not\n",
3865                         (int) tmp);
3866                 } );
3867                 s = --PL_bufptr;
3868             }
3869         }
3870         {
3871             const char tmp = *s++;
3872             if (*s == tmp) {
3873                 s++;
3874                 if (PL_expect == XOPERATOR)
3875                     TERM(POSTDEC);
3876                 else
3877                     OPERATOR(PREDEC);
3878             }
3879             else if (*s == '>') {
3880                 s++;
3881                 s = SKIPSPACE1(s);
3882                 if (isIDFIRST_lazy_if(s,UTF)) {
3883                     s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3884                     TOKEN(ARROW);
3885                 }
3886                 else if (*s == '$')
3887                     OPERATOR(ARROW);
3888                 else
3889                     TERM(ARROW);
3890             }
3891             if (PL_expect == XOPERATOR)
3892                 Aop(OP_SUBTRACT);
3893             else {
3894                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3895                     check_uni();
3896                 OPERATOR('-');          /* unary minus */
3897             }
3898         }
3899
3900     case '+':
3901         {
3902             const char tmp = *s++;
3903             if (*s == tmp) {
3904                 s++;
3905                 if (PL_expect == XOPERATOR)
3906                     TERM(POSTINC);
3907                 else
3908                     OPERATOR(PREINC);
3909             }
3910             if (PL_expect == XOPERATOR)
3911                 Aop(OP_ADD);
3912             else {
3913                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3914                     check_uni();
3915                 OPERATOR('+');
3916             }
3917         }
3918
3919     case '*':
3920         if (PL_expect != XOPERATOR) {
3921             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3922             PL_expect = XOPERATOR;
3923             force_ident(PL_tokenbuf, '*');
3924             if (!*PL_tokenbuf)
3925                 PREREF('*');
3926             TERM('*');
3927         }
3928         s++;
3929         if (*s == '*') {
3930             s++;
3931             PWop(OP_POW);
3932         }
3933         Mop(OP_MULTIPLY);
3934
3935     case '%':
3936         if (PL_expect == XOPERATOR) {
3937             ++s;
3938             Mop(OP_MODULO);
3939         }
3940         PL_tokenbuf[0] = '%';
3941         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3942         if (!PL_tokenbuf[1]) {
3943             PREREF('%');
3944         }
3945         PL_pending_ident = '%';
3946         TERM('%');
3947
3948     case '^':
3949         s++;
3950         BOop(OP_BIT_XOR);
3951     case '[':
3952         PL_lex_brackets++;
3953         /* FALL THROUGH */
3954     case '~':
3955         if (s[1] == '~'
3956         && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
3957         && FEATURE_IS_ENABLED("~~"))
3958         {
3959             s += 2;
3960             Eop(OP_SMARTMATCH);
3961         }
3962     case ',':
3963         {
3964             const char tmp = *s++;
3965             OPERATOR(tmp);
3966         }
3967     case ':':
3968         if (s[1] == ':') {
3969             len = 0;
3970             goto just_a_word_zero_gv;
3971         }
3972         s++;
3973         switch (PL_expect) {
3974             OP *attrs;
3975 #ifdef PERL_MAD
3976             I32 stuffstart;
3977 #endif
3978         case XOPERATOR:
3979             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3980                 break;
3981             PL_bufptr = s;      /* update in case we back off */
3982             goto grabattrs;
3983         case XATTRBLOCK:
3984             PL_expect = XBLOCK;
3985             goto grabattrs;
3986         case XATTRTERM:
3987             PL_expect = XTERMBLOCK;
3988          grabattrs:
3989 #ifdef PERL_MAD
3990             stuffstart = s - SvPVX(PL_linestr) - 1;
3991 #endif
3992             s = PEEKSPACE(s);
3993             attrs = NULL;
3994             while (isIDFIRST_lazy_if(s,UTF)) {
3995                 I32 tmp;
3996                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3997                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3998                     if (tmp < 0) tmp = -tmp;
3999                     switch (tmp) {
4000                     case KEY_or:
4001                     case KEY_and:
4002                     case KEY_err:
4003                     case KEY_for:
4004                     case KEY_unless:
4005                     case KEY_if:
4006                     case KEY_while:
4007                     case KEY_until:
4008                         goto got_attrs;
4009                     default:
4010                         break;
4011                     }
4012                 }
4013                 if (*d == '(') {
4014                     d = scan_str(d,TRUE,TRUE);
4015                     if (!d) {
4016                         /* MUST advance bufptr here to avoid bogus
4017                            "at end of line" context messages from yyerror().
4018                          */
4019                         PL_bufptr = s + len;
4020                         yyerror("Unterminated attribute parameter in attribute list");
4021                         if (attrs)
4022                             op_free(attrs);
4023                         return REPORT(0);       /* EOF indicator */
4024                     }
4025                 }
4026                 if (PL_lex_stuff) {
4027                     SV *sv = newSVpvn(s, len);
4028                     sv_catsv(sv, PL_lex_stuff);
4029                     attrs = append_elem(OP_LIST, attrs,
4030                                         newSVOP(OP_CONST, 0, sv));
4031                     SvREFCNT_dec(PL_lex_stuff);
4032                     PL_lex_stuff = NULL;
4033                 }
4034                 else {
4035                     if (len == 6 && strnEQ(s, "unique", len)) {
4036                         if (PL_in_my == KEY_our) {
4037 #ifdef USE_ITHREADS
4038                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4039 #else
4040                             /* skip to avoid loading attributes.pm */
4041 #endif
4042                             deprecate(":unique");
4043                         }
4044                         else
4045                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4046                     }
4047
4048                     /* NOTE: any CV attrs applied here need to be part of
4049                        the CVf_BUILTIN_ATTRS define in cv.h! */
4050                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
4051                         CvLVALUE_on(PL_compcv);
4052                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
4053                         CvLOCKED_on(PL_compcv);
4054                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
4055                         CvMETHOD_on(PL_compcv);
4056                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
4057                         CvASSERTION_on(PL_compcv);
4058                     /* After we've set the flags, it could be argued that
4059                        we don't need to do the attributes.pm-based setting
4060                        process, and shouldn't bother appending recognized
4061                        flags.  To experiment with that, uncomment the
4062                        following "else".  (Note that's already been
4063                        uncommented.  That keeps the above-applied built-in
4064                        attributes from being intercepted (and possibly
4065                        rejected) by a package's attribute routines, but is
4066                        justified by the performance win for the common case
4067                        of applying only built-in attributes.) */
4068                     else
4069                         attrs = append_elem(OP_LIST, attrs,
4070                                             newSVOP(OP_CONST, 0,
4071                                                     newSVpvn(s, len)));
4072                 }
4073                 s = PEEKSPACE(d);
4074                 if (*s == ':' && s[1] != ':')
4075                     s = PEEKSPACE(s+1);
4076                 else if (s == d)
4077                     break;      /* require real whitespace or :'s */
4078                 /* XXX losing whitespace on sequential attributes here */
4079             }
4080             {
4081                 const char tmp
4082                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4083                 if (*s != ';' && *s != '}' && *s != tmp
4084                     && (tmp != '=' || *s != ')')) {
4085                     const char q = ((*s == '\'') ? '"' : '\'');
4086                     /* If here for an expression, and parsed no attrs, back
4087                        off. */
4088                     if (tmp == '=' && !attrs) {
4089                         s = PL_bufptr;
4090                         break;
4091                     }
4092                     /* MUST advance bufptr here to avoid bogus "at end of line"
4093                        context messages from yyerror().
4094                     */
4095                     PL_bufptr = s;
4096                     yyerror( *s
4097                              ? Perl_form(aTHX_ "Invalid separator character "
4098                                          "%c%c%c in attribute list", q, *s, q)
4099                              : "Unterminated attribute list" );
4100                     if (attrs)
4101                         op_free(attrs);
4102                     OPERATOR(':');
4103                 }
4104             }
4105         got_attrs:
4106             if (attrs) {
4107                 start_force(PL_curforce);
4108                 NEXTVAL_NEXTTOKE.opval = attrs;
4109                 CURMAD('_', PL_nextwhite);
4110                 force_next(THING);
4111             }
4112 #ifdef PERL_MAD
4113             if (PL_madskills) {
4114                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4115                                      (s - SvPVX(PL_linestr)) - stuffstart);
4116             }
4117 #endif
4118             TOKEN(COLONATTR);
4119         }
4120         OPERATOR(':');
4121     case '(':
4122         s++;
4123         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4124             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4125         else
4126             PL_expect = XTERM;
4127         s = SKIPSPACE1(s);
4128         TOKEN('(');
4129     case ';':
4130         CLINE;
4131         {
4132             const char tmp = *s++;
4133             OPERATOR(tmp);
4134         }
4135     case ')':
4136         {
4137             const char tmp = *s++;
4138             s = SKIPSPACE1(s);
4139             if (*s == '{')
4140                 PREBLOCK(tmp);
4141             TERM(tmp);
4142         }
4143     case ']':
4144         s++;
4145         if (PL_lex_brackets <= 0)
4146             yyerror("Unmatched right square bracket");
4147         else
4148             --PL_lex_brackets;
4149         if (PL_lex_state == LEX_INTERPNORMAL) {
4150             if (PL_lex_brackets == 0) {
4151                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4152                     PL_lex_state = LEX_INTERPEND;
4153             }
4154         }
4155         TERM(']');
4156     case '{':
4157       leftbracket:
4158         s++;
4159         if (PL_lex_brackets > 100) {
4160             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4161         }
4162         switch (PL_expect) {
4163         case XTERM:
4164             if (PL_lex_formbrack) {
4165                 s--;
4166                 PRETERMBLOCK(DO);
4167             }
4168             if (PL_oldoldbufptr == PL_last_lop)
4169                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4170             else
4171                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4172             OPERATOR(HASHBRACK);
4173         case XOPERATOR:
4174             while (s < PL_bufend && SPACE_OR_TAB(*s))
4175                 s++;
4176             d = s;
4177             PL_tokenbuf[0] = '\0';
4178             if (d < PL_bufend && *d == '-') {
4179                 PL_tokenbuf[0] = '-';
4180                 d++;
4181                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4182                     d++;
4183             }
4184             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4185                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4186                               FALSE, &len);
4187                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4188                     d++;
4189                 if (*d == '}') {
4190                     const char minus = (PL_tokenbuf[0] == '-');
4191                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4192                     if (minus)
4193                         force_next('-');
4194                 }
4195             }
4196             /* FALL THROUGH */
4197         case XATTRBLOCK:
4198         case XBLOCK:
4199             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4200             PL_expect = XSTATE;
4201             break;
4202         case XATTRTERM:
4203         case XTERMBLOCK:
4204             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4205             PL_expect = XSTATE;
4206             break;
4207         default: {
4208                 const char *t;
4209                 if (PL_oldoldbufptr == PL_last_lop)
4210                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4211                 else
4212                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4213                 s = SKIPSPACE1(s);
4214                 if (*s == '}') {
4215                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4216                         PL_expect = XTERM;
4217                         /* This hack is to get the ${} in the message. */
4218                         PL_bufptr = s+1;
4219                         yyerror("syntax error");
4220                         break;
4221                     }
4222                     OPERATOR(HASHBRACK);
4223                 }
4224                 /* This hack serves to disambiguate a pair of curlies
4225                  * as being a block or an anon hash.  Normally, expectation
4226                  * determines that, but in cases where we're not in a
4227                  * position to expect anything in particular (like inside
4228                  * eval"") we have to resolve the ambiguity.  This code
4229                  * covers the case where the first term in the curlies is a
4230                  * quoted string.  Most other cases need to be explicitly
4231                  * disambiguated by prepending a "+" before the opening
4232                  * curly in order to force resolution as an anon hash.
4233                  *
4234                  * XXX should probably propagate the outer expectation
4235                  * into eval"" to rely less on this hack, but that could
4236                  * potentially break current behavior of eval"".
4237                  * GSAR 97-07-21
4238                  */
4239                 t = s;
4240                 if (*s == '\'' || *s == '"' || *s == '`') {
4241                     /* common case: get past first string, handling escapes */
4242                     for (t++; t < PL_bufend && *t != *s;)
4243                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
4244                             t++;
4245                     t++;
4246                 }
4247                 else if (*s == 'q') {
4248                     if (++t < PL_bufend
4249                         && (!isALNUM(*t)
4250                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4251                                 && !isALNUM(*t))))
4252                     {
4253                         /* skip q//-like construct */
4254                         const char *tmps;
4255                         char open, close, term;
4256                         I32 brackets = 1;
4257
4258                         while (t < PL_bufend && isSPACE(*t))
4259                             t++;
4260                         /* check for q => */
4261                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4262                             OPERATOR(HASHBRACK);
4263                         }
4264                         term = *t;
4265                         open = term;
4266                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4267                             term = tmps[5];
4268                         close = term;
4269                         if (open == close)
4270                             for (t++; t < PL_bufend; t++) {
4271                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4272                                     t++;
4273                                 else if (*t == open)
4274                                     break;
4275                             }
4276                         else {
4277                             for (t++; t < PL_bufend; t++) {
4278                                 if (*t == '\\' && t+1 < PL_bufend)
4279                                     t++;
4280                                 else if (*t == close && --brackets <= 0)
4281                                     break;
4282                                 else if (*t == open)
4283                                     brackets++;
4284                             }
4285                         }
4286                         t++;
4287                     }
4288                     else
4289                         /* skip plain q word */
4290                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4291                              t += UTF8SKIP(t);
4292                 }
4293                 else if (isALNUM_lazy_if(t,UTF)) {
4294                     t += UTF8SKIP(t);
4295                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4296                          t += UTF8SKIP(t);
4297                 }
4298                 while (t < PL_bufend && isSPACE(*t))
4299                     t++;
4300                 /* if comma follows first term, call it an anon hash */
4301                 /* XXX it could be a comma expression with loop modifiers */
4302                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4303                                    || (*t == '=' && t[1] == '>')))
4304                     OPERATOR(HASHBRACK);
4305                 if (PL_expect == XREF)
4306                     PL_expect = XTERM;
4307                 else {
4308                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4309                     PL_expect = XSTATE;
4310                 }
4311             }
4312             break;
4313         }
4314         yylval.ival = CopLINE(PL_curcop);
4315         if (isSPACE(*s) || *s == '#')
4316             PL_copline = NOLINE;   /* invalidate current command line number */
4317         TOKEN('{');
4318     case '}':
4319       rightbracket:
4320         s++;
4321         if (PL_lex_brackets <= 0)
4322             yyerror("Unmatched right curly bracket");
4323         else
4324             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4325         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4326             PL_lex_formbrack = 0;
4327         if (PL_lex_state == LEX_INTERPNORMAL) {
4328             if (PL_lex_brackets == 0) {
4329                 if (PL_expect & XFAKEBRACK) {
4330                     PL_expect &= XENUMMASK;
4331                     PL_lex_state = LEX_INTERPEND;
4332                     PL_bufptr = s;
4333 #if 0
4334                     if (PL_madskills) {
4335                         if (!PL_thiswhite)
4336                             PL_thiswhite = newSVpvn("",0);
4337                         sv_catpvn(PL_thiswhite,"}",1);
4338                     }
4339 #endif
4340                     return yylex();     /* ignore fake brackets */
4341                 }
4342                 if (*s == '-' && s[1] == '>')
4343                     PL_lex_state = LEX_INTERPENDMAYBE;
4344                 else if (*s != '[' && *s != '{')
4345                     PL_lex_state = LEX_INTERPEND;
4346             }
4347         }
4348         if (PL_expect & XFAKEBRACK) {
4349             PL_expect &= XENUMMASK;
4350             PL_bufptr = s;
4351             return yylex();             /* ignore fake brackets */
4352         }
4353         start_force(PL_curforce);
4354         if (PL_madskills) {
4355             curmad('X', newSVpvn(s-1,1));
4356             CURMAD('_', PL_thiswhite);
4357         }
4358         force_next('}');
4359 #ifdef PERL_MAD
4360         if (!PL_thistoken)
4361             PL_thistoken = newSVpvn("",0);
4362 #endif
4363         TOKEN(';');
4364     case '&':
4365         s++;
4366         if (*s++ == '&')
4367             AOPERATOR(ANDAND);
4368         s--;
4369         if (PL_expect == XOPERATOR) {
4370             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4371                 && isIDFIRST_lazy_if(s,UTF))
4372             {
4373                 CopLINE_dec(PL_curcop);
4374                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4375                 CopLINE_inc(PL_curcop);
4376             }
4377             BAop(OP_BIT_AND);
4378         }
4379