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