This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
SvPVX_const() - Patch #1
[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_const(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_const(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_const(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_const(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_const(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                         const char *ostart = SvPVX_const(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                         const char *odest = SvPVX_const(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_const(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_const(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_const(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*)u.iop, 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 #ifdef DEBUGGING
2169     u.filter = funcp;
2170     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)u.iop));
2171 #endif
2172     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2173         return;
2174     /* if filter is on top of stack (usual case) just pop it off */
2175     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2176     u.iop = IoANY(datasv);
2177     if (u.filter == funcp) {
2178         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2179         IoANY(datasv) = (void *)NULL;
2180         sv_free(av_pop(PL_rsfp_filters));
2181
2182         return;
2183     }
2184     /* we need to search for the correct entry and clear it     */
2185     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2186 }
2187
2188
2189 /* Invoke the idxth filter function for the current rsfp.        */
2190 /* maxlen 0 = read one text line */
2191 I32
2192 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2193 {
2194     filter_t funcp;
2195     SV *datasv = NULL;
2196     xpvio_filter_u u;
2197
2198     if (!PL_rsfp_filters)
2199         return -1;
2200     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2201         /* Provide a default input filter to make life easy.    */
2202         /* Note that we append to the line. This is handy.      */
2203         DEBUG_P(PerlIO_printf(Perl_debug_log,
2204                               "filter_read %d: from rsfp\n", idx));
2205         if (maxlen) {
2206             /* Want a block */
2207             int len ;
2208             const int old_len = SvCUR(buf_sv);
2209
2210             /* ensure buf_sv is large enough */
2211             SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2212             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2213                 if (PerlIO_error(PL_rsfp))
2214                     return -1;          /* error */
2215                 else
2216                     return 0 ;          /* end of file */
2217             }
2218             SvCUR_set(buf_sv, old_len + len) ;
2219         } else {
2220             /* Want a line */
2221             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2222                 if (PerlIO_error(PL_rsfp))
2223                     return -1;          /* error */
2224                 else
2225                     return 0 ;          /* end of file */
2226             }
2227         }
2228         return SvCUR(buf_sv);
2229     }
2230     /* Skip this filter slot if filter has been deleted */
2231     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2232         DEBUG_P(PerlIO_printf(Perl_debug_log,
2233                               "filter_read %d: skipped (filter deleted)\n",
2234                               idx));
2235         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2236     }
2237     /* Get function pointer hidden within datasv        */
2238     u.iop = IoANY(datasv);
2239     funcp = u.filter;
2240     DEBUG_P(PerlIO_printf(Perl_debug_log,
2241                           "filter_read %d: via function %p (%s)\n",
2242                           idx, (void*)u.iop, SvPV_nolen(datasv)));
2243     /* Call function. The function is expected to       */
2244     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2245     /* Return: <0:error, =0:eof, >0:not eof             */
2246     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2247 }
2248
2249 STATIC char *
2250 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2251 {
2252 #ifdef PERL_CR_FILTER
2253     if (!PL_rsfp_filters) {
2254         filter_add(S_cr_textfilter,NULL);
2255     }
2256 #endif
2257     if (PL_rsfp_filters) {
2258         if (!append)
2259             SvCUR_set(sv, 0);   /* start with empty line        */
2260         if (FILTER_READ(0, sv, 0) > 0)
2261             return ( SvPVX(sv) ) ;
2262         else
2263             return Nullch ;
2264     }
2265     else
2266         return (sv_gets(sv, fp, append));
2267 }
2268
2269 STATIC HV *
2270 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2271 {
2272     GV *gv;
2273
2274     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2275         return PL_curstash;
2276
2277     if (len > 2 &&
2278         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2279         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2280     {
2281         return GvHV(gv);                        /* Foo:: */
2282     }
2283
2284     /* use constant CLASS => 'MyClass' */
2285     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2286         SV *sv;
2287         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2288             pkgname = SvPV_nolen(sv);
2289         }
2290     }
2291
2292     return gv_stashpv(pkgname, FALSE);
2293 }
2294
2295 #ifdef DEBUGGING
2296     static const char* const exp_name[] =
2297         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2298           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2299         };
2300 #endif
2301
2302 /*
2303   yylex
2304
2305   Works out what to call the token just pulled out of the input
2306   stream.  The yacc parser takes care of taking the ops we return and
2307   stitching them into a tree.
2308
2309   Returns:
2310     PRIVATEREF
2311
2312   Structure:
2313       if read an identifier
2314           if we're in a my declaration
2315               croak if they tried to say my($foo::bar)
2316               build the ops for a my() declaration
2317           if it's an access to a my() variable
2318               are we in a sort block?
2319                   croak if my($a); $a <=> $b
2320               build ops for access to a my() variable
2321           if in a dq string, and they've said @foo and we can't find @foo
2322               croak
2323           build ops for a bareword
2324       if we already built the token before, use it.
2325 */
2326
2327
2328 #ifdef __SC__
2329 #pragma segment Perl_yylex
2330 #endif
2331 int
2332 Perl_yylex(pTHX)
2333 {
2334     register char *s = PL_bufptr;
2335     register char *d;
2336     register I32 tmp;
2337     STRLEN len;
2338     GV *gv = Nullgv;
2339     GV **gvp = 0;
2340     bool bof = FALSE;
2341     I32 orig_keyword = 0;
2342
2343     DEBUG_T( {
2344         PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2345                                         lex_state_names[PL_lex_state]);
2346     } );
2347     /* check if there's an identifier for us to look at */
2348     if (PL_pending_ident)
2349         return REPORT(S_pending_ident(aTHX));
2350
2351     /* no identifier pending identification */
2352
2353     switch (PL_lex_state) {
2354 #ifdef COMMENTARY
2355     case LEX_NORMAL:            /* Some compilers will produce faster */
2356     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2357         break;
2358 #endif
2359
2360     /* when we've already built the next token, just pull it out of the queue */
2361     case LEX_KNOWNEXT:
2362         PL_nexttoke--;
2363         yylval = PL_nextval[PL_nexttoke];
2364         if (!PL_nexttoke) {
2365             PL_lex_state = PL_lex_defer;
2366             PL_expect = PL_lex_expect;
2367             PL_lex_defer = LEX_NORMAL;
2368         }
2369         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2370               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2371               (IV)PL_nexttype[PL_nexttoke]); });
2372
2373         return REPORT(PL_nexttype[PL_nexttoke]);
2374
2375     /* interpolated case modifiers like \L \U, including \Q and \E.
2376        when we get here, PL_bufptr is at the \
2377     */
2378     case LEX_INTERPCASEMOD:
2379 #ifdef DEBUGGING
2380         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2381             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2382 #endif
2383         /* handle \E or end of string */
2384         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2385             /* if at a \E */
2386             if (PL_lex_casemods) {
2387                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
2388                 PL_lex_casestack[PL_lex_casemods] = '\0';
2389
2390                 if (PL_bufptr != PL_bufend
2391                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2392                     PL_bufptr += 2;
2393                     PL_lex_state = LEX_INTERPCONCAT;
2394                 }
2395                 return REPORT(')');
2396             }
2397             if (PL_bufptr != PL_bufend)
2398                 PL_bufptr += 2;
2399             PL_lex_state = LEX_INTERPCONCAT;
2400             return yylex();
2401         }
2402         else {
2403             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2404               "### Saw case modifier at '%s'\n", PL_bufptr); });
2405             s = PL_bufptr + 1;
2406             if (s[1] == '\\' && s[2] == 'E') {
2407                 PL_bufptr = s + 3;
2408                 PL_lex_state = LEX_INTERPCONCAT;
2409                 return yylex();
2410             }
2411             else {
2412                 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2413                     tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
2414                 if ((*s == 'L' || *s == 'U') &&
2415                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2416                     PL_lex_casestack[--PL_lex_casemods] = '\0';
2417                     return REPORT(')');
2418                 }
2419                 if (PL_lex_casemods > 10)
2420                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2421                 PL_lex_casestack[PL_lex_casemods++] = *s;
2422                 PL_lex_casestack[PL_lex_casemods] = '\0';
2423                 PL_lex_state = LEX_INTERPCONCAT;
2424                 PL_nextval[PL_nexttoke].ival = 0;
2425                 force_next('(');
2426                 if (*s == 'l')
2427                     PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2428                 else if (*s == 'u')
2429                     PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2430                 else if (*s == 'L')
2431                     PL_nextval[PL_nexttoke].ival = OP_LC;
2432                 else if (*s == 'U')
2433                     PL_nextval[PL_nexttoke].ival = OP_UC;
2434                 else if (*s == 'Q')
2435                     PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2436                 else
2437                     Perl_croak(aTHX_ "panic: yylex");
2438                 PL_bufptr = s + 1;
2439             }
2440             force_next(FUNC);
2441             if (PL_lex_starts) {
2442                 s = PL_bufptr;
2443                 PL_lex_starts = 0;
2444                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2445                 if (PL_lex_casemods == 1 && PL_lex_inpat)
2446                     OPERATOR(',');
2447                 else
2448                     Aop(OP_CONCAT);
2449             }
2450             else
2451                 return yylex();
2452         }
2453
2454     case LEX_INTERPPUSH:
2455         return REPORT(sublex_push());
2456
2457     case LEX_INTERPSTART:
2458         if (PL_bufptr == PL_bufend)
2459             return REPORT(sublex_done());
2460         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2461               "### Interpolated variable at '%s'\n", PL_bufptr); });
2462         PL_expect = XTERM;
2463         PL_lex_dojoin = (*PL_bufptr == '@');
2464         PL_lex_state = LEX_INTERPNORMAL;
2465         if (PL_lex_dojoin) {
2466             PL_nextval[PL_nexttoke].ival = 0;
2467             force_next(',');
2468             force_ident("\"", '$');
2469             PL_nextval[PL_nexttoke].ival = 0;
2470             force_next('$');
2471             PL_nextval[PL_nexttoke].ival = 0;
2472             force_next('(');
2473             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2474             force_next(FUNC);
2475         }
2476         if (PL_lex_starts++) {
2477             s = PL_bufptr;
2478             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2479             if (!PL_lex_casemods && PL_lex_inpat)
2480                 OPERATOR(',');
2481             else
2482                 Aop(OP_CONCAT);
2483         }
2484         return yylex();
2485
2486     case LEX_INTERPENDMAYBE:
2487         if (intuit_more(PL_bufptr)) {
2488             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2489             break;
2490         }
2491         /* FALL THROUGH */
2492
2493     case LEX_INTERPEND:
2494         if (PL_lex_dojoin) {
2495             PL_lex_dojoin = FALSE;
2496             PL_lex_state = LEX_INTERPCONCAT;
2497             return REPORT(')');
2498         }
2499         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2500             && SvEVALED(PL_lex_repl))
2501         {
2502             if (PL_bufptr != PL_bufend)
2503                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2504             PL_lex_repl = Nullsv;
2505         }
2506         /* FALLTHROUGH */
2507     case LEX_INTERPCONCAT:
2508 #ifdef DEBUGGING
2509         if (PL_lex_brackets)
2510             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2511 #endif
2512         if (PL_bufptr == PL_bufend)
2513             return REPORT(sublex_done());
2514
2515         if (SvIVX(PL_linestr) == '\'') {
2516             SV *sv = newSVsv(PL_linestr);
2517             if (!PL_lex_inpat)
2518                 sv = tokeq(sv);
2519             else if ( PL_hints & HINT_NEW_RE )
2520                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2521             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2522             s = PL_bufend;
2523         }
2524         else {
2525             s = scan_const(PL_bufptr);
2526             if (*s == '\\')
2527                 PL_lex_state = LEX_INTERPCASEMOD;
2528             else
2529                 PL_lex_state = LEX_INTERPSTART;
2530         }
2531
2532         if (s != PL_bufptr) {
2533             PL_nextval[PL_nexttoke] = yylval;
2534             PL_expect = XTERM;
2535             force_next(THING);
2536             if (PL_lex_starts++) {
2537                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2538                 if (!PL_lex_casemods && PL_lex_inpat)
2539                     OPERATOR(',');
2540                 else
2541                     Aop(OP_CONCAT);
2542             }
2543             else {
2544                 PL_bufptr = s;
2545                 return yylex();
2546             }
2547         }
2548
2549         return yylex();
2550     case LEX_FORMLINE:
2551         PL_lex_state = LEX_NORMAL;
2552         s = scan_formline(PL_bufptr);
2553         if (!PL_lex_formbrack)
2554             goto rightbracket;
2555         OPERATOR(';');
2556     }
2557
2558     s = PL_bufptr;
2559     PL_oldoldbufptr = PL_oldbufptr;
2560     PL_oldbufptr = s;
2561     DEBUG_T( {
2562         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2563                       exp_name[PL_expect], s);
2564     } );
2565
2566   retry:
2567     switch (*s) {
2568     default:
2569         if (isIDFIRST_lazy_if(s,UTF))
2570             goto keylookup;
2571         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2572     case 4:
2573     case 26:
2574         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2575     case 0:
2576         if (!PL_rsfp) {
2577             PL_last_uni = 0;
2578             PL_last_lop = 0;
2579             if (PL_lex_brackets) {
2580                 if (PL_lex_formbrack)
2581                     yyerror("Format not terminated");
2582                 else
2583                     yyerror("Missing right curly or square bracket");
2584             }
2585             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2586                         "### Tokener got EOF\n");
2587             } );
2588             TOKEN(0);
2589         }
2590         if (s++ < PL_bufend)
2591             goto retry;                 /* ignore stray nulls */
2592         PL_last_uni = 0;
2593         PL_last_lop = 0;
2594         if (!PL_in_eval && !PL_preambled) {
2595             PL_preambled = TRUE;
2596             sv_setpv(PL_linestr,incl_perldb());
2597             if (SvCUR(PL_linestr))
2598                 sv_catpvn(PL_linestr,";", 1);
2599             if (PL_preambleav){
2600                 while(AvFILLp(PL_preambleav) >= 0) {
2601                     SV *tmpsv = av_shift(PL_preambleav);
2602                     sv_catsv(PL_linestr, tmpsv);
2603                     sv_catpvn(PL_linestr, ";", 1);
2604                     sv_free(tmpsv);
2605                 }
2606                 sv_free((SV*)PL_preambleav);
2607                 PL_preambleav = NULL;
2608             }
2609             if (PL_minus_n || PL_minus_p) {
2610                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2611                 if (PL_minus_l)
2612                     sv_catpv(PL_linestr,"chomp;");
2613                 if (PL_minus_a) {
2614                     if (PL_minus_F) {
2615                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2616                              || *PL_splitstr == '"')
2617                               && strchr(PL_splitstr + 1, *PL_splitstr))
2618                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2619                         else {
2620                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2621                                bytes can be used as quoting characters.  :-) */
2622                             /* The count here deliberately includes the NUL
2623                                that terminates the C string constant.  This
2624                                embeds the opening NUL into the string.  */
2625                             const char *splits = PL_splitstr;
2626                             sv_catpvn(PL_linestr, "our @F=split(q", 15);
2627                             do {
2628                                 /* Need to \ \s  */
2629                                 if (*splits == '\\')
2630                                     sv_catpvn(PL_linestr, splits, 1);
2631                                 sv_catpvn(PL_linestr, splits, 1);
2632                             } while (*splits++);
2633                             /* This loop will embed the trailing NUL of
2634                                PL_linestr as the last thing it does before
2635                                terminating.  */
2636                             sv_catpvn(PL_linestr, ");", 2);
2637                         }
2638                     }
2639                     else
2640                         sv_catpv(PL_linestr,"our @F=split(' ');");
2641                 }
2642             }
2643             sv_catpvn(PL_linestr, "\n", 1);
2644             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2645             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2646             PL_last_lop = PL_last_uni = Nullch;
2647             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2648                 SV *sv = NEWSV(85,0);
2649
2650                 sv_upgrade(sv, SVt_PVMG);
2651                 sv_setsv(sv,PL_linestr);
2652                 (void)SvIOK_on(sv);
2653                 SvIV_set(sv, 0);
2654                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2655             }
2656             goto retry;
2657         }
2658         do {
2659             bof = PL_rsfp ? TRUE : FALSE;
2660             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2661               fake_eof:
2662                 if (PL_rsfp) {
2663                     if (PL_preprocess && !PL_in_eval)
2664                         (void)PerlProc_pclose(PL_rsfp);
2665                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2666                         PerlIO_clearerr(PL_rsfp);
2667                     else
2668                         (void)PerlIO_close(PL_rsfp);
2669                     PL_rsfp = Nullfp;
2670                     PL_doextract = FALSE;
2671                 }
2672                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2673                     sv_setpv(PL_linestr,PL_minus_p
2674                              ? ";}continue{print;}" : ";}");
2675                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2676                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2677                     PL_last_lop = PL_last_uni = Nullch;
2678                     PL_minus_n = PL_minus_p = 0;
2679                     goto retry;
2680                 }
2681                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2682                 PL_last_lop = PL_last_uni = Nullch;
2683                 sv_setpvn(PL_linestr,"",0);
2684                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2685             }
2686             /* If it looks like the start of a BOM or raw UTF-16,
2687              * check if it in fact is. */
2688             else if (bof &&
2689                      (*s == 0 ||
2690                       *(U8*)s == 0xEF ||
2691                       *(U8*)s >= 0xFE ||
2692                       s[1] == 0)) {
2693 #ifdef PERLIO_IS_STDIO
2694 #  ifdef __GNU_LIBRARY__
2695 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2696 #      define FTELL_FOR_PIPE_IS_BROKEN
2697 #    endif
2698 #  else
2699 #    ifdef __GLIBC__
2700 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2701 #        define FTELL_FOR_PIPE_IS_BROKEN
2702 #      endif
2703 #    endif
2704 #  endif
2705 #endif
2706 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2707                 /* This loses the possibility to detect the bof
2708                  * situation on perl -P when the libc5 is being used.
2709                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2710                  */
2711                 if (!PL_preprocess)
2712                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2713 #else
2714                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2715 #endif
2716                 if (bof) {
2717                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2718                     s = swallow_bom((U8*)s);
2719                 }
2720             }
2721             if (PL_doextract) {
2722                 /* Incest with pod. */
2723                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2724                     sv_setpvn(PL_linestr, "", 0);
2725                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2726                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2727                     PL_last_lop = PL_last_uni = Nullch;
2728                     PL_doextract = FALSE;
2729                 }
2730             }
2731             incline(s);
2732         } while (PL_doextract);
2733         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2734         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2735             SV *sv = NEWSV(85,0);
2736
2737             sv_upgrade(sv, SVt_PVMG);
2738             sv_setsv(sv,PL_linestr);
2739             (void)SvIOK_on(sv);
2740             SvIV_set(sv, 0);
2741             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2742         }
2743         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2744         PL_last_lop = PL_last_uni = Nullch;
2745         if (CopLINE(PL_curcop) == 1) {
2746             while (s < PL_bufend && isSPACE(*s))
2747                 s++;
2748             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2749                 s++;
2750             d = Nullch;
2751             if (!PL_in_eval) {
2752                 if (*s == '#' && *(s+1) == '!')
2753                     d = s + 2;
2754 #ifdef ALTERNATE_SHEBANG
2755                 else {
2756                     static char const as[] = ALTERNATE_SHEBANG;
2757                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2758                         d = s + (sizeof(as) - 1);
2759                 }
2760 #endif /* ALTERNATE_SHEBANG */
2761             }
2762             if (d) {
2763                 char *ipath;
2764                 char *ipathend;
2765
2766                 while (isSPACE(*d))
2767                     d++;
2768                 ipath = d;
2769                 while (*d && !isSPACE(*d))
2770                     d++;
2771                 ipathend = d;
2772
2773 #ifdef ARG_ZERO_IS_SCRIPT
2774                 if (ipathend > ipath) {
2775                     /*
2776                      * HP-UX (at least) sets argv[0] to the script name,
2777                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2778                      * at least, set argv[0] to the basename of the Perl
2779                      * interpreter. So, having found "#!", we'll set it right.
2780                      */
2781                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2782                     assert(SvPOK(x) || SvGMAGICAL(x));
2783                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2784                         sv_setpvn(x, ipath, ipathend - ipath);
2785                         SvSETMAGIC(x);
2786                     }
2787                     else {
2788                         STRLEN blen;
2789                         STRLEN llen;
2790                         const char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2791                         const char *lstart = SvPV(x,llen);
2792                         if (llen < blen) {
2793                             bstart += blen - llen;
2794                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2795                                 sv_setpvn(x, ipath, ipathend - ipath);
2796                                 SvSETMAGIC(x);
2797                             }
2798                         }
2799                     }
2800                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2801                 }
2802 #endif /* ARG_ZERO_IS_SCRIPT */
2803
2804                 /*
2805                  * Look for options.
2806                  */
2807                 d = instr(s,"perl -");
2808                 if (!d) {
2809                     d = instr(s,"perl");
2810 #if defined(DOSISH)
2811                     /* avoid getting into infinite loops when shebang
2812                      * line contains "Perl" rather than "perl" */
2813                     if (!d) {
2814                         for (d = ipathend-4; d >= ipath; --d) {
2815                             if ((*d == 'p' || *d == 'P')
2816                                 && !ibcmp(d, "perl", 4))
2817                             {
2818                                 break;
2819                             }
2820                         }
2821                         if (d < ipath)
2822                             d = Nullch;
2823                     }
2824 #endif
2825                 }
2826 #ifdef ALTERNATE_SHEBANG
2827                 /*
2828                  * If the ALTERNATE_SHEBANG on this system starts with a
2829                  * character that can be part of a Perl expression, then if
2830                  * we see it but not "perl", we're probably looking at the
2831                  * start of Perl code, not a request to hand off to some
2832                  * other interpreter.  Similarly, if "perl" is there, but
2833                  * not in the first 'word' of the line, we assume the line
2834                  * contains the start of the Perl program.
2835                  */
2836                 if (d && *s != '#') {
2837                     const char *c = ipath;
2838                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2839                         c++;
2840                     if (c < d)
2841                         d = Nullch;     /* "perl" not in first word; ignore */
2842                     else
2843                         *s = '#';       /* Don't try to parse shebang line */
2844                 }
2845 #endif /* ALTERNATE_SHEBANG */
2846 #ifndef MACOS_TRADITIONAL
2847                 if (!d &&
2848                     *s == '#' &&
2849                     ipathend > ipath &&
2850                     !PL_minus_c &&
2851                     !instr(s,"indir") &&
2852                     instr(PL_origargv[0],"perl"))
2853                 {
2854                     dVAR;
2855                     char **newargv;
2856
2857                     *ipathend = '\0';
2858                     s = ipathend + 1;
2859                     while (s < PL_bufend && isSPACE(*s))
2860                         s++;
2861                     if (s < PL_bufend) {
2862                         Newz(899,newargv,PL_origargc+3,char*);
2863                         newargv[1] = s;
2864                         while (s < PL_bufend && !isSPACE(*s))
2865                             s++;
2866                         *s = '\0';
2867                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2868                     }
2869                     else
2870                         newargv = PL_origargv;
2871                     newargv[0] = ipath;
2872                     PERL_FPU_PRE_EXEC
2873                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2874                     PERL_FPU_POST_EXEC
2875                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2876                 }
2877 #endif
2878                 if (d) {
2879                     const U32 oldpdb = PL_perldb;
2880                     const bool oldn = PL_minus_n;
2881                     const bool oldp = PL_minus_p;
2882
2883                     while (*d && !isSPACE(*d)) d++;
2884                     while (SPACE_OR_TAB(*d)) d++;
2885
2886                     if (*d++ == '-') {
2887                         const bool switches_done = PL_doswitches;
2888                         do {
2889                             if (*d == 'M' || *d == 'm' || *d == 'C') {
2890                                 const char *m = d;
2891                                 while (*d && !isSPACE(*d)) d++;
2892                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2893                                       (int)(d - m), m);
2894                             }
2895                             d = moreswitches(d);
2896                         } while (d);
2897                         if (PL_doswitches && !switches_done) {
2898                             int argc = PL_origargc;
2899                             char **argv = PL_origargv;
2900                             do {
2901                                 argc--,argv++;
2902                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2903                             init_argv_symbols(argc,argv);
2904                         }
2905                         if ((PERLDB_LINE && !oldpdb) ||
2906                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2907                               /* if we have already added "LINE: while (<>) {",
2908                                  we must not do it again */
2909                         {
2910                             sv_setpvn(PL_linestr, "", 0);
2911                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2912                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2913                             PL_last_lop = PL_last_uni = Nullch;
2914                             PL_preambled = FALSE;
2915                             if (PERLDB_LINE)
2916                                 (void)gv_fetchfile(PL_origfilename);
2917                             goto retry;
2918                         }
2919                         if (PL_doswitches && !switches_done) {
2920                             int argc = PL_origargc;
2921                             char **argv = PL_origargv;
2922                             do {
2923                                 argc--,argv++;
2924                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2925                             init_argv_symbols(argc,argv);
2926                         }
2927                     }
2928                 }
2929             }
2930         }
2931         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2932             PL_bufptr = s;
2933             PL_lex_state = LEX_FORMLINE;
2934             return yylex();
2935         }
2936         goto retry;
2937     case '\r':
2938 #ifdef PERL_STRICT_CR
2939         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2940         Perl_croak(aTHX_
2941       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2942 #endif
2943     case ' ': case '\t': case '\f': case 013:
2944 #ifdef MACOS_TRADITIONAL
2945     case '\312':
2946 #endif
2947         s++;
2948         goto retry;
2949     case '#':
2950     case '\n':
2951         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2952             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2953                 /* handle eval qq[#line 1 "foo"\n ...] */
2954                 CopLINE_dec(PL_curcop);
2955                 incline(s);
2956             }
2957             d = PL_bufend;
2958             while (s < d && *s != '\n')
2959                 s++;
2960             if (s < d)
2961                 s++;
2962             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2963               Perl_croak(aTHX_ "panic: input overflow");
2964             incline(s);
2965             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2966                 PL_bufptr = s;
2967                 PL_lex_state = LEX_FORMLINE;
2968                 return yylex();
2969             }
2970         }
2971         else {
2972             *s = '\0';
2973             PL_bufend = s;
2974         }
2975         goto retry;
2976     case '-':
2977         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2978             I32 ftst = 0;
2979
2980             s++;
2981             PL_bufptr = s;
2982             tmp = *s++;
2983
2984             while (s < PL_bufend && SPACE_OR_TAB(*s))
2985                 s++;
2986
2987             if (strnEQ(s,"=>",2)) {
2988                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2989                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2990                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2991                 } );
2992                 OPERATOR('-');          /* unary minus */
2993             }
2994             PL_last_uni = PL_oldbufptr;
2995             switch (tmp) {
2996             case 'r': ftst = OP_FTEREAD;        break;
2997             case 'w': ftst = OP_FTEWRITE;       break;
2998             case 'x': ftst = OP_FTEEXEC;        break;
2999             case 'o': ftst = OP_FTEOWNED;       break;
3000             case 'R': ftst = OP_FTRREAD;        break;
3001             case 'W': ftst = OP_FTRWRITE;       break;
3002             case 'X': ftst = OP_FTREXEC;        break;
3003             case 'O': ftst = OP_FTROWNED;       break;
3004             case 'e': ftst = OP_FTIS;           break;
3005             case 'z': ftst = OP_FTZERO;         break;
3006             case 's': ftst = OP_FTSIZE;         break;
3007             case 'f': ftst = OP_FTFILE;         break;
3008             case 'd': ftst = OP_FTDIR;          break;
3009             case 'l': ftst = OP_FTLINK;         break;
3010             case 'p': ftst = OP_FTPIPE;         break;
3011             case 'S': ftst = OP_FTSOCK;         break;
3012             case 'u': ftst = OP_FTSUID;         break;
3013             case 'g': ftst = OP_FTSGID;         break;
3014             case 'k': ftst = OP_FTSVTX;         break;
3015             case 'b': ftst = OP_FTBLK;          break;
3016             case 'c': ftst = OP_FTCHR;          break;
3017             case 't': ftst = OP_FTTTY;          break;
3018             case 'T': ftst = OP_FTTEXT;         break;
3019             case 'B': ftst = OP_FTBINARY;       break;
3020             case 'M': case 'A': case 'C':
3021                 gv_fetchpv("\024",TRUE, SVt_PV);
3022                 switch (tmp) {
3023                 case 'M': ftst = OP_FTMTIME;    break;
3024                 case 'A': ftst = OP_FTATIME;    break;
3025                 case 'C': ftst = OP_FTCTIME;    break;
3026                 default:                        break;
3027                 }
3028                 break;
3029             default:
3030                 break;
3031             }
3032             if (ftst) {
3033                 PL_last_lop_op = (OPCODE)ftst;
3034                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3035                         "### Saw file test %c\n", (int)ftst);
3036                 } );
3037                 FTST(ftst);
3038             }
3039             else {
3040                 /* Assume it was a minus followed by a one-letter named
3041                  * subroutine call (or a -bareword), then. */
3042                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3043                         "### '-%c' looked like a file test but was not\n",
3044                         (int) tmp);
3045                 } );
3046                 s = --PL_bufptr;
3047             }
3048         }
3049         tmp = *s++;
3050         if (*s == tmp) {
3051             s++;
3052             if (PL_expect == XOPERATOR)
3053                 TERM(POSTDEC);
3054             else
3055                 OPERATOR(PREDEC);
3056         }
3057         else if (*s == '>') {
3058             s++;
3059             s = skipspace(s);
3060             if (isIDFIRST_lazy_if(s,UTF)) {
3061                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3062                 TOKEN(ARROW);
3063             }
3064             else if (*s == '$')
3065                 OPERATOR(ARROW);
3066             else
3067                 TERM(ARROW);
3068         }
3069         if (PL_expect == XOPERATOR)
3070             Aop(OP_SUBTRACT);
3071         else {
3072             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3073                 check_uni();
3074             OPERATOR('-');              /* unary minus */
3075         }
3076
3077     case '+':
3078         tmp = *s++;
3079         if (*s == tmp) {
3080             s++;
3081             if (PL_expect == XOPERATOR)
3082                 TERM(POSTINC);
3083             else
3084                 OPERATOR(PREINC);
3085         }
3086         if (PL_expect == XOPERATOR)
3087             Aop(OP_ADD);
3088         else {
3089             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3090                 check_uni();
3091             OPERATOR('+');
3092         }
3093
3094     case '*':
3095         if (PL_expect != XOPERATOR) {
3096             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3097             PL_expect = XOPERATOR;
3098             force_ident(PL_tokenbuf, '*');
3099             if (!*PL_tokenbuf)
3100                 PREREF('*');
3101             TERM('*');
3102         }
3103         s++;
3104         if (*s == '*') {
3105             s++;
3106             PWop(OP_POW);
3107         }
3108         Mop(OP_MULTIPLY);
3109
3110     case '%':
3111         if (PL_expect == XOPERATOR) {
3112             ++s;
3113             Mop(OP_MODULO);
3114         }
3115         PL_tokenbuf[0] = '%';
3116         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3117         if (!PL_tokenbuf[1]) {
3118             PREREF('%');
3119         }
3120         PL_pending_ident = '%';
3121         TERM('%');
3122
3123     case '^':
3124         s++;
3125         BOop(OP_BIT_XOR);
3126     case '[':
3127         PL_lex_brackets++;
3128         /* FALL THROUGH */
3129     case '~':
3130     case ',':
3131         tmp = *s++;
3132         OPERATOR(tmp);
3133     case ':':
3134         if (s[1] == ':') {
3135             len = 0;
3136             goto just_a_word;
3137         }
3138         s++;
3139         switch (PL_expect) {
3140             OP *attrs;
3141         case XOPERATOR:
3142             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3143                 break;
3144             PL_bufptr = s;      /* update in case we back off */
3145             goto grabattrs;
3146         case XATTRBLOCK:
3147             PL_expect = XBLOCK;
3148             goto grabattrs;
3149         case XATTRTERM:
3150             PL_expect = XTERMBLOCK;
3151          grabattrs:
3152             s = skipspace(s);
3153             attrs = Nullop;
3154             while (isIDFIRST_lazy_if(s,UTF)) {
3155                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3156                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3157                     if (tmp < 0) tmp = -tmp;
3158                     switch (tmp) {
3159                     case KEY_or:
3160                     case KEY_and:
3161                     case KEY_err:
3162                     case KEY_for:
3163                     case KEY_unless:
3164                     case KEY_if:
3165                     case KEY_while:
3166                     case KEY_until:
3167                         goto got_attrs;
3168                     default:
3169                         break;
3170                     }
3171                 }
3172                 if (*d == '(') {
3173                     d = scan_str(d,TRUE,TRUE);
3174                     if (!d) {
3175                         /* MUST advance bufptr here to avoid bogus
3176                            "at end of line" context messages from yyerror().
3177                          */
3178                         PL_bufptr = s + len;
3179                         yyerror("Unterminated attribute parameter in attribute list");
3180                         if (attrs)
3181                             op_free(attrs);
3182                         return REPORT(0);       /* EOF indicator */
3183                     }
3184                 }
3185                 if (PL_lex_stuff) {
3186                     SV *sv = newSVpvn(s, len);
3187                     sv_catsv(sv, PL_lex_stuff);
3188                     attrs = append_elem(OP_LIST, attrs,
3189                                         newSVOP(OP_CONST, 0, sv));
3190                     SvREFCNT_dec(PL_lex_stuff);
3191                     PL_lex_stuff = Nullsv;
3192                 }
3193                 else {
3194                     if (len == 6 && strnEQ(s, "unique", len)) {
3195                         if (PL_in_my == KEY_our)
3196 #ifdef USE_ITHREADS
3197                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3198 #else
3199                             ; /* skip to avoid loading attributes.pm */
3200 #endif
3201                         else
3202                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3203                     }
3204
3205                     /* NOTE: any CV attrs applied here need to be part of
3206                        the CVf_BUILTIN_ATTRS define in cv.h! */
3207                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3208                         CvLVALUE_on(PL_compcv);
3209                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3210                         CvLOCKED_on(PL_compcv);
3211                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3212                         CvMETHOD_on(PL_compcv);
3213                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3214                         CvASSERTION_on(PL_compcv);
3215                     /* After we've set the flags, it could be argued that
3216                        we don't need to do the attributes.pm-based setting
3217                        process, and shouldn't bother appending recognized
3218                        flags.  To experiment with that, uncomment the
3219                        following "else".  (Note that's already been
3220                        uncommented.  That keeps the above-applied built-in
3221                        attributes from being intercepted (and possibly
3222                        rejected) by a package's attribute routines, but is
3223                        justified by the performance win for the common case
3224                        of applying only built-in attributes.) */
3225                     else
3226                         attrs = append_elem(OP_LIST, attrs,
3227                                             newSVOP(OP_CONST, 0,
3228                                                     newSVpvn(s, len)));
3229                 }
3230                 s = skipspace(d);
3231                 if (*s == ':' && s[1] != ':')
3232                     s = skipspace(s+1);
3233                 else if (s == d)
3234                     break;      /* require real whitespace or :'s */
3235             }
3236             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3237             if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3238                 const char q = ((*s == '\'') ? '"' : '\'');
3239                 /* If here for an expression, and parsed no attrs, back off. */
3240                 if (tmp == '=' && !attrs) {
3241                     s = PL_bufptr;
3242                     break;
3243                 }
3244                 /* MUST advance bufptr here to avoid bogus "at end of line"
3245                    context messages from yyerror().
3246                  */
3247                 PL_bufptr = s;
3248                 if (!*s)
3249                     yyerror("Unterminated attribute list");
3250                 else
3251                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3252                                       q, *s, q));
3253                 if (attrs)
3254                     op_free(attrs);
3255                 OPERATOR(':');
3256             }
3257         got_attrs:
3258             if (attrs) {
3259                 PL_nextval[PL_nexttoke].opval = attrs;
3260                 force_next(THING);
3261             }
3262             TOKEN(COLONATTR);
3263         }
3264         OPERATOR(':');
3265     case '(':
3266         s++;
3267         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3268             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3269         else
3270             PL_expect = XTERM;
3271         s = skipspace(s);
3272         TOKEN('(');
3273     case ';':
3274         CLINE;
3275         tmp = *s++;
3276         OPERATOR(tmp);
3277     case ')':
3278         tmp = *s++;
3279         s = skipspace(s);
3280         if (*s == '{')
3281             PREBLOCK(tmp);
3282         TERM(tmp);
3283     case ']':
3284         s++;
3285         if (PL_lex_brackets <= 0)
3286             yyerror("Unmatched right square bracket");
3287         else
3288             --PL_lex_brackets;
3289         if (PL_lex_state == LEX_INTERPNORMAL) {
3290             if (PL_lex_brackets == 0) {
3291                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3292                     PL_lex_state = LEX_INTERPEND;
3293             }
3294         }
3295         TERM(']');
3296     case '{':
3297       leftbracket:
3298         s++;
3299         if (PL_lex_brackets > 100) {
3300             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3301         }
3302         switch (PL_expect) {
3303         case XTERM:
3304             if (PL_lex_formbrack) {
3305                 s--;
3306                 PRETERMBLOCK(DO);
3307             }
3308             if (PL_oldoldbufptr == PL_last_lop)
3309                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3310             else
3311                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3312             OPERATOR(HASHBRACK);
3313         case XOPERATOR:
3314             while (s < PL_bufend && SPACE_OR_TAB(*s))
3315                 s++;
3316             d = s;
3317             PL_tokenbuf[0] = '\0';
3318             if (d < PL_bufend && *d == '-') {
3319                 PL_tokenbuf[0] = '-';
3320                 d++;
3321                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3322                     d++;
3323             }
3324             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3325                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3326                               FALSE, &len);
3327                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3328                     d++;
3329                 if (*d == '}') {
3330                     const char minus = (PL_tokenbuf[0] == '-');
3331                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3332                     if (minus)
3333                         force_next('-');
3334                 }
3335             }
3336             /* FALL THROUGH */
3337         case XATTRBLOCK:
3338         case XBLOCK:
3339             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3340             PL_expect = XSTATE;
3341             break;
3342         case XATTRTERM:
3343         case XTERMBLOCK:
3344             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3345             PL_expect = XSTATE;
3346             break;
3347         default: {
3348                 const char *t;
3349                 if (PL_oldoldbufptr == PL_last_lop)
3350                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3351                 else
3352                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3353                 s = skipspace(s);
3354                 if (*s == '}') {
3355                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3356                         PL_expect = XTERM;
3357                         /* This hack is to get the ${} in the message. */
3358                         PL_bufptr = s+1;
3359                         yyerror("syntax error");
3360                         break;
3361                     }
3362                     OPERATOR(HASHBRACK);
3363                 }
3364                 /* This hack serves to disambiguate a pair of curlies
3365                  * as being a block or an anon hash.  Normally, expectation
3366                  * determines that, but in cases where we're not in a
3367                  * position to expect anything in particular (like inside
3368                  * eval"") we have to resolve the ambiguity.  This code
3369                  * covers the case where the first term in the curlies is a
3370                  * quoted string.  Most other cases need to be explicitly
3371                  * disambiguated by prepending a `+' before the opening
3372                  * curly in order to force resolution as an anon hash.
3373                  *
3374                  * XXX should probably propagate the outer expectation
3375                  * into eval"" to rely less on this hack, but that could
3376                  * potentially break current behavior of eval"".
3377                  * GSAR 97-07-21
3378                  */
3379                 t = s;
3380                 if (*s == '\'' || *s == '"' || *s == '`') {
3381                     /* common case: get past first string, handling escapes */
3382                     for (t++; t < PL_bufend && *t != *s;)
3383                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3384                             t++;
3385                     t++;
3386                 }
3387                 else if (*s == 'q') {
3388                     if (++t < PL_bufend
3389                         && (!isALNUM(*t)
3390                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3391                                 && !isALNUM(*t))))
3392                     {
3393                         /* skip q//-like construct */
3394                         const char *tmps;
3395                         char open, close, term;
3396                         I32 brackets = 1;
3397
3398                         while (t < PL_bufend && isSPACE(*t))
3399                             t++;
3400                         /* check for q => */
3401                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3402                             OPERATOR(HASHBRACK);
3403                         }
3404                         term = *t;
3405                         open = term;
3406                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3407                             term = tmps[5];
3408                         close = term;
3409                         if (open == close)
3410                             for (t++; t < PL_bufend; t++) {
3411                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3412                                     t++;
3413                                 else if (*t == open)
3414                                     break;
3415                             }
3416                         else {
3417                             for (t++; t < PL_bufend; t++) {
3418                                 if (*t == '\\' && t+1 < PL_bufend)
3419                                     t++;
3420                                 else if (*t == close && --brackets <= 0)
3421                                     break;
3422                                 else if (*t == open)
3423                                     brackets++;
3424                             }
3425                         }
3426                         t++;
3427                     }
3428                     else
3429                         /* skip plain q word */
3430                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3431                              t += UTF8SKIP(t);
3432                 }
3433                 else if (isALNUM_lazy_if(t,UTF)) {
3434                     t += UTF8SKIP(t);
3435                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3436                          t += UTF8SKIP(t);
3437                 }
3438                 while (t < PL_bufend && isSPACE(*t))
3439                     t++;
3440                 /* if comma follows first term, call it an anon hash */
3441                 /* XXX it could be a comma expression with loop modifiers */
3442                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3443                                    || (*t == '=' && t[1] == '>')))
3444                     OPERATOR(HASHBRACK);
3445                 if (PL_expect == XREF)
3446                     PL_expect = XTERM;
3447                 else {
3448                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3449                     PL_expect = XSTATE;
3450                 }
3451             }
3452             break;
3453         }
3454         yylval.ival = CopLINE(PL_curcop);
3455         if (isSPACE(*s) || *s == '#')
3456             PL_copline = NOLINE;   /* invalidate current command line number */
3457         TOKEN('{');
3458     case '}':
3459       rightbracket:
3460         s++;
3461         if (PL_lex_brackets <= 0)
3462             yyerror("Unmatched right curly bracket");
3463         else
3464             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3465         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3466             PL_lex_formbrack = 0;
3467         if (PL_lex_state == LEX_INTERPNORMAL) {
3468             if (PL_lex_brackets == 0) {
3469                 if (PL_expect & XFAKEBRACK) {
3470                     PL_expect &= XENUMMASK;
3471                     PL_lex_state = LEX_INTERPEND;
3472                     PL_bufptr = s;
3473                     return yylex();     /* ignore fake brackets */
3474                 }
3475                 if (*s == '-' && s[1] == '>')
3476                     PL_lex_state = LEX_INTERPENDMAYBE;
3477                 else if (*s != '[' && *s != '{')
3478                     PL_lex_state = LEX_INTERPEND;
3479             }
3480         }
3481         if (PL_expect & XFAKEBRACK) {
3482             PL_expect &= XENUMMASK;
3483             PL_bufptr = s;
3484             return yylex();             /* ignore fake brackets */
3485         }
3486         force_next('}');
3487         TOKEN(';');
3488     case '&':
3489         s++;
3490         tmp = *s++;
3491         if (tmp == '&')
3492             AOPERATOR(ANDAND);
3493         s--;
3494         if (PL_expect == XOPERATOR) {
3495             if (ckWARN(WARN_SEMICOLON)
3496                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3497             {
3498                 CopLINE_dec(PL_curcop);
3499                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3500                 CopLINE_inc(PL_curcop);
3501             }
3502             BAop(OP_BIT_AND);
3503         }
3504
3505         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3506         if (*PL_tokenbuf) {
3507             PL_expect = XOPERATOR;
3508             force_ident(PL_tokenbuf, '&');
3509         }
3510         else
3511             PREREF('&');
3512         yylval.ival = (OPpENTERSUB_AMPER<<8);
3513         TERM('&');
3514
3515     case '|':
3516         s++;
3517         tmp = *s++;
3518         if (tmp == '|')
3519             AOPERATOR(OROR);
3520         s--;
3521         BOop(OP_BIT_OR);
3522     case '=':
3523         s++;
3524         tmp = *s++;
3525         if (tmp == '=')
3526             Eop(OP_EQ);
3527         if (tmp == '>')
3528             OPERATOR(',');
3529         if (tmp == '~')
3530             PMop(OP_MATCH);
3531         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3532             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3533         s--;
3534         if (PL_expect == XSTATE && isALPHA(tmp) &&
3535                 (s == PL_linestart+1 || s[-2] == '\n') )
3536         {
3537             if (PL_in_eval && !PL_rsfp) {
3538                 d = PL_bufend;
3539                 while (s < d) {
3540                     if (*s++ == '\n') {
3541                         incline(s);
3542                         if (strnEQ(s,"=cut",4)) {
3543                             s = strchr(s,'\n');
3544                             if (s)
3545                                 s++;
3546                             else
3547                                 s = d;
3548                             incline(s);
3549                             goto retry;
3550                         }
3551                     }
3552                 }
3553                 goto retry;
3554             }
3555             s = PL_bufend;
3556             PL_doextract = TRUE;
3557             goto retry;
3558         }
3559         if (PL_lex_brackets < PL_lex_formbrack) {
3560             const char *t;
3561 #ifdef PERL_STRICT_CR
3562             for (t = s; SPACE_OR_TAB(*t); t++) ;
3563 #else
3564             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3565 #endif
3566             if (*t == '\n' || *t == '#') {
3567                 s--;
3568                 PL_expect = XBLOCK;
3569                 goto leftbracket;
3570             }
3571         }
3572         yylval.ival = 0;
3573         OPERATOR(ASSIGNOP);
3574     case '!':
3575         s++;
3576         tmp = *s++;
3577         if (tmp == '=') {
3578             /* was this !=~ where !~ was meant?
3579              * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3580
3581             if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3582                 const char *t = s+1;
3583
3584                 while (t < PL_bufend && isSPACE(*t))
3585                     ++t;
3586
3587                 if (*t == '/' || *t == '?' ||
3588                     ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3589                     (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3590                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3591                                 "!=~ should be !~");
3592             }
3593             Eop(OP_NE);
3594         }
3595         if (tmp == '~')
3596             PMop(OP_NOT);
3597         s--;
3598         OPERATOR('!');
3599     case '<':
3600         if (PL_expect != XOPERATOR) {
3601             if (s[1] != '<' && !strchr(s,'>'))
3602                 check_uni();
3603             if (s[1] == '<')
3604                 s = scan_heredoc(s);
3605             else
3606                 s = scan_inputsymbol(s);
3607             TERM(sublex_start());
3608         }
3609         s++;
3610         tmp = *s++;
3611         if (tmp == '<')
3612             SHop(OP_LEFT_SHIFT);
3613         if (tmp == '=') {
3614             tmp = *s++;
3615             if (tmp == '>')
3616                 Eop(OP_NCMP);
3617             s--;
3618             Rop(OP_LE);
3619         }
3620         s--;
3621         Rop(OP_LT);
3622     case '>':
3623         s++;
3624         tmp = *s++;
3625         if (tmp == '>')
3626             SHop(OP_RIGHT_SHIFT);
3627         if (tmp == '=')
3628             Rop(OP_GE);
3629         s--;
3630         Rop(OP_GT);
3631
3632     case '$':
3633         CLINE;
3634
3635         if (PL_expect == XOPERATOR) {
3636             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3637                 PL_expect = XTERM;
3638                 depcom();
3639                 return REPORT(','); /* grandfather non-comma-format format */
3640             }
3641         }
3642
3643         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3644             PL_tokenbuf[0] = '@';
3645             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3646                            sizeof PL_tokenbuf - 1, FALSE);
3647             if (PL_expect == XOPERATOR)
3648                 no_op("Array length", s);
3649             if (!PL_tokenbuf[1])
3650                 PREREF(DOLSHARP);
3651             PL_expect = XOPERATOR;
3652             PL_pending_ident = '#';
3653             TOKEN(DOLSHARP);
3654         }
3655
3656         PL_tokenbuf[0] = '$';
3657         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3658                        sizeof PL_tokenbuf - 1, FALSE);
3659         if (PL_expect == XOPERATOR)
3660             no_op("Scalar", s);
3661         if (!PL_tokenbuf[1]) {
3662             if (s == PL_bufend)
3663                 yyerror("Final $ should be \\$ or $name");
3664             PREREF('$');
3665         }
3666
3667         /* This kludge not intended to be bulletproof. */
3668         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3669             yylval.opval = newSVOP(OP_CONST, 0,
3670                                    newSViv(PL_compiling.cop_arybase));
3671             yylval.opval->op_private = OPpCONST_ARYBASE;
3672             TERM(THING);
3673         }
3674
3675         d = s;
3676         tmp = (I32)*s;
3677         if (PL_lex_state == LEX_NORMAL)
3678             s = skipspace(s);
3679
3680         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3681             char *t;
3682             if (*s == '[') {
3683                 PL_tokenbuf[0] = '@';
3684                 if (ckWARN(WARN_SYNTAX)) {
3685                     for(t = s + 1;
3686                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3687                         t++) ;
3688                     if (*t++ == ',') {
3689                         PL_bufptr = skipspace(PL_bufptr);
3690                         while (t < PL_bufend && *t != ']')
3691                             t++;
3692                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3693                                 "Multidimensional syntax %.*s not supported",
3694                                 (t - PL_bufptr) + 1, PL_bufptr);
3695                     }
3696                 }
3697             }
3698             else if (*s == '{') {
3699                 PL_tokenbuf[0] = '%';
3700                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3701                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3702                 {
3703                     char tmpbuf[sizeof PL_tokenbuf];
3704                     for (t++; isSPACE(*t); t++) ;
3705                     if (isIDFIRST_lazy_if(t,UTF)) {
3706                         STRLEN len;
3707                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3708                         for (; isSPACE(*t); t++) ;
3709                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3710                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3711                                 "You need to quote \"%s\"", tmpbuf);
3712                     }
3713                 }
3714             }
3715         }
3716
3717         PL_expect = XOPERATOR;
3718         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3719             const bool islop = (PL_last_lop == PL_oldoldbufptr);
3720             if (!islop || PL_last_lop_op == OP_GREPSTART)
3721                 PL_expect = XOPERATOR;
3722             else if (strchr("$@\"'`q", *s))
3723                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3724             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3725                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3726             else if (isIDFIRST_lazy_if(s,UTF)) {
3727                 char tmpbuf[sizeof PL_tokenbuf];
3728                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3729                 if ((tmp = keyword(tmpbuf, len))) {
3730                     /* binary operators exclude handle interpretations */
3731                     switch (tmp) {
3732                     case -KEY_x:
3733                     case -KEY_eq:
3734                     case -KEY_ne:
3735                     case -KEY_gt:
3736                     case -KEY_lt:
3737                     case -KEY_ge:
3738                     case -KEY_le:
3739                     case -KEY_cmp:
3740                         break;
3741                     default:
3742                         PL_expect = XTERM;      /* e.g. print $fh length() */
3743                         break;
3744                     }
3745                 }
3746                 else {
3747                     PL_expect = XTERM;          /* e.g. print $fh subr() */
3748                 }
3749             }
3750             else if (isDIGIT(*s))
3751                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3752             else if (*s == '.' && isDIGIT(s[1]))
3753                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3754             else if ((*s == '?' || *s == '-' || *s == '+')
3755                      && !isSPACE(s[1]) && s[1] != '=')
3756                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3757             else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3758                 PL_expect = XTERM;              /* e.g. print $fh /.../
3759                                                  XXX except DORDOR operator */
3760             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3761                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3762         }
3763         PL_pending_ident = '$';
3764         TOKEN('$');
3765
3766     case '@':
3767         if (PL_expect == XOPERATOR)
3768             no_op("Array", s);
3769         PL_tokenbuf[0] = '@';
3770         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3771         if (!PL_tokenbuf[1]) {
3772             PREREF('@');
3773         }
3774         if (PL_lex_state == LEX_NORMAL)
3775             s = skipspace(s);
3776         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3777             if (*s == '{')
3778                 PL_tokenbuf[0] = '%';
3779
3780             /* Warn about @ where they meant $. */
3781             if (ckWARN(WARN_SYNTAX)) {
3782                 if (*s == '[' || *s == '{') {
3783                     const char *t = s + 1;
3784                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3785                         t++;
3786                     if (*t == '}' || *t == ']') {
3787                         t++;
3788                         PL_bufptr = skipspace(PL_bufptr);
3789                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3790                             "Scalar value %.*s better written as $%.*s",
3791                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3792                     }
3793                 }
3794             }
3795         }
3796         PL_pending_ident = '@';
3797         TERM('@');
3798
3799      case '/':                  /* may be division, defined-or, or pattern */
3800         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3801             s += 2;
3802             AOPERATOR(DORDOR);
3803         }
3804      case '?':                  /* may either be conditional or pattern */
3805          if(PL_expect == XOPERATOR) {
3806              tmp = *s++;
3807              if(tmp == '?') {
3808                   OPERATOR('?');
3809              }
3810              else {
3811                  tmp = *s++;
3812                  if(tmp == '/') {
3813                      /* A // operator. */
3814                     AOPERATOR(DORDOR);
3815                  }
3816                  else {
3817                      s--;
3818                      Mop(OP_DIVIDE);
3819                  }
3820              }
3821          }
3822          else {
3823              /* Disable warning on "study /blah/" */
3824              if (PL_oldoldbufptr == PL_last_uni
3825               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3826                   || memNE(PL_last_uni, "study", 5)
3827                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3828               ))
3829                  check_uni();
3830              s = scan_pat(s,OP_MATCH);
3831              TERM(sublex_start());
3832          }
3833
3834     case '.':
3835         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3836 #ifdef PERL_STRICT_CR
3837             && s[1] == '\n'
3838 #else
3839             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3840 #endif
3841             && (s == PL_linestart || s[-1] == '\n') )
3842         {
3843             PL_lex_formbrack = 0;
3844             PL_expect = XSTATE;
3845             goto rightbracket;
3846         }
3847         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3848             tmp = *s++;
3849             if (*s == tmp) {
3850                 s++;
3851                 if (*s == tmp) {
3852                     s++;
3853                     yylval.ival = OPf_SPECIAL;
3854                 }
3855                 else
3856                     yylval.ival = 0;
3857                 OPERATOR(DOTDOT);
3858             }
3859             if (PL_expect != XOPERATOR)
3860                 check_uni();
3861             Aop(OP_CONCAT);
3862         }
3863         /* FALL THROUGH */
3864     case '0': case '1': case '2': case '3': case '4':
3865     case '5': case '6': case '7': case '8': case '9':
3866         s = scan_num(s, &yylval);
3867         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3868                     "### Saw number in '%s'\n", s);
3869         } );
3870         if (PL_expect == XOPERATOR)
3871             no_op("Number",s);
3872         TERM(THING);
3873
3874     case '\'':
3875         s = scan_str(s,FALSE,FALSE);
3876         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3877                     "### Saw string before '%s'\n", s);
3878         } );
3879         if (PL_expect == XOPERATOR) {
3880             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3881                 PL_expect = XTERM;
3882                 depcom();
3883                 return REPORT(','); /* grandfather non-comma-format format */
3884             }
3885             else
3886                 no_op("String",s);
3887         }
3888         if (!s)
3889             missingterm((char*)0);
3890         yylval.ival = OP_CONST;
3891         TERM(sublex_start());
3892
3893     case '"':
3894         s = scan_str(s,FALSE,FALSE);
3895         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3896                     "### Saw string before '%s'\n", s);
3897         } );
3898         if (PL_expect == XOPERATOR) {
3899             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3900                 PL_expect = XTERM;
3901                 depcom();
3902                 return REPORT(','); /* grandfather non-comma-format format */
3903             }
3904             else
3905                 no_op("String",s);
3906         }
3907         if (!s)
3908             missingterm((char*)0);
3909         yylval.ival = OP_CONST;
3910         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3911             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3912                 yylval.ival = OP_STRINGIFY;
3913                 break;
3914             }
3915         }
3916         TERM(sublex_start());
3917
3918     case '`':
3919         s = scan_str(s,FALSE,FALSE);
3920         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3921                     "### Saw backtick string before '%s'\n", s);
3922         } );
3923         if (PL_expect == XOPERATOR)
3924             no_op("Backticks",s);
3925         if (!s)
3926             missingterm((char*)0);
3927         yylval.ival = OP_BACKTICK;
3928         set_csh();
3929         TERM(sublex_start());
3930
3931     case '\\':
3932         s++;
3933         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3934             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3935                         *s, *s);
3936         if (PL_expect == XOPERATOR)
3937             no_op("Backslash",s);
3938         OPERATOR(REFGEN);
3939
3940     case 'v':
3941         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3942             char *start = s + 2;
3943             while (isDIGIT(*start) || *start == '_')
3944                 start++;
3945             if (*start == '.' && isDIGIT(start[1])) {
3946                 s = scan_num(s, &yylval);
3947                 TERM(THING);
3948             }
3949             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3950             else if (!isALPHA(*start) && (PL_expect == XTERM
3951                         || PL_expect == XREF || PL_expect == XSTATE
3952                         || PL_expect == XTERMORDORDOR)) {
3953                 const char c = *start;
3954                 GV *gv;
3955                 *start = '\0';
3956                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3957                 *start = c;
3958                 if (!gv) {
3959                     s = scan_num(s, &yylval);
3960                     TERM(THING);
3961                 }
3962             }
3963         }
3964         goto keylookup;
3965     case 'x':
3966         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3967             s++;
3968             Mop(OP_REPEAT);
3969         }
3970         goto keylookup;
3971
3972     case '_':
3973     case 'a': case 'A':
3974     case 'b': case 'B':
3975     case 'c': case 'C':
3976     case 'd': case 'D':
3977     case 'e': case 'E':
3978     case 'f': case 'F':
3979     case 'g': case 'G':
3980     case 'h': case 'H':
3981     case 'i': case 'I':
3982     case 'j': case 'J':
3983     case 'k': case 'K':
3984     case 'l': case 'L':
3985     case 'm': case 'M':
3986     case 'n': case 'N':
3987     case 'o': case 'O':
3988     case 'p': case 'P':
3989     case 'q': case 'Q':
3990     case 'r': case 'R':
3991     case 's': case 'S':
3992     case 't': case 'T':
3993     case 'u': case 'U':
3994               case 'V':
3995     case 'w': case 'W':
3996               case 'X':
3997     case 'y': case 'Y':
3998     case 'z': case 'Z':
3999
4000       keylookup: {
4001         orig_keyword = 0;
4002         gv = Nullgv;
4003         gvp = 0;
4004
4005         PL_bufptr = s;
4006         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4007
4008         /* Some keywords can be followed by any delimiter, including ':' */
4009         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4010                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4011                              (PL_tokenbuf[0] == 'q' &&
4012                               strchr("qwxr", PL_tokenbuf[1])))));
4013
4014         /* x::* is just a word, unless x is "CORE" */
4015         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4016             goto just_a_word;
4017
4018         d = s;
4019         while (d < PL_bufend && isSPACE(*d))
4020                 d++;    /* no comments skipped here, or s### is misparsed */
4021
4022         /* Is this a label? */
4023         if (!tmp && PL_expect == XSTATE
4024               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4025             s = d + 1;
4026             yylval.pval = savepv(PL_tokenbuf);
4027             CLINE;
4028             TOKEN(LABEL);
4029         }
4030
4031         /* Check for keywords */
4032         tmp = keyword(PL_tokenbuf, len);
4033
4034         /* Is this a word before a => operator? */
4035         if (*d == '=' && d[1] == '>') {
4036             CLINE;
4037             yylval.opval
4038                 = (OP*)newSVOP(OP_CONST, 0,
4039                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4040             yylval.opval->op_private = OPpCONST_BARE;
4041             TERM(WORD);
4042         }
4043
4044         if (tmp < 0) {                  /* second-class keyword? */
4045             GV *ogv = Nullgv;   /* override (winner) */
4046             GV *hgv = Nullgv;   /* hidden (loser) */
4047             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4048                 CV *cv;
4049                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4050                     (cv = GvCVu(gv)))
4051                 {
4052                     if (GvIMPORTED_CV(gv))
4053                         ogv = gv;
4054                     else if (! CvMETHOD(cv))
4055                         hgv = gv;
4056                 }
4057                 if (!ogv &&
4058                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4059                     (gv = *gvp) != (GV*)&PL_sv_undef &&
4060                     GvCVu(gv) && GvIMPORTED_CV(gv))
4061                 {
4062                     ogv = gv;
4063                 }
4064             }
4065             if (ogv) {
4066                 orig_keyword = tmp;
4067                 tmp = 0;                /* overridden by import or by GLOBAL */
4068             }
4069             else if (gv && !gvp
4070                      && -tmp==KEY_lock  /* XXX generalizable kludge */
4071                      && GvCVu(gv)
4072                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4073             {
4074                 tmp = 0;                /* any sub overrides "weak" keyword */
4075             }
4076             else if (gv && !gvp
4077                     && tmp == -KEY_err
4078                     && GvCVu(gv)
4079                     && PL_expect != XOPERATOR
4080                     && PL_expect != XTERMORDORDOR)
4081             {
4082                 /* any sub overrides the "err" keyword, except when really an
4083                  * operator is expected */
4084                 tmp = 0;
4085             }
4086             else {                      /* no override */
4087                 tmp = -tmp;
4088                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4089                     Perl_warner(aTHX_ packWARN(WARN_MISC),
4090                             "dump() better written as CORE::dump()");
4091                 }
4092                 gv = Nullgv;
4093                 gvp = 0;
4094                 if (ckWARN(WARN_AMBIGUOUS) && hgv
4095                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
4096                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4097                         "Ambiguous call resolved as CORE::%s(), %s",
4098                          GvENAME(hgv), "qualify as such or use &");
4099             }
4100         }
4101
4102       reserved_word:
4103         switch (tmp) {
4104
4105         default:                        /* not a keyword */
4106           just_a_word: {
4107                 SV *sv;
4108                 int pkgname = 0;
4109                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4110
4111                 /* Get the rest if it looks like a package qualifier */
4112
4113                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4114                     STRLEN morelen;
4115                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4116                                   TRUE, &morelen);
4117                     if (!morelen)
4118                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4119                                 *s == '\'' ? "'" : "::");
4120                     len += morelen;
4121                     pkgname = 1;
4122                 }
4123
4124                 if (PL_expect == XOPERATOR) {
4125                     if (PL_bufptr == PL_linestart) {
4126                         CopLINE_dec(PL_curcop);
4127                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4128                         CopLINE_inc(PL_curcop);
4129                     }
4130                     else
4131                         no_op("Bareword",s);
4132                 }
4133
4134                 /* Look for a subroutine with this name in current package,
4135                    unless name is "Foo::", in which case Foo is a bearword
4136                    (and a package name). */
4137
4138                 if (len > 2 &&
4139                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4140                 {
4141                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4142                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4143                             "Bareword \"%s\" refers to nonexistent package",
4144                              PL_tokenbuf);
4145                     len -= 2;
4146                     PL_tokenbuf[len] = '\0';
4147                     gv = Nullgv;
4148                     gvp = 0;
4149                 }
4150                 else {
4151                     len = 0;
4152                     if (!gv)
4153                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4154                 }
4155
4156                 /* if we saw a global override before, get the right name */
4157
4158                 if (gvp) {
4159                     sv = newSVpvn("CORE::GLOBAL::",14);
4160                     sv_catpv(sv,PL_tokenbuf);
4161                 }
4162                 else {
4163                     /* If len is 0, newSVpv does strlen(), which is correct.
4164                        If len is non-zero, then it will be the true length,
4165                        and so the scalar will be created correctly.  */
4166                     sv = newSVpv(PL_tokenbuf,len);
4167                 }
4168
4169                 /* Presume this is going to be a bareword of some sort. */
4170
4171                 CLINE;
4172                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4173                 yylval.opval->op_private = OPpCONST_BARE;
4174                 /* UTF-8 package name? */
4175                 if (UTF && !IN_BYTES &&
4176                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4177                     SvUTF8_on(sv);
4178
4179                 /* And if "Foo::", then that's what it certainly is. */
4180
4181                 if (len)
4182                     goto safe_bareword;
4183
4184                 /* See if it's the indirect object for a list operator. */
4185
4186                 if (PL_oldoldbufptr &&
4187                     PL_oldoldbufptr < PL_bufptr &&
4188                     (PL_oldoldbufptr == PL_last_lop
4189                      || PL_oldoldbufptr == PL_last_uni) &&
4190                     /* NO SKIPSPACE BEFORE HERE! */
4191                     (PL_expect == XREF ||
4192                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4193                 {
4194                     bool immediate_paren = *s == '(';
4195
4196                     /* (Now we can afford to cross potential line boundary.) */
4197                     s = skipspace(s);
4198
4199                     /* Two barewords in a row may indicate method call. */
4200
4201                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4202                         return REPORT(tmp);
4203
4204                     /* If not a declared subroutine, it's an indirect object. */
4205                     /* (But it's an indir obj regardless for sort.) */
4206
4207                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4208                          ((!gv || !GvCVu(gv)) &&
4209                         (PL_last_lop_op != OP_MAPSTART &&
4210                          PL_last_lop_op != OP_GREPSTART))))
4211                     {
4212                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4213                         goto bareword;
4214                     }
4215                 }
4216
4217                 PL_expect = XOPERATOR;
4218                 s = skipspace(s);
4219
4220                 /* Is this a word before a => operator? */
4221                 if (*s == '=' && s[1] == '>' && !pkgname) {
4222                     CLINE;
4223                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4224                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4225                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4226                     TERM(WORD);
4227                 }
4228
4229                 /* If followed by a paren, it's certainly a subroutine. */
4230                 if (*s == '(') {
4231                     CLINE;
4232                     if (gv && GvCVu(gv)) {
4233                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4234                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4235                             s = d + 1;
4236                             goto its_constant;
4237                         }
4238                     }
4239                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4240                     PL_expect = XOPERATOR;
4241                     force_next(WORD);
4242                     yylval.ival = 0;
4243                     TOKEN('&');
4244                 }
4245
4246                 /* If followed by var or block, call it a method (unless sub) */
4247
4248                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4249                     PL_last_lop = PL_oldbufptr;
4250                     PL_last_lop_op = OP_METHOD;
4251                     PREBLOCK(METHOD);
4252                 }
4253
4254                 /* If followed by a bareword, see if it looks like indir obj. */
4255
4256                 if (!orig_keyword
4257                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4258                         && (tmp = intuit_method(s,gv)))
4259                     return REPORT(tmp);
4260
4261                 /* Not a method, so call it a subroutine (if defined) */
4262
4263                 if (gv && GvCVu(gv)) {
4264                     CV* cv;
4265                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4266                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4267   &nb