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