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