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