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