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